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.

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 Remote
-import qualified Command.Move
 
 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 slots t info
-					runTransfer st dstatus t info
 			go
 
 {- Checks if the requested transfer is already running, or
@@ -55,27 +55,48 @@ shouldTransfer dstatus t = go =<< currentTransfers <$> getDaemonStatus dstatus
  - 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.
  -}
-runTransfer :: ThreadState -> DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
+runTransfer :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
-runTransfer st dstatus t info
+runTransfer st dstatus slots t info = case (transferRemote info, associatedFile info) of
-	| transferDirection t == Download = go Command.Move.fromStart
+	(Nothing, _) -> noop
-	| otherwise = go Command.Move.toStart
+	(_, 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
+		isdownload = transferDirection t == Download
-			(Nothing, _) -> noop
+		tofrom
-			(_, Nothing) -> noop
+			| isdownload = "from"
-			(Just remote, Just file) -> do
+			| otherwise = "to"
-				now <- getCurrentTime
+		key = transferKey t
-				pid <- unsafeForkProcessThreadState st $
+
-					doCommand $ cmd remote False file (transferKey t)
+		shouldtransfer remote
-				runThreadState st $ 
+			| isdownload = return True
-					adjustTransfers dstatus $
+			| otherwise = runThreadState st $
-						M.insertWith' const t info
+				{- Trust the location log to check if the
-							{ startedTime = Just now
+				 - remote already has the key. This avoids
-							, transferPid = Just pid
+				 - a roundtrip to the remote. -}
-							, shouldWait = True
+				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