From 3f402a20a8f2343f41c1dccf71188c6557de66de Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 8 Jul 2024 21:00:10 -0400
Subject: [PATCH] implement Locker

---
 P2P/Http.hs                     | 54 +++++++++++++++++++++++++++++++--
 doc/todo/git-annex_proxies.mdwn | 11 +++----
 2 files changed, 55 insertions(+), 10 deletions(-)

diff --git a/P2P/Http.hs b/P2P/Http.hs
index 50e7989958..41639e083b 100644
--- 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 291da779e6..3caf27023e 100644
--- 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.
-- 
2.30.2