diff options
| -rw-r--r-- | Command/RecvKey.hs | 24 | ||||
| -rw-r--r-- | Command/SendKey.hs | 18 | ||||
| -rw-r--r-- | GitAnnexShell.hs | 18 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 7 | ||||
| -rw-r--r-- | Utility/RsyncFile.hs | 11 |
5 files changed, 51 insertions, 27 deletions
diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 9744a56d4..ce8bff997 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -12,6 +12,7 @@ import Command import CmdLine import Annex.Content import Utility.RsyncFile +import Logs.Transfer def :: [Command] def = [oneShot $ command "recvkey" paramKey seek @@ -21,14 +22,15 @@ seek :: [CommandSeek] seek = [withKeys start] start :: Key -> CommandStart -start key = do - whenM (inAnnex key) $ error "key is already present in annex" - - ok <- getViaTmp key (liftIO . rsyncServerReceive) - if ok - then do - -- forcibly quit after receiving one key, - -- and shutdown cleanly - _ <- shutdown True - liftIO exitSuccess - else liftIO exitFailure +start key = ifM (inAnnex key) + ( error "key is already present in annex" + , fieldTransfer Download key $ do + ifM (getViaTmp key $ liftIO . rsyncServerReceive) + ( do + -- forcibly quit after receiving one key, + -- and shutdown cleanly + _ <- shutdown True + liftIO exitSuccess + , liftIO exitFailure + ) + ) diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 686a31caa..5eca70d24 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010,2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,7 @@ import Common.Annex import Command import Annex.Content import Utility.RsyncFile +import Logs.Transfer def :: [Command] def = [oneShot $ command "sendkey" paramKey seek @@ -20,9 +21,12 @@ seek :: [CommandSeek] seek = [withKeys start] start :: Key -> CommandStart -start key = do - file <- inRepo $ gitAnnexLocation key - whenM (inAnnex key) $ - liftIO $ rsyncServerSend file -- does not return - warning "requested key is not present" - liftIO exitFailure +start key = ifM (inAnnex key) + ( fieldTransfer Upload key $ do + file <- inRepo $ gitAnnexLocation key + liftIO $ ifM (rsyncServerSend file) + ( exitSuccess , exitFailure ) + , do + warning "requested key is not present" + liftIO exitFailure + ) diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index 2a9f3c26a..559e30235 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -9,6 +9,7 @@ module GitAnnexShell where import System.Environment import System.Console.GetOpt +import Data.Char import Common.Annex import qualified Git.Construct @@ -84,8 +85,9 @@ builtins = map cmdname cmds builtin :: String -> String -> [String] -> IO () builtin cmd dir params = do checkNotReadOnly cmd - let (params', fields) = partitionParams params - dispatch False (cmd : params') cmds options (parseFields fields) header $ + let (params', fieldparams) = partitionParams params + fields <- filterM checkField $ parseFields fieldparams + dispatch False (cmd : params') cmds options fields header $ Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath external :: [String] -> IO () @@ -110,6 +112,18 @@ partitionParams params parseFields :: [String] -> [(String, String)] parseFields = map (separate (== '=')) +{- Only allow known fields to be set, ignore others. + - Make sure that field values make sense. -} +checkField :: (String, String) -> IO Bool +checkField (field, value) + | field == "remoteuuid" = return $ + -- does it look like a UUID? + all (\c -> isAlphaNum c || c == '-') value + | field == "associatedfile" = + -- is the file located within the current directory? + dirContains <$> getCurrentDirectory <*> pure value + | otherwise = return False + failure :: IO () failure = error $ "bad parameters\n\n" ++ usage header cmds options diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 526241f93..658e18b5d 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -10,6 +10,7 @@ module Logs.Transfer where import Common.Annex import Annex.Perms import Annex.Exception +import qualified Annex import qualified Git import Types.Remote @@ -54,6 +55,12 @@ upload u key file a = transfer (Transfer Upload u key) file a download :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a download u key file a = transfer (Transfer Download u key) file a +fieldTransfer :: Direction -> Key -> Annex a -> Annex a +fieldTransfer direction key a = do + afile <- Annex.getField "associatedfile" + maybe a (\u -> transfer (Transfer direction (toUUID u) key) afile a) + =<< Annex.getField "remoteuuid" + {- Runs a transfer action. Creates and locks the transfer information file - while the action is running. Will throw an error if the transfer is - already in progress. diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs index db9057843..075e91d23 100644 --- a/Utility/RsyncFile.hs +++ b/Utility/RsyncFile.hs @@ -22,9 +22,9 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman - string is a single quote. -} escape s = "'" ++ join "''" (split "'" s) ++ "'" -{- Runs rsync in server mode to send a file, and exits. -} -rsyncServerSend :: FilePath -> IO () -rsyncServerSend file = rsyncExec $ +{- Runs rsync in server mode to send a file. -} +rsyncServerSend :: FilePath -> IO Bool +rsyncServerSend file = rsync $ rsyncServerParams ++ [Param "--sender", File file] {- Runs rsync in server mode to receive a file. -} @@ -47,11 +47,8 @@ rsyncServerParams = rsync :: [CommandParam] -> IO Bool rsync = boolSystem "rsync" -rsyncExec :: [CommandParam] -> IO () -rsyncExec params = executeFile "rsync" True (toCommand params) Nothing - {- Checks if an rsync url involves the remote shell (ssh or rsh). - - Use of such urls with rsync or rsyncExec requires additional shell + - Use of such urls with rsync requires additional shell - escaping. -} rsyncUrlIsShell :: String -> Bool rsyncUrlIsShell s |