implemented serveLockContent (untested)

diff --git a/P2P/Http.hs b/P2P/Http.hs
index 205478c5a51ff6a715180c5e08ddc18c3205a6bc..8ecfa4d8143d363f734ff85e05a9be5fc5dfd2c3 100644 (file)
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@@ -798,6 +798,8 @@ type LockContentAPI
        = KeyParam
        :> CU Required
        :> BypassUUIDs
+       :> IsSecure
+       :> AuthHeader
        :> Post '[JSON] LockResult
 
 serveLockContent
@@ -808,8 +810,35 @@ serveLockContent
        -> B64Key
        -> B64UUID ClientSide
        -> [B64UUID Bypass]
+       -> IsSecure
+       -> Maybe Auth
        -> Handler LockResult
-serveLockContent = undefined -- TODO
+serveLockContent st su apiver (B64Key k) cu bypass sec auth = do
+       conn <- getP2PConnection apiver st cu su bypass sec auth WriteAction id
+       let lock = do
+               lockresv <- newEmptyTMVarIO
+               unlockv <- newEmptyTMVarIO
+               annexworker <- async $ inAnnexWorker st $ do
+                       lockres <- runFullProto (clientRunState conn) (clientP2PConnection conn) $ do
+                               net $ sendMessage (LOCKCONTENT k)
+                               checkSuccess
+                       liftIO $ atomically $ putTMVar lockresv lockres
+                       -- TODO timeout
+                       liftIO $ atomically $ takeTMVar unlockv
+                       void $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ do
+                               net $ sendMessage UNLOCKCONTENT
+               atomically (takeTMVar lockresv) >>= \case
+                       Right True -> return (Just (annexworker, unlockv))
+                       _ -> return Nothing
+       let unlock (annexworker, unlockv) = do
+               atomically $ putTMVar unlockv ()
+               wait annexworker
+               releaseP2PConnection conn
+       liftIO $ mkLocker lock unlock >>= \case
+               Just (locker, lockid) -> do
+                       liftIO $ storeLock lockid locker st
+                       return $ LockResult True (Just lockid)
+               Nothing -> return $ LockResult False Nothing
 
 clientLockContent
        :: B64UUID ServerSide
@@ -817,6 +846,7 @@ clientLockContent
        -> B64Key
        -> B64UUID ClientSide
        -> [B64UUID Bypass]
+       -> Maybe Auth
        -> ClientM LockResult
 clientLockContent su (ProtocolVersion ver) = case ver of
        3 -> v3 su V3

diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs
index 534a46ed88ace56fbc9b8111c155f8d0800b9039..b38ceae0f070ce3814e45b8d1e36c7c2af4ba444 100644 (file)
--- a/P2P/Http/State.hs
+++ b/P2P/Http/State.hs
@@ -264,23 +264,21 @@ data Locker = Locker
        -- and setting to False causes the lock to be released.
        }
 
-mkLocker :: IO () -> IO () -> IO (Maybe (Locker, LockID))
+mkLocker :: IO (Maybe a) -> (a -> IO ()) -> IO (Maybe (Locker, LockID))
 mkLocker lock unlock = do
        lv <- newEmptyTMVarIO
        let setlocked = putTMVar lv
-       tid <- async $
-               tryNonAsync lock >>= \case
-                       Left _ -> do
-                               atomically $ setlocked False
-                               unlock
-                       Right () -> do
-                               atomically $ setlocked True
-                               atomically $ do
-                                       v <- takeTMVar lv
-                                       if v
-                                               then retry
-                                               else setlocked False
-                               unlock
+       tid <- async $ lock >>= \case
+               Nothing ->
+                       atomically $ setlocked False
+               Just st -> do
+                       atomically $ setlocked True
+                       atomically $ do
+                               v <- takeTMVar lv
+                               if v
+                                       then retry
+                                       else setlocked False
+                       unlock st
        locksuccess <- atomically $ readTMVar lv
        if locksuccess
                then do
@@ -305,7 +303,8 @@ dropLock lckid st = do
                putTMVar (openLocks st) m'
                case mlocker of
                        Nothing -> return Nothing
-                       -- Signal to the locker's thread that it can release the lock.
+                       -- Signal to the locker's thread that it can
+                       -- release the lock.
                        Just locker -> do
                                _ <- swapTMVar (lockerVar locker) False
                                return (Just locker)

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index 85a2ee0bf2db44582d0d33370b7924745ad716ea..4cecfaf68ff011a9cfb0e193aa30131d62def20e 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/doc/todo/git-annex_proxies.mdwn
@@ -28,12 +28,12 @@ Planned schedule of work:
 
 ## work notes
 
-* Implement serveLockContent
+* Test serveLockContent
 
 * A Locker should expire the lock on its own after 10 minutes initially.
 
-* Since each held lock needs a connection to a proxy, the Locker
-  could reference count, and avoid holding more than one lock per key.
+* serveKeepLocked should check auth just to be safe, although added
+  security is probably minimal.
 
 * Make Remote.Git use http client when remote.name.annex-url is configured.