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.

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

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

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

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

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

Remote/Helper/ReadOnly.hs

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

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 _ = 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
 

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. -}
-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
 	]

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 _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"
 		)
 

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

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)