keep logs of failed transfers, and requeue them when doing a non-full scan

of a remote

Assistant/ScanRemotes.hs

@@ -14,9 +14,12 @@ import Data.Function
 import Control.Concurrent.STM
 import qualified Data.Map as M
 
-type Priority = Int
+data ScanInfo = ScanInfo
+	{ scanPriority :: Int
+	, fullScan :: Bool
+	}
 
-type ScanRemoteMap = TMVar (M.Map Remote Priority)
+type ScanRemoteMap = TMVar (M.Map Remote ScanInfo)
 
 {- The TMVar starts empty, and is left empty when there are no remotes
  - to scan. -}
@@ -25,21 +28,23 @@ newScanRemoteMap = atomically newEmptyTMVar
 
 {- Blocks until there is a remote that needs to be scanned.
  - Processes higher priority remotes first. -}
-getScanRemote :: ScanRemoteMap -> IO Remote
+getScanRemote :: ScanRemoteMap -> IO (Remote, ScanInfo)
 getScanRemote v = atomically $ do
 	m <- takeTMVar v
-	let l = reverse $ map fst $ sortBy (compare `on` snd) $ M.toList m
+	let l = reverse $ sortBy (compare `on` scanPriority . snd) $ M.toList m
 	case l of
 		[] -> retry -- should never happen
-		(newest:_) -> do
-			let m' = M.delete newest m
+		(ret@(r, _):_) -> do
+			let m' = M.delete r m
 			unless (M.null m') $
 				putTMVar v m'
-			return newest
+			return ret
 
 {- Adds new remotes that need scanning to the map. -}
-addScanRemotes :: ScanRemoteMap -> [Remote] -> IO ()
-addScanRemotes _ [] = noop
-addScanRemotes v rs = atomically $ do
+addScanRemotes :: ScanRemoteMap -> [Remote] -> Bool -> IO ()
+addScanRemotes _ [] _ = noop
+addScanRemotes v rs full = atomically $ do
 	m <- fromMaybe M.empty <$> tryTakeTMVar v
-	putTMVar v $ M.union m $ M.fromList $ map (\r -> (r, Remote.cost r)) rs
+	putTMVar v $ M.union (M.fromList $ zip rs (map info rs)) m
+	where
+		info r = ScanInfo (Remote.cost r) full

Assistant/Sync.hs

@@ -26,10 +26,11 @@ import qualified Data.Map as M
 
 {- Syncs with remotes that may have been disconnected for a while.
  - 
- - After getting git in sync, queues a scan for file transfers.
- - To avoid doing that expensive scan unnecessarily, it's only run
- - if the git-annex branches of the remotes have diverged from the
- - local git-annex branch.
+ - First gets git in sync, and then prepares any necessary file transfers.
+ -
+ - An expensive full scan is queued when the git-annex branches of the
+ - remotes have diverged from the local git-annex branch. Otherwise,
+ - it's sufficient to requeue failed transfers.
  -}
 reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> [Remote] -> IO ()
 reconnectRemotes _ _ _ _ [] = noop
@@ -38,16 +39,14 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
 		sync =<< runThreadState st (inRepo Git.Branch.current)
 	where
 		sync (Just branch) = do
-			haddiverged <- manualPull st (Just branch) rs
-			when haddiverged $
-				addScanRemotes scanremotes rs	
+			diverged <- manualPull st (Just branch) rs
+			addScanRemotes scanremotes rs diverged
 			now <- getCurrentTime	
 			pushToRemotes threadname now st Nothing rs
 		{- No local branch exists yet, but we can try pulling. -}
 		sync Nothing = do
-			haddiverged <- manualPull st Nothing rs
-			when haddiverged $
-				addScanRemotes scanremotes rs	
+			diverged <- manualPull st Nothing rs
+			addScanRemotes scanremotes rs diverged
 			return True
 
 {- Updates the local sync branch, then pushes it to all remotes, in

Assistant/Threads/TransferScanner.hs

@@ -30,24 +30,45 @@ thisThread = "TransferScanner"
 transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> IO ()
 transferScannerThread st dstatus scanremotes transferqueue = do
 	runEvery (Seconds 2) $ do
-		r <- getScanRemote scanremotes
-		liftIO $ debug thisThread ["starting scan of", show r]
-		void $ alertWhile dstatus (scanAlert r) $
-			scan st dstatus transferqueue r
-		liftIO $ debug thisThread ["finished scan of", show r]
+		(r, info) <- getScanRemote scanremotes
+		scanned <- runThreadState st $ inRepo $
+			checkTransferScanned $ Remote.uuid r
+		if not scanned || fullScan info
+			then do
+				liftIO $ debug thisThread ["starting scan of", show r]
+				void $ alertWhile dstatus (scanAlert r) $
+					expensiveScan st dstatus transferqueue r
+				liftIO $ debug thisThread ["finished scan of", show r]
+				runThreadState st $ inRepo $
+					transferScanned $ Remote.uuid r
+			else failedTransferScan st dstatus transferqueue r
 
-{- This is a naive scan through the git work tree.
+{- This is a cheap scan for failed transfers involving a remote. -}
+failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
+failedTransferScan st dstatus transferqueue r = do
+	ts <- runThreadState st $ 
+		getFailedTransfers $ Remote.uuid r
+	go ts
+	where
+		go [] = noop
+		go ((t, info):ts) = do
+			queueTransferWhenSmall
+				transferqueue dstatus (associatedFile info) t r
+			void $ runThreadState st $ inRepo $
+				liftIO . tryIO . removeFile . failedTransferFile t
+			go ts
+
+{- This is a expensive scan through the full git work tree.
  - 
  - The scan is blocked when the transfer queue gets too large. -}
-scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool
-scan st dstatus transferqueue r = do
+expensiveScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool
+expensiveScan st dstatus transferqueue r = do
 	g <- runThreadState st $ fromRepo id
 	files <- LsFiles.inRepo [] g
 	go files
-	inRepo $ transferScanned $ uuid r
 	return True
 	where
-		go [] = return ()
+		go [] = noop
 		go (f:fs) = do
 			v <- runThreadState st $ whenAnnexed check f
 			case v of
@@ -67,8 +88,7 @@ scan st dstatus transferqueue r = do
 					| otherwise = return Nothing
 				
 		u = Remote.uuid r
-		enqueue f t = queueTransferAt smallsize Later transferqueue dstatus (Just f) t r
-		smallsize = 10
+		enqueue f t = queueTransferWhenSmall transferqueue dstatus (Just f) t r
 
 		{- Look directly in remote for the key when it's cheap;
 		 - otherwise rely on the location log. -}

Assistant/TransferQueue.hs

@@ -13,6 +13,7 @@ module Assistant.TransferQueue (
 	queueTransfers,
 	queueTransfer,
 	queueTransferAt,
+	queueTransferWhenSmall,
 	getNextTransfer,
 	dequeueTransfer,
 ) where
@@ -115,6 +116,9 @@ queueTransferAt wantsz schedule q dstatus f t remote = do
 			else retry -- blocks until queuesize changes
 	enqueue schedule q dstatus t (stubInfo f remote)
 
+queueTransferWhenSmall :: TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
+queueTransferWhenSmall = queueTransferAt 10 Later
+
 {- Blocks until a pending transfer is available from the queue,
  - and removes it.
  -