add additional debug info about reasons for drops

5 files changed, 40 insertions, 24 deletions

diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs
index 4dd13f2fa..634d5f4ac 100644
--- a/Assistant/Drop.hs
+++ b/Assistant/Drop.hs
@@ -21,23 +21,24 @@ import Config
 
 import qualified Data.Set as S
 
+type Reason = String
+
 {- Drop from local and/or remote when allowed by the preferred content and
  - numcopies settings. -}
-handleDrops :: Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
-handleDrops _ _ Nothing _ = noop
-handleDrops fromhere key f knownpresentremote = do
+handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
+handleDrops _ _ _ Nothing _ = noop
+handleDrops reason fromhere key f knownpresentremote = do
 	syncrs <- syncDataRemotes <$> getDaemonStatus
-	liftAnnex $ do
-		locs <- loggedLocations key
-		handleDropsFrom locs syncrs fromhere key f knownpresentremote
+	locs <- liftAnnex $ loggedLocations key
+	handleDropsFrom locs syncrs reason fromhere key f knownpresentremote
 
 {- The UUIDs are ones where the content is believed to be present.
  - The Remote list can include other remotes that do not have the content;
  - only ones that match the UUIDs will be dropped from.
  - If allows to drop fromhere, that drop will be tried first. -}
-handleDropsFrom :: [UUID] -> [Remote] -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
-handleDropsFrom _ _ _ _ Nothing _ = noop
-handleDropsFrom locs rs fromhere key (Just f) knownpresentremote
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
+handleDropsFrom _ _ _ _ _ Nothing _ = noop
+handleDropsFrom locs rs reason fromhere key (Just f) knownpresentremote
 	| fromhere = do
 		n <- getcopies
 		if checkcopies n
@@ -45,7 +46,7 @@ handleDropsFrom locs rs fromhere key (Just f) knownpresentremote
 			else go rs n
 	| otherwise = go rs =<< getcopies
   where
-	getcopies = do
+	getcopies = liftAnnex $ do
 		have <- length <$> trustExclude UnTrusted locs
 		numcopies <- getNumCopies =<< numCopies f
 		return (have, numcopies)
@@ -58,13 +59,22 @@ handleDropsFrom locs rs fromhere key (Just f) knownpresentremote
 		| checkcopies n = dropr r n >>= go rest
 		| otherwise = noop
 
-	checkdrop n@(_, numcopies) u a = ifM (wantDrop True u (Just f))
-		( ifM (safely $ doCommand $ a (Just numcopies))
-			( return $ decrcopies n
+	checkdrop n@(have, numcopies) u a =
+		ifM (liftAnnex $ wantDrop True u (Just f))
+			( ifM (liftAnnex $ safely $ doCommand $ a (Just numcopies))
+				( do
+					debug
+						[ "dropped"
+						, f
+						, "(from" ++ maybe "here" show u ++ ")"
+						, "(copies now " ++ show (have - 1) ++ ")"
+						, ": " ++ reason
+						]
+					return $ decrcopies n
+				, return n
+				)
 			, return n
 			)
-		, return n
-		)
 
 	dropl n = checkdrop n Nothing $ \numcopies ->
 		Command.Drop.startLocal f numcopies key knownpresentremote
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 198daca94..c6bb8c586 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -115,12 +115,12 @@ expensiveScan rs = unless onlyweb $ do
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
 		syncrs <- syncDataRemotes <$> getDaemonStatus
+		locs <- liftAnnex $ loggedLocations key
+		present <- liftAnnex $ inAnnex key
+		handleDropsFrom locs syncrs
+			"expensive scan found too many copies of object"
+			present key (Just f) Nothing
 		liftAnnex $ do
-			locs <- loggedLocations key
-			present <- inAnnex key
-
-			handleDropsFrom locs syncrs present key (Just f) Nothing
-
 			let slocs = S.fromList locs
 			let use a = return $ catMaybes $ map (a key slocs) syncrs
 			if present
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs
index fcf573374..7a6e426b3 100644
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/Assistant/Threads/TransferWatcher.hs
@@ -115,10 +115,14 @@ finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
 finishedTransfer t (Just info)
 	| transferDirection t == Download =
 		whenM (liftAnnex $ inAnnex $ transferKey t) $ do
-			handleDrops False (transferKey t) (associatedFile info) Nothing
+			dodrops False
 			queueTransfersMatching (/= transferUUID t)
 				"newly received object"
 				Later (transferKey t) (associatedFile info) Upload
-	| otherwise = handleDrops True (transferKey t) (associatedFile info) Nothing
+	| otherwise = dodrops True
+  where
+	dodrops fromhere = handleDrops
+		("drop wanted after " ++ describeTransfer t info)
+		fromhere (transferKey t) (associatedFile info) Nothing
 finishedTransfer _ _ = noop
 
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index fe3cb212c..575307d24 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -76,7 +76,9 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
 			void $ addAlert $ makeAlertFiller True $
 				transferFileAlert direction True file
 			unless isdownload $
-				handleDrops True (transferKey t)
+				handleDrops
+					("object uploaded to " ++ show remote)
+					True (transferKey t)
 					(associatedFile info)
 					(Just remote)
 			recordCommit
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index c7616b678..7e373e95a 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -254,7 +254,7 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
 			if present
 				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
+			handleDrops "file renamed" present key (Just file) Nothing
 		| otherwise = noop
 
 onDel :: Handler