add a progress callback to storeKey, and threaded it all the way through

Transfer info files are updated when the callback is called, updating
the number of bytes transferred.

Left unused p variables at every place the callback should be used.
Which is rather a lot..

Command/RecvKey.hs

@@ -25,7 +25,7 @@ seek = [withKeys start]
 start :: Key -> CommandStart
 start key = ifM (inAnnex key)
 	( error "key is already present in annex"
-	, fieldTransfer Download key $ do
+	, fieldTransfer Download key $ \p -> do
 		ifM (getViaTmp key $ liftIO . rsyncServerReceive)
 			( do
 				-- forcibly quit after receiving one key,

Command/SendKey.hs

@@ -12,6 +12,7 @@ import Command
 import Annex.Content
 import Utility.Rsync
 import Logs.Transfer
+import Types.Remote
 import qualified Fields
 
 def :: [Command]
@@ -23,7 +24,7 @@ seek = [withKeys start]
 
 start :: Key -> CommandStart
 start key = ifM (inAnnex key)
-	( fieldTransfer Upload key $ do
+	( fieldTransfer Upload key $ \p -> do
 		file <- inRepo $ gitAnnexLocation key
 		liftIO $ rsyncServerSend file
 	, do
@@ -31,10 +32,11 @@ start key = ifM (inAnnex key)
 		liftIO exitFailure
 	)
 
-fieldTransfer :: Direction -> Key -> Annex Bool -> CommandStart
+fieldTransfer :: Direction -> Key -> (ProgressCallback -> Annex Bool) -> CommandStart
 fieldTransfer direction key a = do
 	afile <- Fields.getField Fields.associatedFile
-	ok <- maybe a (\u -> runTransfer (Transfer direction (toUUID u) key) afile a)
+	ok <- maybe (a $ const noop)
+		(\u -> runTransfer (Transfer direction (toUUID u) key) afile a)
 		=<< Fields.getField Fields.remoteUUID
 	if ok
 		then liftIO exitSuccess

Command/TransferKey.hs

@@ -43,8 +43,8 @@ start to from file key =
 
 toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
 toPerform remote key file = next $
-	upload (uuid remote) key file $ do
+	upload (uuid remote) key file $ \p -> do
-		ok <- Remote.storeKey remote key file
+		ok <- Remote.storeKey remote key file p
 		when ok $
 			Remote.logStatus remote key InfoPresent
 		return ok

Logs/Transfer.hs

@@ -74,11 +74,11 @@ percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
 percentComplete (Transfer { transferKey = key }) info =
 	percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
 
-upload :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool
+upload :: UUID -> Key -> AssociatedFile -> (ProgressCallback -> Annex Bool) -> Annex Bool
 upload u key file a = runTransfer (Transfer Upload u key) file a
 
 download :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool
-download u key file a = runTransfer (Transfer Download u key) file a
+download u key file a = runTransfer (Transfer Download u key) file (const a)
 
 {- Runs a transfer action. Creates and locks the lock file while the
  - action is running, and stores info in the transfer information
@@ -87,7 +87,7 @@ download u key file a = runTransfer (Transfer Download u key) file a
  - If the transfer action returns False, the transfer info is 
  - left in the failedTransferDir.
  -}
-runTransfer :: Transfer -> Maybe FilePath -> Annex Bool -> Annex Bool
+runTransfer :: Transfer -> Maybe FilePath -> (ProgressCallback -> Annex Bool) -> Annex Bool
 runTransfer t file a = do
 	tfile <- fromRepo $ transferFile t
 	createAnnexDirectory $ takeDirectory tfile
@@ -100,7 +100,9 @@ runTransfer t file a = do
 		<*> pure Nothing
 		<*> pure file
 		<*> pure False
-	ok <- bracketIO (prep tfile mode info) (cleanup tfile) a
+	ok <- bracketIO (prep tfile mode info) (cleanup tfile) $ a $ \bytes ->
+		writeTransferInfoFile (info { bytesComplete = Just bytes }) tfile
+		
 	unless ok $ failed info
 	return ok
 	where
@@ -208,12 +210,16 @@ writeTransferInfoFile info tfile = do
 	hPutStr h $ writeTransferInfo info
 	hClose h
 
+{- File format is a header line containing the startedTime and any
+ - bytesComplete value. Followed by a newline and the associatedFile.
+ -
+ - The transferPid is not included; instead it is obtained by looking
+ - at the process that locks the file.
+ -}
 writeTransferInfo :: TransferInfo -> String
 writeTransferInfo info = unlines
-	-- transferPid is not included; instead obtained by looking at
+	[ (maybe "" show $ startedTime info) ++
-	-- the process that locks the file.
+	  (maybe "" (\b -> " " ++ show b) $ bytesComplete info)
-	[ maybe "" show $ startedTime info
-	-- bytesComplete is not included; changes too fast 
 	, fromMaybe "" $ associatedFile info -- comes last; arbitrary content
 	]
 
@@ -224,20 +230,24 @@ readTransferInfoFile mpid tfile = do
 	hClose h `after` (readTransferInfo mpid <$> hGetContentsStrict h)
 
 readTransferInfo :: (Maybe ProcessID) -> String -> Maybe TransferInfo
-readTransferInfo mpid s =
+readTransferInfo mpid s = TransferInfo
-	case bits of
+	<$> time
-		[time] -> TransferInfo
+	<*> pure mpid
-			<$> (Just <$> parsePOSIXTime time)
+	<*> pure Nothing
-			<*> pure mpid
+	<*> pure Nothing
-			<*> pure Nothing
+	<*> bytes
-			<*> pure Nothing
+	<*> pure (if null filename then Nothing else Just filename)
-			<*> pure Nothing
+	<*> pure False
-			<*> pure (if null filename then Nothing else Just filename)
-			<*> pure False
-		_ -> Nothing
 	where
-		(bits, filebits) = splitAt 1 $ lines s 
+		(bits, filebits) = splitAt 1 $ lines s
 		filename = join "\n" filebits
+		numbits = length bits
+		time = if numbits > 0
+			then Just <$> parsePOSIXTime (bits !! 0)
+			else pure Nothing
+		bytes = if numbits > 1
+			then Just <$> readish (bits !! 1)
+			else pure Nothing
 
 parsePOSIXTime :: String -> Maybe POSIXTime
 parsePOSIXTime s = utcTimeToPOSIXSeconds

Remote/Bup.hs

@@ -113,14 +113,14 @@ bupSplitParams r buprepo k src = do
 	return $ bupParams "split" buprepo 
 		(os ++ [Param "-n", Param (bupRef k), src])
 
-store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> Annex Bool
+store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-store r buprepo k _f = do
+store r buprepo k _f p = do
 	src <- inRepo $ gitAnnexLocation k
 	params <- bupSplitParams r buprepo k (File src)
 	liftIO $ boolSystem "bup" params
 
-storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
-storeEncrypted r buprepo (cipher, enck) k = do
+storeEncrypted r buprepo (cipher, enck) k p = do
 	src <- inRepo $ gitAnnexLocation k
 	params <- bupSplitParams r buprepo enck (Param "-")
 	liftIO $ catchBoolIO $

Remote/Directory.hs

@@ -124,8 +124,8 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
 withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
 withStoredFiles = withCheckedFiles doesFileExist
 
-store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> Annex Bool
+store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-store d chunksize k _f = do
+store d chunksize k _f p = do
 	src <- inRepo $ gitAnnexLocation k
 	metered k $ \meterupdate -> 
 		storeHelper d chunksize k $ \dests ->
@@ -139,8 +139,8 @@ store d chunksize k _f = do
 					storeSplit meterupdate chunksize dests
 						=<< L.readFile src
 
-storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
-storeEncrypted d chunksize (cipher, enck) k = do
+storeEncrypted d chunksize (cipher, enck) k p = do
 	src <- inRepo $ gitAnnexLocation k
 	metered k $ \meterupdate ->
 		storeHelper d chunksize enck $ \dests ->

Remote/Git.hs

@@ -262,8 +262,8 @@ copyFromRemoteCheap r key file
 	| otherwise = return False
 
 {- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Git.Repo -> Key -> AssociatedFile -> Annex Bool
+copyToRemote :: Git.Repo -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-copyToRemote r key file
+copyToRemote r key file p
 	| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do
 		keysrc <- inRepo $ gitAnnexLocation key
 		params <- rsyncParams r
@@ -276,7 +276,7 @@ copyToRemote r key file
 				download u key file $
 					Annex.Content.saveState True `after`
 						Annex.Content.getViaTmp key
-							(rsyncOrCopyFile params keysrc)
+							(\d -> rsyncOrCopyFile params keysrc d p)
 			)
 	| Git.repoIsSsh r = commitOnCleanup r $ do
 		keysrc <- inRepo $ gitAnnexLocation key
@@ -295,8 +295,8 @@ rsyncHelper p = do
 
 {- Copys a file with rsync unless both locations are on the same
  - filesystem. Then cp could be faster. -}
-rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> Annex Bool
+rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> ProgressCallback -> Annex Bool
-rsyncOrCopyFile rsyncparams src dest =
+rsyncOrCopyFile rsyncparams src dest p =
 	ifM (sameDeviceIds src dest)
 		( liftIO $ copyFileExternal src dest
 		, rsyncHelper $ rsyncparams ++ [Param src, Param dest]

Remote/Helper/Encryptable.hs

@@ -45,7 +45,7 @@ encryptionSetup c = case (M.lookup "encryption" c, extractCipher c) of
  - to support storing and retrieving encrypted content. -}
 encryptableRemote
 	:: Maybe RemoteConfig
-	-> ((Cipher, Key) -> Key -> Annex Bool)
+	-> ((Cipher, Key) -> Key -> ProgressCallback -> Annex Bool)
 	-> ((Cipher, Key) -> Key -> FilePath -> Annex Bool)
 	-> Remote
 	-> Remote
@@ -59,9 +59,9 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
 		cost = cost r + encryptedRemoteCostAdj
 	}
 	where
-		store k f = cip k >>= maybe
+		store k f p = cip k >>= maybe
-			(storeKey r k f)
+			(storeKey r k f p)
-			(`storeKeyEncrypted` k)
+			(\enck -> storeKeyEncrypted enck k p)
 		retrieve k f d = cip k >>= maybe
 			(retrieveKeyFile r k f d)
 			(\enck -> retrieveKeyFileEncrypted enck k d)

Remote/Helper/Hooks.hs

@@ -27,7 +27,7 @@ addHooks' r Nothing Nothing = r
 addHooks' r starthook stophook = r'
 	where
 		r' = r
-			{ storeKey = \k f -> wrapper $ storeKey r k f
+			{ storeKey = \k f p -> wrapper $ storeKey r k f p
 			, retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d
 			, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
 			, removeKey = \k -> wrapper $ removeKey r k

Remote/Hook.hs

@@ -103,13 +103,13 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
 					return False
 				)
 
-store :: String -> Key -> AssociatedFile -> Annex Bool
+store :: String -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-store h k _f = do
+store h k _f _p = do
 	src <- inRepo $ gitAnnexLocation k
 	runHook h "store" k (Just src) $ return True
 
-storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted :: String -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
-storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
+storeEncrypted h (cipher, enck) k _p = withTmp enck $ \tmp -> do
 	src <- inRepo $ gitAnnexLocation k
 	liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
 	runHook h "store" enck (Just tmp) $ return True

Remote/Rsync.hs

@@ -104,11 +104,11 @@ rsyncUrls o k = map use annexHashes
 		use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f)
                 f = keyFile k
 
-store :: RsyncOpts -> Key -> AssociatedFile -> Annex Bool
+store :: RsyncOpts -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-store o k _f = rsyncSend o k <=< inRepo $ gitAnnexLocation k
+store o k _f p = rsyncSend o k <=< inRepo $ gitAnnexLocation k
 
-storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
-storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
+storeEncrypted o (cipher, enck) k p = withTmp enck $ \tmp -> do
 	src <- inRepo $ gitAnnexLocation k
 	liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
 	rsyncSend o enck tmp

Remote/S3.hs

@@ -115,14 +115,14 @@ s3Setup u c = handlehost $ M.lookup "host" c
 					-- be human-readable
 					M.delete "bucket" defaults
 
-store :: Remote -> Key -> AssociatedFile -> Annex Bool
+store :: Remote -> Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-store r k _f = s3Action r False $ \(conn, bucket) -> do
+store r k _f p = s3Action r False $ \(conn, bucket) -> do
 	dest <- inRepo $ gitAnnexLocation k
 	res <- liftIO $ storeHelper (conn, bucket) r k dest
 	s3Bool res
 
-storeEncrypted :: Remote -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted :: Remote -> (Cipher, Key) -> Key -> ProgressCallback -> Annex Bool
-storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> 
+storeEncrypted r (cipher, enck) k p = s3Action r False $ \(conn, bucket) -> 
 	-- To get file size of the encrypted content, have to use a temp file.
 	-- (An alternative would be chunking to to a constant size.)
 	withTmp enck $ \tmp -> do

Remote/Web.hs

@@ -66,8 +66,8 @@ downloadKey key _file dest = get =<< getUrls key
 downloadKeyCheap :: Key -> FilePath -> Annex Bool
 downloadKeyCheap _ _ = return False
 
-uploadKey :: Key -> AssociatedFile -> Annex Bool
+uploadKey :: Key -> AssociatedFile -> ProgressCallback -> Annex Bool
-uploadKey _ _ = do
+uploadKey _ _ _ = do
 	warning "upload to web not supported"
 	return False
 

Types/Remote.hs

@@ -36,6 +36,10 @@ instance Eq (RemoteTypeA a) where
 {- A filename associated with a Key, for display to user. -}
 type AssociatedFile = Maybe FilePath
 
+{- An action that can be run repeatedly, feeding it the number of
+ - bytes sent or retreived so far. -}
+type ProgressCallback = (Integer -> IO ())
+
 {- An individual remote. -}
 data RemoteA a = Remote {
 	-- each Remote has a unique uuid
@@ -45,7 +49,7 @@ data RemoteA a = Remote {
 	-- Remotes have a use cost; higher is more expensive
 	cost :: Int,
 	-- Transfers a key to the remote.
-	storeKey :: Key -> AssociatedFile -> a Bool,
+	storeKey :: Key -> AssociatedFile -> ProgressCallback -> a Bool,
 	-- retrieves a key's contents to a file
 	retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> a Bool,
 	-- retrieves a key's contents to a tmp file, if it can be done cheaply