mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

locking over http basically working

Browse source
This commit is contained in:
Joey Hess 2024-07-22 19:44:26 -04:00
parent e979e85bff
commit 7f4cff7ae9
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 55 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

51
Command/P2PHttp.hs
View file

@ -16,13 +16,11 @@ import P2P.Http
import qualified P2P.Protocol as P2P import qualified P2P.Protocol as P2P
import Annex.Url import Annex.Url
import Utility.Env import Utility.Env
import Utility.ThreadScheduler
import Utility.MonotonicClock import Utility.MonotonicClock
import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp as Warp
import Servant import Servant
import Servant.Client.Streaming import Servant.Client.Streaming
import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Network.Socket (PortNumber) import Network.Socket (PortNumber)
import qualified Data.Map as M import qualified Data.Map as M
@ -73,7 +71,7 @@ seek o = getAnnexWorkerPool $ \workerpool -> do
-- XXX remove this -- XXX remove this
when (isNothing (portOption o)) $ do when (isNothing (portOption o)) $ do
liftIO $ putStrLn "test begins" liftIO $ putStrLn "test begins"
testPutOffset testLocking
giveup "TEST DONE" giveup "TEST DONE"
withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do withLocalP2PConnections workerpool $ \acquireconn -> liftIO $ do
authenv <- getAuthEnv authenv <- getAuthEnv
@ -130,14 +128,51 @@ getAuthEnv = do
Nothing -> (auth, P2P.ServeReadWrite) Nothing -> (auth, P2P.ServeReadWrite)
Just perms -> (auth, perms) 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 testKeepLocked = do
mgr <- httpManager <$> getUrlOptions mgr <- httpManager <$> getUrlOptions
burl <- liftIO $ parseBaseUrl "http://localhost:8080/" burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
liftIO $ clientKeepLocked (mkClientEnv mgr burl) liftIO $ clientKeepLocked (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3) (P2P.ProtocolVersion 3)
(B64UUID (toUUID ("lck" :: String))) (B64UUID (toUUID ("lck" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String))) (B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("su" :: String)))
[] []
Nothing $ \keeplocked -> do Nothing $ \keeplocked -> do
print "running, press enter to drop lock" print "running, press enter to drop lock"
@ -150,8 +185,8 @@ testCheckPresent = do
res <- liftIO $ clientCheckPresent (mkClientEnv mgr burl) res <- liftIO $ clientCheckPresent (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3) (P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String))) (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[] []
Nothing Nothing
liftIO $ print res liftIO $ print res
@ -205,8 +240,8 @@ testRemove = do
res <- liftIO $ clientRemove (mkClientEnv mgr burl) res <- liftIO $ clientRemove (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3) (P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720547401--foo" :: String))) (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720547401--foo" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[] []
Nothing Nothing
liftIO $ print res liftIO $ print res
@ -221,8 +256,8 @@ testRemoveBefore = do
res <- liftIO $ clientRemoveBefore (mkClientEnv mgr burl) res <- liftIO $ clientRemoveBefore (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3) (P2P.ProtocolVersion 3)
(B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String))) (B64Key (fromJust $ deserializeKey ("WORM-s30-m1720617630--bar" :: String)))
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[] []
(Timestamp ts) (Timestamp ts)
Nothing Nothing
@ -233,8 +268,8 @@ testGetTimestamp = do
burl <- liftIO $ parseBaseUrl "http://localhost:8080/" burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
res <- liftIO $ clientGetTimestamp (mkClientEnv mgr burl) res <- liftIO $ clientGetTimestamp (mkClientEnv mgr burl)
(P2P.ProtocolVersion 3) (P2P.ProtocolVersion 3)
(B64UUID (toUUID ("cu" :: String)))
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String))) (B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
(B64UUID (toUUID ("cu" :: String)))
[] []
Nothing Nothing
liftIO $ print res liftIO $ print res

24
P2P/Http.hs
View file

@ -345,12 +345,12 @@ clientCheckPresent
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
-> B64Key -> B64Key
-> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe Auth -> Maybe Auth
-> IO Bool -> 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 withClientM (cli su key cu bypass auth) clientenv $ \case
Left err -> throwM err Left err -> throwM err
Right (CheckPresentResult res) -> return res Right (CheckPresentResult res) -> return res
@ -399,12 +399,12 @@ clientRemove
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
-> B64Key -> B64Key
-> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe Auth -> Maybe Auth
-> IO RemoveResultPlus -> IO RemoveResultPlus
clientRemove clientenv (ProtocolVersion ver) key cu su bypass auth = clientRemove clientenv (ProtocolVersion ver) key su cu bypass auth =
withClientM cli clientenv $ \case withClientM cli clientenv $ \case
Left err -> throwM err Left err -> throwM err
Right res -> return res Right res -> return res
@ -456,13 +456,13 @@ clientRemoveBefore
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
-> B64Key -> B64Key
-> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Timestamp -> Timestamp
-> Maybe Auth -> Maybe Auth
-> IO RemoveResultPlus -> 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 withClientM (cli su key cu bypass ts auth) clientenv $ \case
Left err -> throwM err Left err -> throwM err
Right res -> return res Right res -> return res
@ -505,12 +505,12 @@ serveGetTimestamp st su apiver cu bypass sec auth = do
clientGetTimestamp clientGetTimestamp
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
-> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe Auth -> Maybe Auth
-> IO GetTimestampResult -> 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 withClientM (cli su cu bypass auth) clientenv $ \case
Left err -> throwM err Left err -> throwM err
Right res -> return res Right res -> return res
@ -842,14 +842,14 @@ serveLockContent st su apiver (B64Key k) cu bypass sec auth = do
clientLockContent clientLockContent
:: ClientEnv :: ClientEnv
-> B64UUID ServerSide
-> ProtocolVersion -> ProtocolVersion
-> B64Key -> B64Key
-> B64UUID ServerSide
-> B64UUID ClientSide -> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe Auth -> Maybe Auth
-> IO LockResult -> 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 withClientM (cli k cu bypass auth) clientenv $ \case
Left err -> throwM err Left err -> throwM err
Right res -> return res Right res -> return res
@ -911,8 +911,8 @@ clientKeepLocked
:: ClientEnv :: ClientEnv
-> ProtocolVersion -> ProtocolVersion
-> LockID -> LockID
-> B64UUID ClientSide
-> B64UUID ServerSide -> B64UUID ServerSide
-> B64UUID ClientSide
-> [B64UUID Bypass] -> [B64UUID Bypass]
-> Maybe Auth -> Maybe Auth
-> (TMVar Bool -> IO ()) -> (TMVar Bool -> IO ())
@ -920,7 +920,7 @@ clientKeepLocked
-- repeated keep locked requests, eg to keep a connection alive. -- repeated keep locked requests, eg to keep a connection alive.
-- Once filled with False, the lock will be dropped. -- Once filled with False, the lock will be dropped.
-> IO () -> 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 keeplocked <- newEmptyTMVarIO
tid <- async $ a keeplocked tid <- async $ a keeplocked
let cli' = cli lckid cu bypass auth let cli' = cli lckid cu bypass auth