git-annex-shell transferinfo command

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

1 files changed, 32 insertions, 23 deletions

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)