70 lines
1.9 KiB
Haskell
70 lines
1.9 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
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
|
|
"communicate in P2P protocol over http"
|
|
paramNothing (seek <$$> optParser)
|
|
|
|
data Options = Options
|
|
{ cmdParams :: CmdParams
|
|
, authEnvOption :: Bool
|
|
, authEnvHttpOption :: Bool
|
|
, readOnlyOption :: Bool
|
|
, appendOnlyOption :: Bool
|
|
, wideOpenOption :: Bool
|
|
}
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
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-s30-m1720547401--foo" :: String)))
|
|
(B64UUID (toUUID ("cu" :: String)))
|
|
(B64UUID (toUUID ("f11773f0-11e1-45b2-9805-06db16768efe" :: String)))
|
|
[]
|
|
liftIO $ print res
|