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

p2phttp is almost working for checkpresent

Browse source 
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
Download patch file Download diff file Expand all files Collapse all files

41
Command/P2PHttp.hs
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