add additional debug info about reasons for transfers

9 files changed, 43 insertions, 31 deletions

diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 585dfde9b..0062e2324 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -216,7 +216,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
 			whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do
 				stageSymlink file =<< hashSymlink link
 				showEndOk
-		queueTransfers Next key (Just file) Upload
+		queueTransfers "newly added file" Next key (Just file) Upload
 		return $ Just change
 
 	{- Check that the keysource's keyFilename still exists,
diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs
index 2f3b03b16..46f64cd56 100644
--- a/Assistant/Threads/Glacier.hs
+++ b/Assistant/Threads/Glacier.hs
@@ -39,5 +39,5 @@ glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go
 		let l' = filter (\p -> S.member (getkey p) s) l
 		forM_ l' $ \(t, info) -> do
 			liftAnnex $ removeFailedTransfer t
-			queueTransferWhenSmall (associatedFile info) t r
+			queueTransferWhenSmall "object available from glacier" (associatedFile info) t r
 	getkey = transferKey . fst
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index d8eea8c84..1488a2f0d 100644
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@@ -65,7 +65,7 @@ onAdd file
 	| isAnnexBranch file = do
 		branchChanged
 		whenM (liftAnnex Annex.Branch.forceUpdate) $
-			queueDeferredDownloads Later
+			queueDeferredDownloads "retrying deferred download" Later
 	| "/synced/" `isInfixOf` file = do
 		mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
 	| otherwise = noop
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 929fb53e7..198daca94 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -78,7 +78,7 @@ failedTransferScan r = do
 			 - that the remote doesn't already have the
 			 - key, so it's not redundantly checked here. -}
 			requeue t info
-	requeue t info = queueTransferWhenSmall (associatedFile info) t r
+	requeue t info = queueTransferWhenSmall "retrying failed transfer" (associatedFile info) t r
 
 {- This is a expensive scan through the full git work tree, finding
  - files to transfer. The scan is blocked when the transfer queue gets
@@ -108,9 +108,9 @@ expensiveScan rs = unless onlyweb $ do
 	onlyweb = all (== webUUID) $ map Remote.uuid rs
 	visiblers = let rs' = filter (not . Remote.readonly) rs
 		in if null rs' then rs else rs'
-	enqueue f (r, t) = do
-		debug ["queuing", show t]
-		queueTransferWhenSmall (Just f) t r
+	enqueue f (r, t) =
+		queueTransferWhenSmall "expensive scan found missing object"
+			(Just f) t r
 	findtransfers f (key, _) = do
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs
index d2ca0e535..fcf573374 100644
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/Assistant/Threads/TransferWatcher.hs
@@ -61,7 +61,7 @@ onAdd file = case parseTransferFile file of
   where
 	go _ Nothing = noop -- transfer already finished
 	go t (Just info) = do
-		debug [ "transfer starting:", show t]
+		debug [ "transfer starting:", describeTransfer t info ]
 		r <- headMaybe . filter (sameuuid t)
 			<$> liftAnnex Remote.remoteList
 		updateTransferInfo t info { transferRemote = r }
@@ -116,8 +116,9 @@ finishedTransfer t (Just info)
 	| transferDirection t == Download =
 		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
 			handleDrops False (transferKey t) (associatedFile info) Nothing
-			queueTransfersMatching (/= transferUUID t) Later
-				(transferKey t) (associatedFile info) Upload
+			queueTransfersMatching (/= transferUUID t)
+				"newly received object"
+				Later (transferKey t) (associatedFile info) Upload
 	| otherwise = handleDrops True (transferKey t) (associatedFile info) Nothing
 finishedTransfer _ _ = noop
 
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 0acadec4b..fe3cb212c 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -40,11 +40,11 @@ startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Trans
 startTransfer program t info = case (transferRemote info, associatedFile info) of
 	(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
 		( do
-			debug [ "Transferring:" , show t ]
+			debug [ "Transferring:" , describeTransfer t info ]
 			notifyTransfer
 			return $ Just (t, info, transferprocess remote file)
 		, do
-			debug [ "Skipping unnecessary transfer:" , show t ]
+			debug [ "Skipping unnecessary transfer:" , describeTransfer t info ]
 			void $ removeTransfer t
 			return Nothing
 		)
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index be82a105f..c7616b678 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -252,8 +252,8 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
 		| scanComplete daemonstatus = do
 			present <- liftAnnex $ inAnnex key
 			if present
-				then queueTransfers Next key (Just file) Upload
-				else queueTransfers Next key (Just file) Download
+				then queueTransfers "new file created" Next key (Just file) Upload
+				else queueTransfers "new or renamed file wanted" Next key (Just file) Download
 			handleDrops present key (Just file) Nothing
 		| otherwise = noop
 
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 66d761f6e..7c41f0399 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -33,6 +33,8 @@ import Annex.Wanted
 import Control.Concurrent.STM
 import qualified Data.Map as M
 
+type Reason = String
+
 {- Reads the queue's content without blocking or changing it. -}
 getTransferQueue :: Assistant [(Transfer, TransferInfo)]
 getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue
@@ -45,13 +47,13 @@ stubInfo f r = stubTransferInfo
 
 {- Adds transfers to queue for some of the known remotes.
  - Honors preferred content settings, only transferring wanted files. -}
-queueTransfers :: Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
 queueTransfers = queueTransfersMatching (const True)
 
 {- Adds transfers to queue for some of the known remotes, that match a
  - condition. Honors preferred content settings. -}
-queueTransfersMatching :: (UUID -> Bool) -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
-queueTransfersMatching matching schedule k f direction
+queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfersMatching matching reason schedule k f direction
 	| direction == Download = whenM (liftAnnex $ wantGet True f) go
 	| otherwise = go
   where
@@ -62,7 +64,7 @@ queueTransfersMatching matching schedule k f direction
 		if null matchingrs
 			then defer
 			else forM_ matchingrs $ \r ->
-				enqueue schedule (gentransfer r) (stubInfo f r)
+				enqueue reason schedule (gentransfer r) (stubInfo f r)
 	sufficientremotes rs
 		{- Queue downloads from all remotes that
 		 - have the key, with the cheapest ones first.
@@ -90,8 +92,8 @@ queueTransfersMatching matching schedule k f direction
 
 {- Queues any deferred downloads that can now be accomplished, leaving
  - any others in the list to try again later. -}
-queueDeferredDownloads :: Schedule -> Assistant ()
-queueDeferredDownloads schedule = do
+queueDeferredDownloads :: Reason -> Schedule -> Assistant ()
+queueDeferredDownloads reason schedule = do
 	q <- getAssistant transferQueue
 	l <- liftIO $ atomically $ swapTVar (deferreddownloads q) []
 	rs <- syncDataRemotes <$> getDaemonStatus
@@ -105,7 +107,7 @@ queueDeferredDownloads schedule = do
 		let sources = filter (\r -> uuid r `elem` uuids) rs
 		unless (null sources) $
 			forM_ sources $ \r ->
-				enqueue schedule (gentransfer r) (stubInfo f r)
+				enqueue reason schedule (gentransfer r) (stubInfo f r)
 		return $ null sources
 	  where
 		gentransfer r = Transfer
@@ -114,8 +116,8 @@ queueDeferredDownloads schedule = do
 			, transferUUID = Remote.uuid r
 			}
 
-enqueue :: Schedule -> Transfer -> TransferInfo -> Assistant ()
-enqueue schedule t info
+enqueue :: Reason -> Schedule -> Transfer -> TransferInfo -> Assistant ()
+enqueue reason schedule t info
 	| schedule == Next = go (new:)
 	| otherwise = go (\l -> l++[new])
   where
@@ -125,31 +127,33 @@ enqueue schedule t info
 		liftIO $ atomically $ do
 			void $ modifyTVar' (queuesize q) succ
 			void $ modifyTVar' (queuelist q) modlist
+		debug [ "queued", describeTransfer t info, ": " ++ reason ]
 		notifyTransfer
 
 {- Adds a transfer to the queue. -}
-queueTransfer :: Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransfer schedule f t remote = enqueue schedule t (stubInfo f remote)
+queueTransfer :: Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransfer reason schedule f t remote =
+	enqueue reason schedule t (stubInfo f remote)
 
 {- Blocks until the queue is no larger than a given size, and then adds a
  - transfer to the queue. -}
-queueTransferAt :: Int -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransferAt wantsz schedule f t remote = do
+queueTransferAt :: Int -> Reason -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransferAt wantsz reason schedule f t remote = do
 	q <- getAssistant transferQueue
 	liftIO $ atomically $ do
 		sz <- readTVar (queuesize q)
 		unless (sz <= wantsz) $
 			retry -- blocks until queuesize changes
-	enqueue schedule t (stubInfo f remote)
+	enqueue reason schedule t (stubInfo f remote)
 
-queueTransferWhenSmall :: AssociatedFile -> Transfer -> Remote -> Assistant ()
-queueTransferWhenSmall = queueTransferAt 10 Later
+queueTransferWhenSmall :: Reason -> AssociatedFile -> Transfer -> Remote -> Assistant ()
+queueTransferWhenSmall reason = queueTransferAt 10 reason Later
 
 {- Blocks until a pending transfer is available in the queue,
  - and removes it.
  -
  - Checks that it's acceptable, before adding it to the
- - the currentTransfers map. If it's not acceptable, it's discarded.
+ - currentTransfers map. If it's not acceptable, it's discarded.
  -
  - This is done in a single STM transaction, so there is no window
  - where an observer sees an inconsistent status. -}
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 5818f5fc2..6d6d3d890 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -64,6 +64,13 @@ readLcDirection "upload" = Just Upload
 readLcDirection "download" = Just Download
 readLcDirection _ = Nothing
 
+describeTransfer :: Transfer -> TransferInfo -> String
+describeTransfer t info = unwords
+	[ show $ transferDirection t
+	, show $ transferUUID t
+	, fromMaybe (key2file $ transferKey t) (associatedFile info)
+	]
+
 {- Transfers that will accomplish the same task. -}
 equivilantTransfer :: Transfer -> Transfer -> Bool
 equivilantTransfer t1 t2