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.

Command/RecvKey.hs

@@ -12,6 +12,7 @@ import Command
 import CmdLine
 import Annex.Content
 import Utility.RsyncFile
+import Logs.Transfer
 
 def :: [Command]
 def = [oneShot $ command "recvkey" paramKey seek
@@ -21,14 +22,15 @@ seek :: [CommandSeek]
 seek = [withKeys start]
 
 start :: Key -> CommandStart
-start key = do
+start key = ifM (inAnnex key)
-	whenM (inAnnex key) $ error "key is already present in annex"
+	( error "key is already present in annex"
-	
+	, fieldTransfer Download key $ do
-	ok <- getViaTmp key (liftIO . rsyncServerReceive)
+		ifM (getViaTmp key $ liftIO . rsyncServerReceive)
-	if ok
+			( do
-		then do
+				-- forcibly quit after receiving one key,
-			-- forcibly quit after receiving one key,
+				-- and shutdown cleanly
-			-- and shutdown cleanly
+				_ <- shutdown True
-			_ <- shutdown True
+				liftIO exitSuccess
-			liftIO exitSuccess
+			, liftIO exitFailure
-		else liftIO exitFailure
+			)
+	)

Command/SendKey.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010,2012 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Annex.Content
 import Utility.RsyncFile
+import Logs.Transfer
 
 def :: [Command]
 def = [oneShot $ command "sendkey" paramKey seek
@@ -20,9 +21,12 @@ seek :: [CommandSeek]
 seek = [withKeys start]
 
 start :: Key -> CommandStart
-start key = do
+start key = ifM (inAnnex key)
-	file <- inRepo $ gitAnnexLocation key
+	( fieldTransfer Upload key $ do
-	whenM (inAnnex key) $
+		file <- inRepo $ gitAnnexLocation key
-		liftIO $ rsyncServerSend file -- does not return
+		liftIO $ ifM (rsyncServerSend file)
-	warning "requested key is not present"
+			( exitSuccess , exitFailure )
-	liftIO exitFailure
+	, do
+		warning "requested key is not present"
+		liftIO exitFailure
+	)

GitAnnexShell.hs

@@ -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
+	let (params', fieldparams) = partitionParams params
-	dispatch False (cmd : params') cmds options (parseFields fields) header $
+	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
 

Logs/Transfer.hs

@@ -10,6 +10,7 @@ module Logs.Transfer where
 import Common.Annex
 import Annex.Perms
 import Annex.Exception
+import qualified Annex
 import qualified Git
 import Types.Remote
 
@@ -54,6 +55,12 @@ upload u key file a = transfer (Transfer Upload u key) file a
 download :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a
 download u key file a = transfer (Transfer Download u key) file a
 
+fieldTransfer :: Direction -> Key -> Annex a -> Annex a
+fieldTransfer direction key a = do
+	afile <- Annex.getField "associatedfile"
+	maybe a (\u -> transfer (Transfer direction (toUUID u) key) afile a)
+		=<< Annex.getField "remoteuuid"
+
 {- Runs a transfer action. Creates and locks the transfer information file
  - while the action is running. Will throw an error if the transfer is
  - already in progress.

Utility/RsyncFile.hs

@@ -22,9 +22,9 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman
                  - string is a single quote. -}
 		escape s = "'" ++  join "''" (split "'" s) ++ "'"
 
-{- Runs rsync in server mode to send a file, and exits. -}
+{- Runs rsync in server mode to send a file. -}
-rsyncServerSend :: FilePath -> IO ()
+rsyncServerSend :: FilePath -> IO Bool
-rsyncServerSend file = rsyncExec $
+rsyncServerSend file = rsync $
 	rsyncServerParams ++ [Param "--sender", File file]
 
 {- Runs rsync in server mode to receive a file. -}
@@ -47,11 +47,8 @@ rsyncServerParams =
 rsync :: [CommandParam] -> IO Bool
 rsync = boolSystem "rsync"
 
-rsyncExec :: [CommandParam] -> IO ()
-rsyncExec params = executeFile "rsync" True (toCommand params) Nothing
-
 {- Checks if an rsync url involves the remote shell (ssh or rsh).
- - Use of such urls with rsync or rsyncExec requires additional shell
+ - Use of such urls with rsync requires additional shell
  - escaping. -}
 rsyncUrlIsShell :: String -> Bool
 rsyncUrlIsShell s