From f5dd7a8bc00317140c0a273dfde413798c5bd7fa Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 22 Jul 2024 17:36:56 -0400
Subject: [PATCH] implemented serveLockContent (untested)

---
 P2P/Http.hs                     | 32 +++++++++++++++++++++++++++++++-
 P2P/Http/State.hs               | 29 ++++++++++++++---------------
 doc/todo/git-annex_proxies.mdwn |  6 +++---
 3 files changed, 48 insertions(+), 19 deletions(-)

diff --git a/P2P/Http.hs b/P2P/Http.hs
index 205478c5a5..8ecfa4d814 100644
--- 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 534a46ed88..b38ceae0f0 100644
--- 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 85a2ee0bf2..4cecfaf68f 100644
--- 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.
 
-- 
2.39.5