diff options
| -rw-r--r-- | Command/RecvKey.hs | 18 | ||||
| -rw-r--r-- | Command/SendKey.hs | 20 | ||||
| -rw-r--r-- | GitAnnexShell.hs | 29 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 23 |
4 files changed, 61 insertions, 29 deletions
diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index c5ff4a9c8..c1c11a550 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -11,6 +11,7 @@ import Common.Annex import Command import CmdLine import Annex.Content +import Annex import Utility.Rsync import Logs.Transfer import Command.SendKey (fieldTransfer) @@ -19,6 +20,8 @@ import qualified Types.Key import qualified Types.Backend import qualified Backend +import System.Console.GetOpt + def :: [Command] def = [noCommit $ command "recvkey" paramKey seek SectionPlumbing "runs rsync in server mode to receive content"] @@ -40,13 +43,16 @@ start key = ifM (inAnnex key) ) ) where - go tmp = ifM (liftIO $ rsyncServerReceive tmp) - ( ifM (isJust <$> Fields.getField Fields.direct) - ( directcheck tmp - , return True + go tmp = do + (opts,_,_) <- getOpt Permute rsyncSafeOptions <$> + maybe [] (split " ") <$> getField "RsyncOptions" + ifM (liftIO $ rsyncServerReceive (map Param opts) tmp) + ( ifM (isJust <$> Fields.getField Fields.direct) + ( directcheck tmp + , return True + ) + , return False ) - , return False - ) {- If the sending repository uses direct mode, the file - it sends could be modified as it's sending it. So check - that the right size file was received, and that the key/value diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 0a07dcece..42a0377a3 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -10,11 +10,14 @@ module Command.SendKey where import Common.Annex import Command import Annex.Content +import Annex import Utility.Rsync import Logs.Transfer import qualified Fields import Utility.Metered +import System.Console.GetOpt + def :: [Command] def = [noCommit $ command "sendkey" paramKey seek SectionPlumbing "runs rsync in server mode to send content"] @@ -23,13 +26,16 @@ seek :: [CommandSeek] seek = [withKeys start] start :: Key -> CommandStart -start key = ifM (inAnnex key) - ( fieldTransfer Upload key $ \_p -> - sendAnnex key rollback $ liftIO . rsyncServerSend - , do - warning "requested key is not present" - liftIO exitFailure - ) +start key = do + (opts,_,_) <- getOpt Permute rsyncSafeOptions <$> + maybe [] (split " ") <$> getField "RsyncOptions" + ifM (inAnnex key) + ( fieldTransfer Upload key $ \_p -> + sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts) + , do + warning "requested key is not present" + liftIO exitFailure + ) where {- No need to do any rollback; when sendAnnex fails, a nonzero - exit will be propigated, and the remote will know the transfer diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index 2661d52e8..d641c6c3f 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -15,6 +15,7 @@ import qualified Git.Construct import CmdLine import Command import Annex.UUID +import Annex (setField) import qualified Option import Fields import Utility.UserInfo @@ -86,32 +87,38 @@ builtin :: String -> String -> [String] -> IO () builtin cmd dir params = do checkNotReadOnly cmd checkDirectory $ Just dir - let (params', fieldparams) = partitionParams params - let fields = filter checkField $ parseFields fieldparams - dispatch False (cmd : params') cmds options fields header $ + let (params', fieldparams, opts) = partitionParams params + fields = filter checkField $ parseFields fieldparams + cmds' = map (newcmd $ intercalate " " opts) cmds + dispatch False (cmd : params') cmds' options fields header $ Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath + where + newseek opts seek k = setField "RsyncOptions" opts >> seek k + newcmd opts c = c { cmdseek = map (newseek opts) (cmdseek c) } external :: [String] -> IO () external params = do {- Normal git-shell commands all have the directory as their last - parameter. -} let lastparam = lastMaybe =<< shellUnEscape <$> lastMaybe params + (params', _, _) = partitionParams params checkDirectory lastparam checkNotLimited - unlessM (boolSystem "git-shell" $ map Param $ "-c":fst (partitionParams params)) $ + unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $ error "git-shell failed" -{- Parameters between two -- markers are field settings, in the form: +{- Split the input list into 3 groups separated with a double dash --. + - Parameters between two -- markers are field settings, in the form: - field=value field=value - - - Parameters after the last -- are ignored, these tend to be passed by - - rsync and not be useful. + - Parameters after the last -- are the command itself and its arguments e.g., + - rsync --bandwidth=100. -} -partitionParams :: [String] -> ([String], [String]) +partitionParams :: [String] -> ([String], [String], [String]) partitionParams ps = case segment (== "--") ps of - params:fieldparams:_ -> (params, fieldparams) - [params] -> (params, []) - _ -> ([], []) + params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest ) + [params] -> (params, [], []) + _ -> ([], [], []) parseFields :: [String] -> [(String, String)] parseFields = map (separate (== '=')) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index afb3dcbc8..93c63c989 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -11,6 +11,7 @@ import Common import Utility.Metered import Data.Char +import System.Console.GetOpt {- Generates parameters to make rsync use a specified command as its remote - shell. -} @@ -23,13 +24,14 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman escape s = "'" ++ join "''" (split "'" s) ++ "'" {- Runs rsync in server mode to send a file. -} -rsyncServerSend :: FilePath -> IO Bool -rsyncServerSend file = rsync $ - rsyncServerParams ++ [Param "--sender", File file] +rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool +rsyncServerSend options file = rsync $ + rsyncServerParams ++ Param "--sender" : options ++ [File file] {- Runs rsync in server mode to receive a file. -} -rsyncServerReceive :: FilePath -> IO Bool -rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file] +rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool +rsyncServerReceive options file = rsync $ + rsyncServerParams ++ options ++ [File file] rsyncServerParams :: [CommandParam] rsyncServerParams = @@ -127,3 +129,14 @@ parseRsyncProgress = go [] . reverse . progresschunks ([], _) -> Nothing (_, []) -> Nothing (b, _) -> readish b + +{- To prevent an evil client to run harmful options on the server, we + - cherry-pick those that are harmless. Them only are passed to rsync + - when executed through 'git-annex-shell'. + - Note: Ensure that when calling getopt, the first component of the + - outupt is a subset of the input. + -} +rsyncSafeOptions :: [OptDescr String] +rsyncSafeOptions = [ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ] + where + reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) "" |