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:
Joey Hess 2024-07-09 13:37:55 -04:00
parent a3dd8b4bcb
commit edf8a3df2d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 197 additions and 63 deletions

View file

@ -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