p2phttp drop supports checking proof timestamps

At this point the p2phttp implementation is fully complete!

P2P/Http/Client.hs

@@ -71,8 +71,19 @@ p2pHttpClient
 	-> (String -> Annex a)
 	-> ClientAction a
 	-> Annex a
+p2pHttpClient rmt fallback clientaction = 
+	p2pHttpClientVersions (const True) rmt fallback clientaction >>= \case
+		Just res -> return res
+		Nothing -> fallback "git-annex HTTP API server is missing an endpoint"
+
+p2pHttpClientVersions
+	:: (ProtocolVersion -> Bool)
+	-> Remote
+	-> (String -> Annex a)
+	-> ClientAction a
+	-> Annex (Maybe a)
 #ifdef WITH_SERVANT
-p2pHttpClient rmt fallback clientaction =
+p2pHttpClientVersions allowedversion rmt fallback clientaction =
 	case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of
 		Nothing -> error "internal"
 		Just baseurl -> do
@@ -82,9 +93,10 @@ p2pHttpClient rmt fallback clientaction =
 			Git.CredentialCache cc <- liftIO $ atomically $
 				readTMVar ccv
 			case M.lookup (Git.CredentialBaseURL credentialbaseurl) cc of
-				Nothing -> go clientenv Nothing False Nothing allProtocolVersions
-				Just cred -> go clientenv (Just cred) True (credauth cred) allProtocolVersions
+				Nothing -> go clientenv Nothing False Nothing versions
+				Just cred -> go clientenv (Just cred) True (credauth cred) versions
   where
+	versions = filter allowedversion allProtocolVersions
 	go clientenv mcred credcached mauth (v:vs) = do
 		myuuid <- getUUID
 		res <- clientaction clientenv v
@@ -95,7 +107,7 @@ p2pHttpClient rmt fallback clientaction =
 		case res of
 			Right resp -> do
 				unless credcached $ cachecred mcred
-				return resp
+				return (Just resp)
 			Left (FailureResponse _ resp)
 				| statusCode (responseStatusCode resp) == 404 && not (null vs) ->
 					go clientenv mcred credcached mauth vs
@@ -104,15 +116,15 @@ p2pHttpClient rmt fallback clientaction =
 						Nothing -> authrequired clientenv (v:vs)
 						Just cred -> do
 							inRepo $ Git.rejectUrlCredential cred
-							fallback (showstatuscode resp)
-				| otherwise -> fallback (showstatuscode resp)
+							Just <$> fallback (showstatuscode resp)
+				| otherwise -> Just <$> fallback (showstatuscode resp)
 			Left (ConnectionError ex) -> case fromException ex of
-				Just (HttpExceptionRequest _ (ConnectionFailure err)) -> fallback $
-					"unable to connect to HTTP server: " ++ show err
-				_ -> fallback (show ex)
-			Left clienterror -> fallback $
-					"git-annex HTTP API server returned an unexpected response: " ++ show clienterror
-	go _ _ _ _ [] = error "internal"
+				Just (HttpExceptionRequest _ (ConnectionFailure err)) -> Just <$> fallback
+					("unable to connect to HTTP server: " ++ show err)
+				_ -> Just <$> fallback (show ex)
+			Left clienterror -> Just <$> fallback
+					("git-annex HTTP API server returned an unexpected response: " ++ show clienterror)
+	go _ _ _ _ [] = return Nothing
 
 	authrequired clientenv vs = do
 		cred <- prompt $ 
@@ -212,12 +224,38 @@ clientCheckPresent key clientenv (ProtocolVersion ver) su cu bypass auth =
 clientCheckPresent _ = ()
 #endif
 
-clientRemove
+-- Similar to P2P.Protocol.remove.
+clientRemoveWithProof
 	:: Maybe SafeDropProof
 	-> Key
-	-> ClientAction RemoveResultPlus
+	-> Annex RemoveResultPlus
+	-> Remote
+	-> Annex RemoveResultPlus
+clientRemoveWithProof proof k unabletoremove remote =
+	case safeDropProofEndTime =<< proof of
+		Nothing -> removeanytime
+		Just endtime -> removebefore endtime
+  where
+	removeanytime = p2pHttpClient remote giveup (clientRemove k)
+
+	removebefore endtime =
+		p2pHttpClientVersions useversion remote giveup clientGetTimestamp >>= \case
+			Just (GetTimestampResult (Timestamp remotetime)) ->
+				removebefore' endtime remotetime
+			-- Peer is too old to support REMOVE-BEFORE.
+			Nothing -> removeanytime
+				
+	removebefore' endtime remotetime =
+		canRemoveBefore endtime remotetime (liftIO getPOSIXTime) >>= \case
+			Just remoteendtime -> p2pHttpClient remote giveup $
+				clientRemoveBefore k (Timestamp remoteendtime)
+			Nothing -> unabletoremove
+	
+	useversion v = v >= ProtocolVersion 3
+
+clientRemove :: Key -> ClientAction RemoveResultPlus
 #ifdef WITH_SERVANT
