add fields to git-annex-shell

5 files changed, 42 insertions, 12 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index 910f228b6..edbe5e107 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -30,8 +30,8 @@ type Params = [String]
 type Flags = [Annex ()]
 
 {- Runs the passed command line. -}
-dispatch :: Bool -> Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
-dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do
+dispatch :: Bool -> Params -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO ()
+dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
 	setupConsole
 	r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
 	case r of
@@ -40,6 +40,7 @@ dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do
 			state <- Annex.new g
 			(actions, state') <- Annex.run state $ do
 				checkfuzzy
+				forM_ fields $ \(f, v) -> Annex.setField f v
 				sequence_ flags
 				prepCommand cmd params
 		 	tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]
diff --git a/GitAnnex.hs b/GitAnnex.hs
index 8dba5a3a7..bf1f27bfd 100644
--- a/GitAnnex.hs
+++ b/GitAnnex.hs
@@ -143,4 +143,4 @@ header :: String
 header = "Usage: git-annex command [option ..]"
 
 run :: [String] -> IO ()
-run args = dispatch True args cmds options header Git.CurrentRepo.get
+run args = dispatch True args cmds options [] header Git.CurrentRepo.get
diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs
index 663303713..2a9f3c26a 100644
--- a/GitAnnexShell.hs
+++ b/GitAnnexShell.hs
@@ -47,7 +47,8 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
 
 options :: [OptDescr (Annex ())]
 options = Option.common ++
-	[ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "repository uuid"
+	[ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "local repository uuid"
+	, Option [] ["remote-uuid"] (ReqArg checkuuid paramUUID) "remote repository uuid"
 	]
 	where
 		checkuuid expected = getUUID >>= check
@@ -83,21 +84,31 @@ builtins = map cmdname cmds
 builtin :: String -> String -> [String] -> IO ()
 builtin cmd dir params = do
 	checkNotReadOnly cmd
-	dispatch False (cmd : filterparams params) cmds options header $
+	let (params', fields) = partitionParams params
+	dispatch False (cmd : params') cmds options (parseFields fields) header $
 		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
 
 external :: [String] -> IO ()
 external params = do
 	checkNotLimited
-	unlessM (boolSystem "git-shell" $ map Param $ "-c":filterparams params) $
+	unlessM (boolSystem "git-shell" $ map Param $ "-c":fst (partitionParams params)) $
 		error "git-shell failed"
 
--- Drop all args after "--".
--- These tend to be passed by rsync and not useful.
-filterparams :: [String] -> [String]
-filterparams [] = []
-filterparams ("--":_) = []
-filterparams (a:as) = a:filterparams as
+{- 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.
+ -}
+partitionParams :: [String] -> ([String], [String])
+partitionParams params
+	| length segments < 2 = (segments !! 0, [])
+	| otherwise = (segments !! 0, segments !! 1)
+	where
+		segments = segment (== "--") params
+
+parseFields :: [String] -> [(String, String)]
+parseFields = map (separate (== '='))
 
 failure :: IO ()
 failure = error $ "bad parameters\n\n" ++ usage header cmds options
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 3ac5ca5c0..3b359139b 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -35,3 +35,13 @@ separate c l = unbreak $ break c l
 {- Breaks out the first line. -}
 firstLine :: String-> String
 firstLine = takeWhile (/= '\n')
+
+{- Splits a list into segments that are delimited by items matching
+ - a predicate. (The delimiters are not included in the segments.) -}
+segment :: (a -> Bool) -> [a] -> [[a]]
+segment p l = map reverse $ go [] [] l
+	where
+		go c r [] = reverse $ c:r
+		go c r (i:is)
+			| p i = go [] (c:r) is
+			| otherwise = go (i:c) r is
diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn
index 00c68ff3a..20a9d3d37 100644
--- a/doc/git-annex-shell.mdwn
+++ b/doc/git-annex-shell.mdwn
@@ -61,6 +61,14 @@ to git-annex-shell are:
   git-annex uses this to specify the UUID of the repository it was expecting
   git-annex-shell to access, as a sanity check.
 
+* -- fields=val fields=val.. --
+
+  Additional fields may be specified this way, to retain compatability with
+  past versions of git-annex-shell (that ignore these, but would choke
+  on new dashed options).
+
+  Currently used fields include remoteuuid= and associatedfile=
+
 # HOOK
 
 After content is received or dropped from the repository by git-annex-shell,