mirror of https://github.com/voidlizard/hbs2
tests fixed
This commit is contained in:
Dmitry Zuikov
parent
ff75e14cb3
commit
ceeb498505
|
|
@ -127,10 +127,6 @@ library
|
||||||
, HBS2.System.Logger.Simple.ANSI
|
, HBS2.System.Logger.Simple.ANSI
|
||||||
, HBS2.System.Logger.Simple.Class
|
, HBS2.System.Logger.Simple.Class
|
||||||
, HBS2.System.Dir
|
, HBS2.System.Dir
|
||||||
, HBS2.Net.Dialog.Core
|
|
||||||
, HBS2.Net.Dialog.Client
|
|
||||||
, HBS2.Net.Dialog.Helpers.List
|
|
||||||
, HBS2.Net.Dialog.Helpers.Streaming
|
|
||||||
, HBS2.Misc.PrettyStuff
|
, HBS2.Misc.PrettyStuff
|
||||||
, HBS2.Version
|
, HBS2.Version
|
||||||
|
|
||||||
|
|
@ -218,7 +214,6 @@ test-suite test
|
||||||
-- , TestUniqProtoId
|
-- , TestUniqProtoId
|
||||||
, FakeMessaging
|
, FakeMessaging
|
||||||
, HasProtocol
|
, HasProtocol
|
||||||
, DialogSpec
|
|
||||||
, TestScheduled
|
, TestScheduled
|
||||||
, TestDerivedKey
|
, TestDerivedKey
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,194 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedLabels #-}
|
|
||||||
{-# LANGUAGE StrictData #-}
|
|
||||||
{-# LANGUAGE ImpredicativeTypes #-}
|
|
||||||
module HBS2.Net.Dialog.Client where
|
|
||||||
|
|
||||||
-- import System.Clock
|
|
||||||
-- import System.Timeout
|
|
||||||
import Codec.Serialise
|
|
||||||
import Control.Arrow
|
|
||||||
import Control.Exception qualified as Exception
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Cont
|
|
||||||
import Control.Monad.Error.Class
|
|
||||||
import Control.Monad.Except (ExceptT(..), runExcept, runExceptT)
|
|
||||||
import Control.Monad.IO.Unlift
|
|
||||||
import Control.Monad.State.Class as State
|
|
||||||
import Control.Monad.State.Strict (evalState, evalStateT)
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.ByteString qualified as BS
|
|
||||||
import Data.ByteString.Builder
|
|
||||||
import Data.ByteString.Lazy qualified as BSL
|
|
||||||
import Data.Default
|
|
||||||
import Data.Generics.Labels
|
|
||||||
import Data.Generics.Product.Fields
|
|
||||||
import Data.List qualified as List
|
|
||||||
import Data.Map.Strict as Map
|
|
||||||
import Data.String.Conversions (cs, ConvertibleStrings)
|
|
||||||
import Data.Time
|
|
||||||
import GHC.Generics(Generic)
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
import Streaming as S
|
|
||||||
import Streaming.Prelude qualified as S
|
|
||||||
import UnliftIO.Exception
|
|
||||||
import UnliftIO.STM
|
|
||||||
import UnliftIO.Timeout
|
|
||||||
|
|
||||||
import HBS2.Net.Dialog.Core
|
|
||||||
import HBS2.Net.Dialog.Helpers.Streaming
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
dQuery_ :: MonadUnliftIO m
|
|
||||||
=> RequestParams
|
|
||||||
-> DialogClient m peer
|
|
||||||
-> peer
|
|
||||||
-> Frames
|
|
||||||
-> m ()
|
|
||||||
dQuery_ _par dcli peer rq =
|
|
||||||
withClientQuery dcli & \dialf ->
|
|
||||||
dialf peer rq' \_flow -> pure ()
|
|
||||||
where
|
|
||||||
rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>)
|
|
||||||
|
|
||||||
--
|
|
||||||
dQuery1 :: (MonadUnliftIO m)
|
|
||||||
=> RequestParams
|
|
||||||
-> DialogClient m peer
|
|
||||||
-> peer
|
|
||||||
-> Frames
|
|
||||||
-> m Frames
|
|
||||||
|
|
||||||
dQuery1 par dcli peer rq = dQuery' par dcli peer rq \flow ->
|
|
||||||
either (throwIO . DQuery1Error) (pure . view _2) =<< headEither flow
|
|
||||||
|
|
||||||
data DQuery1Error = DQuery1Error RequestResult
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
instance Exception DQuery1Error
|
|
||||||
|
|
||||||
--
|
|
||||||
dQuery' :: MonadUnliftIO m
|
|
||||||
=> RequestParams
|
|
||||||
-> DialogClient m peer
|
|
||||||
-> peer
|
|
||||||
-> Frames
|
|
||||||
-> (Stream (Of (ResponseHeader, Frames)) m RequestResult -> m r)
|
|
||||||
-> m r
|
|
||||||
|
|
||||||
dQuery' par dcli peer rq go =
|
|
||||||
withClientQuery dcli & \dialf -> do
|
|
||||||
dialf peer rq' \flow -> go $
|
|
||||||
flow
|
|
||||||
& withEffectsMay RequestTimeout (timeout' (requestParamsTimeout par))
|
|
||||||
& S.map decodeHeader
|
|
||||||
& stopAfterLeftMay (either
|
|
||||||
(\(merr, xs) -> Left (Nothing, RequestErrorBadResponse merr xs))
|
|
||||||
processResponseHeader
|
|
||||||
)
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
processResponseHeader :: (ResponseHeader, Frames) ->
|
|
||||||
Either
|
|
||||||
(Maybe (ResponseHeader, Frames), RequestResult)
|
|
||||||
(ResponseHeader, Frames)
|
|
||||||
|
|
||||||
processResponseHeader rhxs@(rh, xs) = case ((responseStatusCode . respStatus) rh) of
|
|
||||||
Success200 -> Left (Just rhxs, RequestDone)
|
|
||||||
SuccessNoContent204 -> Left (Just rhxs, RequestDone)
|
|
||||||
SuccessMore -> Right rhxs
|
|
||||||
BadRequest400 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
|
|
||||||
Forbidden403 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
|
|
||||||
NotFound404 -> Left (Nothing, (RequestFailure (respStatus rh) xs))
|
|
||||||
|
|
||||||
rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>)
|
|
||||||
|
|
||||||
timeout' :: MonadUnliftIO m => NominalDiffTime -> m a -> m (Maybe a)
|
|
||||||
timeout' = timeout . round . (* 10^6) . nominalDiffTimeToSeconds
|
|
||||||
|
|
||||||
--
|
|
||||||
decodeHeader :: Frames -> Either (BadResponse, Frames) (ResponseHeader, Frames)
|
|
||||||
decodeHeader = evalState do
|
|
||||||
ex <- runExceptT cutFrameDecode'
|
|
||||||
xs <- State.get
|
|
||||||
pure $ ex
|
|
||||||
& left ((, xs) . maybe ResponseInsufficientFrames ResponseParseError)
|
|
||||||
& right (, xs)
|
|
||||||
|
|
||||||
data RequestParams = RequestParams
|
|
||||||
{ requestParamsTimeout :: NominalDiffTime
|
|
||||||
}
|
|
||||||
deriving (Generic)
|
|
||||||
|
|
||||||
instance Default RequestParams where
|
|
||||||
def = RequestParams
|
|
||||||
{ requestParamsTimeout = 5
|
|
||||||
}
|
|
||||||
|
|
||||||
data DialogClient m p = DialogClient
|
|
||||||
{ withClientQuery :: ClientQuery m p
|
|
||||||
}
|
|
||||||
|
|
||||||
type ClientQuery m p = forall r .
|
|
||||||
p
|
|
||||||
-> Frames
|
|
||||||
-> (Stream (Of Frames) m RequestResult -> m r)
|
|
||||||
-> m r
|
|
||||||
|
|
||||||
withClient :: forall m p i r . MonadUnliftIO m
|
|
||||||
=> DClient m p i -> (DialogClient m p -> m r) -> m r
|
|
||||||
withClient dclient go = do
|
|
||||||
callerID <- newCallerID
|
|
||||||
|
|
||||||
requestIDtvar <- newTVarIO 1
|
|
||||||
|
|
||||||
-- У обработчика получателя - своё окружение, в которое мы добавляем
|
|
||||||
-- обработчики ответов на запросы по requestID
|
|
||||||
requestResponseEnv <- newRequestResponseEnv
|
|
||||||
|
|
||||||
let withClientQuery' :: ClientQuery m p
|
|
||||||
withClientQuery' = \pid xs handleStream -> do
|
|
||||||
requestID <- atomically $ stateTVar requestIDtvar (id &&& succ)
|
|
||||||
|
|
||||||
ch <- newTQueueIO
|
|
||||||
let useResponse = RequestResponseHandler @m do
|
|
||||||
atomically . writeTQueue ch
|
|
||||||
let
|
|
||||||
-- flow :: Stream (Of Frames) m RequestResult
|
|
||||||
flow = S.repeatM (atomically (readTQueue ch))
|
|
||||||
|
|
||||||
bracket_
|
|
||||||
(setupRepHandler requestResponseEnv requestID useResponse)
|
|
||||||
(clearRepHandler requestResponseEnv requestID)
|
|
||||||
(do
|
|
||||||
|
|
||||||
clientSendProtoRequest dclient pid do
|
|
||||||
xs & addEnvelope
|
|
||||||
[ (BSL.toStrict . serialise) callerID
|
|
||||||
, (BSL.toStrict . serialise) requestID
|
|
||||||
]
|
|
||||||
|
|
||||||
handleStream flow
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Установить в окружении обработчик получателя с callerID
|
|
||||||
let callerHandler = CallerHandler $ unFrames >>> \case
|
|
||||||
|
|
||||||
requestIDRaw:xs -> do
|
|
||||||
case deserialiseOrFail (BSL.fromStrict requestIDRaw) of
|
|
||||||
Left _ ->
|
|
||||||
-- Если не нашли, ничего не предпринимать
|
|
||||||
-- На этот вопрос уже не ждут ответа
|
|
||||||
pure ()
|
|
||||||
Right requestID -> do
|
|
||||||
mh <- findRepHandler requestResponseEnv requestID
|
|
||||||
forM_ mh \(RequestResponseHandler h) -> h (Frames xs)
|
|
||||||
|
|
||||||
_ -> pure ()
|
|
||||||
|
|
||||||
bracket_
|
|
||||||
(setupCallerEnv (clientCallerEnv dclient) callerID callerHandler)
|
|
||||||
(clearCallerEnv (clientCallerEnv dclient) callerID)
|
|
||||||
(go (DialogClient {withClientQuery = withClientQuery'}))
|
|
||||||
|
|
||||||
|
|
@ -1,831 +0,0 @@
|
||||||
{-# Language AllowAmbiguousTypes #-}
|
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE InstanceSigs #-}
|
|
||||||
{-# LANGUAGE PolyKinds #-}
|
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
|
||||||
{-# LANGUAGE StrictData #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
-- {-# LANGUAGE ConstraintKinds #-}
|
|
||||||
-- {-# LANGUAGE OverloadedLists #-}
|
|
||||||
|
|
||||||
-- {-# LANGUAGE CPP #-}
|
|
||||||
-- {-# LANGUAGE DataKinds #-}
|
|
||||||
-- {-# LANGUAGE FlexibleContexts #-}
|
|
||||||
-- {-# LANGUAGE FlexibleInstances #-}
|
|
||||||
-- {-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
-- {-# LANGUAGE OverloadedStrings #-}
|
|
||||||
-- {-# LANGUAGE RankNTypes #-}
|
|
||||||
-- {-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
-- {-# LANGUAGE TupleSections #-}
|
|
||||||
-- {-# LANGUAGE TypeApplications #-}
|
|
||||||
-- {-# LANGUAGE TypeFamilies #-}
|
|
||||||
|
|
||||||
|
|
||||||
module HBS2.Net.Dialog.Core where
|
|
||||||
|
|
||||||
import Codec.Serialise
|
|
||||||
import Control.Arrow
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Error.Class
|
|
||||||
import Control.Monad.Except (Except, ExceptT(..), runExcept, runExceptT)
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.State.Class as State
|
|
||||||
import Control.Monad.State.Strict as StateStrict (evalState, evalStateT, runStateT, StateT(..))
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
import Data.Binary.Get as Get
|
|
||||||
import Data.Binary.Put as Put
|
|
||||||
import Data.Bits
|
|
||||||
import Data.Bool
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.ByteString qualified as BS
|
|
||||||
import Data.ByteString.Base16 qualified as B16
|
|
||||||
import Data.ByteString.Char8 qualified as BS8
|
|
||||||
import Data.ByteString.Lazy qualified as BSL
|
|
||||||
import Data.Constraint (Dict(..))
|
|
||||||
import Data.Foldable as F
|
|
||||||
import Data.Function
|
|
||||||
import Data.Functor
|
|
||||||
import Data.Generics.Labels ()
|
|
||||||
import Data.Generics.Product.Fields ()
|
|
||||||
import Data.Generics.Sum.Constructors
|
|
||||||
import Data.Kind
|
|
||||||
import Data.List qualified as List
|
|
||||||
import Data.List.NonEmpty qualified as NE
|
|
||||||
import Data.Map.Strict as Map
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Proxy
|
|
||||||
import Data.String.Conversions as X (cs)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Typeable
|
|
||||||
import Data.Word
|
|
||||||
import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..))
|
|
||||||
import GHC.Generics qualified as Generics
|
|
||||||
import GHC.TypeLits
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
import Streaming
|
|
||||||
import System.Random.MWC
|
|
||||||
import UnliftIO.STM
|
|
||||||
|
|
||||||
import HBS2.Net.Dialog.Helpers.List
|
|
||||||
|
|
||||||
type Frames = Frames' ByteString
|
|
||||||
newtype Frames' a = Frames { unFrames :: [a] }
|
|
||||||
deriving stock (Generic,Eq)
|
|
||||||
deriving newtype (Functor, Foldable, Semigroup, Monoid
|
|
||||||
-- , IsList
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
instance Show Frames where
|
|
||||||
show (Frames xs) = "Frames " <> show (BS.length <$> xs)
|
|
||||||
-- <> " " <> show (fmap B16.encode xs)
|
|
||||||
<> " " <> (show . fmap (limitSize 42)) xs
|
|
||||||
|
|
||||||
where
|
|
||||||
limitSize n as = bool as (BS.take (n-3) as <> "...") (BS.length as > n)
|
|
||||||
|
|
||||||
framesBodyPart :: Traversal' Frames [ByteString]
|
|
||||||
framesBodyPart = #unFrames . tailAfterP (== "")
|
|
||||||
|
|
||||||
tailAfterP :: forall a . (a -> Bool) -> Traversal' [a] [a]
|
|
||||||
tailAfterP p focus = fix \go -> \case
|
|
||||||
x:xs -> (x :) <$> bool go focus (p x) xs
|
|
||||||
xs -> pure xs
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
encodeFrames :: Frames -> ByteString
|
|
||||||
-- encodeFrames :: Foldable t => t ByteString -> ByteString
|
|
||||||
encodeFrames = F.toList >>> BSL.toStrict . runPut . \case
|
|
||||||
|
|
||||||
[] -> pure ()
|
|
||||||
|
|
||||||
xss -> flip fix xss \go -> \case
|
|
||||||
[] -> pure ()
|
|
||||||
bs:xs -> do
|
|
||||||
let (flip shiftR 1 -> n1, ns) = unfoldSizeBytes @Word64 . flip shiftL 1 . fromIntegral . BS.length $ bs
|
|
||||||
|
|
||||||
putWord8 $ n1
|
|
||||||
& bool (sbit 7) id (List.null xs)
|
|
||||||
& bool (sbit 6) id (List.null ns)
|
|
||||||
|
|
||||||
forM_ (markMore ns) \(n, isMoreBytesInSize) -> do
|
|
||||||
putWord8 $ n & bool (zbit 7) (sbit 7) isMoreBytesInSize
|
|
||||||
|
|
||||||
putByteString bs
|
|
||||||
|
|
||||||
go xs
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
markMore as = zip as ((True <$ List.drop 1 as) <> [False])
|
|
||||||
|
|
||||||
unfoldSizeBytes :: (Bits n, Integral n) => n -> (Word8, [Word8])
|
|
||||||
unfoldSizeBytes = (\(a NE.:| as) -> (a, as)) . NE.unfoldr \w ->
|
|
||||||
( (flip shiftR 1 . flip shiftL 1 . fromIntegral) w
|
|
||||||
, let w' = shiftR w 7
|
|
||||||
in bool Nothing (Just w') (w' > 0)
|
|
||||||
)
|
|
||||||
|
|
||||||
decodeFrames :: MonadError String m => ByteString -> m Frames
|
|
||||||
decodeFrames = \case
|
|
||||||
"" -> pure mempty
|
|
||||||
|
|
||||||
bs' -> (bs' &) $ BSL.fromStrict >>> either (throwError . view _3) (pure . Frames . view _3)
|
|
||||||
<$> runGetOrFail do
|
|
||||||
|
|
||||||
fix \go -> do
|
|
||||||
|
|
||||||
j <- getWord8
|
|
||||||
|
|
||||||
bsize <-
|
|
||||||
flip fix (6, j) \fu (b, j') -> do
|
|
||||||
let n = (fromIntegral . clearLeftBits (8-b)) j'
|
|
||||||
if tbit b j'
|
|
||||||
then (n +) . flip shiftL b <$> (fu . (7, ) =<< getWord8)
|
|
||||||
else pure n
|
|
||||||
|
|
||||||
bs <- getByteString bsize
|
|
||||||
|
|
||||||
let moreFrames = tbit 7 j
|
|
||||||
|
|
||||||
if moreFrames
|
|
||||||
then (bs :) <$> go
|
|
||||||
else pure [bs]
|
|
||||||
|
|
||||||
where
|
|
||||||
clearLeftBits n = flip shiftR n . flip shiftL n
|
|
||||||
tbit = flip testBit
|
|
||||||
|
|
||||||
|
|
||||||
devDialogCore :: IO ()
|
|
||||||
devDialogCore = do
|
|
||||||
display (Frames [])
|
|
||||||
display (Frames [""])
|
|
||||||
display (Frames [BS.replicate 32 0x55])
|
|
||||||
display (Frames [BS.replicate 32 0x55, ""])
|
|
||||||
display (Frames [BS.replicate 32 0x55, "\3\3"])
|
|
||||||
display (Frames [BS.replicate 33 0x55, "\3\3"])
|
|
||||||
display (Frames [BS.replicate 63 0x55])
|
|
||||||
display (Frames [BS.replicate 64 0x55])
|
|
||||||
-- display (Frames [BS.replicate 65 0x55])
|
|
||||||
display (Frames ["\8\8\8","\4\4\4"])
|
|
||||||
display (Frames ["","\1"])
|
|
||||||
where
|
|
||||||
display a = do
|
|
||||||
putStrLn . cs . show . B16.encode . encodeFrames $ a
|
|
||||||
putStrLn ""
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
sbit :: (Bits n) => Int -> n -> n
|
|
||||||
sbit = flip setBit
|
|
||||||
|
|
||||||
zbit :: (Bits n) => Int -> n -> n
|
|
||||||
zbit = flip clearBit
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
decodeFramesFail :: (MonadFail m) => ByteString -> m Frames
|
|
||||||
decodeFramesFail = errorToFail . decodeFrames
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
errorToFailT :: (MonadFail m) => ExceptT String m a -> m a
|
|
||||||
errorToFailT = either fail pure <=< runExceptT
|
|
||||||
|
|
||||||
errorToFail :: MonadFail m => Except String a -> m a
|
|
||||||
errorToFail = either fail pure . runExcept
|
|
||||||
|
|
||||||
errorShowToFail :: (MonadFail m, Show s) => Except s a -> m a
|
|
||||||
errorShowToFail = either (fail . show) pure . runExcept
|
|
||||||
|
|
||||||
--
|
|
||||||
|
|
||||||
data CallerID = CallerID
|
|
||||||
{ unCallerIDV :: Word8
|
|
||||||
, unCallerID :: Word32
|
|
||||||
}
|
|
||||||
deriving stock (Generic, Eq, Ord)
|
|
||||||
|
|
||||||
instance Serialise CallerID
|
|
||||||
|
|
||||||
newCallerID :: forall m. MonadIO m => m CallerID
|
|
||||||
newCallerID = liftIO $ withSystemRandomST \g ->
|
|
||||||
CallerID <$> uniformM g <*> uniformM g
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
newtype CallerHandler m = CallerHandler
|
|
||||||
{ unCallerHandler :: Frames -> m ()
|
|
||||||
}
|
|
||||||
|
|
||||||
newtype CallerEnv m = CallerEnv
|
|
||||||
{ unCallerEnv :: TVar (Map CallerID (CallerHandler m)) }
|
|
||||||
|
|
||||||
newCallerEnv :: MonadIO m => m (CallerEnv m')
|
|
||||||
newCallerEnv = CallerEnv <$> newTVarIO mempty
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
newtype RequestResponseHandler m = RequestResponseHandler
|
|
||||||
{ unRequestResponseHandler :: Frames -> m ()
|
|
||||||
}
|
|
||||||
|
|
||||||
newtype RequestResponseEnv m = RequestResponseEnv
|
|
||||||
{ unRequestResponseEnv :: TVar (Map RequestID (RequestResponseHandler m))
|
|
||||||
}
|
|
||||||
|
|
||||||
newRequestResponseEnv :: MonadIO m => m (RequestResponseEnv m')
|
|
||||||
newRequestResponseEnv =
|
|
||||||
RequestResponseEnv <$> newTVarIO mempty
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
data DClient m p i = DClient
|
|
||||||
{ clientCallerEnv :: CallerEnv m
|
|
||||||
, clientSendProtoRequest :: p -> Frames -> m ()
|
|
||||||
, clientGetKnownPeers :: m [(p, i)]
|
|
||||||
}
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
newtype RequestID = RequestID { unRequestID :: Word32 }
|
|
||||||
deriving stock (Generic, Eq, Ord)
|
|
||||||
deriving newtype (Serialise, Num, Enum)
|
|
||||||
-- deriving via TODO_GenericVLQ Put Get
|
|
||||||
|
|
||||||
data RequestResult
|
|
||||||
= RequestDone
|
|
||||||
-- | RequestSuccessIncomplete
|
|
||||||
| RequestTimeout
|
|
||||||
| RequestFailure ResponseStatus Frames
|
|
||||||
| RequestErrorBadResponse BadResponse Frames
|
|
||||||
deriving stock (Generic, Eq, Show)
|
|
||||||
|
|
||||||
data BadResponse
|
|
||||||
= ResponseErrorNoResponseHeader
|
|
||||||
| ResponseInsufficientFrames
|
|
||||||
| ResponseParseError DeserialiseFailure
|
|
||||||
deriving stock (Generic, Eq, Show)
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
setupCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> CallerHandler m' -> m ()
|
|
||||||
setupCallerEnv env callerID repHandleEnv =
|
|
||||||
(atomically . modifyTVar' (unCallerEnv env))
|
|
||||||
(at callerID ?~ repHandleEnv)
|
|
||||||
|
|
||||||
clearCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> m ()
|
|
||||||
clearCallerEnv env callerID =
|
|
||||||
(atomically . modifyTVar' (unCallerEnv env))
|
|
||||||
(at callerID .~ Nothing)
|
|
||||||
|
|
||||||
findCallerHandler :: MonadIO m => CallerEnv m' -> CallerID -> m (Maybe (CallerHandler m'))
|
|
||||||
findCallerHandler CallerEnv{..} callerID =
|
|
||||||
readTVarIO unCallerEnv <&> preview (ix callerID)
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m ()
|
|
||||||
setupRepHandler RequestResponseEnv{..} requestID useResponse =
|
|
||||||
(atomically . modifyTVar' unRequestResponseEnv)
|
|
||||||
(at requestID ?~ useResponse)
|
|
||||||
|
|
||||||
clearRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m ()
|
|
||||||
clearRepHandler RequestResponseEnv{..} requestID =
|
|
||||||
(atomically . modifyTVar' unRequestResponseEnv)
|
|
||||||
(at requestID .~ Nothing)
|
|
||||||
|
|
||||||
findRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m (Maybe (RequestResponseHandler m'))
|
|
||||||
findRepHandler RequestResponseEnv{..} requestID =
|
|
||||||
readTVarIO unRequestResponseEnv <&> preview (ix requestID)
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
data DialogRequestEnv m p pd = DialogRequestEnv
|
|
||||||
{ dreqEnvPeer :: p
|
|
||||||
, dreqEnvGetPeerData :: m pd
|
|
||||||
}
|
|
||||||
|
|
||||||
-- data DialogRequestError
|
|
||||||
-- = DialogRequestFailure String
|
|
||||||
-- deriving stock (Show)
|
|
||||||
-- instance Exception DialogRequestError
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
-- type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
|
|
||||||
type DApp m = Frames -> (Frames -> m ()) -> m ()
|
|
||||||
|
|
||||||
mkDApp ::
|
|
||||||
forall spec ctx m io.
|
|
||||||
( Monad m
|
|
||||||
, Monad io
|
|
||||||
, HasHandler m (NamedSpec spec) ctx
|
|
||||||
, HasHandler io (NamedSpec spec) ctx
|
|
||||||
)
|
|
||||||
=> Proxy (NamedSpec spec)
|
|
||||||
-> Ctx ctx
|
|
||||||
-> (forall x. m x -> DialHandlerT io x)
|
|
||||||
-> spec (ModeServerT m)
|
|
||||||
-> DApp io
|
|
||||||
mkDApp p ctx ntToDialHandlerTn hd = routeDialogRequest rr
|
|
||||||
where
|
|
||||||
rr :: DialogRequestRouter io
|
|
||||||
rr = route p ctx
|
|
||||||
$ hoistDialogWithContext p (Proxy @ctx) ntToDialHandlerTn
|
|
||||||
hd
|
|
||||||
|
|
||||||
type DialogReplyHandler m = (Frames -> m ()) -> m ()
|
|
||||||
|
|
||||||
type DialogRequestRouter (m :: Type -> Type) =
|
|
||||||
DialogRequestRoutes (DialogReplyHandler m)
|
|
||||||
|
|
||||||
data DialogRequestRoutes (h :: Type)
|
|
||||||
= DialogRequestPaths (Map ByteString (DialogRequestRoutes h))
|
|
||||||
| DialogRequestPreparse (Frames -> Either Text (DialogRequestRoutes h, Frames))
|
|
||||||
| DialogRequestEndpoint h
|
|
||||||
deriving (Generic, Functor)
|
|
||||||
|
|
||||||
instance Semigroup (DialogRequestRoutes h) where
|
|
||||||
(<>) a b = case (a, b) of
|
|
||||||
(DialogRequestPaths p1, DialogRequestPaths p2) ->
|
|
||||||
DialogRequestPaths (p1 <> p2)
|
|
||||||
_ -> b
|
|
||||||
|
|
||||||
-- instance Monoid (DialogRequestRoutes h) where
|
|
||||||
-- mempty = DialogRequestPaths mempty
|
|
||||||
|
|
||||||
dialogRequestRoutes
|
|
||||||
:: ListBuilder
|
|
||||||
([ByteString], Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
|
|
||||||
-> DialogRequestRouter m
|
|
||||||
dialogRequestRoutes = List.foldl1' (<>)
|
|
||||||
. fmap toPaths
|
|
||||||
. over (traverse . _2) (DialogRequestPreparse . (fmap . fmap) (over _1 DialogRequestEndpoint))
|
|
||||||
. buildList
|
|
||||||
where
|
|
||||||
toPaths :: ([ByteString], DialogRequestRoutes ((Frames -> m ()) -> m ()))
|
|
||||||
-> DialogRequestRoutes (DialogReplyHandler m)
|
|
||||||
toPaths = fix \go (ps, rr) -> case ps of
|
|
||||||
[] -> rr
|
|
||||||
[p] -> DialogRequestPaths (Map.singleton p rr)
|
|
||||||
p:px' -> DialogRequestPaths (Map.singleton p (go (px', rr)))
|
|
||||||
|
|
||||||
hand :: Monad m => a -> b -> ListBuilderT m (a, b)
|
|
||||||
hand = curry li
|
|
||||||
|
|
||||||
handconv :: (Monad m, Monad m', Serialise req, Serialise resp)
|
|
||||||
=> a
|
|
||||||
-> Text
|
|
||||||
-> (req -> ExceptT ResponseStatus m resp)
|
|
||||||
-> ListBuilderT m' (a, Frames -> Either Text ((Frames -> m ()) -> m (), Frames))
|
|
||||||
handconv path msg h =
|
|
||||||
hand path $ processReply msg h
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
processReply :: forall m m' req resp .
|
|
||||||
( Monad m
|
|
||||||
, Serialise req
|
|
||||||
, Serialise resp
|
|
||||||
, m' ~ ExceptT ResponseStatus m
|
|
||||||
)
|
|
||||||
=> Text
|
|
||||||
-> (req -> m' resp)
|
|
||||||
-> Frames
|
|
||||||
-> Either Text ((Frames -> m ()) -> m (), Frames)
|
|
||||||
processReply msg h = runExcept . runStateT do
|
|
||||||
flip runReply . h <$> cutFrameDecode msg
|
|
||||||
|
|
||||||
runReply ::
|
|
||||||
( Monad m
|
|
||||||
, Serialise a
|
|
||||||
)
|
|
||||||
=> (Frames -> m r)
|
|
||||||
-> ExceptT ResponseStatus m a
|
|
||||||
-> m r
|
|
||||||
runReply reply =
|
|
||||||
either
|
|
||||||
(\e -> reply (Frames [serialiseS (ResponseHeader e 0)]))
|
|
||||||
(\a -> reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
|
|
||||||
, serialiseS a
|
|
||||||
])
|
|
||||||
)
|
|
||||||
<=< runExceptT
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
dpath :: Text -> [ByteString] -> Frames
|
|
||||||
dpath path = Frames . (cs path :)
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
addEnvelope :: Monoid a => [a] -> Frames' a -> Frames' a
|
|
||||||
addEnvelope en = over #unFrames ((en <> [mempty]) <>)
|
|
||||||
|
|
||||||
splitEnvelope :: (Monoid a, Eq a) => Frames' a -> ([a], Frames' a)
|
|
||||||
splitEnvelope = fmap (Frames . List.drop 1) . List.break (== mempty) . unFrames
|
|
||||||
|
|
||||||
data ResponseHeader = ResponseHeader
|
|
||||||
{ respStatus :: ResponseStatus
|
|
||||||
, respSeqNumber :: Int
|
|
||||||
}
|
|
||||||
deriving (Generic, Show, Eq)
|
|
||||||
|
|
||||||
instance Serialise ResponseHeader
|
|
||||||
|
|
||||||
data ResponseStatus = ResponseStatus
|
|
||||||
{ responseStatusCode :: ResponseStatusCode
|
|
||||||
, responseStatusMessage :: Text
|
|
||||||
}
|
|
||||||
deriving (Generic, Show, Eq)
|
|
||||||
|
|
||||||
instance Serialise ResponseStatus
|
|
||||||
|
|
||||||
data ResponseStatusCode
|
|
||||||
= Success200
|
|
||||||
| SuccessNoContent204
|
|
||||||
| SuccessMore
|
|
||||||
| BadRequest400
|
|
||||||
| Forbidden403
|
|
||||||
| NotFound404
|
|
||||||
deriving (Generic, Show, Eq)
|
|
||||||
|
|
||||||
instance Serialise ResponseStatusCode
|
|
||||||
|
|
||||||
routerSignature :: Word8
|
|
||||||
routerSignature = 1
|
|
||||||
|
|
||||||
routeDialogRequest :: forall m .
|
|
||||||
Monad m
|
|
||||||
=> DialogRequestRouter m
|
|
||||||
-> Frames
|
|
||||||
-> (Frames -> m ())
|
|
||||||
-> m ()
|
|
||||||
routeDialogRequest router frames rawReplyToPeer = do
|
|
||||||
-- error $ show router
|
|
||||||
erun <- pure $ runExcept $ flip evalStateT req do
|
|
||||||
|
|
||||||
signature <- cutFrameDecode
|
|
||||||
(ResponseStatus BadRequest400 "No signature in request")
|
|
||||||
|
|
||||||
when (signature /= routerSignature) $ throwError
|
|
||||||
(ResponseStatus BadRequest400 "Wrong signature in request")
|
|
||||||
|
|
||||||
path <- cutFrameOr
|
|
||||||
(ResponseStatus BadRequest400 "No path in request")
|
|
||||||
|
|
||||||
lift . ExceptT . pure
|
|
||||||
-- Если не может разобрать параметры запроса,
|
|
||||||
-- то самим ответить этому пиру '404'
|
|
||||||
-- . left (ResponseStatus BadRequest400)
|
|
||||||
. travel (BS8.split '/' path) router
|
|
||||||
-- передать оставшуюся часть запроса в хэндлер
|
|
||||||
=<< get
|
|
||||||
|
|
||||||
case erun of
|
|
||||||
Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)])
|
|
||||||
Right go ->
|
|
||||||
-- передать хэндлеру продолжение чтобы ответить этому пиру
|
|
||||||
go replyToPeer
|
|
||||||
|
|
||||||
where
|
|
||||||
(backPath, req) = splitEnvelope frames
|
|
||||||
|
|
||||||
replyToPeer :: Frames -> m ()
|
|
||||||
replyToPeer = rawReplyToPeer . over #unFrames (backPath <>)
|
|
||||||
|
|
||||||
travel :: ()
|
|
||||||
=> [ByteString]
|
|
||||||
-> DialogRequestRouter m
|
|
||||||
-> Frames
|
|
||||||
-> Either ResponseStatus ((Frames -> m ()) -> m ())
|
|
||||||
travel path'' router'' = evalStateT $ flipfix2 path'' router''
|
|
||||||
\go path -> \case
|
|
||||||
DialogRequestPaths kv -> case path of
|
|
||||||
step:path' ->
|
|
||||||
maybe
|
|
||||||
(throwError (ResponseStatus BadRequest400 "Path not found"))
|
|
||||||
(go path')
|
|
||||||
(Map.lookup step kv)
|
|
||||||
_ -> throwError (ResponseStatus BadRequest400 "Path not found (too long)")
|
|
||||||
DialogRequestPreparse hfx ->
|
|
||||||
go path =<< StateT (left (ResponseStatus BadRequest400) . hfx)
|
|
||||||
DialogRequestEndpoint ep -> pure ep
|
|
||||||
|
|
||||||
flipfix2 :: a -> b -> ((a -> b -> c) -> (a -> b -> c)) -> c
|
|
||||||
flipfix2 a b f = fix f a b
|
|
||||||
|
|
||||||
cutFrameDecode :: (Serialise b, MonadState Frames m, MonadError e m) => e -> m b
|
|
||||||
cutFrameDecode e =
|
|
||||||
State.gets unFrames >>= \case
|
|
||||||
x:xs ->
|
|
||||||
(either (const (throwError e)) pure . deserialiseOrFailS) x
|
|
||||||
<* State.put (Frames xs)
|
|
||||||
_ -> throwError e
|
|
||||||
|
|
||||||
cutFrameDecode'
|
|
||||||
:: (Serialise b, MonadState Frames m, MonadError (Maybe DeserialiseFailure) m)
|
|
||||||
=> m b
|
|
||||||
cutFrameDecode' =
|
|
||||||
State.gets unFrames >>= \case
|
|
||||||
x:xs ->
|
|
||||||
(either (throwError . Just) pure . deserialiseOrFailS) x
|
|
||||||
<* State.put (Frames xs)
|
|
||||||
_ -> throwError Nothing
|
|
||||||
|
|
||||||
cutFrameOr :: (MonadState (Frames' b) m, MonadError e m) => e -> m b
|
|
||||||
cutFrameOr e =
|
|
||||||
State.gets unFrames >>= \case
|
|
||||||
x:xs -> x <$ State.put (Frames xs)
|
|
||||||
_ -> throwError e
|
|
||||||
|
|
||||||
serialiseS :: Serialise a => a -> ByteString
|
|
||||||
serialiseS = BSL.toStrict . serialise
|
|
||||||
|
|
||||||
deserialiseOrFailS :: Serialise a => ByteString -> Either DeserialiseFailure a
|
|
||||||
deserialiseOrFailS = deserialiseOrFail . BSL.fromStrict
|
|
||||||
|
|
||||||
fromMaybeM :: Applicative m => m a -> Maybe a -> m a
|
|
||||||
fromMaybeM ma = maybe ma pure
|
|
||||||
|
|
||||||
fromJustThrowError :: MonadError e m => e -> Maybe a -> m a
|
|
||||||
fromJustThrowError = fromMaybeM . throwError
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------
|
|
||||||
--- Type-level specification -------------
|
|
||||||
------------------------------------------
|
|
||||||
|
|
||||||
|
|
||||||
data ReqCBOR (a :: Type)
|
|
||||||
data SingleAck
|
|
||||||
data SingleRespCBOR (a :: Type)
|
|
||||||
data StreamingRespCBOR (a :: Type)
|
|
||||||
|
|
||||||
data NamedSpec (spec :: Type -> Type)
|
|
||||||
|
|
||||||
class DialMode mode where
|
|
||||||
type mode &- spec :: Type
|
|
||||||
infixl 0 &-
|
|
||||||
|
|
||||||
data (path :: k) &/ (a :: Type)
|
|
||||||
deriving (Typeable)
|
|
||||||
infixr 4 &/
|
|
||||||
|
|
||||||
type path &// a = path &/ NamedSpec a
|
|
||||||
infixr 4 &//
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
data ModePlain
|
|
||||||
instance DialMode ModePlain where
|
|
||||||
type ModePlain &- spec = spec
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
data ModeServerT (m :: Type -> Type)
|
|
||||||
|
|
||||||
instance DialMode (ModeServerT m) where
|
|
||||||
type ModeServerT m &- spec = HandlerD spec m
|
|
||||||
|
|
||||||
class HasHandler m spec ctx where
|
|
||||||
type HandlerD spec (m' :: Type -> Type) :: Type
|
|
||||||
|
|
||||||
route ::
|
|
||||||
Proxy spec
|
|
||||||
-> Ctx ctx
|
|
||||||
-> HandlerD spec (DialHandlerT m)
|
|
||||||
-> DialogRequestRouter m
|
|
||||||
|
|
||||||
hoistDialogWithContext
|
|
||||||
:: Proxy spec
|
|
||||||
-> Proxy ctx
|
|
||||||
-> (forall x. m x -> n x)
|
|
||||||
-> HandlerD spec m
|
|
||||||
-> HandlerD spec n
|
|
||||||
|
|
||||||
data EmptyCX -- '[]
|
|
||||||
data Ctx ctx where
|
|
||||||
EmptyCtx :: Ctx EmptyCX
|
|
||||||
-- (:&.) :: x -> Ctx xs -> Ctx (x ': xs)
|
|
||||||
-- infixr 5 :&.
|
|
||||||
|
|
||||||
-- hoistTRouter :: forall t m n .
|
|
||||||
-- (MonadTrans t, Monad m, Monad n, m ~ t n)
|
|
||||||
-- => (forall a . m a -> n a)
|
|
||||||
-- -> DialogRequestRouter m
|
|
||||||
-- -> DialogRequestRouter n
|
|
||||||
-- hoistTRouter nt = fmap nt'
|
|
||||||
-- where
|
|
||||||
-- nt' :: ((x -> m y) -> m y)
|
|
||||||
-- -> ((x -> n y) -> n y)
|
|
||||||
-- nt' xtmy_tmy = nt . xtmy_tmy . fmap lift
|
|
||||||
|
|
||||||
hoistTRouter :: forall m n .
|
|
||||||
(Monad m, Monad n)
|
|
||||||
=> (forall a . m a -> n a)
|
|
||||||
-> (forall a . n a -> m a)
|
|
||||||
-> DialogRequestRouter m
|
|
||||||
-> DialogRequestRouter n
|
|
||||||
hoistTRouter ntf ntb = fmap nt'
|
|
||||||
where
|
|
||||||
nt' :: ((x -> m y) -> m y)
|
|
||||||
-> ((x -> n y) -> n y)
|
|
||||||
nt' xtmy_tmy = ntf . xtmy_tmy . fmap ntb
|
|
||||||
|
|
||||||
|
|
||||||
type DialHandlerIO a = DialHandlerT IO a
|
|
||||||
newtype DialHandlerT m a = DialHandlerT { runDialHandlerT :: ExceptT ResponseStatus m a }
|
|
||||||
deriving
|
|
||||||
( Generic, Functor, Applicative, Monad
|
|
||||||
, MonadIO
|
|
||||||
, MonadTrans
|
|
||||||
, MonadError ResponseStatus
|
|
||||||
-- , MonadUnliftIO
|
|
||||||
-- , MonadThrow, MonadCatch, MonadMask
|
|
||||||
)
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
instance (KnownSymbol path, HasHandler m spec ctx) => HasHandler m (path &/ spec) ctx where
|
|
||||||
type HandlerD (path &/ spec) m = HandlerD spec m
|
|
||||||
|
|
||||||
route _ ctx h = DialogRequestPaths $
|
|
||||||
Map.singleton (cs (symbolVal (Proxy @path))) (route (Proxy @spec) ctx h)
|
|
||||||
|
|
||||||
hoistDialogWithContext _ = hoistDialogWithContext (Proxy @spec)
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
instance
|
|
||||||
( Serialise a
|
|
||||||
, Typeable a
|
|
||||||
, HasHandler m spec ctx
|
|
||||||
) =>
|
|
||||||
HasHandler m (ReqCBOR a &/ spec) ctx where
|
|
||||||
type HandlerD (ReqCBOR a &/ spec) m = a -> HandlerD spec m
|
|
||||||
|
|
||||||
route _ ctx (ha :: a -> HandlerD spec (DialHandlerT m)) =
|
|
||||||
DialogRequestPreparse \fx -> do
|
|
||||||
(a, fx')
|
|
||||||
<- runExcept
|
|
||||||
$ flip runStateT fx
|
|
||||||
$ cutFrameDecode ((cs . show . typeRep) (Proxy @a))
|
|
||||||
pure (route (Proxy @spec) ctx (ha a), fx')
|
|
||||||
|
|
||||||
hoistDialogWithContext _ pc nt s = hoistDialogWithContext (Proxy @spec) pc nt . s
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
instance
|
|
||||||
( Applicative m
|
|
||||||
) =>
|
|
||||||
HasHandler m SingleAck ctx where
|
|
||||||
type HandlerD SingleAck m = m ()
|
|
||||||
|
|
||||||
route _ _ctx _mx =
|
|
||||||
DialogRequestEndpoint \reply -> do
|
|
||||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessNoContent204 "") 0)])
|
|
||||||
|
|
||||||
hoistDialogWithContext _ _ nt hdlM = nt hdlM
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
instance
|
|
||||||
( Monad m
|
|
||||||
, Serialise a
|
|
||||||
) =>
|
|
||||||
HasHandler m (SingleRespCBOR a) ctx where
|
|
||||||
type HandlerD (SingleRespCBOR a) m = m a
|
|
||||||
|
|
||||||
route _ _ctx ma =
|
|
||||||
DialogRequestEndpoint \reply -> do
|
|
||||||
|
|
||||||
ea <- runExceptT $ runDialHandlerT ma
|
|
||||||
|
|
||||||
case ea of
|
|
||||||
Left e -> reply $ Frames [ serialiseS e ]
|
|
||||||
Right a -> reply $ Frames
|
|
||||||
[ serialiseS (ResponseHeader (ResponseStatus Success200 "") 0)
|
|
||||||
, serialiseS (a :: a)
|
|
||||||
]
|
|
||||||
|
|
||||||
hoistDialogWithContext _ _ nt hdlM = nt hdlM
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
instance
|
|
||||||
( Serialise a
|
|
||||||
) =>
|
|
||||||
HasHandler m (StreamingRespCBOR a) ctx where
|
|
||||||
type HandlerD (StreamingRespCBOR a) m = Stream (Of a) m ()
|
|
||||||
|
|
||||||
route = undefined
|
|
||||||
|
|
||||||
-- hoistDialogWithContext = undefined
|
|
||||||
|
|
||||||
---
|
|
||||||
|
|
||||||
type GServerConstraints spec m =
|
|
||||||
( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
|
|
||||||
, GProduct (Rep (spec (ModeServerT m)))
|
|
||||||
)
|
|
||||||
|
|
||||||
class GServer (spec :: Type -> Type) (m :: Type -> Type) where
|
|
||||||
gServerProof :: Dict (GServerConstraints spec m)
|
|
||||||
|
|
||||||
instance
|
|
||||||
( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m
|
|
||||||
, GProduct (Rep (spec (ModeServerT m)))
|
|
||||||
) => GServer spec m where
|
|
||||||
gServerProof = Dict
|
|
||||||
|
|
||||||
|
|
||||||
instance
|
|
||||||
( HasHandler m (GToProduct (Rep (spec ModePlain))) ctx
|
|
||||||
-- , HasHandler m (GToProduct (Rep (spec (ModeServerT m)))) ctx
|
|
||||||
-- , GProduct (Rep (spec ModePlain))
|
|
||||||
, forall q . Generic (spec (ModeServerT q))
|
|
||||||
, forall q . GServer spec q
|
|
||||||
) =>
|
|
||||||
HasHandler m (NamedSpec spec) ctx where
|
|
||||||
type HandlerD (NamedSpec spec) m = spec (ModeServerT m)
|
|
||||||
|
|
||||||
route ::
|
|
||||||
Proxy (NamedSpec spec)
|
|
||||||
-> Ctx ctx
|
|
||||||
-> spec (ModeServerT (DialHandlerT m))
|
|
||||||
-> DialogRequestRouter m
|
|
||||||
route _ ctx spec =
|
|
||||||
case gServerProof @spec @(DialHandlerT m) of
|
|
||||||
Dict -> route (Proxy @(GToProduct (Rep (spec ModePlain)))) ctx (toProduct spec)
|
|
||||||
|
|
||||||
hoistDialogWithContext
|
|
||||||
:: forall n. Proxy (NamedSpec spec)
|
|
||||||
-> Proxy ctx
|
|
||||||
-> (forall x. m x -> n x)
|
|
||||||
-> spec (ModeServerT m)
|
|
||||||
-> spec (ModeServerT n)
|
|
||||||
hoistDialogWithContext _ pctx nat dl =
|
|
||||||
case (gServerProof @spec @m, gServerProof @spec @n) of
|
|
||||||
(Dict, Dict) ->
|
|
||||||
fromProduct dlN
|
|
||||||
where
|
|
||||||
dlM :: HandlerD (GToProduct (Rep (spec ModePlain))) m =
|
|
||||||
toProduct dl
|
|
||||||
dlN :: HandlerD (GToProduct (Rep (spec ModePlain))) n =
|
|
||||||
hoistDialogWithContext (Proxy @(GToProduct (Rep (spec ModePlain)))) pctx nat dlM
|
|
||||||
|
|
||||||
|
|
||||||
toProduct :: (Generic (spec mode), GProduct (Rep (spec mode)))
|
|
||||||
=> spec mode -> GToProduct (Rep (spec mode))
|
|
||||||
toProduct = gtoProduct . Generics.from
|
|
||||||
|
|
||||||
fromProduct
|
|
||||||
:: (Generic (spec mode), GProduct (Rep (spec mode)))
|
|
||||||
=> GToProduct (Rep (spec mode)) -> spec mode
|
|
||||||
fromProduct = Generics.to . gfromProduct
|
|
||||||
|
|
||||||
instance
|
|
||||||
( HasHandler m speca ctx
|
|
||||||
, HasHandler m specb ctx
|
|
||||||
) =>
|
|
||||||
HasHandler m (GP speca specb) ctx where
|
|
||||||
type HandlerD (GP speca specb) m = GP (HandlerD speca m) (HandlerD specb m)
|
|
||||||
route _ ctx (GP speca specb) =
|
|
||||||
route (Proxy @speca) ctx speca
|
|
||||||
<> route (Proxy @specb) ctx specb
|
|
||||||
|
|
||||||
hoistDialogWithContext _ pc nt (GP speca specb) =
|
|
||||||
GP
|
|
||||||
(hoistDialogWithContext (Proxy @speca) pc nt speca)
|
|
||||||
(hoistDialogWithContext (Proxy @specb) pc nt specb)
|
|
||||||
|
|
||||||
data GP a b = GP a b
|
|
||||||
|
|
||||||
class GProduct f where
|
|
||||||
type GToProduct (f :: Type -> Type)
|
|
||||||
gtoProduct :: f p -> GToProduct f
|
|
||||||
gfromProduct :: GToProduct f -> f p
|
|
||||||
|
|
||||||
instance (GProduct l, GProduct r) => GProduct (l :*: r) where
|
|
||||||
type GToProduct (l :*: r) = GP (GToProduct l) (GToProduct r)
|
|
||||||
gtoProduct (l :*: r) = GP (gtoProduct l) (gtoProduct r)
|
|
||||||
gfromProduct (GP l r) = gfromProduct l :*: gfromProduct r
|
|
||||||
|
|
||||||
instance GProduct f => GProduct (M1 i c f) where
|
|
||||||
type GToProduct (M1 i c f) = GToProduct f
|
|
||||||
gtoProduct = gtoProduct . unM1
|
|
||||||
gfromProduct = M1 . gfromProduct
|
|
||||||
|
|
||||||
instance GProduct (K1 i c) where
|
|
||||||
type GToProduct (K1 i c) = c
|
|
||||||
gtoProduct = unK1
|
|
||||||
gfromProduct = K1
|
|
||||||
|
|
@ -1,19 +0,0 @@
|
||||||
module HBS2.Net.Dialog.Helpers.List where
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Writer.CPS qualified as W
|
|
||||||
import Data.Functor.Identity
|
|
||||||
import Data.Monoid
|
|
||||||
|
|
||||||
type ListBuilder a = ListBuilderT Identity a
|
|
||||||
|
|
||||||
type ListBuilderT m a = W.WriterT (Endo [a]) m ()
|
|
||||||
|
|
||||||
buildList :: ListBuilder a -> [a]
|
|
||||||
buildList = runIdentity . buildListT
|
|
||||||
|
|
||||||
buildListT :: Monad m => ListBuilderT m a -> m [a]
|
|
||||||
buildListT = fmap (flip appEndo []) . W.execWriterT
|
|
||||||
|
|
||||||
li :: Monad m => a -> ListBuilderT m a
|
|
||||||
li = W.tell . Endo . (:)
|
|
||||||
|
|
||||||
|
|
@ -1,88 +0,0 @@
|
||||||
module HBS2.Net.Dialog.Helpers.Streaming where
|
|
||||||
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Data.ByteString qualified as BS
|
|
||||||
import Data.Int
|
|
||||||
import Data.Map.Strict qualified as Map
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Set qualified as Set
|
|
||||||
import Streaming as S
|
|
||||||
import Streaming.Internal
|
|
||||||
import Streaming.Prelude (cons)
|
|
||||||
import Streaming.Prelude qualified as S
|
|
||||||
import UnliftIO.Async
|
|
||||||
import UnliftIO.STM
|
|
||||||
import Prelude hiding (cons)
|
|
||||||
|
|
||||||
withEffects
|
|
||||||
:: (Functor m, Functor f, s ~ Stream f m r)
|
|
||||||
=> (forall a. m a -> m a)
|
|
||||||
-> s
|
|
||||||
-> s
|
|
||||||
withEffects trans = fix \go -> \case
|
|
||||||
Return r -> Return r
|
|
||||||
Effect m -> Effect (trans (fmap go m))
|
|
||||||
Step f -> Step (fmap go f)
|
|
||||||
{-# INLINEABLE withEffects #-}
|
|
||||||
|
|
||||||
withEffectsMay
|
|
||||||
:: (Monad m, Functor f, s ~ Stream f m r)
|
|
||||||
=> r
|
|
||||||
-> (forall a. m a -> m (Maybe a))
|
|
||||||
-> s
|
|
||||||
-> s
|
|
||||||
withEffectsMay d trans = fix \go -> \case
|
|
||||||
Return r -> Return r
|
|
||||||
Effect m -> Effect (fromMaybe (Return d) <$> trans (fmap go m))
|
|
||||||
Step f -> Step (fmap go f)
|
|
||||||
{-# INLINEABLE withEffectsMay #-}
|
|
||||||
|
|
||||||
stopOnLeft
|
|
||||||
:: (Monad m)
|
|
||||||
=> (a -> Either r b)
|
|
||||||
-> Stream (Of a) m r
|
|
||||||
-> Stream (Of b) m r
|
|
||||||
stopOnLeft f = fix \go -> \case
|
|
||||||
Return r -> Return r
|
|
||||||
Effect m -> Effect (go <$> m)
|
|
||||||
Step (a :> s) -> either Return (\b -> Step (b :> go s)) (f a)
|
|
||||||
{-# INLINEABLE stopOnLeft #-}
|
|
||||||
|
|
||||||
stopAfterLeftMay
|
|
||||||
:: (Monad m)
|
|
||||||
=> (a -> Either (Maybe b, r) b)
|
|
||||||
-> Stream (Of a) m r
|
|
||||||
-> Stream (Of b) m r
|
|
||||||
stopAfterLeftMay f = fix \go -> \case
|
|
||||||
Return r -> Return r
|
|
||||||
Effect m -> Effect (go <$> m)
|
|
||||||
Step (a :> s) -> either
|
|
||||||
(\(mb, r) -> maybe
|
|
||||||
(Return r)
|
|
||||||
(\b -> Step (b :> Return r))
|
|
||||||
mb)
|
|
||||||
(\b -> Step (b :> go s))
|
|
||||||
(f a)
|
|
||||||
{-# INLINEABLE stopAfterLeftMay #-}
|
|
||||||
|
|
||||||
stopAfter
|
|
||||||
:: (Monad m)
|
|
||||||
=> (a -> Maybe r)
|
|
||||||
-> Stream (Of a) m r
|
|
||||||
-> Stream (Of a) m r
|
|
||||||
stopAfter f = fix \go -> \case
|
|
||||||
Return r -> Return r
|
|
||||||
Effect m -> Effect (go <$> m)
|
|
||||||
Step (a :> s) -> Step (a :> (maybe (go s) Return (f a)))
|
|
||||||
{-# INLINEABLE stopAfter #-}
|
|
||||||
|
|
||||||
headEither
|
|
||||||
:: (Monad m)
|
|
||||||
=> Stream (Of a) m r
|
|
||||||
-> m (Either r a)
|
|
||||||
headEither = fix \go -> \case
|
|
||||||
Return r -> pure (Left r)
|
|
||||||
Effect ms -> go =<< ms
|
|
||||||
Step (a :> _) -> pure (Right a)
|
|
||||||
{-# INLINEABLE headEither #-}
|
|
||||||
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
module DialogSpec where
|
|
||||||
|
|
||||||
import Test.QuickCheck
|
|
||||||
import Test.Tasty
|
|
||||||
import Test.Tasty.HUnit
|
|
||||||
import Test.Tasty.QuickCheck as TastyQ
|
|
||||||
|
|
||||||
import Control.Concurrent.Async
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.ByteString qualified as BS
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
import System.IO
|
|
||||||
|
|
||||||
import HBS2.Net.Dialog.Core
|
|
||||||
import HBS2.Net.Dialog.Helpers.List
|
|
||||||
|
|
||||||
newtype BSA = BSA { unBSA :: ByteString }
|
|
||||||
deriving (Generic, Show)
|
|
||||||
|
|
||||||
instance Arbitrary BSA where
|
|
||||||
arbitrary = BSA <$> randomSizedByteString
|
|
||||||
|
|
||||||
-- shrink = \case
|
|
||||||
-- BSA bs | BS.length bs > 1 ->
|
|
||||||
-- let (bs1, bs2) = BS.splitAt (BS.length bs `div` 2) bs
|
|
||||||
-- in [BSA bs1, BSA bs2]
|
|
||||||
-- _ -> []
|
|
||||||
|
|
||||||
shrink = \case
|
|
||||||
BSA (BS.uncons -> Just (x, xs)) -> [BSA xs]
|
|
||||||
_ -> []
|
|
||||||
|
|
||||||
deriving via [BSA] instance Arbitrary Frames
|
|
||||||
|
|
||||||
randomByteString :: Int -> Gen ByteString
|
|
||||||
randomByteString n =
|
|
||||||
vectorOf n arbitrary <&> BS.pack
|
|
||||||
{-# NOINLINE randomByteString #-}
|
|
||||||
|
|
||||||
randomSizedByteString :: Gen ByteString
|
|
||||||
randomSizedByteString = do
|
|
||||||
let low = 0
|
|
||||||
let high = 2^13
|
|
||||||
size <- choose (low, high)
|
|
||||||
randomByteString size
|
|
||||||
{-# NOINLINE randomSizedByteString #-}
|
|
||||||
|
|
||||||
property' name = li . (name, ) . property
|
|
||||||
|
|
||||||
testDialog :: TestTree
|
|
||||||
testDialog = testGroup "dialog" $ buildList do
|
|
||||||
li . TastyQ.testProperties "props" $ buildList do
|
|
||||||
|
|
||||||
property' "roundtrip encode Frames" \ xs ->
|
|
||||||
(decodeFrames . encodeFrames) xs == Right xs
|
|
||||||
|
|
||||||
property' "encodeFrames is quasidistributive over mappend" \ (xs, ys) ->
|
|
||||||
BS.drop (BS.length (encodeFrames xs)) (encodeFrames (xs <> ys))
|
|
||||||
== encodeFrames ys
|
|
||||||
|
|
||||||
|
|
@ -2,7 +2,6 @@ module Main where
|
||||||
|
|
||||||
import TestFakeMessaging
|
import TestFakeMessaging
|
||||||
import TestActors
|
import TestActors
|
||||||
import DialogSpec
|
|
||||||
import TestFileLogger
|
import TestFileLogger
|
||||||
import TestScheduled
|
import TestScheduled
|
||||||
import TestDerivedKey
|
import TestDerivedKey
|
||||||
|
|
@ -20,9 +19,6 @@ main =
|
||||||
, testCase "testFileLogger" testFileLogger
|
, testCase "testFileLogger" testFileLogger
|
||||||
, testCase "testScheduledActions" testScheduled
|
, testCase "testScheduledActions" testScheduled
|
||||||
, testCase "testDerivedKeys1" testDerivedKeys1
|
, testCase "testDerivedKeys1" testDerivedKeys1
|
||||||
|
|
||||||
-- FIXME does-not-finish
|
|
||||||
-- , testDialog
|
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ testDerivedKeys1 = do
|
||||||
let nonce = 0x123456780928934 :: Word64
|
let nonce = 0x123456780928934 :: Word64
|
||||||
(pk1,sk1) <- derivedKey @'HBS2Basic @'Sign nonce sk
|
(pk1,sk1) <- derivedKey @'HBS2Basic @'Sign nonce sk
|
||||||
|
|
||||||
let box = makeSignedBox @L4Proto pk1 sk1 (42 :: Word32)
|
let box = makeSignedBox @'HBS2Basic pk1 sk1 (42 :: Word32)
|
||||||
|
|
||||||
(pk, n) <- pure (unboxSignedBox0 box)
|
(pk, n) <- pure (unboxSignedBox0 box)
|
||||||
`orDie` "can not unbox"
|
`orDie` "can not unbox"
|
||||||
|
|
|
||||||
|
|
@ -1,255 +0,0 @@
|
||||||
{-# LANGUAGE StrictData #-}
|
|
||||||
|
|
||||||
module PeerMain.DialogCliCommand where
|
|
||||||
|
|
||||||
import Data.Generics.Labels
|
|
||||||
import Data.Generics.Product.Fields
|
|
||||||
import HBS2.Actors.Peer
|
|
||||||
import HBS2.Hash
|
|
||||||
import HBS2.Net.IP.Addr
|
|
||||||
import HBS2.Net.Messaging.UDP
|
|
||||||
import HBS2.Net.Proto
|
|
||||||
import HBS2.Net.Proto.Dialog
|
|
||||||
import HBS2.OrDie
|
|
||||||
import HBS2.Prelude
|
|
||||||
import HBS2.System.Logger.Simple hiding (info)
|
|
||||||
|
|
||||||
import PeerConfig
|
|
||||||
import RPC (PeerRpcKey, RpcM, runRPC)
|
|
||||||
|
|
||||||
import Control.Monad.Except (Except(..), ExceptT(..), runExcept, runExceptT)
|
|
||||||
import Control.Monad.State.Strict (evalStateT)
|
|
||||||
import Control.Monad.Trans.Cont
|
|
||||||
import Data.Default
|
|
||||||
import Data.Function
|
|
||||||
import Data.Functor
|
|
||||||
import Data.Kind
|
|
||||||
import Data.List qualified as List
|
|
||||||
import Data.String.Conversions as X (cs)
|
|
||||||
import Data.Void (absurd, Void)
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
import Network.Socket
|
|
||||||
import Options.Applicative
|
|
||||||
import Streaming.Prelude qualified as S
|
|
||||||
import System.IO
|
|
||||||
import UnliftIO.Async
|
|
||||||
import UnliftIO.Concurrent
|
|
||||||
import UnliftIO.Exception as U
|
|
||||||
import UnliftIO.Resource
|
|
||||||
|
|
||||||
|
|
||||||
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") )
|
|
||||||
<> command "reflog" (info pReflog (progDesc "reflog commands") )
|
|
||||||
|
|
||||||
pReflog :: Parser (IO ())
|
|
||||||
pReflog = hsubparser $ mempty
|
|
||||||
<> command "get" (info pRefLogGet (progDesc "get own reflog from all" ))
|
|
||||||
<> command "fetch" (info pRefLogFetch (progDesc "fetch reflog from all" ))
|
|
||||||
|
|
||||||
confOpt :: Parser FilePath
|
|
||||||
confOpt = strOption ( long "config" <> short 'c' <> help "config" )
|
|
||||||
|
|
||||||
newtype OptInitial (f :: Type -> Type) a b = OptInitial { unOptInitial :: f a }
|
|
||||||
deriving (Generic, Show)
|
|
||||||
|
|
||||||
newtype OptResolved (f :: Type -> Type) a b = OptResolved { unOptResolved :: b }
|
|
||||||
deriving (Generic, Show)
|
|
||||||
|
|
||||||
type DialOptInitial = DialOpt OptInitial
|
|
||||||
type DialOptResolved = DialOpt OptResolved
|
|
||||||
|
|
||||||
data DialOpt (f :: (Type -> Type) -> Type -> Type -> Type) = 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" [])
|
|
||||||
|
|
||||||
reflogKeyP :: ReadM (PubKey 'Sign (Encryption L4Proto))
|
|
||||||
reflogKeyP = eitherReader $
|
|
||||||
maybe (Left "invalid REFLOG-KEY") pure . fromStringMay
|
|
||||||
|
|
||||||
pRefLogGet :: Parser (IO ())
|
|
||||||
pRefLogGet = do
|
|
||||||
dopt <- pDialCommon
|
|
||||||
rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" )
|
|
||||||
pure do
|
|
||||||
withDial dopt \peer dclient ->
|
|
||||||
withClient dclient \cli -> do
|
|
||||||
xs <- dQuery1 def cli peer (dpath "reflog/get" [serialiseS rkey])
|
|
||||||
|
|
||||||
hash <- either (lift . lift . fail) pure $ runExcept $ flip evalStateT xs do
|
|
||||||
cutFrameDecode @(Hash HbSync) do
|
|
||||||
"No hash in response: " <> show xs
|
|
||||||
|
|
||||||
liftIO . print $ pretty hash
|
|
||||||
|
|
||||||
pRefLogFetch :: Parser (IO ())
|
|
||||||
pRefLogFetch = do
|
|
||||||
dopt <- pDialCommon
|
|
||||||
rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" )
|
|
||||||
pure do
|
|
||||||
withDial dopt \peer dclient ->
|
|
||||||
withClient dclient \cli -> do
|
|
||||||
xs <- dQuery1 def cli peer (dpath "reflog/fetch" [serialiseS rkey])
|
|
||||||
|
|
||||||
liftIO . print $ "Response: " <> show xs
|
|
||||||
|
|
||||||
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 ()
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue