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.

Annex/Content.hs

@@ -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

Annex/NumCopies.hs

@@ -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)
 

Annex/Proxy.hs

@@ -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

Annex/SafeDropProof.hs

@@ -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)
+

CmdLine/GitRemoteAnnex.hs

@@ -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
 

Command/Drop.hs

@@ -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
 		)

Command/Fsck.hs

@@ -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

Command/Move.hs

@@ -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

Command/TestRemote.hs

@@ -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
 

P2P/Annex.hs

@@ -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)

P2P/Protocol.hs

@@ -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 :: Maybe SafeDropProof -> Key -> Proto (Either String Bool, Maybe [UUID])
-remove key = do
+remove proof key = do
 	net $ sendMessage (REMOVE key)
 	checkSuccessFailurePlus
 

Remote/Adb.hs

@@ -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"
 

Remote/BitTorrent.hs

@@ -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 :: Maybe SafeDropProof -> Key -> Annex ()
-dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k
+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

Remote/Bup.hs

@@ -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

Remote/Ddar.hs

@@ -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) $

Remote/Directory.hs

@@ -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))
 

Remote/External.hs

@@ -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

Remote/GCrypt.hs

@@ -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
+	removersync = Remote.Rsync.remove rsyncopts proof k
-	removeshell = Ssh.dropKey repo k
+	removeshell = Ssh.dropKey repo proof k
 
 checkKey :: Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> CheckPresent
 checkKey r rsyncopts accessmethod k = do

Remote/Git.hs

@@ -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 :: Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
-dropKey r st key = do
+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' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
-dropKey' repo r st@(State connpool duc _ _ _) key
+dropKey' repo r st@(State connpool duc _ _ _) proof key
 	| not $ Git.repoIsUrl repo = ifM duc
-		( guardUsable repo (giveup "cannot access remote") $
+		( guardUsable repo (giveup "cannot access remote") removelocal
-			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
 		, giveup "remote does not have expected annex.uuid value"
 		)
 	| Git.repoIsHttp repo = giveup "dropping from http remote not supported"
-	| otherwise = P2PHelper.remove (uuid r) 
+	| otherwise = P2PHelper.remove (uuid r) p2prunner proof key
-		(Ssh.runProto r connpool (return (Right False, Nothing))) 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

Remote/GitLFS.hs

@@ -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
 		)
 

Remote/Glacier.hs

@@ -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

Remote/Helper/Chunked.hs

@@ -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 -> UUID -> ChunkConfig -> EncKey -> Maybe SafeDropProof -> Key -> Annex ()
-removeChunks remover u chunkconfig encryptor k = do
+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
 

Remote/Helper/Hooks.hs

@@ -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

Remote/Helper/P2P.hs

@@ -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 :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Maybe SafeDropProof -> Key -> Annex ()
-remove remoteuuid runner k = runner (P2P.remove k) >>= \case
+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 _ False = giveup "can't lock content"
-	go True = withVerifiedCopy LockedCopy u (return True) callback
+	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"

Remote/Helper/ReadOnly.hs

@@ -47,8 +47,8 @@ adjustReadOnly r
 readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
 readonlyStoreKey _ _ _ _ = readonlyFail
 
-readonlyRemoveKey :: Key -> Annex ()
+readonlyRemoveKey :: Maybe SafeDropProof -> Key -> Annex ()
-readonlyRemoveKey _ = readonlyFail
+readonlyRemoveKey _ _ = readonlyFail
 
 readonlyStorer :: Storer
 readonlyStorer _ _ _ = readonlyFail

Remote/Helper/Special.hs

@@ -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 :: Maybe SafeDropProof -> Key -> Annex ()
-removeKeyDummy _ = error "missing removeKey implementation"
+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 = 
+	removeKeyGen proof k enc = 
-		removeChunks remover (uuid baser) chunkconfig enck k
+		removeChunks remover (uuid baser) chunkconfig enck proof k
 	  where
 		enck = maybe id snd enc
 

Remote/Helper/Ssh.hs

