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
+	:: Key
-	-> ProtocolVersion
+	-> ClientAction LockResult
-	-> B64Key
+clientLockContent k clientenv (ProtocolVersion ver) su cu bypass auth = 
-	-> B64UUID ServerSide
+	liftIO $ withClientM (cli (B64Key k) cu bypass auth) clientenv return
-	-> 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
   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
+	:: LockID
-	-> ProtocolVersion
+	-> UUID
-	-> LockID
+	-> a
-	-> B64UUID ServerSide
+	-> (VerifiedCopy -> Annex a)
-	-> B64UUID ClientSide
+	-- ^ Callback is run only after successfully connecting to the http
-	-> [B64UUID Bypass]
+	-- server. The lock will remain held until the callback returns,
-	-> Maybe Auth
+	-- and then will be dropped.
-	-> (TMVar Bool -> IO ())
+	-> ClientAction a
-	-- ^ The TMVar can be filled any number of times with True to send
+clientKeepLocked lckid remoteuuid unablelock callback clientenv (ProtocolVersion ver) su cu bypass auth = do
-	-- repeated keep locked requests, eg to keep a connection alive.
+	readyv <- liftIO newEmptyTMVarIO
-	-- Once filled with False, the lock will be dropped.
+	keeplocked <- liftIO newEmptyTMVarIO
-	-> IO ()
-clientKeepLocked clientenv (ProtocolVersion ver) lckid su cu bypass auth a = do
-	keeplocked <- newEmptyTMVarIO
-	tid <- async $ a keeplocked
 	let cli' = cli lckid (Just cu) bypass auth
 		(Just connectionKeepAlive) (Just keepAlive)
-		(S.fromStepT (unlocksender keeplocked))
+		(S.fromStepT (unlocksender readyv keeplocked))
-	withClientM cli' clientenv $ \case
+	starttime <- liftIO getPOSIXTime
-		Right (LockResult _ _) ->
+	tid <- liftIO $ async $ withClientM cli' clientenv $ \case
-			wait tid
+		Right (LockResult _ _) -> 
-		Left err  -> do
+			atomically $ writeTMVar readyv (Right False)
-			wait tid
+		Left err -> 
-			throwM 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