From a733271a9c41a3a4941e96b78bf3dccc2b7b924f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 1 Mar 2013 15:58:44 -0400 Subject: [PATCH] add additional debug info about reasons for drops --- Assistant/Drop.hs | 40 +++++++++++++++++----------- Assistant/Threads/TransferScanner.hs | 10 +++---- Assistant/Threads/TransferWatcher.hs | 8 ++++-- Assistant/Threads/Transferrer.hs | 4 ++- Assistant/Threads/Watcher.hs | 2 +- 5 files changed, 40 insertions(+), 24 deletions(-) diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index 4dd13f2fa3..634d5f4acd 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 198daca942..c6bb8c586b 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 fcf5733741..7a6e426b32 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 fe3cb212ce..575307d240 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 c7616b6782..7e373e95a3 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