From 7f4cff7ae97526a4a55942db1d3ee39a0dfb8ff1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 22 Jul 2024 19:44:26 -0400 Subject: [PATCH] locking over http basically working --- Command/P2PHttp.hs | 51 ++++++++++++++++++++++++++++++++++++++-------- P2P/Http.hs | 24 +++++++++++----------- 2 files changed, 55 insertions(+), 20 deletions(-) diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index d85c9e5598..5e0e8a172c 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -16,13 +16,11 @@ import P2P.Http import qualified P2P.Protocol as P2P import Annex.Url import Utility.Env -import Utility.ThreadScheduler import Utility.MonotonicClock import qualified Network.Wai.Handler.Warp as Warp import Servant import Servant.Client.Streaming -import Control.Concurrent import Control.Concurrent.STM import Network.Socket (PortNumber) import qualified Data.Map as M @@ -73,7 +71,7 @@ seek o = getAnnexWorkerPool $ \workerpool -> do -- XXX remove this when (isNothing (portOption o)) $ do liftIO $ putStrLn "test begins" - testPutOffset + testLocking giveup "TEST DONE" withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do authenv <- getAuthEnv @@ -130,14 +128,51 @@ getAuthEnv = do Nothing -> (auth, P2P.ServeReadWrite) Just perms -> (auth, perms) +testLocking = do + mgr <- httpManager <$> getUrlOptions + burl <- liftIO $ parseBaseUrl "http://localhost:8080/" + let k = B64Key (fromJust $ deserializeKey ("SHA256E-s6--5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03" :: String)) + res <- liftIO $ clientLockContent (mkClientEnv mgr burl) + (P2P.ProtocolVersion 3) + k + (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) + [] + Nothing + case res of + LockResult True (Just lckid) -> + liftIO $ clientKeepLocked (mkClientEnv mgr burl) + (P2P.ProtocolVersion 3) + lckid + (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) + [] + Nothing $ \keeplocked -> do + print "running, press enter to drop lock" + _ <- getLine + atomically $ writeTMVar keeplocked False + _ -> liftIO $ print ("lockin failed", res) + +testLockContent = do + mgr <- httpManager <$> getUrlOptions + burl <- liftIO $ parseBaseUrl "http://localhost:8080/" + res <- liftIO $ clientLockContent (mkClientEnv mgr burl) + (P2P.ProtocolVersion 3) + (B64Key (fromJust $ deserializeKey ("SHA256E-s6--5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03" :: String))) + (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) + [] + Nothing + liftIO $ print res + testKeepLocked = do mgr <- httpManager <$> getUrlOptions burl <- liftIO $ parseBaseUrl "http://localhost:8080/" liftIO $ clientKeepLocked (mkClientEnv mgr burl) (P2P.ProtocolVersion 3) (B64UUID (toUUID ("lck" :: String))) + (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) (B64UUID (toUUID ("cu" :: String))) - (B64UUID (toUUID ("su" :: String))) [] Nothing $ \keeplocked -> do print "running, press enter to drop lock" @@ -150,8 +185,8 @@ testCheckPresent = do res <- liftIO $ clientCheckPresent (mkClientEnv mgr burl) (P2P.ProtocolVersion 3) (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String))) - (B64UUID (toUUID ("cu" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) [] Nothing liftIO $ print res @@ -205,8 +240,8 @@ testRemove = do res <- liftIO $ clientRemove (mkClientEnv mgr burl) (P2P.ProtocolVersion 3) (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720547401--foo" :: String))) - (B64UUID (toUUID ("cu" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) [] Nothing liftIO $ print res @@ -221,8 +256,8 @@ testRemoveBefore = do res <- liftIO $ clientRemoveBefore (mkClientEnv mgr burl) (P2P.ProtocolVersion 3) (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String))) - (B64UUID (toUUID ("cu" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) [] (Timestamp ts) Nothing @@ -233,8 +268,8 @@ testGetTimestamp = do burl <- liftIO $ parseBaseUrl "http://localhost:8080/" res <- liftIO $ clientGetTimestamp (mkClientEnv mgr burl) (P2P.ProtocolVersion 3) - (B64UUID (toUUID ("cu" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) + (B64UUID (toUUID ("cu" :: String))) [] Nothing liftIO $ print res diff --git a/P2P/Http.hs b/P2P/Http.hs index 2576c0d9b5..638a81ed53 100644 --- a/P2P/Http.hs +++ b/P2P/Http.hs @@ -345,12 +345,12 @@ clientCheckPresent :: ClientEnv -> ProtocolVersion -> B64Key - -> B64UUID ClientSide -> B64UUID ServerSide + -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth -> IO Bool -clientCheckPresent clientenv (ProtocolVersion ver) key cu su bypass auth = +clientCheckPresent clientenv (ProtocolVersion ver) key su cu bypass auth = withClientM (cli su key cu bypass auth) clientenv $ \case Left err -> throwM err Right (CheckPresentResult res) -> return res @@ -399,12 +399,12 @@ clientRemove :: ClientEnv -> ProtocolVersion -> B64Key - -> B64UUID ClientSide -> B64UUID ServerSide + -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth -> IO RemoveResultPlus -clientRemove clientenv (ProtocolVersion ver) key cu su bypass auth = +clientRemove clientenv (ProtocolVersion ver) key su cu bypass auth = withClientM cli clientenv $ \case Left err -> throwM err Right res -> return res @@ -456,13 +456,13 @@ clientRemoveBefore :: ClientEnv -> ProtocolVersion -> B64Key - -> B64UUID ClientSide -> B64UUID ServerSide + -> B64UUID ClientSide -> [B64UUID Bypass] -> Timestamp -> Maybe Auth -> IO RemoveResultPlus -clientRemoveBefore clientenv (ProtocolVersion ver) key cu su bypass ts auth = +clientRemoveBefore clientenv (ProtocolVersion ver) key su cu bypass ts auth = withClientM (cli su key cu bypass ts auth) clientenv $ \case Left err -> throwM err Right res -> return res @@ -505,12 +505,12 @@ serveGetTimestamp st su apiver cu bypass sec auth = do clientGetTimestamp :: ClientEnv -> ProtocolVersion - -> B64UUID ClientSide -> B64UUID ServerSide + -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth -> IO GetTimestampResult -clientGetTimestamp clientenv (ProtocolVersion ver) cu su bypass auth = +clientGetTimestamp clientenv (ProtocolVersion ver) su cu bypass auth = withClientM (cli su cu bypass auth) clientenv $ \case Left err -> throwM err Right res -> return res @@ -842,14 +842,14 @@ serveLockContent st su apiver (B64Key k) cu bypass sec auth = do clientLockContent :: ClientEnv - -> B64UUID ServerSide -> ProtocolVersion -> B64Key + -> B64UUID ServerSide -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth -> IO LockResult -clientLockContent clientenv su (ProtocolVersion ver) k cu bypass auth = +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 @@ -911,8 +911,8 @@ clientKeepLocked :: ClientEnv -> ProtocolVersion -> LockID - -> B64UUID ClientSide -> B64UUID ServerSide + -> B64UUID ClientSide -> [B64UUID Bypass] -> Maybe Auth -> (TMVar Bool -> IO ()) @@ -920,7 +920,7 @@ clientKeepLocked -- 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 cu su bypass auth a = do +clientKeepLocked clientenv (ProtocolVersion ver) lckid su cu bypass auth a = do keeplocked <- newEmptyTMVarIO tid <- async $ a keeplocked let cli' = cli lckid cu bypass auth -- 2.39.5