lockContent for S3 (with versioning=yes) and git-lfs

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.

In both cases, verify the content is present actively, because it's
certianly possible for things other than git-annex to have removed it.

Worth thinking about what to do if at some later point, git-lfs gains
support for dropping content, and a content locking operation.
That would probably need a transition; first would need to make lockContent
use the locking operation. Then, once enough time had passed that we can
assume any git-annex operating on the git-lfs remote had that change,
git-annex could finally allow dropping from git-lfs.

Or, it could be that git-lfs gains support for dropping content, but not
locking it. In that case, it seems this commit would need to be reverted,
and then wait long enough for that git-annex to be everywhere, and only
then can git-annex safely support dropping from git-lfs.

So, the assumption made in this commit could lead to bother later.. But I
think it's actually highly unlikely git-lfs does ever support dropping;
it's outside their centralized model. Probably. :) Worth keeping in mind as
the same assumption is made about other special remotes though.

This commit was sponsored by Ethan Aubin.

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 <id@joeyh.name>  Thu, 18 Jun 2020 12:21:14 -0400
 

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"

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