display drop safety proofs in debug mode

diff --git a/Command/Drop.hs b/Command/Drop.hs
index fa8ac45ad1499708fc8d0600e5d8b98bb01745c3..43dc51d740b8757e0a21fe31d68a736812480914 100644 (file)
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -20,6 +20,9 @@ import Annex.Content
 import Annex.Wanted
 import Annex.Notification
 
+import Utility.ThreadScheduler
+
+import System.Log.Logger (debugM)
 import qualified Data.Set as S
 
 cmd :: Command
@@ -100,7 +103,12 @@ performLocal key afile numcopies preverified = lockContentExclusive key $ \conte
        let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids)
        u <- getUUID
        doDrop u key afile numcopies [] preverified' tocheck
-               ( do
+               ( \proof -> do
+                       liftIO $ debugM "drop" $ unwords
+                               [ "Dropping from here"
+                               , "proof: "
+                               , show proof
+                               ]
                        removeAnnex contentlock
                        notifyDrop afile True
                        next $ cleanupLocal key
@@ -122,7 +130,15 @@ performRemote key afile numcopies remote = do
        let tocheck = filter (/= remote) $
                Remote.remotesWithoutUUID remotes (trusted++untrusteduuids)
        doDrop uuid key afile numcopies [uuid] preverified tocheck
-               ( do 
+               ( \proof -> do 
+                       liftIO $ debugM "drop" $ unwords
+                               [ "Dropping from remote"
+                               , show remote
+                               , "proof: "
+                               , show proof
+                               ]
+                       liftIO $ print "waiting to drop.."
+                       liftIO $ threadDelaySeconds (Seconds 10)
                        ok <- Remote.removeKey remote key
                        next $ cleanupRemote key remote ok
                , stop
@@ -149,13 +165,15 @@ cleanupRemote key remote ok = do
  -
  - --force overrides and always allows dropping.
  -}
-doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (CommandPerform, CommandPerform) -> CommandPerform
+doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform
 doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = 
        ifM (Annex.getState Annex.force)
-               ( dropaction
+               ( dropaction Nothing
                , ifM (checkRequiredContent dropfrom key afile)
                        ( verifyEnoughCopiesToDrop nolocmsg key numcopies
-                               skip preverified check (const dropaction) (forcehint nodropaction)
+                               skip preverified check
+                                       (dropaction . Just)
+                                       (forcehint nodropaction)
                        , stop
                        )
                )

diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs
index 476c33058e9ecd9bb541f23c54e23643dfe379ad..17080cf7c566812641b3b68ede76549844cc1fb8 100644 (file)
--- a/Types/NumCopies.hs
+++ b/Types/NumCopies.hs
@@ -31,7 +31,7 @@ import Control.Monad.IO.Class (MonadIO)
 import Control.Monad
 
 newtype NumCopies = NumCopies Int
-       deriving (Ord, Eq)
+       deriving (Ord, Eq, Show)
 
 fromNumCopies :: NumCopies -> Int
 fromNumCopies (NumCopies n) = n
@@ -138,6 +138,7 @@ fullVerification (RecentlyVerifiedCopy _) = False
 
 -- A proof that it's currently safe to drop an object.
 data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy]
+       deriving (Show)
 
 -- Make sure that none of the VerifiedCopies have become invalidated
 -- before constructing proof.