diff --git a/Backend/File.hs b/Backend/File.hs index ee73150211..9bc5a2aa63 100644 --- a/Backend/File.hs +++ b/Backend/File.hs @@ -65,12 +65,7 @@ copyKeyFile key file = do trycopy full (r:rs) = do probablythere <- probablyPresent r if probablythere - then do - showNote $ "copying from " ++ Git.repoDescribe r ++ "..." - copied <- Remotes.copyFromRemote r key file - if copied - then return True - else trycopy full rs + then docopy r (trycopy full rs) else trycopy full rs -- This check is to avoid an ugly message if a remote is a -- drive that is not mounted. Avoid checking inAnnex for ssh @@ -82,6 +77,12 @@ copyKeyFile key file = do if not $ Git.repoIsUrl r then liftIO $ doesFileExist $ annexLocation r key else return True + docopy r continue = do + showNote $ "copying from " ++ Git.repoDescribe r ++ "..." + copied <- Remotes.copyFromRemote r key file + if copied + then return True + else continue {- Checks remotes to verify that enough copies of a key exist to allow - for a key to be safely removed (with no data loss), and fails with an diff --git a/Command/Move.hs b/Command/Move.hs index d96d36138c..fa847e6bab 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -7,13 +7,11 @@ module Command.Move where -import Control.Monad (when) import Control.Monad.State (liftIO) import Command import qualified Command.Drop import qualified Annex -import Locations import LocationLog import Types import Core @@ -86,26 +84,17 @@ toPerform move key = do return Nothing Right False -> do showNote $ "to " ++ Git.repoDescribe remote ++ "..." - let tmpfile = annexTmpLocation remote ++ keyFile key - ok <- Remotes.copyToRemote remote key tmpfile + ok <- Remotes.copyToRemote remote key if ok - then return $ Just $ toCleanup move remote key tmpfile + then return $ Just $ toCleanup move remote key else return Nothing -- failed Right True -> return $ Just $ Command.Drop.cleanup key -toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> CommandCleanup -toCleanup move remote key tmpfile = do - -- Tell remote to use the transferred content. - ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet", - "--backend=" ++ backendName key, - "--key=" ++ keyName key, - tmpfile] - if ok - then do - remoteHasKey remote key True - if move - then Command.Drop.cleanup key - else return True - else return False +toCleanup :: Bool -> Git.Repo -> Key -> CommandCleanup +toCleanup move remote key = do + remoteHasKey remote key True + if move + then Command.Drop.cleanup key + else return True {- Moves (or copies) the content of an annexed file from another repository - to the current repository and updates locationlog information on both. @@ -140,7 +129,9 @@ fromCleanup True remote key = do ["--quiet", "--force", "--backend=" ++ backendName key, keyName key] - when ok $ - remoteHasKey remote key False + -- better safe than sorry: assume the remote dropped the key + -- even if it seemed to fail; the failure could have occurred + -- after it really dropped it + remoteHasKey remote key False return ok fromCleanup False _ _ = return True diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 3232010d49..840b328613 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -34,5 +34,9 @@ start keyname = do ok <- getViaTmp key (liftIO . rsyncServerReceive) if ok - then return Nothing + then do + -- forcibly quit after receiving one key, + -- and shutdown cleanly so queued git commands run + _ <- shutdown 0 + liftIO exitSuccess else liftIO exitFailure diff --git a/Remotes.hs b/Remotes.hs index 70356de024..19d1bfdd37 100644 --- a/Remotes.hs +++ b/Remotes.hs @@ -15,7 +15,6 @@ module Remotes ( byName, copyFromRemote, copyToRemote, - runCmd, onRemote ) where @@ -23,11 +22,10 @@ import Control.Exception.Extensible import Control.Monad.State (liftIO) import qualified Data.Map as Map import Data.String.Utils -import System.Directory hiding (copyFile) -import System.Posix.Directory import System.Cmd.Utils import Data.List (intersect, sortBy) import Control.Monad (when, unless, filterM) +import Data.Maybe import Types import qualified GitRepo as Git @@ -39,6 +37,7 @@ import Utility import qualified Core import Messages import CopyFile +import RsyncFile {- Human visible list of remotes. -} list :: [Git.Repo] -> String @@ -227,92 +226,95 @@ tryGitConfigRead r then new : exchange ls new else old : exchange ls new -{- Tries to copy a key's content from a remote to a file. -} +{- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool copyFromRemote r key file - | not $ Git.repoIsUrl r = getlocal - | Git.repoIsSsh r = getssh + | not $ Git.repoIsUrl r = liftIO $ copyFile (annexLocation r key) file + | Git.repoIsSsh r = rsynchelper r True key file | otherwise = error "copying from non-ssh repo not supported" - where - keyloc = annexLocation r key - getlocal = liftIO $ copyFile keyloc file - getssh = remoteCopyFile True r (sshLocation r keyloc) file -{- Tries to copy a key's content to a file on a remote. -} -copyToRemote :: Git.Repo -> Key -> FilePath -> Annex Bool -copyToRemote r key file = do - g <- Annex.gitRepo - let keyloc = annexLocation g key - if not $ Git.repoIsUrl r - then putlocal keyloc - else if Git.repoIsSsh r - then putssh keyloc - else error "copying to non-ssh repo not supported" - where - putlocal src = liftIO $ copyFile src file - putssh src = remoteCopyFile False r src (sshLocation r file) +{- Tries to copy a key's content to a remote's annex. -} +copyToRemote :: Git.Repo -> Key -> Annex Bool +copyToRemote r key + | not $ Git.repoIsUrl r = do + g <- Annex.gitRepo + let keysrc = annexLocation g key + let keydest = annexLocation r key + liftIO $ copyFile keysrc keydest + | Git.repoIsSsh r = do + g <- Annex.gitRepo + let keysrc = annexLocation g key + rsynchelper r False key keysrc + | otherwise = error "copying to non-ssh repo not supported" -sshLocation :: Git.Repo -> FilePath -> FilePath -sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file - -{- Copies a file from or to a remote, using rsync. -} -remoteCopyFile :: Bool -> Git.Repo -> String -> String -> Annex Bool -remoteCopyFile recv r src dest = do +rsynchelper :: Git.Repo -> Bool -> Key -> FilePath -> Annex (Bool) +rsynchelper r sending key file = do showProgress -- make way for progress bar - o <- repoConfig r configopt "" - res <- liftIO $ boolSystem cmd $ options ++ words o ++ [src, dest] + p <- rsyncParams r sending key file + liftIO $ putStrLn $ unwords p + res <- liftIO $ boolSystem "rsync" p if res then return res else do showLongNote "rsync failed -- run git annex again to resume file transfer" return res + +{- Generates rsync parameters that ssh to the remote and asks it + - to either receive or send the key's content. -} +rsyncParams :: Git.Repo -> Bool -> Key -> FilePath -> Annex [String] +rsyncParams r sending key file = do + -- Note that the command is terminated with "--", because + -- rsync will tack on its own options to this command, + -- and they need to be ignored. + shellcmd <- git_annex_shell r + (if sending then "sendkey" else "recvkey") + ["--backend=" ++ backendName key, keyName key, "--"] + -- Convert the ssh command into rsync command line. + let eparam = rsyncShell $ fromJust shellcmd + o <- repoConfig r "rsync-options" "" + let base = options ++ words o ++ eparam + if sending + then return $ base ++ [dummy, file] + else return $ base ++ [file, dummy] where - cmd = "rsync" - configopt= "rsync-options" -- inplace makes rsync resume partial files options = ["-p", "--progress", "--inplace"] + -- the rsync shell parameter controls where rsync + -- does, so the source/dest parameter can be a dummy value, + -- that just enables remote rsync mode. + dummy = ":" -{- Uses a supplied function to run a git-annex-shell command on a remote. -} +{- 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 - -> ((String -> [String] -> IO a), a) + -> (String -> [String] -> IO a, a) -> String -> [String] -> Annex a -onRemote r (with, errorval) command params - | not $ Git.repoIsUrl r = liftIO $ with shellcmd shellopts +onRemote r (with, errorval) command params = do + s <- git_annex_shell r command params + case s of + Just shellcmd -> liftIO $ with (shellcmd !! 0) (tail shellcmd) + Nothing -> return errorval + +{- Generates parameters to run a git-annex-shell command on a remote. -} +git_annex_shell :: Git.Repo -> String -> [String] -> Annex (Maybe [String]) +git_annex_shell r command params + | not $ Git.repoIsUrl r = return $ Just (shellcmd:shellopts) | Git.repoIsSsh r = do sshoptions <- repoConfig r "ssh-options" "" - liftIO $ with "ssh" $ - words sshoptions ++ [Git.urlHost r, sshcmd] - | otherwise = return errorval + return $ Just $ ["ssh"] ++ words sshoptions ++ + [Git.urlHost r, sshcmd] + | otherwise = return Nothing where dir = Git.workTree r shellcmd = "git-annex-shell" shellopts = command:dir:params sshcmd = shellcmd ++ " " ++ unwords (map shellEscape shellopts) -{- Runs a command in a remote, using ssh if necessary. - - (Honors annex-ssh-options.) -} -runCmd :: Git.Repo -> String -> [String] -> Annex Bool -runCmd r command params = do - sshoptions <- repoConfig r "ssh-options" "" - if not $ Git.repoIsUrl r - then do - cwd <- liftIO getCurrentDirectory - liftIO $ bracket_ - (changeWorkingDirectory (Git.workTree r)) - (changeWorkingDirectory cwd) - (boolSystem command params) - else if Git.repoIsSsh r - then liftIO $ boolSystem "ssh" $ - words sshoptions ++ [Git.urlHost r, sshcmd] - else error "running command in non-ssh repo not supported" - where - sshcmd = "cd " ++ shellEscape (Git.workTree r) ++ - " && " ++ shellEscape command ++ " " ++ - unwords (map shellEscape params) - {- Looks up a per-remote config option in git config. - Failing that, tries looking for a global config option. -} repoConfig :: Git.Repo -> String -> String -> Annex String diff --git a/RsyncFile.hs b/RsyncFile.hs index 14f6dc926b..274e66151b 100644 --- a/RsyncFile.hs +++ b/RsyncFile.hs @@ -7,8 +7,20 @@ module RsyncFile where -import Utility import System.Posix.Process +import Data.String.Utils + +import Utility + +{- Generates parameters to make rsync use a specified command as its remote + - shell. -} +rsyncShell :: [String] -> [String] +rsyncShell command = ["-e", unwords $ map escape command] + where + {- rsync requires some weird, non-shell like quoting in + - here. A doubled single quote inside the single quoted + - string is a single quote. -} + escape s = "'" ++ (join "''" $ split "'" s) ++ "'" {- Runs rsync in server mode to send a file, and exits. -} rsyncServerSend :: FilePath -> IO () diff --git a/doc/todo/git-annex-shell.mdwn b/doc/todo/git-annex-shell.mdwn index 47db0c1ca7..a9e3b43ede 100644 --- a/doc/todo/git-annex-shell.mdwn +++ b/doc/todo/git-annex-shell.mdwn @@ -1,3 +1,5 @@ +[[done]] + I've been considering adding a `git-annex-shell` command. This would be similar to `git-shell` (and in fact would pass unknown commands off to `git-shell`). @@ -11,38 +13,3 @@ be similar to `git-shell` (and in fact would pass unknown commands off to * Could possibly allow multiple things to be done with one ssh connection in future. * Allows expanding `~` and `~user` in repopath on the remote system. - -## Design - -`git-annex-shell -c ` - -### options - -Need at least `--quiet`, `--backend`, `--key`, `--force` - -### commands - -* `configlist repopath` - - Returns `git config --list`, for use by `tryGitConfigRead`. - - May filter the listed config to only the options git-annex really needs, - to prevent info disclosure. - -* `inannex repopath key ...` - - Checks if the keys are in the annex; shell exits zero if so. - -* `dropkey repopath key ... ` - - Same as `git annex dropkey`, and taking the same dashed options. - -* `setkey repopath tmpfile` - - Same as `git annex setkey`, and taking the same dashed options. - -### TODO - -* To be usable as a locked down shell, needs a way to launch the - rsync server, for file receiving. Safely? -* Also needs a way to support receiving files by scp.