fix transferrer thread's use of transfer slots and transfer info files

Check first if a transfer needs to be done, using the location log only
(for speed), and avoid occupying a slot if not. Always write a transfer
info file, and keep it open throughout the tranfer process.

Now transfers to remotes seem reliable.

1 files changed, 49 insertions, 28 deletions

diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index f40218c08..aaf654d34 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -13,9 +13,10 @@ import Assistant.DaemonStatus
 import Assistant.TransferQueue
 import Assistant.TransferSlots
 import Logs.Transfer
+import Logs.Presence
+import Logs.Location
 import Annex.Content
-import Command
-import qualified Command.Move
+import qualified Remote
 
 import Data.Time.Clock
 import qualified Data.Map as M
@@ -31,8 +32,7 @@ transfererThread st dstatus transferqueue slots = go
 		go = do
 			(t, info) <- getNextTransfer transferqueue
 			whenM (runThreadState st $ shouldTransfer dstatus t) $
-				void $ inTransferSlot slots $
-					runTransfer st dstatus t info
+				runTransfer st dstatus slots t info
 			go
 
 {- Checks if the requested transfer is already running, or
@@ -49,33 +49,54 @@ shouldTransfer dstatus t = go =<< currentTransfers <$> getDaemonStatus dstatus
 {- A transfer is run in a separate process, with a *copy* of the Annex
  - state. This is necessary to avoid blocking the rest of the assistant
  - on the transfer completing, and also to allow multiple transfers to run
- - at once. 
+ - at once.
  -
  - However, it means that the transfer processes are responsible
  - for doing any necessary shutdown cleanups, and that the parent
  - thread's cache must be invalidated once a transfer completes, as
- - changes may have been made to the git-annex branch. 
- -
- - Currently a minimal shutdown is done; the transfer processes are
- - effectively running in oneshot mode, without committing changes to the
- - git-annex branch, and transfers should never queue git commands to run.
+ - changes may have been made to the git-annex branch.
  -}
-runTransfer :: ThreadState -> DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
-runTransfer st dstatus t info
-	| transferDirection t == Download = go Command.Move.fromStart
-	| otherwise = go Command.Move.toStart
+runTransfer :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
+runTransfer st dstatus slots t info = case (transferRemote info, associatedFile info) of
+	(Nothing, _) -> noop
+	(_, Nothing) -> noop
+	(Just remote, Just file) -> whenM (shouldtransfer remote) $ do
+		pid <- inTransferSlot slots $
+			unsafeForkProcessThreadState st $
+				transferprocess remote file
+		now <- getCurrentTime
+		runThreadState st $ adjustTransfers dstatus $
+			M.insertWith' const t info
+				{ startedTime = Just now
+				, transferPid = Just pid
+				, shouldWait = True
+				}
 	where
-		go cmd = case (transferRemote info, associatedFile info) of
-			(Nothing, _) -> noop
-			(_, Nothing) -> noop
-			(Just remote, Just file) -> do
-				now <- getCurrentTime
-				pid <- unsafeForkProcessThreadState st $
-					doCommand $ cmd remote False file (transferKey t)
-				runThreadState st $ 
-					adjustTransfers dstatus $
-						M.insertWith' const t info
-							{ startedTime = Just now
-							, transferPid = Just pid
-							, shouldWait = True
-							}
+		isdownload = transferDirection t == Download
+		tofrom
+			| isdownload = "from"
+			| otherwise = "to"
+		key = transferKey t
+
+		shouldtransfer remote
+			| isdownload = return True
+			| otherwise = runThreadState st $
+				{- Trust the location log to check if the
+				 - remote already has the key. This avoids
+				 - a roundtrip to the remote. -}
+				notElem (Remote.uuid remote)
+					<$> loggedLocations key
+
+		transferprocess remote file = do
+			showStart "copy" file
+			showAction $ tofrom ++ " " ++ Remote.name remote
+			ok <- transfer t (Just file) $
+				if isdownload
+					then getViaTmp key $
+						Remote.retrieveKeyFile remote key (Just file)
+					else do
+						ok <- Remote.storeKey remote key $ Just file
+						when ok $
+							Remote.logStatus remote key InfoPresent
+						return ok
+			showEndResult ok