Remote.Git lockContent works with annex+http urls

P2P/Http/Client.hs

@@ -24,6 +24,7 @@ import Annex.Url
 import qualified Annex
 import Annex.UUID
 import Types.Remote
+import Types.NumCopies
 import P2P.Http
 import P2P.Http.Url
 import P2P.Http.Types
@@ -32,6 +33,7 @@ import P2P.Protocol hiding (Offset, Bypass, auth)
 import Annex.Concurrent
 import Utility.Url (BasicAuth(..))
 import Utility.Metered
+import Utility.HumanTime
 import qualified Git.Credential as Git
 
 import Servant hiding (BasicAuthData(..))
@@ -43,6 +45,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Internal as LI
 import qualified Data.Map as M
+import Data.Time.Clock.POSIX
 import Control.Concurrent.STM
 import Control.Concurrent.Async
 import Control.Concurrent
@@ -409,18 +412,10 @@ clientPutOffset _ = ()
 
 #ifdef WITH_SERVANT
 clientLockContent
-	:: ClientEnv
-	-> ProtocolVersion
-	-> B64Key
-	-> B64UUID ServerSide
-	-> B64UUID ClientSide
-	-> [B64UUID Bypass]
-	-> Maybe Auth
-	-> IO LockResult
-clientLockContent clientenv (ProtocolVersion ver) k su cu bypass auth = 
-	withClientM (cli k cu bypass auth) clientenv $ \case
-		Left err -> throwM err
-		Right res -> return res
+	:: Key
+	-> ClientAction LockResult
+clientLockContent k clientenv (ProtocolVersion ver) su cu bypass auth = 
+	liftIO $ withClientM (cli (B64Key k) cu bypass auth) clientenv return
   where
 	cli = case ver of
 		3 -> v3 su V3
@@ -437,41 +432,60 @@ clientLockContent clientenv (ProtocolVersion ver) k su cu bypass auth =
 		_ :<|> _ :<|> _ :<|> _ :<|>
 		_ :<|> _ :<|> _ :<|>
 		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
+#else
+clientLockContent _ = ()
 #endif
 
 #ifdef WITH_SERVANT
 clientKeepLocked
-	:: ClientEnv
-	-> ProtocolVersion
-	-> LockID
-	-> B64UUID ServerSide
-	-> B64UUID ClientSide
-	-> [B64UUID Bypass]
-	-> Maybe Auth
-	-> (TMVar Bool -> IO ())
-	-- ^ The TMVar can be filled any number of times with True to send
-	-- repeated keep locked requests, eg to keep a connection alive.
-	-- Once filled with False, the lock will be dropped.
-	-> IO ()
-clientKeepLocked clientenv (ProtocolVersion ver) lckid su cu bypass auth a = do
-	keeplocked <- newEmptyTMVarIO
-	tid <- async $ a keeplocked
+	:: LockID
+	-> UUID
+	-> a
+	-> (VerifiedCopy -> Annex a)
+	-- ^ Callback is run only after successfully connecting to the http
+	-- server. The lock will remain held until the callback returns,
+	-- and then will be dropped.
+	-> ClientAction a
+clientKeepLocked lckid remoteuuid unablelock callback clientenv (ProtocolVersion ver) su cu bypass auth = do
+	readyv <- liftIO newEmptyTMVarIO
+	keeplocked <- liftIO newEmptyTMVarIO
 	let cli' = cli lckid (Just cu) bypass auth
 		(Just connectionKeepAlive) (Just keepAlive)
-		(S.fromStepT (unlocksender keeplocked))
-	withClientM cli' clientenv $ \case
-		Right (LockResult _ _) ->
-			wait tid
-		Left err  -> do
-			wait tid
-			throwM err
+		(S.fromStepT (unlocksender readyv keeplocked))
+	starttime <- liftIO getPOSIXTime
+	tid <- liftIO $ async $ withClientM cli' clientenv $ \case
+		Right (LockResult _ _) -> 
+			atomically $ writeTMVar readyv (Right False)
+		Left err -> 
+			atomically $ writeTMVar readyv (Left err)
+	let releaselock = liftIO $ do
+		atomically $ putTMVar keeplocked False
+		wait tid
+	liftIO (atomically $ takeTMVar readyv) >>= \case
+		Left err -> do
+			liftIO $ wait tid
+			return (Left err)
+		Right False -> do
+			liftIO $ wait tid
+			return (Right unablelock)
+		Right True -> do
+			let checker = return $ Left $ starttime + retentionduration
+			Right 
+				<$> withVerifiedCopy LockedCopy remoteuuid checker callback
+					`finally` releaselock
   where
-	unlocksender keeplocked =
+	retentionduration = fromIntegral $
+		durationSeconds p2pDefaultLockContentRetentionDuration
+
+	unlocksender readyv keeplocked =
 		S.Yield (UnlockRequest False) $ S.Effect $ do
 			return $ S.Effect $ do
-				stilllocked <- liftIO $ atomically $ takeTMVar keeplocked
+				liftIO $ atomically $ void $
+					tryPutTMVar readyv (Right True)
+				stilllocked <- liftIO $ atomically $
+					takeTMVar keeplocked
 				return $ if stilllocked
-					then unlocksender keeplocked
+					then unlocksender readyv keeplocked
 					else S.Yield (UnlockRequest True) S.Stop
 	
 	cli = case ver of
@@ -490,5 +504,6 @@ clientKeepLocked clientenv (ProtocolVersion ver) lckid su cu bypass auth a = do
 		_ :<|> _ :<|> _ :<|>
 		_ :<|> _ :<|> _ :<|> _ :<|>
 		v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
-
+#else
+clientKeepLocked _ _ _ _ = ()
 #endif

Remote/Git.hs

@@ -521,6 +521,14 @@ lockKey r st key callback = do
 
 lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
 lockKey' repo r st@(State connpool duc _ _ _) key callback
+	| isP2PHttp r = do
+		showLocking r
+		p2pHttpClient r giveup (clientLockContent key) >>= \case
+			LockResult True (Just lckid) ->
+				p2pHttpClient r failedlock $
+					clientKeepLocked lckid (uuid r)
+						failedlock callback
+			_ -> failedlock
 	| not $ Git.repoIsUrl repo = ifM duc
 		( guardUsable repo failedlock $ do
 			inorigrepo <- Annex.makeRunner

doc/todo/git-annex_proxies.mdwn

@@ -30,8 +30,6 @@ Planned schedule of work:
 
 * Drop needs to check the proof and use timestamps.
 
-* Rest of Remote.Git needs implementing: lock
-
 * A Locker should expire the lock on its own after 10 minutes,
   initially. Once keeplocked is called, the lock will expire at the end 
   of that call. But if keeplocked never gets called, the lock currently