ifM (inAnnex key)
( do
u <- getUUID
- withVerifiedCopy LockedCopy u (return True) a
+ withVerifiedCopy LockedCopy u (return (Right True)) a
, notpresent
)
where
import Annex.Common
import qualified Annex
+import Annex.SafeDropProof
import Types.NumCopies
import Logs.NumCopies
import Logs.Trust
{- Verifies that enough copies of a key exist among the listed remotes,
- to safely drop it, running an action with a proof if so, and
- printing an informative message if not.
+ -
+ - Note that the proof is checked to still be valid at the current time
+ - before running the action, but when dropping the key may take some time,
+ - the proof's time may need to be checked again.
-}
verifyEnoughCopiesToDrop
:: String -- message to print when there are no known locations
where
helper bad missing have [] lockunsupported =
liftIO (mkSafeDropProof neednum needmin have removallock) >>= \case
- Right proof -> dropaction proof
+ Right proof -> checkprooftime proof
Left stillhave -> do
notEnoughCopies key dropfrom neednum needmin stillhave (skip++missing) bad nolocmsg lockunsupported
nodropaction
helper bad missing have (c:cs) lockunsupported
| isSafeDrop neednum needmin have removallock =
liftIO (mkSafeDropProof neednum needmin have removallock) >>= \case
- Right proof -> dropaction proof
+ Right proof -> checkprooftime proof
Left stillhave -> helper bad missing stillhave (c:cs) lockunsupported
| otherwise = case c of
UnVerifiedHere -> lockContentShared key Nothing contverified
, MC.Handler (\ (_e :: SomeException) -> fallback)
]
Nothing -> fallback
+
+ checkprooftime proof =
+ ifM (liftIO $ checkSafeDropProofEndTime (Just proof))
+ ( dropaction proof
+ , do
+ safeDropProofExpired
+ nodropaction
+ )
data DropException = DropException SomeException
deriving (Typeable, Show)
liftIO $ sendmessage FAILURE
go
Just (REMOVE k) -> do
- tryNonAsync (Remote.removeKey r k) >>= \case
+ tryNonAsync (Remote.removeKey r Nothing k) >>= \case
Right () -> liftIO $ sendmessage SUCCESS
Left err -> liftIO $ propagateerror err
go
--- /dev/null
+{- git-annex safe drop proof
+ -
+ - Copyright 2014-2024 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Annex.SafeDropProof (
+ SafeDropProof,
+ safeDropProofEndTime,
+ safeDropProofExpired,
+ checkSafeDropProofEndTime,
+) where
+
+import Annex.Common
+import Types.NumCopies
+
+import Data.Time.Clock.POSIX
+
+safeDropProofExpired :: Annex ()
+safeDropProofExpired = do
+ showNote "unsafe"
+ showLongNote $ UnquotedString
+ "Dropping took too long, and locks on remotes may have expired."
+
+checkSafeDropProofEndTime :: Maybe SafeDropProof -> IO Bool
+checkSafeDropProofEndTime p = case safeDropProofEndTime =<< p of
+ Nothing -> return True
+ Just t -> do
+ now <- getPOSIXTime
+ return (t < now)
+
dropKey' :: Remote -> Key -> Annex ()
dropKey' rmt k = getKeyExportLocations rmt k >>= \case
- Nothing -> Remote.removeKey rmt k
+ Nothing -> Remote.removeKey rmt Nothing k
Just locs -> forM_ locs $ \loc ->
Remote.removeExport (Remote.exportActions rmt) k loc
, "proof:"
, show proof
]
- ok <- Remote.action (Remote.removeKey remote key)
+ ok <- Remote.action (Remote.removeKey remote proof key)
next $ cleanupRemote key remote ud ok
, stop
)
)
)
- dropped <- tryNonAsync (Remote.removeKey remote key)
+ dropped <- tryNonAsync (Remote.removeKey remote Nothing key)
when (isRight dropped) $
Remote.logStatus remote key InfoMissing
return $ case (movedbad, dropped) of
fromDrop :: Remote -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> ([UnVerifiedCopy] -> [UnVerifiedCopy])-> CommandPerform
fromDrop src destuuid deststartedwithcopy key afile adjusttocheck =
willDropMakeItWorse (Remote.uuid src) destuuid deststartedwithcopy key afile >>= \case
- DropAllowed -> dropremote "moved"
+ DropAllowed -> dropremote Nothing "moved"
DropCheckNumCopies -> do
(numcopies, mincopies) <- getSafestNumMinCopies afile key
(tocheck, verified) <- verifiableCopies key [Remote.uuid src]
verifyEnoughCopiesToDrop "" key (Just (Remote.uuid src)) Nothing numcopies mincopies [Remote.uuid src] verified
- (adjusttocheck tocheck) (dropremote . showproof) faileddropremote
+ (adjusttocheck tocheck) dropremotewithproof faileddropremote
DropWorse -> faileddropremote
where
showproof proof = "proof: " ++ show proof
- dropremote reason = do
+ dropremotewithproof proof =
+ dropremote (Just proof) (showproof proof)
+
+ dropremote mproof reason = do
fastDebug "Command.Move" $ unwords
[ "Dropping from remote"
, show src
, "(" ++ reason ++ ")"
]
- ok <- Remote.action (Remote.removeKey src key)
+ ok <- Remote.action (Remote.removeKey src mproof key)
when ok $
logMoveCleanup deststartedwithcopy
next $ Command.Drop.cleanupRemote key src (Command.Drop.DroppingUnused False) ok
Right v -> return (True, v)
Left _ -> return (False, UnVerified)
store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate
- remove r k = Remote.removeKey r k
+ remove r k = Remote.removeKey r Nothing k
testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree]
testExportTree runannex mkr mkk1 mkk2 =
testUnavailable :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> [TestTree]
testUnavailable runannex mkr mkk =
[ check isLeft "removeKey" $ \r k ->
- Remote.removeKey r k
+ Remote.removeKey r Nothing k
, check isLeft "storeKey" $ \r k ->
Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate
, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k ->
cleanup rs ks ok
| all Remote.readonly rs = return ok
| otherwise = do
- forM_ rs $ \r -> forM_ ks (Remote.removeKey r)
+ forM_ rs $ \r -> forM_ ks (Remote.removeKey r Nothing)
forM_ ks $ \k -> lockContentForRemoval k noop removeAnnex
return ok
{- P2P protocol, Annex implementation
-
- - Copyright 2016-2023 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Logs.Location
import Types.NumCopies
import Utility.Metered
-import Utility.HumanTime
import Utility.MonotonicClock
import Annex.Verify
Left e -> return $ Left $ ProtoFailureException e
Right result -> runner (next result)
TryLockContent k protoaction next -> do
- v <- tryNonAsync $ lockContentShared k (Just (Duration (60*10))) $ \verifiedcopy ->
+ v <- tryNonAsync $ lockContentShared k (Just p2pDefaultLockContentRetentionDuration) $ \verifiedcopy ->
case verifiedcopy of
LockedCopy _ -> runner (protoaction True)
_ -> runner (protoaction False)
import Utility.MonotonicClock
import Git.FilePath
import Annex.ChangedRefs (ChangedRefs)
+import Types.NumCopies
import Control.Monad
import Control.Monad.Free
cleanup True = runproto () $ net $ sendMessage UNLOCKCONTENT
cleanup False = return ()
-remove :: Key -> Proto (Either String Bool, Maybe [UUID])
-remove key = do
+remove :: Maybe SafeDropProof -> Key -> Proto (Either String Bool, Maybe [UUID])
+remove proof key = do
net $ sendMessage (REMOVE key)
checkSuccessFailurePlus
]
remove :: AndroidSerial -> AndroidPath -> Remover
-remove serial adir k =
+remove serial adir _proof k =
unlessM (remove' serial (androidLocation adir k)) $
giveup "adb failed"
uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
uploadKey _ _ _ _ = giveup "upload to bittorrent not supported"
-dropKey :: Key -> Annex ()
-dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
+dropKey :: Maybe SafeDropProof -> Key -> Annex ()
+dropKey _ k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
{- We punt and don't try to check if a torrent has enough seeders
- with all the pieces etc. That would be quite hard.. and even if
- We can, however, remove the git branch that bup created for the key.
-}
remove :: BupRepo -> Remover
-remove buprepo k = do
+remove buprepo _proof k = do
go =<< liftIO (bup2GitRemote buprepo)
warning "content cannot be completely removed from bup remote"
where
go _ _ _ = error "internal"
remove :: DdarRepo -> Remover
-remove ddarrepo key = do
+remove ddarrepo _proof key = do
(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd'
[Param $ serializeKey key]
unlessM (liftIO $ boolSystem cmd params) $
#endif
removeKeyM :: RawFilePath -> Remover
-removeKeyM d k = liftIO $ removeDirGeneric True
+removeKeyM d _proof k = liftIO $ removeDirGeneric True
(fromRawFilePath d)
(fromRawFilePath (storeDir d k))
_ -> Nothing
removeKeyM :: External -> Remover
-removeKeyM external k = either giveup return =<< go
+removeKeyM external _proof k = either giveup return =<< go
where
go = handleRequestKey external REMOVE k Nothing $ \resp ->
case resp of
retrieversync = fileRetriever $ Remote.Rsync.retrieve rsyncopts
remove :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remover
-remove r rsyncopts accessmethod k = do
+remove r rsyncopts accessmethod proof k = do
repo <- getRepo r
- remove' repo r rsyncopts accessmethod k
+ remove' repo r rsyncopts accessmethod proof k
remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remover
-remove' repo r rsyncopts accessmethod k
+remove' repo r rsyncopts accessmethod proof k
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric True
(gCryptTopDir repo)
| accessmethod == AccessRsyncOverSsh = removersync
| otherwise = unsupportedUrl
where
- removersync = Remote.Rsync.remove rsyncopts k
- removeshell = Ssh.dropKey repo k
+ removersync = Remote.Rsync.remove rsyncopts proof k
+ removeshell = Ssh.dropKey repo proof k
checkKey :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> CheckPresent
checkKey r rsyncopts accessmethod k = do
import Annex.Path
import Creds
import Types.NumCopies
+import Annex.SafeDropProof
import Types.ProposedAccepted
import Annex.Action
import Messages.Progress
#endif
remoteconfig = gitconfig r
-dropKey :: Remote -> State -> Key -> Annex ()
-dropKey r st key = do
+dropKey :: Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
+dropKey r st proof key = do
repo <- getRepo r
- dropKey' repo r st key
+ dropKey' repo r st proof key
-dropKey' :: Git.Repo -> Remote -> State -> Key -> Annex ()
-dropKey' repo r st@(State connpool duc _ _ _) key
+dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
+dropKey' repo r st@(State connpool duc _ _ _) proof key
| not $ Git.repoIsUrl repo = ifM duc
- ( guardUsable repo (giveup "cannot access remote") $
- commitOnCleanup repo r st $ onLocalFast st $ do
- whenM (Annex.Content.inAnnex key) $ do
- let cleanup = logStatus key InfoMissing
- Annex.Content.lockContentForRemoval key cleanup $ \lock -> do
- Annex.Content.removeAnnex lock
- cleanup
+ ( guardUsable repo (giveup "cannot access remote") removelocal
, giveup "remote does not have expected annex.uuid value"
)
| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
- | otherwise = P2PHelper.remove (uuid r)
- (Ssh.runProto r connpool (return (Right False, Nothing))) key
+ | otherwise = P2PHelper.remove (uuid r) p2prunner proof key
+ where
+ p2prunner = Ssh.runProto r connpool (return (Right False, Nothing))
+
+ -- It could take a long time to eg, automount a drive containing
+ -- the repo, so check the proof for expiry again after locking the
+ -- content for removal.
+ removelocal = do
+ proofunexpired <- commitOnCleanup repo r st $ onLocalFast st $ do
+ ifM (Annex.Content.inAnnex key)
+ ( do
+ let cleanup = do
+ logStatus key InfoMissing
+ return True
+ Annex.Content.lockContentForRemoval key cleanup $ \lock ->
+ ifM (liftIO $ checkSafeDropProofEndTime proof)
+ ( do
+ Annex.Content.removeAnnex lock
+ cleanup
+ , return False
+ )
+ , return True
+ )
+ unless proofunexpired
+ safeDropProofExpired
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
lockKey r st key callback = do
lockKey :: Remote -> RemoteStateHandle -> TVar LFSHandle -> Key -> (VerifiedCopy -> Annex a) -> Annex a
lockKey r rs h key callback =
ifM (checkKey rs h key)
- ( withVerifiedCopy LockedCopy (uuid r) (return True) callback
+ ( withVerifiedCopy LockedCopy (uuid r) (return (Right True)) callback
, giveup $ "content seems to be missing from " ++ name r
)
go' _ _ = error "internal"
remove :: Remote -> Remover
-remove r k = unlessM go $
+remove r _proof k = unlessM go $
giveup "removal from glacier failed"
where
go = glacierAction r
-
- This action may be called on a chunked key. It will simply remove it.
-}
-removeChunks :: Remover -> UUID -> ChunkConfig -> EncKey -> Key -> Annex ()
-removeChunks remover u chunkconfig encryptor k = do
+removeChunks :: Remover -> UUID -> ChunkConfig -> EncKey -> Maybe SafeDropProof -> Key -> Annex ()
+removeChunks remover u chunkconfig encryptor proof k = do
ls <- map chunkKeyList <$> chunkKeys u chunkconfig k
- mapM_ (remover . encryptor) (concat ls)
+ mapM_ (remover proof . encryptor) (concat ls)
let chunksizes = catMaybes $ map (fromKey keyChunkSize <=< headMaybe) ls
forM_ chunksizes $ chunksRemoved u k . FixedSizeChunks . fromIntegral
, retrieveKeyFileCheap = case retrieveKeyFileCheap r of
Just a -> Just $ \k af f -> wrapper $ a k af f
Nothing -> Nothing
- , removeKey = wrapper . removeKey r
+ , removeKey = \proof k ->
+ wrapper $ removeKey r proof k
, checkPresent = wrapper . checkPresent r
}
where
import Annex.Verify
import Logs.Location
import Utility.SafeOutput
+import Utility.HumanTime
import Control.Concurrent
+import Data.Time.Clock.POSIX
-- Runs a Proto action using a connection it sets up.
type ProtoRunner a = P2P.Proto a -> Annex (Maybe a)
Just (False, _) -> giveup "Transfer failed"
Nothing -> remoteUnavail
-remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Key -> Annex ()
-remove remoteuuid runner k = runner (P2P.remove k) >>= \case
+remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Maybe SafeDropProof -> Key -> Annex ()
+remove remoteuuid runner proof k = runner (P2P.remove proof k) >>= \case
Just (Right True, alsoremoveduuids) -> note alsoremoveduuids
Just (Right False, alsoremoveduuids) -> do
note alsoremoveduuids
-}
lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a
lock withconn connrunner u k callback = withconn $ \conn -> do
+ starttime <- liftIO getPOSIXTime
connv <- liftIO $ newMVar conn
let runproto d p = do
c <- liftIO $ takeMVar connv
(c', mr) <- connrunner p c
liftIO $ putMVar connv c'
return (fromMaybe d mr)
- r <- P2P.lockContentWhile runproto k go
+ r <- P2P.lockContentWhile runproto k (go starttime)
conn' <- liftIO $ takeMVar connv
return (conn', r)
where
- go False = giveup "can't lock content"
- go True = withVerifiedCopy LockedCopy u (return True) callback
+ go _ False = giveup "can't lock content"
+ go starttime True = do
+ let check = return $ Left $ starttime + retentionduration
+ withVerifiedCopy LockedCopy u check callback
+ retentionduration = fromIntegral $
+ durationSeconds p2pDefaultLockContentRetentionDuration
remoteUnavail :: a
remoteUnavail = giveup "can't connect to remote"
readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
readonlyStoreKey _ _ _ _ = readonlyFail
-readonlyRemoveKey :: Key -> Annex ()
-readonlyRemoveKey _ = readonlyFail
+readonlyRemoveKey :: Maybe SafeDropProof -> Key -> Annex ()
+readonlyRemoveKey _ _ = readonlyFail
readonlyStorer :: Storer
readonlyStorer _ _ _ = readonlyFail
storeKeyDummy _ _ _ _ = error "missing storeKey implementation"
retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation"
-removeKeyDummy :: Key -> Annex ()
-removeKeyDummy _ = error "missing removeKey implementation"
+removeKeyDummy :: Maybe SafeDropProof -> Key -> Annex ()
+removeKeyDummy _ _ = error "missing removeKey implementation"
checkPresentDummy :: Key -> Annex Bool
checkPresentDummy _ = error "missing checkPresent implementation"
, retrievalSecurityPolicy = if isencrypted
then mkRetrievalVerifiableKeysSecure (gitconfig baser)
else retrievalSecurityPolicy baser
- , removeKey = \k -> cip >>= removeKeyGen k
+ , removeKey = \k proof -> cip >>= removeKeyGen k proof
, checkPresent = \k -> cip >>= checkPresentGen k
, cost = if isencrypted
then cost baser + encryptedRemoteCostAdj
storeChunks (uuid baser) chunkconfig enck k src p'
enc encr storer checkpresent
where
- rollback = void $ removeKey encr k
+ rollback = void $ removeKey encr Nothing k
enck = maybe id snd enc
-- call retriever to get chunks; decrypt them; stream to dest file
where
enck = maybe id snd enc
- removeKeyGen k enc =
- removeChunks remover (uuid baser) chunkconfig enck k
+ removeKeyGen proof k enc =
+ removeChunks remover (uuid baser) chunkconfig enck proof k
where
enck = maybe id snd enc
dispatch (ExitFailure 1) = return False
dispatch _ = cantCheck r
-{- Removes a key from a remote. -}
-dropKey :: Git.Repo -> Key -> Annex ()
-dropKey r key = unlessM (dropKey' r key) $
+{- Removes a key from a remote using the legacy git-annex-shell dropkey,
+ - rather than the P2P protocol.
+ -
+ - The proof is not checked for expire on the remote, so this should only
+ - be used by remotes that do not have lockContent return a LockedCopy. -}
+dropKey :: Git.Repo -> Maybe SafeDropProof -> Key -> Annex ()
+dropKey r proof key = unlessM (dropKey' r proof key) $
giveup "unable to remove key from remote"
-dropKey' :: Git.Repo -> Key -> Annex Bool
-dropKey' r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
+dropKey' :: Git.Repo -> Maybe SafeDropProof -> Key -> Annex Bool
+dropKey' r _proof key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
[ Param "--quiet", Param "--force"
, Param $ serializeKey key
]
giveup "failed to retrieve content"
remove :: HookName -> Remover
-remove h k =
+remove h _proof k =
unlessM (runHook' h "remove" k Nothing $ return True) $
giveup "failed to remove content"
)
remove :: RsyncOpts -> Remover
-remove o k = removeGeneric o includes
+remove o _proof k = removeGeneric o includes
where
includes = concatMap use dirHashes
use h = let dir = fromRawFilePath (h def k) in
Url.sinkResponseFile p iv zeroBytesProcessed f WriteMode rsp
remove :: S3HandleVar -> Remote -> S3Info -> Remover
-remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> do
+remove hv r info _proof k = withS3HandleOrFail (uuid r) hv $ \h -> do
S3.DeleteObjectResponse <- liftIO $ runResourceT $ sendS3Handle h $
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return ()
| versioning info = Just $ \k callback -> do
checkVersioning info rs k
ifM (checkKey hv r rs c info k)
- ( withVerifiedCopy LockedCopy (uuid r) (return True) callback
+ ( withVerifiedCopy LockedCopy (uuid r) (return (Right True)) callback
, giveup $ "content seems to be missing from " ++ name r ++ " despite S3 versioning being enabled"
)
| otherwise = Nothing
go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File d]) $
giveup "tahoe failed to reteieve content"
-remove :: Key -> Annex ()
-remove _k = giveup "content cannot be removed from tahoe remote"
+remove :: Maybe SafeDropProof -> Key -> Annex ()
+remove _ _ = giveup "content cannot be removed from tahoe remote"
-- Since content cannot be removed from tahoe (by git-annex),
-- nothing needs to be done to lock content there, except for checking that
lockKey :: UUID -> RemoteStateHandle -> TahoeHandle -> Key -> (VerifiedCopy -> Annex a) -> Annex a
lockKey u rs hrl k callback =
ifM (checkKey rs hrl k)
- ( withVerifiedCopy LockedCopy u (return True) callback
+ ( withVerifiedCopy LockedCopy u (return (Right True)) callback
, giveup $ "content seems to be missing from tahoe remote"
)
uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
uploadKey _ _ _ _ = giveup "upload to web not supported"
-dropKey :: UrlIncludeExclude -> Key -> Annex ()
-dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k
+dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex ()
+dropKey urlincludeexclude _proof k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k
checkKey :: UrlIncludeExclude -> Key -> Annex Bool
checkKey urlincludeexclude key = do
withContentM $ httpBodyRetriever d p iv
remove :: DavHandleVar -> Remover
-remove hv k = withDavHandle hv $ \dav -> liftIO $ goDAV dav $
+remove hv _proof k = withDavHandle hv $ \dav -> liftIO $ goDAV dav $
-- Delete the key's whole directory, including any
-- legacy chunked files, etc, in a single action.
removeHelper (keyDir k)
{- git-annex numcopies types
-
- - Copyright 2014-2022 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
withVerifiedCopy,
isSafeDrop,
SafeDropProof,
+ safeDropProofEndTime,
mkSafeDropProof,
ContentRemovalLock(..),
+ p2pDefaultLockContentRetentionDuration,
) where
import Types.UUID
import Types.Key
import Utility.Exception (bracketIO)
import Utility.Monad
+import Utility.HumanTime
import qualified Data.Map as M
+import Data.Either
import Control.Concurrent.MVar
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class (MonadIO)
-import Control.Monad
+import Data.Time.Clock.POSIX (POSIXTime)
newtype NumCopies = NumCopies Int
deriving (Ord, Eq, Show)
| TrustedCopy V
{- The strongest proof of the existence of a copy.
- Until its associated action is called to unlock it,
+ - or connection with a remote repository is lost,
- the copy is locked in the repository and is guaranteed
- - not to be removed by any git-annex process. -}
+ - not to be removed by any git-annex process. Use
+ - checkVerifiedCopy to detect loss of connection. -}
| LockedCopy V
deriving (Show)
data V = V
{ _getUUID :: UUID
- , _checkVerifiedCopy :: IO Bool
+ , _checkVerifiedCopy :: IO (Either POSIXTime Bool)
, _invalidateVerifiedCopy :: IO ()
}
toV (RecentlyVerifiedCopy v) = v
toV (LockedCopy v) = v
--- Checks that it's still valid.
-checkVerifiedCopy :: VerifiedCopy -> IO Bool
+-- Checks that the VerifiedCopy is still valid.
+--
+-- Invalidation of the VerifiedCopy will make this return False.
+--
+-- When the key is being kept locked by a connection to a remote
+-- repository, a detected loss of connection will make this
+-- return False.
+--
+-- When the connection could possibly break without being detected
+-- immediately, this will return a POSIXTime that is how long the
+-- content is guaranteed to remain locked on the remote even if the
+-- connection has broken.
+checkVerifiedCopy :: VerifiedCopy -> IO (Either POSIXTime Bool)
checkVerifiedCopy = _checkVerifiedCopy . toV
invalidateVerifiedCopy :: VerifiedCopy -> IO ()
M.fromListWith strongestVerifiedCopy (zip (map toUUID l) l)
mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy
-mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ())
+mkVerifiedCopy mk u = mk $ V (toUUID u) (return (Right True)) (return ())
-invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO Bool -> IO VerifiedCopy
+invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO (Either POSIXTime Bool) -> IO VerifiedCopy
invalidatableVerifiedCopy mk u check = do
v <- newEmptyMVar
let invalidate = do
_ <- tryPutMVar v ()
return ()
- let check' = isEmptyMVar v <&&> check
+ let check' = ifM (isEmptyMVar v)
+ ( check
+ , pure (Right False)
+ )
return $ mk $ V (toUUID u) check' invalidate
-- Constructs a VerifiedCopy, and runs the action, ensuring that the
:: (MonadMask m, MonadIO m, ToUUID u)
=> (V -> VerifiedCopy)
-> u
- -> IO Bool
+ -> IO (Either POSIXTime Bool)
-> (VerifiedCopy -> m a)
-> m a
withVerifiedCopy mk u check = bracketIO setup cleanup
- to fall below NumCopies, but it will never fall below MinCopies.
-}
isSafeDrop :: NumCopies -> MinCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> Bool
+isSafeDrop n m l lck = case safeDropAnalysis n m l lck of
+ UnsafeDrop -> False
+ SafeDrop -> True
+ SafeDropCheckTime -> True
+
+data SafeDropAnalysis
+ = UnsafeDrop
+ | SafeDrop
+ | SafeDropCheckTime
+
+safeDropAnalysis :: NumCopies -> MinCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> SafeDropAnalysis
{- When a ContentRemovalLock is provided, the content is being
- dropped from the local repo. That lock will prevent other git repos
- that are concurrently dropping from using the local copy as a VerifiedCopy.
- So, no additional locking is needed; all we need is verifications
- of any kind of enough other copies of the content. -}
-isSafeDrop (NumCopies n) (MinCopies m) l (Just (ContentRemovalLock _)) =
- length (deDupVerifiedCopies l) >= max n m
+safeDropAnalysis (NumCopies n) (MinCopies m) l (Just (ContentRemovalLock _)) =
+ if length (deDupVerifiedCopies l) >= max n m
+ then SafeDrop
+ else UnsafeDrop
{- Dropping from a remote repo.
-
- To guarantee MinCopies is never violated, at least that many LockedCopy
- violated, this is the best that can be done without requiring that
- all special remotes support locking.
-}
-isSafeDrop (NumCopies n) (MinCopies m) l Nothing
- | n == 0 && m == 0 = True
- | otherwise = and
- [ length (deDupVerifiedCopies l) >= n
- , length (filter fullVerification l) >= m
- ]
+safeDropAnalysis (NumCopies n) (MinCopies m) l Nothing
+ | n == 0 && m == 0 = SafeDrop
+ | length (deDupVerifiedCopies l) >= n
+ && length (filter fullVerification l) >= m =
+ SafeDropCheckTime
+ | otherwise = UnsafeDrop
fullVerification :: VerifiedCopy -> Bool
fullVerification (LockedCopy _) = True
fullVerification (TrustedCopy _) = True
fullVerification (RecentlyVerifiedCopy _) = False
--- A proof that it's currently safe to drop an object.
-data SafeDropProof = SafeDropProof NumCopies MinCopies [VerifiedCopy] (Maybe ContentRemovalLock)
+-- Content locked using the P2P protocol defaults to being retained,
+-- still locked, for 10 minutes after a connection loss.
+--
+-- This is only the case since git-annex 10.20240704, but currently
+-- this is used even for older remotes, to avoid a disruptive behavior
+-- change when used with remotes running an old version of git-annex.
+p2pDefaultLockContentRetentionDuration :: Duration
+p2pDefaultLockContentRetentionDuration = Duration (60*10)
+
+-- A proof that it's safe to drop an object.
+--
+-- It may only be safe up until a given POSIXTime.
+data SafeDropProof = SafeDropProof NumCopies MinCopies [VerifiedCopy] (Maybe POSIXTime) (Maybe ContentRemovalLock)
deriving (Show)
+safeDropProofEndTime :: SafeDropProof -> Maybe POSIXTime
+safeDropProofEndTime (SafeDropProof _ _ _ t _) = t
+
-- Makes sure that none of the VerifiedCopies have become invalidated
--- before constructing proof.
+-- before constructing the proof.
mkSafeDropProof :: NumCopies -> MinCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof)
mkSafeDropProof need mincopies have removallock = do
- stillhave <- filterM checkVerifiedCopy have
- return $ if isSafeDrop need mincopies stillhave removallock
- then Right (SafeDropProof need mincopies stillhave removallock)
- else Left stillhave
+ l <- mapM checkVerifiedCopy have
+ let stillhave = map fst $
+ filter (either (const True) id . snd) (zip have l)
+ return $ case safeDropAnalysis need mincopies stillhave removallock of
+ SafeDrop -> Right $
+ SafeDropProof need mincopies stillhave Nothing removallock
+ SafeDropCheckTime -> Right $
+ let endtime = case lefts l of
+ [] -> Nothing
+ ts -> Just (minimum ts)
+ in SafeDropProof need mincopies stillhave endtime removallock
+ UnsafeDrop -> Left stillhave
-
- Most things should not need this, using Types instead
-
- - Copyright 2011-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
, ExportActions(..)
, ImportActions(..)
, ByteSize
+ , SafeDropProof
)
where
, retrievalSecurityPolicy :: RetrievalSecurityPolicy
-- Removes a key's contents (succeeds even the contents are not present)
-- Can throw exception if unable to access remote, or if remote
- -- refuses to remove the content.
- , removeKey :: Key -> a ()
+ -- refuses to remove the content, or if the proof is expired.
+ --
+ -- The proof is verified not to have expired shortly
+ -- before calling this. But, if the remote's lockContent returns
+ -- LockedCopy, the proof's expiry should be checked on the remote,
+ -- so that a delay in communicating with the remote does not
+ -- cause the removal to happen after the proof expires.
+ , removeKey :: Maybe SafeDropProof -> Key -> a ()
-- Uses locking to prevent removal of a key's contents,
-- thus producing a VerifiedCopy, which is passed to the callback.
-- If unable to lock, does not run the callback, and throws an
module Types.StoreRetrieve where
import Annex.Common
+import Types.NumCopies
import Utility.Metered
import Utility.Hash (IncrementalVerifier)
-- Action that removes a Key's content from a remote.
-- Succeeds if key is already not present.
--- Throws an exception if the remote is not accessible.
-type Remover = Key -> Annex ()
+-- Throws an exception if the remote is not accessible
+-- or the proof has expired.
+type Remover = Maybe SafeDropProof -> Key -> Annex ()
-- Checks if a Key's content is present on a remote.
-- Throws an exception if the remote is not accessible.
The server responds with either SUCCESS or FAILURE.
The former indicates the content is locked. It will remain
-locked until the connection is broken, or the client
-sends:
+locked until 10 minutes after the connection is broken, or until
+the client sends:
UNLOCKCONTENT Key
The server responds to the message in the same way as to REMOVE.
If the server receives the message at a time after the specified timestamp,
-the remove must fail. This is used to avoid removing content after a point
+the remove must fail.This is used to avoid removing content after a point
in time where it is no longer locked in other repostitories.
## Getting a timestamp
locked for some amount of time. Then local git-annex would know it
has at most that long to drop the content. But it's the remote that's
dropping that really needs to know. So, extend the P2P protocol with a
-PRE-REMOVE step. After receiving PRE-REMOVE N Key, a REMOVE of that key is only
-allowed until N seconds later. Sending PRE-REMOVE first, followed by
-LOCKCONTENT will guarantee the content remains locked for the full amount
-of time.
-
-How long? 10 minutes is arbitrary, but seems in the right ballpark. Since
-this will cause drops to fail if they timeout sitting at a ssh password
-prompt, it needs to be more than a few minutes. But making it too long, eg
-an hour can result in content being stuck locked on a remote for a long
-time, preventing a later legitimate drop. It could be made configurable, if
-needed, by extending the P2P protocol so LOCKCONTENT was passed the amount
-of time.
+REMOVE-BEFORE Timestamp Key and a GETTIMESTAMP.
+
+How long to lock for? 10 minutes is arbitrary, but seems in the right
+ballpark. Since this will cause drops to fail if they timeout sitting at a
+ssh password prompt, it needs to be more than a few minutes. But making it
+too long, eg an hour can result in content being stuck locked on a remote
+for a long time, preventing a later legitimate drop. It could be made
+configurable, if needed, by extending the P2P protocol so LOCKCONTENT was
+passed the amount of time.
Having lockContentWhile catch all exceptions and keep the content locked
for the time period won't work though. Systemd reaps processes on ssh
between the cluster's clock and each node's clock.
This approach would need to use a monotonic clock!
+
+---
+
+There is a potential future flag day where
+p2pDefaultLockContentRetentionDuration is not assumed, but is probed
+using the P2P protocol, and peers that don't support it can no longer
+produce a LockedCopy. Until that happens, when git-annex is
+communicating with older peers there is a risk of data loss when
+a ssh connection closes during LOCKCONTENT.
Annex.Queue
Annex.ReplaceFile
Annex.RemoteTrackingBranch
+ Annex.SafeDropProof
Annex.SpecialRemote
Annex.SpecialRemote.Config
Annex.Ssh
projects / git-annex.git / commitdiff