Make git-annex-shell call the command with its (safe) options.

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)
+	go tmp = do
-		( ifM (isJust <$> Fields.getField Fields.direct)
+		(opts,_,_) <- getOpt Permute rsyncSafeOptions <$>
-			( directcheck tmp
+				maybe [] (split " ") <$> getField "RsyncOptions"
-			, return True
+		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

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)
+start key = do
-	( fieldTransfer Upload key $ \_p ->
+	(opts,_,_) <- getOpt Permute rsyncSafeOptions <$>
-		sendAnnex key rollback $ liftIO . rsyncServerSend
+			maybe [] (split " ") <$> getField "RsyncOptions"
-	, do
+	ifM (inAnnex key)
-		warning "requested key is not present"
+		( fieldTransfer Upload key $ \_p ->
-		liftIO exitFailure
+			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

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 (params', fieldparams, opts) = partitionParams params
-	let fields = filter checkField $ parseFields fieldparams
+	    fields = filter checkField $ parseFields fieldparams
-	dispatch False (cmd : params') cmds options fields header $
+	    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
+ - Parameters after the last -- are the command itself and its arguments e.g.,
- - rsync and not be useful.
+ - rsync --bandwidth=100.
  -}
-partitionParams :: [String] -> ([String], [String])
+partitionParams :: [String] -> ([String], [String], [String])
 partitionParams ps = case segment (== "--") ps of
-	params:fieldparams:_ -> (params, fieldparams)
+	params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest )
-	[params] -> (params, [])
+	[params] -> (params, [], [])
-	_ -> ([], [])
+	_ -> ([], [], [])
 
 parseFields :: [String] -> [(String, String)]
 parseFields = map (separate (== '='))

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 :: [CommandParam] -> FilePath -> IO Bool
-rsyncServerSend file = rsync $
+rsyncServerSend options file = rsync $
-	rsyncServerParams ++ [Param "--sender", File file]
+	rsyncServerParams ++ Param "--sender" : options ++ [File file]
 
 {- Runs rsync in server mode to receive a file. -}
-rsyncServerReceive :: FilePath -> IO Bool
+rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool
-rsyncServerReceive file = rsync $ rsyncServerParams ++ [File file]
+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) ""