This commit is contained in:
Joey Hess 2011-04-09 14:26:32 -04:00
parent 1e7ad2ee7c
commit 8ad901a647
3 changed files with 37 additions and 37 deletions

View file

@ -16,7 +16,6 @@ import Data.List.Utils
import Command import Command
import qualified Annex import qualified Annex
import qualified GitRepo as Git import qualified GitRepo as Git
import qualified Remote.Git
import Messages import Messages
import Types import Types
import Utility import Utility
@ -203,7 +202,7 @@ tryScan r
Git.hConfigRead r Git.hConfigRead r
configlist = configlist =
Remote.Git.onRemote r (pipedconfig, Nothing) "configlist" [] onRemote r (pipedconfig, Nothing) "configlist" []
manualconfiglist = do manualconfiglist = do
let sshcmd = let sshcmd =
"cd " ++ shellEscape(Git.workTree r) ++ " && " ++ "cd " ++ shellEscape(Git.workTree r) ++ " && " ++

View file

@ -5,10 +5,7 @@
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
module Remote.Git ( module Remote.Git (remote) where
remote,
onRemote
) where
import Control.Exception.Extensible import Control.Exception.Extensible
import Control.Monad.State (liftIO) import Control.Monad.State (liftIO)
@ -194,34 +191,3 @@ rsyncParams r sending key file = do
-- goes, so the source/dest parameter can be a dummy value, -- goes, so the source/dest parameter can be a dummy value,
-- that just enables remote rsync mode. -- that just enables remote rsync mode.
dummy = Param ":" dummy = Param ":"
{- Uses a supplied function to run a git-annex-shell command on a remote.
-
- Or, if the remote does not support running remote commands, returns
- a specified error value. -}
onRemote
:: Git.Repo
-> (FilePath -> [CommandParam] -> IO a, a)
-> String
-> [CommandParam]
-> Annex a
onRemote r (with, errorval) command params = do
s <- git_annex_shell r command params
case s of
Just (c, ps) -> liftIO $ with c ps
Nothing -> return errorval
{- Generates parameters to run a git-annex-shell command on a remote. -}
git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
git_annex_shell r command params
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
| Git.repoIsSsh r = do
sshparams <- sshToRepo r [Param sshcmd]
return $ Just ("ssh", sshparams)
| otherwise = return Nothing
where
dir = Git.workTree r
shellcmd = "git-annex-shell"
shellopts = (Param command):(File dir):params
sshcmd = shellcmd ++ " " ++
unwords (map shellEscape $ toCommand shellopts)

35
Ssh.hs
View file

@ -7,6 +7,8 @@
module Ssh where module Ssh where
import Control.Monad.State (liftIO)
import qualified GitRepo as Git import qualified GitRepo as Git
import Utility import Utility
import Types import Types
@ -24,3 +26,36 @@ sshToRepo repo sshcmd = do
Just p -> [Param "-p", Param (show p)] Just p -> [Param "-p", Param (show p)]
let sshhost = Param $ Git.urlHostUser repo let sshhost = Param $ Git.urlHostUser repo
return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd return $ sshoptions ++ sshport ++ [sshhost] ++ sshcmd
{- Generates parameters to run a git-annex-shell command on a remote
- repository. -}
git_annex_shell :: Git.Repo -> String -> [CommandParam] -> Annex (Maybe (FilePath, [CommandParam]))
git_annex_shell r command params
| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts)
| Git.repoIsSsh r = do
sshparams <- sshToRepo r [Param sshcmd]
return $ Just ("ssh", sshparams)
| otherwise = return Nothing
where
dir = Git.workTree r
shellcmd = "git-annex-shell"
shellopts = (Param command):(File dir):params
sshcmd = shellcmd ++ " " ++
unwords (map shellEscape $ toCommand shellopts)
{- Uses a supplied function (such as boolSystem) to run a git-annex-shell
- command on a remote.
-
- Or, if the remote does not support running remote commands, returns
- a specified error value. -}
onRemote
:: Git.Repo
-> (FilePath -> [CommandParam] -> IO a, a)
-> String
-> [CommandParam]
-> Annex a
onRemote r (with, errorval) command params = do
s <- git_annex_shell r command params
case s of
Just (c, ps) -> liftIO $ with c ps
Nothing -> return errorval