record transfers for git-annex-shell

Not yet tested and places git-annex-shell is run need to be modified to
pass the new field settings.

Note that rsyncServerSend was changed to fork, rather than directly exec
rsync, because it needs to keep the transfer lock held, and clean up the
transfer log when done.
This commit is contained in:
Joey Hess 2012-07-02 01:31:10 -04:00
parent d1f49b0ad0
commit bea0ac0274
5 changed files with 51 additions and 27 deletions

View file

@ -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