git-annex-shell transferinfo command

TODO: Use this when running sendkey, to feed back transfer info from the
client side rsync.

5 files changed, 104 insertions, 24 deletions

diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs
new file mode 100644
index 000000000..0e0e81609
--- /dev/null
+++ b/Command/TransferInfo.hs
@@ -0,0 +1,60 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TransferInfo where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Logs.Transfer
+import Types.Remote
+import Types.Key
+
+def :: [Command]
+def = [noCommit $ command "transferinfo" paramdesc seek
+	"updates sender on number of bytes of content received"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+paramdesc :: String
+paramdesc = paramKey `paramPair` paramUUID `paramPair` paramOptional paramFile
+
+start :: [String] -> CommandStart
+start (k:u:f:[]) = start' (file2key k) (toUUID u) (Just f) >> stop
+start (k:u:[]) = start' (file2key k) (toUUID u) Nothing >> stop
+start _ = error "wrong number of parameters"
+
+{- Security:
+ - 
+ - The transfer info file contains the user-supplied key, but
+ - the built-in guards prevent slashes in it from showing up in the filename.
+ - It also contains the UUID of the remote. But slashes are also filtered
+ - out of that when generating the filename.
+ - 
+ - Checks that the key being transferred is inAnnex, to prevent
+ - malicious spamming of bogus keys. Does not check that a transfer
+ - of the key is actually in progress, because this could be started
+ - concurrently with sendkey, and win the race.
+ -}
+start' :: Maybe Key -> UUID -> AssociatedFile -> Annex ()
+start' Nothing _ _ = error "bad key"
+start' (Just key) u file = whenM (inAnnex key) $ do
+	let t = Transfer
+		{ transferDirection = Upload
+		, transferUUID = u
+		, transferKey = key
+		}
+	info <- liftIO $ startTransferInfo file
+	(update, tfile) <- mkProgressUpdater t info
+	liftIO $ mapM_ void
+		[ tryIO $ forever $ do
+			bytes <- readish <$> getLine
+			maybe (error "transferinfo protocol error") update bytes
+		, tryIO $ removeFile tfile
+		, exitSuccess
+		]
diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs
index d9b60c0f6..ebe280279 100644
--- a/GitAnnexShell.hs
+++ b/GitAnnexShell.hs
@@ -23,6 +23,7 @@ import qualified Command.InAnnex
 import qualified Command.DropKey
 import qualified Command.RecvKey
 import qualified Command.SendKey
+import qualified Command.TransferInfo
 import qualified Command.Commit
 
 cmds_readonly :: [Command]
@@ -30,6 +31,7 @@ cmds_readonly = concat
 	[ Command.ConfigList.def
 	, Command.InAnnex.def
 	, Command.SendKey.def
+	, Command.TransferInfo.def
 	]
 
 cmds_notreadonly :: [Command]
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index e9ac5bd87..7188143d6 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -89,18 +89,9 @@ download u key file a = runTransfer (Transfer Download u key) file (const a)
  -}
 runTransfer :: Transfer -> Maybe FilePath -> (MeterUpdate -> Annex Bool) -> Annex Bool
 runTransfer t file a = do
-	tfile <- fromRepo $ transferFile t
-	createAnnexDirectory $ takeDirectory tfile
+	info <- liftIO $ startTransferInfo file
+	(meter, tfile) <- mkProgressUpdater t info
 	mode <- annexFileMode
-	info <- liftIO $ TransferInfo
-		<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
-		<*> pure Nothing -- pid not stored in file, so omitted for speed
-		<*> pure Nothing -- tid ditto
-		<*> pure Nothing -- not 0; transfer may be resuming
-		<*> pure Nothing
-		<*> pure file
-		<*> pure False
-	meter <- liftIO $ progressupdater tfile info
 	ok <- bracketIO (prep tfile mode info) (cleanup tfile) (a meter)
 	unless ok $ failed info
 	return ok
@@ -122,16 +113,24 @@ runTransfer t file a = do
 			failedtfile <- fromRepo $ failedTransferFile t
 			createAnnexDirectory $ takeDirectory failedtfile
 			liftIO $ writeTransferInfoFile info failedtfile
