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

diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
index c5ff4a9c8a0dd3758237bf88744b937ed218b904..c1c11a550ee11823b578820bf5e255e1a8068d7f 100644 (file)
--- 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 0a07dcecefd8a6262e9c82c7c3eb2dca56ff1f70..42a0377a33cd3d88b1222abeadf9bccd3638dd0c 100644 (file)
--- 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 2661d52e815b650da710797bcf52cf8fadaf96b0..d641c6c3f9f5c3317253defbb967cb2057228469 100644 (file)
--- 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 afb3dcbc8536e14f74adbcaa8c6193eb31aa9064..93c63c989353ade67dfa326a0c3b9d273f2a47d8 100644 (file)
--- 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) ""