display drop safety proofs in debug mode

This commit is contained in:
Joey Hess 2015-10-09 13:47:19 -04:00
parent 865dd11dbf
commit a5e74e9e64
Failed to extract signature
2 changed files with 25 additions and 6 deletions

View file

@ -20,6 +20,9 @@ import Annex.Content
import Annex.Wanted import Annex.Wanted
import Annex.Notification import Annex.Notification
import Utility.ThreadScheduler
import System.Log.Logger (debugM)
import qualified Data.Set as S import qualified Data.Set as S
cmd :: Command cmd :: Command
@ -100,7 +103,12 @@ performLocal key afile numcopies preverified = lockContentExclusive key $ \conte
let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids)
u <- getUUID u <- getUUID
doDrop u key afile numcopies [] preverified' tocheck doDrop u key afile numcopies [] preverified' tocheck
( do ( \proof -> do
liftIO $ debugM "drop" $ unwords
[ "Dropping from here"
, "proof: "
, show proof
]
removeAnnex contentlock removeAnnex contentlock
notifyDrop afile True notifyDrop afile True
next $ cleanupLocal key next $ cleanupLocal key
@ -122,7 +130,15 @@ performRemote key afile numcopies remote = do
let tocheck = filter (/= remote) $ let tocheck = filter (/= remote) $
Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) Remote.remotesWithoutUUID remotes (trusted++untrusteduuids)
doDrop uuid key afile numcopies [uuid] preverified tocheck 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 ok <- Remote.removeKey remote key
next $ cleanupRemote key remote ok next $ cleanupRemote key remote ok
, stop , stop
@ -149,13 +165,15 @@ cleanupRemote key remote ok = do
- -
- --force overrides and always allows dropping. - --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) = doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) =
ifM (Annex.getState Annex.force) ifM (Annex.getState Annex.force)
( dropaction ( dropaction Nothing
, ifM (checkRequiredContent dropfrom key afile) , ifM (checkRequiredContent dropfrom key afile)
( verifyEnoughCopiesToDrop nolocmsg key numcopies ( verifyEnoughCopiesToDrop nolocmsg key numcopies
skip preverified check (const dropaction) (forcehint nodropaction) skip preverified check
(dropaction . Just)
(forcehint nodropaction)
, stop , stop
) )
) )

View file

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