-		{- Updates transfer info file as transfer progresses. -}
-		progressupdater tfile info = do
-			mvar <- newMVar 0
-			return $ \bytes -> modifyMVar_ mvar $ \oldbytes -> do
-				if (bytes - oldbytes >= mindelta)
-					then do
-						let info' = info { bytesComplete = Just bytes }
-						writeTransferInfoFile info' tfile
-						return bytes
-					else return oldbytes
+
+
+{- Generates a callback that can be called as transfer progresses to update
+ - the transfer info file. Also returns the file it'll be updating. -}
+mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath)
+mkProgressUpdater t info = do
+	tfile <- fromRepo $ transferFile t
+	createAnnexDirectory $ takeDirectory tfile
+	mvar <- liftIO $ newMVar 0
+	return (liftIO . updater tfile mvar, tfile)
+	where
+		updater tfile mvar bytes = modifyMVar_ mvar $ \oldbytes -> do
+			if (bytes - oldbytes >= mindelta)
+				then do
+					let info' = info { bytesComplete = Just bytes }
+					writeTransferInfoFile info' tfile
+					return bytes
+				else return oldbytes
 		{- The minimum change in bytesComplete that is worth
 		 - updating a transfer info file for is 1% of the total
 		 - keySize, rounded down. -}
@@ -139,6 +138,16 @@ runTransfer t file a = do
 			Just sz -> sz `div` 100
 			Nothing -> 100 * 1024 -- arbitrarily, 100 kb
 
+startTransferInfo :: Maybe FilePath -> IO TransferInfo
+startTransferInfo file = TransferInfo
+	<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
+	<*> pure Nothing -- pid not stored in file, so omitted for speed
+	<*> pure Nothing -- tid ditto
+	<*> pure Nothing -- not 0; transfer may be resuming
+	<*> pure Nothing
+	<*> pure file
+	<*> pure False
+
 {- If a transfer is still running, returns its TransferInfo. -}
 checkTransfer :: Transfer -> Annex (Maybe TransferInfo)
 checkTransfer t = do
@@ -192,7 +201,7 @@ removeFailedTransfer t = do
 {- The transfer information file to use for a given Transfer. -}
 transferFile :: Transfer -> Git.Repo -> FilePath
 transferFile (Transfer direction u key) r = transferDir direction r
-	</> fromUUID u
+	</> filter (/= '/') (fromUUID u)
 	</> keyFile key
 
 {- The transfer information file to use to record a failed Transfer -}
@@ -278,4 +287,4 @@ failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath
 failedTransferDir u direction r = gitAnnexTransferDir r
 	</> "failed"
 	</> showLcDirection direction
-	</> fromUUID u
+	</> filter (/= '/') (fromUUID u)
diff --git a/Types/Key.hs b/Types/Key.hs
index 619315aed..6794ee003 100644
--- a/Types/Key.hs
+++ b/Types/Key.hs
@@ -40,7 +40,7 @@ stubKey = Key {
 fieldSep :: Char
 fieldSep = '-'
 
-{- Converts a key to a strings that are suitable for use as a filename.
+{- Converts a key to a string that is suitable for use as a filename.
  - The name field is always shown last, separated by doubled fieldSeps,
  - and is the only field allowed to contain the fieldSep. -}
 key2file :: Key -> FilePath
diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn
index 20a9d3d37..8256da0e3 100644
--- a/doc/git-annex-shell.mdwn
+++ b/doc/git-annex-shell.mdwn
@@ -46,6 +46,15 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
 
   This runs rsync in server mode to transfer out the content of a key.
 
+* transferinfo directory key uuid [file]
+
+  This is typically run at the same time as sendkey is sending a key
+  to the remote with the specified uuid.
+
+  It reads lines from standard input, each giving the number of bytes
+  that have been received so far. This is optional, but is used to update
+  progress information for the transfer of the key.
+
 * commit directory
 
   This commits any staged changes to the git-annex branch.