try to drop unused object if it does not need to be transferred anywhere

4 files changed, 22 insertions, 13 deletions

diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 2ddaade2f..e8d17b13f 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -464,7 +464,7 @@ checkChangeContent change@(Change { changeInfo = i }) =
 		Nothing -> noop
 		Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
 			present <- liftAnnex $ inAnnex k
-			if present
+			void $ if present
 				then queueTransfers "new file created" Next k (Just f) Upload
 				else queueTransfers "new or renamed file wanted" Next k (Just f) Download
 			handleDrops "file renamed" present k (Just f) Nothing
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 8a513a43b..aa7d4ff19 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -17,6 +17,7 @@ import Assistant.Common
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.Repair
+import Assistant.Drop
 import Assistant.Ssh
 import Assistant.TransferQueue
 import Assistant.Types.UrlRenderer
@@ -94,11 +95,11 @@ sanityCheckerHourlyThread = namedThread "SanityCheckerHourly" $ forever $ do
 {- This thread wakes up daily to make sure the tree is in good shape. -}
 sanityCheckerDailyThread :: UrlRenderer -> NamedThread
 sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ forever $ do
-	waitForNextCheck
-
 	debug ["starting sanity check"]
 	void $ alertWhile sanityCheckAlert go
 	debug ["sanity check complete"]
+	waitForNextCheck
+
   where
 	go = do
 		modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True }
@@ -172,11 +173,12 @@ dailyCheck urlrenderer = do
 	let (program', params') = batchmaker (program, [Param "unused"])
 	void $ liftIO $ boolSystem program' params'
 	{- Invalidate unused keys cache, and queue transfers of all unused
-	 - keys. -}
+	 - keys, or if no transfers are called for, drop them. -}
 	unused <- liftAnnex unusedKeys'
 	void $ liftAnnex $ setUnusedKeys unused
-	forM_ unused $ \k ->
-		queueTransfers "unused" Later k Nothing Upload
+	forM_ unused $ \k -> do
+		unlessM (queueTransfers "unused" Later k Nothing Upload) $
+			handleDrops "unused" True k Nothing Nothing
 
 	return True
   where
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 86dd36d04..93c982224 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -51,14 +51,17 @@ stubInfo f r = stubTransferInfo
 
 {- Adds transfers to queue for some of the known remotes.
  - Honors preferred content settings, only transferring wanted files. -}
-queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfers :: Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
 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) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
+queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
 queueTransfersMatching matching reason schedule k f direction
-	| direction == Download = whenM (liftAnnex $ wantGet True (Just k) f) go
+	| direction == Download = ifM (liftAnnex $ wantGet True (Just k) f)
+		( go
+		, return False
+		)
 	| otherwise = go
   where
 	go = do
@@ -67,9 +70,13 @@ queueTransfersMatching matching reason schedule k f direction
 			=<< syncDataRemotes <$> getDaemonStatus
 		let matchingrs = filter (matching . Remote.uuid) rs
 		if null matchingrs
-			then defer
-			else forM_ matchingrs $ \r ->
-				enqueue reason schedule (gentransfer r) (stubInfo f r)
+			then do
+				defer
+				return False
+			else do
+				forM_ matchingrs $ \r ->
+					enqueue reason schedule (gentransfer r) (stubInfo f r)
+				return True
 	selectremotes rs
 		{- Queue downloads from all remotes that
 		 - have the key. The list of remotes is ordered with
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 6fc8c3fd7..de96cdf85 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -218,7 +218,7 @@ finishedTransfer t (Just info)
 	| transferDirection t == Download =
 		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
 			dodrops False
-			queueTransfersMatching (/= transferUUID t)
+			void $ queueTransfersMatching (/= transferUUID t)
 				"newly received object"
 				Later (transferKey t) (associatedFile info) Upload
 	| otherwise = dodrops True