mirror of https://github.com/voidlizard/hbs2
270 lines
7.9 KiB
Haskell
270 lines
7.9 KiB
Haskell
{-# LANGUAGE StrictData #-}
|
|
|
|
module PeerMain.DialogCliCommand where
|
|
|
|
import Data.Generics.Labels
|
|
import Data.Generics.Product.Fields
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Base58
|
|
import HBS2.Clock
|
|
import HBS2.Data.Types.Refs (RefLogKey(..))
|
|
import HBS2.Defaults
|
|
import HBS2.Events
|
|
import HBS2.Hash
|
|
import HBS2.Merkle
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Net.IP.Addr
|
|
import HBS2.Net.Messaging
|
|
import HBS2.Net.Messaging.TCP
|
|
import HBS2.Net.Messaging.UDP
|
|
import HBS2.Net.PeerLocator
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Proto.Definition
|
|
import HBS2.Net.Proto.Dialog
|
|
import HBS2.Net.Proto.Peer
|
|
import HBS2.Net.Proto.PeerAnnounce
|
|
import HBS2.Net.Proto.PeerExchange
|
|
import HBS2.Net.Proto.PeerMeta
|
|
import HBS2.Net.Proto.RefLog
|
|
import HBS2.Net.Proto.Sessions
|
|
import HBS2.Net.Proto.Types
|
|
import HBS2.OrDie
|
|
import HBS2.Prelude
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Storage.Simple
|
|
import HBS2.System.Logger.Simple hiding (info)
|
|
import HBS2.System.Logger.Simple qualified as Log
|
|
|
|
import BlockDownload
|
|
import BlockHttpDownload
|
|
import Bootstrap
|
|
import Brains
|
|
import CheckMetrics
|
|
import DownloadQ
|
|
import HttpWorker
|
|
import PeerConfig
|
|
import PeerInfo
|
|
import PeerMeta
|
|
import PeerTypes
|
|
import ProxyMessaging
|
|
import RefLog (reflogWorker)
|
|
import RefLog qualified
|
|
import RPC
|
|
|
|
import Control.Monad
|
|
import Control.Monad.IO.Unlift
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans.Cont
|
|
import Control.Monad.Trans.Maybe
|
|
import Crypto.Saltine.Core.Box qualified as Encrypt
|
|
import Data.ByteString qualified as BS
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.Default
|
|
import Data.Function
|
|
import Data.Functor
|
|
import Data.List qualified as List
|
|
import Data.Map.Strict qualified as Map
|
|
import Data.Maybe
|
|
import Data.Monoid qualified as Monoid
|
|
import Data.Set qualified as Set
|
|
import Data.String.Conversions as X (cs)
|
|
import Data.Void (absurd, Void)
|
|
import Lens.Micro.Platform
|
|
import Network.Socket
|
|
import Options.Applicative
|
|
import Streaming as S
|
|
import Streaming.Prelude qualified as S
|
|
import System.Directory
|
|
import UnliftIO.Async
|
|
import UnliftIO.Concurrent
|
|
import UnliftIO.Exception as U
|
|
import UnliftIO.Resource
|
|
|
|
-- import System.FilePath.Posix
|
|
import System.IO
|
|
import System.Exit
|
|
|
|
|
|
pDialog :: Parser (IO ())
|
|
pDialog = hsubparser $ mempty
|
|
<> command "ping" (info pPing (progDesc "ping hbs2 node via dialog inteface") )
|
|
<> command "debug" (info pDebug (progDesc "debug call different dialog inteface routes") )
|
|
|
|
confOpt :: Parser FilePath
|
|
confOpt = strOption ( long "config" <> short 'c' <> help "config" )
|
|
|
|
data OptInitial (f :: * -> *) a b = OptInitial { unOptInitial :: f a }
|
|
deriving (Generic, Show)
|
|
|
|
data OptResolved (f :: * -> *) a b = OptResolved { unOptResolved :: b }
|
|
deriving (Generic, Show)
|
|
|
|
type DialOptInitial = DialOpt OptInitial
|
|
type DialOptResolved = DialOpt OptResolved
|
|
|
|
data DialOpt (f :: (* -> *) -> * -> * -> *) = DialOpt
|
|
{ dialOptConf :: f Maybe FilePath PeerConfig
|
|
, dialOptAddr :: f Maybe String (Peer L4Proto)
|
|
}
|
|
deriving (Generic)
|
|
|
|
deriving instance Show DialOptInitial
|
|
|
|
pDialCommon :: Parser DialOptInitial
|
|
pDialCommon = do
|
|
|
|
dialOptConf <- OptInitial <$> optional do
|
|
strOption ( long "config" <> short 'c' <> help "config" )
|
|
|
|
dialOptAddr <- OptInitial <$> optional do
|
|
strOption ( short 'r' <> long "dial" <> help "addr:port" )
|
|
|
|
pure DialOpt {..}
|
|
|
|
resolveDialOpt :: DialOptInitial -> IO DialOptResolved
|
|
resolveDialOpt dopt = do
|
|
config <- peerConfigRead (dopt ^. #dialOptConf . #unOptInitial)
|
|
|
|
let dialConf = cfgValue @PeerRpcKey config :: Maybe String
|
|
|
|
saddr <- (dopt ^. #dialOptAddr . #unOptInitial <|> dialConf)
|
|
`orDieM` "Dial endpoint not set"
|
|
|
|
as <- parseAddrUDP (cs saddr) <&> fmap (fromSockAddr @'UDP . addrAddress)
|
|
peer <- (headMay $ List.sortBy (compare `on` addrPriority) as)
|
|
`orDieM` "Can't parse Dial endpoint"
|
|
|
|
pure DialOpt
|
|
{ dialOptConf = OptResolved config
|
|
, dialOptAddr = OptResolved peer
|
|
}
|
|
|
|
pPing :: Parser (IO ())
|
|
pPing = do
|
|
dopt <- pDialCommon
|
|
pure $ withDial dopt \peer dclient ->
|
|
withClient dclient \cli -> do
|
|
liftIO . print =<< do
|
|
dQuery1 def cli peer (dpath "ping" [])
|
|
|
|
|
|
pDebug :: Parser (IO ())
|
|
pDebug = do
|
|
dopt <- pDialCommon
|
|
|
|
pure $ withDial dopt \peer dclient ->
|
|
withClient dclient \cli -> do
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "ping"
|
|
liftIO . print =<< do
|
|
dQuery' def cli peer (dpath "ping" []) \flow -> do
|
|
S.print flow
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "ping1"
|
|
liftIO . print =<< do
|
|
dQuery1 def cli peer (dpath "ping" [])
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "undefined-route"
|
|
liftIO . print =<< do
|
|
dQuery' def cli peer (dpath "undefined-rout" []) \flow -> do
|
|
S.print flow
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "debug/timeout"
|
|
liftIO . print =<< do
|
|
dQuery' (def & #requestParamsTimeout .~ 0.1)
|
|
cli peer (dpath "debug/timeout" []) \flow -> do
|
|
S.print flow
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "debug/no-response-header"
|
|
liftIO . print =<< do
|
|
dQuery' def cli peer (dpath "debug/no-response-header" []) \flow -> do
|
|
S.print flow
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "debug/wrong-header"
|
|
liftIO . print =<< do
|
|
dQuery' def cli peer (dpath "debug/wrong-header" []) \flow -> do
|
|
S.print flow
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "undefined-route-1"
|
|
(U.handleAny \e -> liftIO (print e)) do
|
|
liftIO . print =<< do
|
|
dQuery1 def cli peer (dpath "undefined-route-1" [])
|
|
|
|
threadDelay 100
|
|
liftIO $ putStrLn ""
|
|
liftIO $ putStrLn "spec"
|
|
liftIO . print =<< do
|
|
dQuery' def cli peer (dpath "spec" []) \flow -> do
|
|
S.print flow
|
|
|
|
|
|
evalContT' :: ContT r m Void -> m r
|
|
evalContT' = flip runContT absurd
|
|
|
|
withDial :: forall e i .
|
|
( e ~ L4Proto
|
|
)
|
|
=> DialOptInitial
|
|
-> ( Peer e
|
|
-> DClient (ResponseM e (RpcM (ResourceT IO))) (Peer e) i
|
|
-> (ResponseM e (RpcM (ResourceT IO))) ()
|
|
)
|
|
-> IO ()
|
|
withDial dopt' cmd = do
|
|
dopt <- resolveDialOpt dopt'
|
|
setLoggingOff @DEBUG
|
|
hSetBuffering stdout LineBuffering
|
|
|
|
runResourceT do
|
|
udp1 <- newMessagingUDP False Nothing `orDie` "Can't start Dial"
|
|
|
|
evalContT' do
|
|
|
|
dialProtoEnv :: DialogProtoEnv (ResponseM L4Proto (RpcM (ResourceT IO))) L4Proto
|
|
<- newDialogProtoEnv
|
|
|
|
amessaging <- ContT $ withAsync do
|
|
runMessagingUDP udp1
|
|
|
|
aprotos <- ContT $ withAsync $ runRPC udp1 do
|
|
|
|
runProto @e
|
|
[ makeResponse do
|
|
dialRespProto (DialRespProtoAdapter dialProtoEnv)
|
|
]
|
|
|
|
aclient <- ContT $ withAsync $
|
|
runRPC udp1 do
|
|
let p = dopt ^. #dialOptAddr . #unOptResolved
|
|
runResponseM p $
|
|
cmd p
|
|
DClient
|
|
{ clientCallerEnv = dialogProtoEnvCallerEnv dialProtoEnv
|
|
, clientSendProtoRequest = \peer frames -> do
|
|
request peer (DialReq @e frames)
|
|
|
|
-- , clientGetKnownPeers :: m [(p, i)]
|
|
, clientGetKnownPeers = pure []
|
|
}
|
|
|
|
ContT \_ -> waitAnyCancel [amessaging, aprotos, aclient]
|
|
|
|
pure ()
|
|
|