@@ -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. -}
+{- Removes a key from a remote using the legacy git-annex-shell dropkey,
-dropKey :: Git.Repo -> Key -> Annex ()
+ - rather than the P2P protocol.
-dropKey r key = unlessM (dropKey' r key) $
+ -
+ - 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' :: Git.Repo -> Maybe SafeDropProof -> Key -> Annex Bool
-dropKey' r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
+dropKey' r _proof key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
 	[ Param "--quiet", Param "--force"
 	, Param $ serializeKey key
 	]

Remote/Hook.hs

@@ -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"
 

Remote/Rsync.hs

@@ -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

Remote/S3.hs

@@ -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

Remote/Tahoe.hs

@@ -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 :: Maybe SafeDropProof -> Key -> Annex ()
-remove _k = giveup "content cannot be removed from tahoe remote"
+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"
 		)
 

Remote/Web.hs

@@ -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 -> Maybe SafeDropProof -> Key -> Annex ()
-dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k
+dropKey urlincludeexclude _proof k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k
 
 checkKey :: UrlIncludeExclude -> Key -> Annex Bool
 checkKey urlincludeexclude key = do

Remote/WebDAV.hs

@@ -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)

Types/NumCopies.hs

@@ -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.
+-- Checks that the VerifiedCopy is still valid.
-checkVerifiedCopy :: VerifiedCopy -> IO Bool
+--
+-- 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 _)) = 
+safeDropAnalysis (NumCopies n) (MinCopies m) l (Just (ContentRemovalLock _)) =
-	length (deDupVerifiedCopies l) >= max n m
+	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
+safeDropAnalysis (NumCopies n) (MinCopies m) l Nothing
-	| n == 0 && m == 0 = True
+	| n == 0 && m == 0 = SafeDrop
-	| otherwise = and
+	| length (deDupVerifiedCopies l) >= n 
-		[ length (deDupVerifiedCopies l) >= n
+		&& length (filter fullVerification l) >= m =
-		, 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.
+-- Content locked using the P2P protocol defaults to being retained,
-data SafeDropProof = SafeDropProof NumCopies MinCopies [VerifiedCopy] (Maybe ContentRemovalLock)
+-- 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
+	l <- mapM checkVerifiedCopy have
-	return $ if isSafeDrop need mincopies stillhave removallock
+	let stillhave = map fst $ 
-		then Right (SafeDropProof need mincopies stillhave removallock)
+		filter (either (const True) id . snd) (zip have l)
-		else Left stillhave
+	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

Types/Remote.hs

@@ -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.
+	-- refuses to remove the content, or if the proof is expired.
-	, removeKey :: Key -> a ()
+	--
+	-- 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

Types/StoreRetrieve.hs

@@ -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.
+-- Throws an exception if the remote is not accessible
-type Remover = Key -> Annex ()
+-- 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.

doc/design/p2p_protocol.mdwn

@@ -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
+locked until 10 minutes after the connection is broken, or until
-sends:
+the client sends:
 
 	UNLOCKCONTENT Key
 

doc/todo/P2P_locking_connection_drop_safety.mdwn

@@ -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
+REMOVE-BEFORE Timestamp Key and a GETTIMESTAMP.
-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
+How long to lock for? 10 minutes is arbitrary, but seems in the right
-this will cause drops to fail if they timeout sitting at a ssh password
+ballpark. Since this will cause drops to fail if they timeout sitting at a
-prompt, it needs to be more than a few minutes. But making it too long, eg
+ssh password prompt, it needs to be more than a few minutes. But making it
-an hour can result in content being stuck locked on a remote for a long
+too long, eg an hour can result in content being stuck locked on a remote
-time, preventing a later legitimate drop. It could be made configurable, if
+for a long time, preventing a later legitimate drop. It could be made
-needed, by extending the P2P protocol so LOCKCONTENT was passed the amount
+configurable, if needed, by extending the P2P protocol so LOCKCONTENT was
-of time.
+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.

git-annex.cabal

@@ -555,6 +555,7 @@ Executable git-annex
     Annex.Queue
     Annex.ReplaceFile
     Annex.RemoteTrackingBranch
+    Annex.SafeDropProof
     Annex.SpecialRemote
     Annex.SpecialRemote.Config
     Annex.Ssh