Remote.Git lockContent works with annex+http urls

diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs
index 5d6d3f420a12a01d9ab172d24b25068e204e96ed..9fb35d067e787380bc9832a754ee11f773feaf82 100644 (file)
--- a/P2P/Http/Client.hs
+++ b/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

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 8edb5f544995d60f4240882cf359b54f9971774d..ceccacc66e438b9a81db27e6d16bcfb76913c1bd 100644 (file)
--- a/Remote/Git.hs
+++ b/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

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index 529092b4db289776d451a2c01e02b83524405531..905fe2c4313f88cf74786f18f506c5a4ba96971d 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/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