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.

5 files changed, 51 insertions, 27 deletions

diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs
index 9744a56d4..ce8bff997 100644
--- a/Command/RecvKey.hs
+++ b/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
-	whenM (inAnnex key) $ error "key is already present in annex"
-	
-	ok <- getViaTmp key (liftIO . rsyncServerReceive)
-	if ok
-		then do
-			-- forcibly quit after receiving one key,
-			-- and shutdown cleanly
-			_ <- shutdown True
-			liftIO exitSuccess
-		else liftIO exitFailure
+start key = ifM (inAnnex key)
+	( error "key is already present in annex"
+	, fieldTransfer Download key $ do
+		ifM (getViaTmp key $ liftIO . rsyncServerReceive)
+			( do
+				-- forcibly quit after receiving one key,
+				-- and shutdown cleanly
+				_ <- shutdown True
+				liftIO exitSuccess
+			, liftIO exitFailure
+			)
+	)
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index 686a31caa..5eca70d24 100644
--- a/Command/SendKey.hs
+++ b/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
-	file <- inRepo $ gitAnnexLocation key
-	whenM (inAnnex key) $
-		liftIO $ rsyncServerSend file -- does not return
-	warning "requested key is not present"
-	liftIO exitFailure
+start key = ifM (inAnnex key)
+	( fieldTransfer Upload key $ do
+		file <- inRepo $ gitAnnexLocation key
+		liftIO $ ifM (rsyncServerSend file)
+			( exitSuccess , exitFailure )
+	, do
+		warning "requested key is not present"
+		liftIO exitFailure
+	)
diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs
index 2a9f3c26a..559e30235 100644
--- a/GitAnnexShell.hs
+++ b/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
-	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
 
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 526241f93..658e18b5d 100644
--- a/Logs/Transfer.hs
+++ b/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.
diff --git a/Utility/RsyncFile.hs b/Utility/RsyncFile.hs
index db9057843..075e91d23 100644
--- a/Utility/RsyncFile.hs
+++ b/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. -}
-rsyncServerSend :: FilePath -> IO ()
-rsyncServerSend file = rsyncExec $
+{- Runs rsync in server mode to send a file. -}
+rsyncServerSend :: FilePath -> IO Bool
+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