toward SafeDropProof expiry checking
Added Maybe POSIXTime to SafeDropProof, which gets set when the proof is based on a LockedCopy. If there are several LockedCopies, it uses the closest expiry time. That is not optimal, it may be that the proof expires based on one LockedCopy but another one has not expired. But that seems unlikely to really happen, and anyway the user can just re-run a drop if it fails due to expiry. Pass the SafeDropProof to removeKey, which is responsible for checking it for expiry in situations where that could be a problem. Which really only means in Remote.Git. Made Remote.Git check expiry when dropping from a local remote. Checking expiry when dropping from a P2P remote is not yet implemented. P2P.Protocol.remove has SafeDropProof plumbed through to it for that purpose. Fixing the remaining 2 build warnings should complete this work. Note that the use of a POSIXTime here means that if the clock gets set forward while git-annex is in the middle of a drop, it may say that dropping took too long. That seems ok. Less ok is that if the clock gets turned back a sufficient amount (eg 5 minutes), proof expiry won't be noticed. It might be better to use the Monotonic clock, but that doesn't advance when a laptop is suspended, and while there is the linux Boottime clock, that is not available on other systems. Perhaps a combination of POSIXTime and the Monotonic clock could detect laptop suspension and also detect clock being turned back? 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.
This commit is contained in:
Joey Hess
parent
98dbfb6bbd
commit
1243af4a18
39 changed files with 274 additions and 123 deletions
|
|
@ -141,7 +141,7 @@ lockContentShared key mduration a = do
|
|||
ifM (inAnnex key)
|
||||
( do
|
||||
u <- getUUID
|
||||
withVerifiedCopy LockedCopy u (return True) a
|
||||
withVerifiedCopy LockedCopy u (return (Right True)) a
|
||||
, notpresent
|
||||
)
|
||||
where
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ module Annex.NumCopies (
|
|||
|
||||
import Annex.Common
|
||||
import qualified Annex
|
||||
import Annex.SafeDropProof
|
||||
import Types.NumCopies
|
||||
import Logs.NumCopies
|
||||
import Logs.Trust
|
||||
|
|
@ -227,6 +228,10 @@ data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere
|
|||
{- 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
|
||||
|
|
@ -246,14 +251,14 @@ verifyEnoughCopiesToDrop nolocmsg key dropfrom removallock neednum needmin skip
|
|||
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
|
||||
|
|
@ -295,6 +300,14 @@ verifyEnoughCopiesToDrop nolocmsg key dropfrom removallock neednum needmin skip
|
|||
]
|
||||
Nothing -> fallback
|
||||
|
||||
checkprooftime proof =
|
||||
ifM (liftIO $ checkSafeDropProofEndTime (Just proof))
|
||||
( dropaction proof
|
||||
, do
|
||||
safeDropProofExpired
|
||||
nodropaction
|
||||
)
|
||||
|
||||
data DropException = DropException SomeException
|
||||
deriving (Typeable, Show)
|
||||
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv endv = go
|
|||
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
|
||||
|
|
|
|||
34
Annex/SafeDropProof.hs
Normal file
34
Annex/SafeDropProof.hs
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
{- 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)
|
||||
|
||||
|
|
@ -996,7 +996,7 @@ dropKey rmt k = tryNonAsync (dropKey' rmt k) >>= \case
|
|||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -151,7 +151,7 @@ performRemote pcc key afile numcopies mincopies remote ud = do
|
|||
, "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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -639,7 +639,7 @@ badContentRemote remote localcopy key = do
|
|||
)
|
||||
)
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -296,23 +296,26 @@ fromPerform' present updatelocationlog src key afile = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -303,7 +303,7 @@ test runannex mkr mkk =
|
|||
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 =
|
||||
|
|
@ -366,7 +366,7 @@ 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 ->
|
||||
|
|
@ -397,7 +397,7 @@ cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
|
@ -23,7 +23,6 @@ import P2P.IO
|
|||
import Logs.Location
|
||||
import Types.NumCopies
|
||||
import Utility.Metered
|
||||
import Utility.HumanTime
|
||||
import Utility.MonotonicClock
|
||||
import Annex.Verify
|
||||
|
||||
|
|
@ -135,7 +134,7 @@ runLocal runst runner a = case a of
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ import Utility.FileSystemEncoding
|
|||
import Utility.MonotonicClock
|
||||
import Git.FilePath
|
||||
import Annex.ChangedRefs (ChangedRefs)
|
||||
import Types.NumCopies
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Free
|
||||
|
|
@ -395,8 +396,8 @@ lockContentWhile runproto key a = bracket setup cleanup a
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -210,7 +210,7 @@ retrieve' serial src dest =
|
|||
]
|
||||
|
||||
remove :: AndroidSerial -> AndroidPath -> Remover
|
||||
remove serial adir k =
|
||||
remove serial adir _proof k =
|
||||
unlessM (remove' serial (androidLocation adir k)) $
|
||||
giveup "adb failed"
|
||||
|
||||
|
|
|
|||
|
|
@ -121,8 +121,8 @@ downloadKey key _file dest p _ = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -210,7 +210,7 @@ retrieve r buprepo = byteRetriever $ \k sink -> lockBup True r $ do
|
|||
- 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
|
||||
|
|
|
|||
|
|
@ -180,7 +180,7 @@ retrieve ddarrepo = byteRetriever $ \k sink -> do
|
|||
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) $
|
||||
|
|
|
|||
|
|
@ -270,7 +270,7 @@ retrieveKeyFileCheapM _ _ = Nothing
|
|||
#endif
|
||||
|
||||
removeKeyM :: RawFilePath -> Remover
|
||||
removeKeyM d k = liftIO $ removeDirGeneric True
|
||||
removeKeyM d _proof k = liftIO $ removeDirGeneric True
|
||||
(fromRawFilePath d)
|
||||
(fromRawFilePath (storeDir d k))
|
||||
|
||||
|
|
|
|||
|
|
@ -259,7 +259,7 @@ retrieveKeyFileM external = fileRetriever $ \d k p ->
|
|||
_ -> 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
|
||||
|
|
|
|||
|
|
@ -432,12 +432,12 @@ retrieve' repo r rsyncopts accessmethod
|
|||
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)
|
||||
|
|
@ -446,8 +446,8 @@ remove' repo r rsyncopts accessmethod k
|
|||
| 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
|
||||
|
|
|
|||
|
|
@ -61,6 +61,7 @@ import P2P.Address
|
|||
import Annex.Path
|
||||
import Creds
|
||||
import Types.NumCopies
|
||||
import Annex.SafeDropProof
|
||||
import Types.ProposedAccepted
|
||||
import Annex.Action
|
||||
import Messages.Progress
|
||||
|
|
@ -437,26 +438,43 @@ keyUrls gc repo r key = map tourl locs'
|
|||
#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
|
||||
|
|
|
|||
|
|
@ -504,7 +504,7 @@ retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownl
|
|||
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
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -214,7 +214,7 @@ retrieve' r k sink = go =<< glacierEnv c gc u
|
|||
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
|
||||
|
|
|
|||
|
|
@ -226,10 +226,10 @@ seekResume h encryptor chunkkeys checker = do
|
|||
-
|
||||
- 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
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,8 @@ addHooks' r starthook stophook = r'
|
|||
, 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
|
||||
|
|
|
|||
|
|
@ -21,8 +21,10 @@ import Types.NumCopies
|
|||
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)
|
||||
|
|
@ -60,8 +62,8 @@ retrieve gc runner k af dest p verifyconfig = do
|
|||
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
|
||||
|
|
@ -94,18 +96,23 @@ checkpresent runner k =
|
|||
-}
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -47,8 +47,8 @@ adjustReadOnly r
|
|||
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
|
||||
|
|
|
|||
|
|
@ -138,8 +138,8 @@ storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex
|
|||
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"
|
||||
|
||||
|
|
@ -197,7 +197,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
|
|||
, 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
|
||||
|
|
@ -227,7 +227,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
|
|||
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
|
||||
|
|
@ -238,8 +238,8 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -105,13 +105,17 @@ inAnnex r k = onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex"
|
|||
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
|
||||
]
|
||||
|
|
|
|||
|
|
@ -166,7 +166,7 @@ retrieve h = fileRetriever $ \d k _p ->
|
|||
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"
|
||||
|
||||
|
|
|
|||
|
|
@ -265,7 +265,7 @@ retrieveCheap o k _af f = ifM (preseedTmp k f)
|
|||
)
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -449,7 +449,7 @@ retrieveHelper' h f p iv req = liftIO $ runResourceT $ do
|
|||
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 ()
|
||||
|
|
@ -462,7 +462,7 @@ lockContentS3 hv r rs c info
|
|||
| 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
|
||||
|
|
|
|||
|
|
@ -155,8 +155,8 @@ retrieve rs hdl k _f d _p _ = do
|
|||
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
|
||||
|
|
@ -164,7 +164,7 @@ remove _k = giveup "content cannot be removed from tahoe remote"
|
|||
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"
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -184,8 +184,8 @@ downloadKey urlincludeexclude key _af dest p vc =
|
|||
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
|
||||
|
|
|
|||
|
|
@ -185,7 +185,7 @@ retrieveHelper loc d p iv = 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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
|
@ -22,20 +22,24 @@ module Types.NumCopies (
|
|||
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)
|
||||
|
|
@ -77,14 +81,16 @@ data VerifiedCopy
|
|||
| 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 ()
|
||||
}
|
||||
|
||||
|
|
@ -99,8 +105,19 @@ toV (TrustedCopy v) = v
|
|||
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 ()
|
||||
|
|
@ -119,15 +136,18 @@ deDupVerifiedCopies l = M.elems $
|
|||
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
|
||||
|
|
@ -136,7 +156,7 @@ withVerifiedCopy
|
|||
:: (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
|
||||
|
|
@ -155,13 +175,26 @@ 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
|
||||
|
|
@ -174,27 +207,49 @@ isSafeDrop (NumCopies n) (MinCopies m) l (Just (ContentRemovalLock _)) =
|
|||
- 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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- 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.
|
||||
-}
|
||||
|
|
@ -25,6 +25,7 @@ module Types.Remote
|
|||
, ExportActions(..)
|
||||
, ImportActions(..)
|
||||
, ByteSize
|
||||
, SafeDropProof
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -105,8 +106,14 @@ data RemoteA a = Remote
|
|||
, 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
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
module Types.StoreRetrieve where
|
||||
|
||||
import Annex.Common
|
||||
import Types.NumCopies
|
||||
import Utility.Metered
|
||||
import Utility.Hash (IncrementalVerifier)
|
||||
|
||||
|
|
@ -44,8 +45,9 @@ type Retriever = forall a.
|
|||
|
||||
-- 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.
|
||||
|
|
|
|||
|
|
@ -115,8 +115,8 @@ the client sends:
|
|||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -29,18 +29,15 @@ It seems that LOCKCONTENT needs to guarantee that the content remains
|
|||
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.
|
||||
REMOVE-BEFORE Timestamp Key and a GETTIMESTAMP.
|
||||
|
||||
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.
|
||||
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
|
||||
|
|
@ -111,3 +108,12 @@ out to each client, by calling GETTIMESTAMP again and applying the offsets
|
|||
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.
|
||||
|
|
|
|||
|
|
@ -555,6 +555,7 @@ Executable git-annex
|
|||
Annex.Queue
|
||||
Annex.ReplaceFile
|
||||
Annex.RemoteTrackingBranch
|
||||
Annex.SafeDropProof
|
||||
Annex.SpecialRemote
|
||||
Annex.SpecialRemote.Config
|
||||
Annex.Ssh
|
||||
|
|
|
|||
Loading…
Reference in a new issue