locking over http basically working
This commit is contained in:
Joey Hess
parent
e979e85bff
commit
7f4cff7ae9
2 changed files with 55 additions and 20 deletions
|
|
@ -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
|
||||
|
|
|
|||
24
P2P/Http.hs
24
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue