diff --git a/CHANGELOG b/CHANGELOG index 1c363bd376..04067c73a1 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -13,6 +13,10 @@ git-annex (8.20200618) UNRELEASED; urgency=medium * importfeed: Added some additional --template variables: itempubyear, itempubmonth, itempubday, itempubhour, itempubminute, itempubsecond. + * Made several special remotes support locking content on them while + dropping, which allows dropping from another special remote when + the content will only remain on a special remote of these types: + S3 (with versioning=yes), git-lfs -- Joey Hess Thu, 18 Jun 2020 12:21:14 -0400 diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index a829bd39e8..f485a9b259 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -16,6 +16,7 @@ import Annex.Url import Types.Key import Types.Creds import Types.ProposedAccepted +import Types.NumCopies import qualified Annex import qualified Git import qualified Git.Types as Git @@ -100,9 +101,9 @@ gen r u rc gc rs = do (retrieve rs h) (remove h) (checkKey rs h) - (this c cst) + (this c cst h) where - this c cst = Remote + this c cst h = Remote { uuid = u , cost = cst , name = Git.repoDescribe r @@ -114,7 +115,7 @@ gen r u rc gc rs = do -- is checked on download , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy - , lockContent = Nothing + , lockContent = Just $ lockKey (this c cst h) rs h , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = exportUnsupported @@ -132,7 +133,7 @@ gen r u rc gc rs = do -- content cannot be removed from a git-lfs repo , appendonly = True , mkUnavailable = return Nothing - , getInfo = gitRepoInfo (this c cst) + , getInfo = gitRepoInfo (this c cst h) , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs @@ -493,6 +494,16 @@ retrieve rs h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload uo <- getUrlOptions liftIO $ downloadConduit p req dest uo +-- Since git-lfs does not support removing content, nothing needs to be +-- done to lock content in the remote, except for checking that the content +-- is actually present. +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 + , giveup $ "content seems to be missing from " ++ name r + ) + checkKey :: RemoteStateHandle -> TVar LFSHandle -> CheckPresent checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case Nothing -> giveup "unable to connect to git-lfs endpoint" diff --git a/Remote/S3.hs b/Remote/S3.hs index ceac3239e8..8dd7fe4c4a 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -58,6 +58,7 @@ import Logs.Web import Logs.MetaData import Types.MetaData import Types.ProposedAccepted +import Types.NumCopies import Utility.Metered import Utility.DataUnits import Annex.Content @@ -199,7 +200,7 @@ gen r u rc gc rs = do -- secure. , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy - , lockContent = Nothing + , lockContent = lockContentS3 hdl this rs c info , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = ExportActions @@ -427,6 +428,19 @@ remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> do S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) return () +lockContentS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Maybe (Key -> (VerifiedCopy -> Annex a) -> Annex a) +lockContentS3 hv r rs c info + -- When versioning is enabled, content is never removed from the + -- remote, so nothing needs to be done to lock the content there, + -- beyond a sanity check that the content is in fact present. + | 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 + , giveup $ "content seems to be missing from " ++ name r ++ " despite S3 versioning being enabled" + ) + | otherwise = Nothing + checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey hv r rs c info k = withS3Handle hv $ \case Just h -> do