implement Locker

diff --git a/P2P/Http.hs b/P2P/Http.hs
index 50e7989958c51442aa4070000e39bd75661465ff..41639e083b11ebdda5d83cb1f5206003d238285a 100644 (file)
--- a/P2P/Http.hs
+++ b/P2P/Http.hs
@@ -7,6 +7,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -19,6 +20,7 @@
 module P2P.Http where
 
 import Annex.Common
+import Annex.UUID (genUUID)
 import qualified P2P.Protocol as P2P
 import Utility.Base64
 import Utility.MonotonicClock
@@ -539,13 +541,59 @@ type LockID = B64UUID Lock
 data Locker = Locker
        { lockerThread :: Async ()
        , lockerVar :: TMVar Bool
+       -- ^ Left empty until the thread has taken the lock
+       -- (or failed to do so), then True while the lock is held,
+       -- and setting to False causes the lock to be released.
        }
 
-storeLock :: LockID -> P2PHttpServerState -> IO ()
-storeLock lckid st = error "TODO" -- XXX
+mkLocker :: IO () -> 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
+       locksuccess <- atomically $ readTMVar lv
+       if locksuccess
+               then do
+                       lckid <- B64UUID <$> genUUID
+                       return (Just (Locker tid lv, lckid))
+               else do
+                       wait tid
+                       return Nothing
+
+storeLock :: LockID -> Locker -> P2PHttpServerState -> IO ()
+storeLock lckid locker st = atomically $ do
+       m <- takeTMVar (openLocks st)
+       let !m' = M.insert lckid locker m
+       putTMVar (openLocks st) m'
 
 dropLock :: LockID -> P2PHttpServerState -> IO ()
-dropLock lckid st = error "TODO" -- XXX
+dropLock lckid st = do
+       v <- atomically $ do
+               m <- takeTMVar (openLocks st)
+               let (mlocker, !m') =
+                       M.updateLookupWithKey (\_ _ -> Nothing) lckid m
+               putTMVar (openLocks st) m'
+               case mlocker of
+                       Nothing -> return Nothing
+                       -- Signal to the locker's thread that it can release the lock.
+                       Just locker -> do
+                               _ <- swapTMVar (lockerVar locker) False
+                               return (Just locker)
+       case v of
+               Nothing -> return ()
+               Just locker -> wait (lockerThread locker)
 
 type ClientUUID req = QueryParam' '[req] "clientuuid" (B64UUID ClientSide)
 

diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn
index 291da779e62344212aec2d740bb8b62bc64539c1..3caf27023e5a8ff24d3a2d807b83c6fe92d4fb46 100644 (file)
--- a/doc/todo/git-annex_proxies.mdwn
+++ b/doc/todo/git-annex_proxies.mdwn
@@ -28,16 +28,13 @@ Planned schedule of work:
 
 ## work notes
 
-* Next step: Ready to begin implementing in servant. I have a file
-  `servant.hs` in the httpproto branch that works through some of the
+* I have a file `servant.hs` in the httpproto branch that works through some of the
   bytestring streaming issues.
 
-* P2P.Http has LockContent disabled, needs `HasClient ClientM WebSocket`
-  implementation, or redesign not to use websockets
+* A Locker should expire the lock on its own after 10 minutes.
 
-* P2P.Http.clientGet needs to call v1 and v0, which needs a way to
-  add a DataLengthHeader to the type of them. 
-  Or add it to the API for those versions, but document that it's not checked?
+* Since each held lock needs a connection to a proxy, the Locker
+  could reference count, and avoid holding more than one lock per key.
 
 * Perhaps: Support cgi program that proxies over to a webserver
   speaking the http protocol.