p2phttp is almost working for checkpresent
The server is fully running annex actions, only the P2PConnection is wrong, currently using stdio.
This commit is contained in:
parent
a3dd8b4bcb
commit
edf8a3df2d
4 changed files with 197 additions and 63 deletions
|
@ -13,8 +13,13 @@ module Command.P2PHttp where
|
|||
|
||||
import Command
|
||||
import P2P.Http
|
||||
import qualified P2P.Protocol as P2P
|
||||
import Annex.Url
|
||||
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import Servant.Client.Streaming
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
|
||||
cmd :: Command
|
||||
cmd = command "p2phttp" SectionPlumbing
|
||||
|
@ -22,7 +27,35 @@ cmd = command "p2phttp" SectionPlumbing
|
|||
paramNothing (withParams seek)
|
||||
|
||||
seek :: CmdParams -> CommandSeek
|
||||
seek ["server"] = liftIO $ do
|
||||
st <- mkP2PHttpServerState
|
||||
Warp.run 8080 (p2pHttpApp st)
|
||||
seek ["client"] = liftIO testClientLock
|
||||
seek ["server"] = startConcurrency commandStages $
|
||||
withLocalP2PConnections $ \acquireconn -> liftIO $ do
|
||||
st <- mkP2PHttpServerState acquireconn
|
||||
Warp.run 8080 (p2pHttpApp st)
|
||||
seek ["client"] = testCheckPresent
|
||||
|
||||
testKeepLocked = do
|
||||
mgr <- httpManager <$> getUrlOptions
|
||||
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
|
||||
keeplocked <- liftIO newEmptyTMVarIO
|
||||
_ <- liftIO $ forkIO $ do
|
||||
print "running, press enter to drop lock"
|
||||
_ <- getLine
|
||||
atomically $ writeTMVar keeplocked False
|
||||
liftIO $ clientKeepLocked (mkClientEnv mgr burl)
|
||||
(P2P.ProtocolVersion 3)
|
||||
(B64UUID (toUUID ("lck" :: String)))
|
||||
(B64UUID (toUUID ("cu" :: String)))
|
||||
(B64UUID (toUUID ("su" :: String)))
|
||||
[]
|
||||
keeplocked
|
||||
|
||||
testCheckPresent = do
|
||||
mgr <- httpManager <$> getUrlOptions
|
||||
burl <- liftIO $ parseBaseUrl "http://localhost:8080/"
|
||||
res <- liftIO $ clientCheckPresent (mkClientEnv mgr burl)
|
||||
(P2P.ProtocolVersion 3)
|
||||
(B64Key (fromJust $ deserializeKey ("WORM--foo" :: String)))
|
||||
(B64UUID (toUUID ("cu" :: String)))
|
||||
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
|
||||
[]
|
||||
liftIO $ print res
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue