locking over http basically working

diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs
index d85c9e559816eb7d5130f227cd57a0a8b8a2887a..5e0e8a172c2d6d08528e39cbb5fb572c780b8129 100644 (file)
--- 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 2576c0d9b591d9c78a84eec10b6ebfa65ae87824..638a81ed53edd7cdef89a86afd6739df820d91c4 100644 (file)
--- 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