-clientRemove proof k clientenv (ProtocolVersion ver) su cu bypass auth =
+clientRemove k clientenv (ProtocolVersion ver) su cu bypass auth =
 	liftIO $ withClientM cli clientenv return
   where
 	bk = B64Key k
@@ -233,7 +271,7 @@ clientRemove proof k clientenv (ProtocolVersion ver) su cu bypass auth =
 		_ :<|> _ :<|> _ :<|> _ :<|>
 		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
 #else
-clientRemove _ _ = ()
+clientRemove _ = ()
 #endif
 
 clientRemoveBefore

P2P/Protocol.hs

@@ -439,6 +439,16 @@ getTimestamp = do
 			net $ sendMessage (ERROR "expected TIMESTAMP")
 			return (Left "protocol error")
 
+removeBefore :: POSIXTime -> Key -> Proto (Either String Bool, Maybe [UUID])
+removeBefore endtime key = getTimestamp >>= \case
+	Right remotetime -> 
+		canRemoveBefore endtime remotetime (local getLocalCurrentTime) >>= \case
+			Just remoteendtime -> 
+				removeBeforeRemoteEndTime remoteendtime key
+			Nothing ->
+				return (Right False, Nothing)
+	Left err -> return (Left err, Nothing)
+
 {- The endtime is the last local time at which the key can be removed.
  - To tell the remote how long it has to remove the key, get its current
  - timestamp, and add to it the number of seconds from the current local
@@ -449,17 +459,15 @@ getTimestamp = do
  - response from the remote, that is reflected in the local time, and so
  - reduces the allowed time.
  -}
-removeBefore :: POSIXTime -> Key -> Proto (Either String Bool, Maybe [UUID])
-removeBefore endtime key = getTimestamp >>= \case
-	Right remotetime -> do
-		localtime <- local getLocalCurrentTime
-		let timeleft = endtime - localtime
-		let timeleft' = MonotonicTimestamp (floor timeleft)
-		let remoteendtime = remotetime + timeleft'
-		if timeleft <= 0
-			then return (Right False, Nothing)
-			else removeBeforeRemoteEndTime remoteendtime key
-	Left err -> return (Left err, Nothing)
+canRemoveBefore :: Monad m => POSIXTime -> MonotonicTimestamp -> m POSIXTime -> m (Maybe MonotonicTimestamp)
+canRemoveBefore endtime remotetime getlocaltime = do
+	localtime <- getlocaltime
+	let timeleft = endtime - localtime
+	let timeleft' = MonotonicTimestamp (floor timeleft)
+	let remoteendtime = remotetime + timeleft'
+	return $ if timeleft <= 0
+		then Nothing
+		else Just remoteendtime
 
 removeBeforeRemoteEndTime :: MonotonicTimestamp -> Key -> Proto (Either String Bool, Maybe [UUID])
 removeBeforeRemoteEndTime remoteendtime key = do

Remote/Git.hs

@@ -479,12 +479,13 @@ dropKey r st proof key = do
 
 dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex ()
 dropKey' repo r st@(State connpool duc _ _ _) proof key
-	| isP2PHttp r = p2pHttpClient r giveup (clientRemove proof key) >>= \case
-		RemoveResultPlus True fanoutuuids ->
-			storefanout fanoutuuids
-		RemoveResultPlus False fanoutuuids -> do
-			storefanout fanoutuuids
-			giveup "removing content from remote failed"
+	| isP2PHttp r = 
+		clientRemoveWithProof proof key unabletoremove r >>= \case
+				RemoveResultPlus True fanoutuuids ->
+					storefanout fanoutuuids
+				RemoveResultPlus False fanoutuuids -> do
+					storefanout fanoutuuids
+					unabletoremove
 	| not $ Git.repoIsUrl repo = ifM duc
 		( guardUsable repo (giveup "cannot access remote") removelocal
 		, giveup "remote does not have expected annex.uuid value"
@@ -494,6 +495,8 @@ dropKey' repo r st@(State connpool duc _ _ _) proof key
   where
 	p2prunner = Ssh.runProto r connpool (return (Right False, Nothing))
 
+	unabletoremove = giveup "removing content from remote failed"
+
 	-- 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.

doc/todo/git-annex_proxies.mdwn

@@ -28,8 +28,6 @@ Planned schedule of work:
 
 ## work notes
 
-* Drop needs to check the proof and use timestamps.
-
 * Make http server support proxies and clusters.
 
 * Support proxying to git remotes using annex+http urls.