mirror of https://github.com/voidlizard/hbs2
PR 3nmxU5Ro8b dialog-proto
This commit is contained in:
Dmitry Zuikov
parent
0c9cfdbde3
commit
71e325f8bc
|
|
@ -1,5 +1,2 @@
|
|||
|
||||
(fixme-set "workflow" "test" "8ey8Fnr4c4")
|
||||
fixme-del "7TVJE7H1YY"
|
||||
fixme-del "DoshYTWtk5"
|
||||
(fixme-set "workflow" "done" "DgtWWrbatG")
|
||||
(fixme-set "workflow" "test" "3nmxU5Ro8b")
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
SHELL := bash
|
||||
.ONESHELL:
|
||||
.SHELLFLAGS := -eu -o pipefail -c
|
||||
.DELETE_ON_ERROR:
|
||||
MAKEFLAGS += --warn-undefined-variables
|
||||
MAKEFLAGS += --no-builtin-rules
|
||||
|
||||
ifeq ($(origin .RECIPEPREFIX), undefined)
|
||||
$(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)
|
||||
endif
|
||||
.RECIPEPREFIX = >
|
||||
|
||||
.PHONY: build
|
||||
build:
|
||||
> nix develop -c cabal build all
|
||||
|
||||
.PHONY: test-core
|
||||
test-core:
|
||||
> nix develop -c cabal run hbs2-core:test
|
||||
|
||||
|
|
@ -51,8 +51,10 @@ common shared-properties
|
|||
, ImportQualifiedPost
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, RankNTypes
|
||||
, RecordWildCards
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
|
|
@ -60,6 +62,7 @@ common shared-properties
|
|||
, TypeApplications
|
||||
, TypeFamilies
|
||||
, TemplateHaskell
|
||||
, ViewPatterns
|
||||
|
||||
|
||||
|
||||
|
|
@ -96,6 +99,7 @@ library
|
|||
, HBS2.Net.Proto.BlockChunks
|
||||
, HBS2.Net.Proto.BlockInfo
|
||||
, HBS2.Net.Proto.Definition
|
||||
, HBS2.Net.Proto.Dialog
|
||||
, HBS2.Net.Proto.EncryptionHandshake
|
||||
, HBS2.Net.Proto.Event.PeerExpired
|
||||
, HBS2.Net.Proto.Peer
|
||||
|
|
@ -112,6 +116,10 @@ library
|
|||
, HBS2.Storage
|
||||
, HBS2.System.Logger.Simple
|
||||
, HBS2.System.Logger.Simple.Class
|
||||
, Dialog.Core
|
||||
, Dialog.Client
|
||||
, Dialog.Helpers.List
|
||||
, Dialog.Helpers.Streaming
|
||||
|
||||
|
||||
-- other-modules:
|
||||
|
|
@ -120,6 +128,7 @@ library
|
|||
, aeson
|
||||
, async
|
||||
, attoparsec
|
||||
, base16-bytestring
|
||||
, base58-bytestring
|
||||
, binary
|
||||
, bytestring
|
||||
|
|
@ -128,11 +137,13 @@ library
|
|||
, clock
|
||||
, containers
|
||||
, cryptonite
|
||||
, data-default
|
||||
, deepseq
|
||||
, directory
|
||||
, fast-logger
|
||||
, filelock
|
||||
, filepath
|
||||
, generic-lens
|
||||
, hashable
|
||||
, interpolatedstring-perl6
|
||||
, iproute
|
||||
|
|
@ -146,6 +157,7 @@ library
|
|||
, network-simple
|
||||
, network-byte-order
|
||||
, prettyprinter
|
||||
, mwc-random
|
||||
, random
|
||||
, random-shuffle
|
||||
, resourcet
|
||||
|
|
@ -156,6 +168,7 @@ library
|
|||
, split
|
||||
, stm
|
||||
, stm-chans
|
||||
, string-conversions
|
||||
, streaming
|
||||
, string-conversions
|
||||
, suckless-conf
|
||||
|
|
@ -166,6 +179,7 @@ library
|
|||
, uniplate
|
||||
, unordered-containers
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
|
||||
|
||||
hs-source-dirs: lib
|
||||
|
|
@ -181,6 +195,7 @@ test-suite test
|
|||
-- , TestUniqProtoId
|
||||
, FakeMessaging
|
||||
, HasProtocol
|
||||
, DialogSpec
|
||||
|
||||
-- other-extensions:
|
||||
|
||||
|
|
@ -207,6 +222,7 @@ test-suite test
|
|||
, tasty
|
||||
, tasty-quickcheck
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, transformers
|
||||
, uniplate
|
||||
, vector
|
||||
|
|
|
|||
|
|
@ -0,0 +1,193 @@
|
|||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE ImpredicativeTypes #-}
|
||||
module 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 Dialog.Core
|
||||
import 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)
|
||||
SuccessMore -> Right rhxs
|
||||
r@BadRequest400 -> Left (Nothing, (RequestFailure r xs))
|
||||
r@Forbidden403 -> Left (Nothing, (RequestFailure r xs))
|
||||
r@NotFound404 -> Left (Nothing, (RequestFailure r 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'}))
|
||||
|
||||
|
|
@ -0,0 +1,442 @@
|
|||
{-# LANGUAGE StrictData #-}
|
||||
-- {-# LANGUAGE OverloadedLists #-}
|
||||
-- {-# LANGUAGE UndecidableInstances #-}
|
||||
module Dialog.Core where
|
||||
|
||||
-- import Data.ByteString.Builder as Builder
|
||||
-- import Data.ByteString.Builder.Internal as Builder
|
||||
-- import GHC.IsList
|
||||
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 (evalStateT)
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Writer qualified as W
|
||||
import Data.Binary.Get as Get
|
||||
import Data.Binary.Put as Put
|
||||
import Data.Bits
|
||||
import Data.Bool
|
||||
import Data.ByteArray (ByteArrayAccess)
|
||||
import Data.ByteArray.Sized as BAS
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Char8 qualified as BS8
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Foldable
|
||||
import Data.Foldable as F
|
||||
import Data.Function
|
||||
import Data.Generics.Labels
|
||||
import Data.Generics.Product.Fields
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import Data.String.Conversions as X (cs)
|
||||
import Data.Text (Text)
|
||||
import Data.Word
|
||||
import GHC.Exts
|
||||
import GHC.Generics (Generic)
|
||||
import Lens.Micro.Platform
|
||||
import Numeric.Natural
|
||||
import System.Random.MWC
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO.STM
|
||||
|
||||
-- import Prettyprinter
|
||||
-- import HBS2.Base58
|
||||
import Data.ByteString.Base16 qualified as B16
|
||||
|
||||
import 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
|
||||
|
||||
size <-
|
||||
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 size
|
||||
|
||||
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 ResponseStatusCode 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 .~ Just 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 =
|
||||
(atomically (readTVar unCallerEnv)) <&> (preview (ix callerID))
|
||||
|
||||
---
|
||||
|
||||
setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m ()
|
||||
setupRepHandler RequestResponseEnv{..} requestID useResponse =
|
||||
(atomically . modifyTVar' unRequestResponseEnv)
|
||||
(at requestID .~ Just 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 =
|
||||
(atomically (readTVar 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
|
||||
|
||||
---
|
||||
|
||||
newtype DialogRequestRouter m = DialogRequestRouter
|
||||
{ unDialogRequestRouter ::
|
||||
Map [ByteString] -- path
|
||||
|
||||
-- handler :: Input -> m (Either ErrorMessage (HowToReply -> ResponseContinuation))
|
||||
(Frames -> Either Text ((Frames -> m ()) -> m ()))
|
||||
}
|
||||
|
||||
deriving (Semigroup, Monoid)
|
||||
|
||||
dialogRequestRoutes
|
||||
:: ListBuilder
|
||||
([ByteString], Frames -> Either Text ((Frames -> m ()) -> m ()))
|
||||
-> DialogRequestRouter m
|
||||
dialogRequestRoutes = DialogRequestRouter . Map.fromList . buildList
|
||||
|
||||
hand :: Monad m => a -> b -> ListBuilderT m (a, b)
|
||||
hand = curry li
|
||||
|
||||
---
|
||||
|
||||
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
|
||||
| SuccessMore
|
||||
| BadRequest400
|
||||
| Forbidden403
|
||||
| NotFound404
|
||||
deriving (Generic, Show, Eq)
|
||||
|
||||
instance Serialise ResponseStatusCode
|
||||
|
||||
routerSignature :: Word8
|
||||
routerSignature = 1
|
||||
|
||||
routeDialogRequest :: forall m p pd .
|
||||
Monad m
|
||||
=> DialogRequestRouter m
|
||||
-> DialogRequestEnv m p pd
|
||||
-> (Frames -> m ())
|
||||
-> Frames
|
||||
-> m ()
|
||||
routeDialogRequest router drenv rawReplyToPeer frames = do
|
||||
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")
|
||||
|
||||
route <- cutFrameOr
|
||||
(ResponseStatus BadRequest400 "No route in request")
|
||||
|
||||
h <- fromJustThrowError
|
||||
(ResponseStatus NotFound404 "Route not found")
|
||||
(unDialogRequestRouter router ^? ix (BS8.split '/' route))
|
||||
|
||||
lift . ExceptT . pure
|
||||
-- Если не может разобрать параметры запроса,
|
||||
-- то самим ответить этому пиру '404'
|
||||
. left (ResponseStatus BadRequest400)
|
||||
. h
|
||||
-- передать оставшуюся часть запроса в хэндлер
|
||||
=<< get
|
||||
|
||||
case erun of
|
||||
Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)])
|
||||
Right run ->
|
||||
-- передать хэндлеру продолжение чтобы ответить этому пиру
|
||||
run replyToPeer
|
||||
|
||||
where
|
||||
(backPath, req) = splitEnvelope frames
|
||||
|
||||
replyToPeer :: Frames -> m ()
|
||||
replyToPeer = rawReplyToPeer . over #unFrames (backPath <>)
|
||||
|
||||
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
|
||||
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
module 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 . (:)
|
||||
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
module 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 #-}
|
||||
|
||||
|
|
@ -43,10 +43,10 @@ import Data.HashMap.Strict (HashMap)
|
|||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Concurrent.STM
|
||||
import Data.Hashable (hash)
|
||||
import UnliftIO (MonadUnliftIO(..))
|
||||
import Crypto.Saltine.Core.SecretBox qualified as SBox -- Симметричное шифрование с nonce без подписи
|
||||
import Crypto.Saltine.Core.Box qualified as Encrypt -- Асимметричное шифрование без подписи
|
||||
import Control.Monad.IO.Unlift
|
||||
|
||||
import Codec.Serialise (serialise, deserialiseOrFail)
|
||||
|
||||
|
|
@ -128,6 +128,22 @@ makeResponse h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p))
|
|||
, handle = h
|
||||
}
|
||||
|
||||
-- makeResponse' :: forall e p m . ( MonadIO m
|
||||
-- , Response e p m
|
||||
-- , HasProtocol e p
|
||||
-- , Messaging (Fabriq e) e (AnyMessage (Encoded e) e)
|
||||
-- )
|
||||
-- => (Encoded e -> Maybe p)
|
||||
-- -> (p -> Encoded e)
|
||||
-- -> (p -> m ())
|
||||
-- -> AnyProtocol e m
|
||||
|
||||
-- makeResponse' dec enc h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p))
|
||||
-- , protoDecode = dec
|
||||
-- , protoEncode = enc
|
||||
-- , handle = h
|
||||
-- }
|
||||
|
||||
data PeerEnv e =
|
||||
PeerEnv
|
||||
{ _envSelf :: Peer e
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# Language FunctionalDependencies #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Net.Messaging where
|
||||
|
||||
|
|
@ -7,6 +8,7 @@ import HBS2.Net.Proto
|
|||
import Control.Monad.IO.Class
|
||||
|
||||
newtype From a = From (Peer a)
|
||||
deriving instance Show (Peer a) => Show (From a)
|
||||
|
||||
newtype To a = To (Peer a)
|
||||
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import HBS2.Net.Proto
|
|||
import HBS2.Net.Proto.BlockAnnounce
|
||||
import HBS2.Net.Proto.BlockChunks
|
||||
import HBS2.Net.Proto.BlockInfo
|
||||
import HBS2.Net.Proto.Dialog
|
||||
import HBS2.Net.Proto.EncryptionHandshake
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.PeerAnnounce
|
||||
|
|
@ -27,6 +28,7 @@ import Control.Monad
|
|||
import Data.Functor
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Codec.Serialise (deserialiseOrFail,serialise)
|
||||
|
||||
import Crypto.Saltine.Core.Box qualified as Crypto
|
||||
|
|
@ -177,6 +179,18 @@ instance HasProtocol L4Proto (RefChanNotify L4Proto) where
|
|||
-- возьмем пока 10 секунд
|
||||
requestPeriodLim = ReqLimPerMessage 10
|
||||
|
||||
instance HasProtocol L4Proto (DialReq L4Proto) where
|
||||
type instance ProtocolId (DialReq L4Proto) = 96000
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = dialReqDecode . BSL.toStrict
|
||||
encode = BSL.fromStrict . dialReqEncode
|
||||
|
||||
instance HasProtocol L4Proto (DialResp L4Proto) where
|
||||
type instance ProtocolId (DialResp L4Proto) = 96001
|
||||
type instance Encoded L4Proto = ByteString
|
||||
decode = dialRespDecode . BSL.toStrict
|
||||
encode = BSL.fromStrict . dialRespEncode
|
||||
|
||||
instance Expires (SessionKey L4Proto (BlockInfo L4Proto)) where
|
||||
expiresIn _ = Just defCookieTimeoutSec
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,157 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module HBS2.Net.Proto.Dialog
|
||||
( module HBS2.Net.Proto.Dialog
|
||||
, module Dialog.Core
|
||||
, module Dialog.Client
|
||||
) where
|
||||
|
||||
import HBS2.Actors.Peer
|
||||
import HBS2.Clock
|
||||
import HBS2.Data.Types
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto
|
||||
import HBS2.Net.Proto.Peer
|
||||
import HBS2.Net.Proto.Sessions
|
||||
import HBS2.Prelude.Plated hiding (at)
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Codec.Serialise (deserialiseOrFail)
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Control.Monad.Error.Class
|
||||
import Control.Monad.IO.Unlift
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Builder
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict as Map
|
||||
import Lens.Micro.Platform
|
||||
import Streaming as S
|
||||
import Streaming.Prelude qualified as S
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO.STM
|
||||
|
||||
import Dialog.Client
|
||||
import Dialog.Core
|
||||
|
||||
---
|
||||
|
||||
newtype DialReq e = DialReq { unDialReq :: Frames }
|
||||
deriving stock (Generic)
|
||||
|
||||
dialReqDecode :: MonadFail m => ByteString -> m (DialReq e)
|
||||
dialReqDecode = fmap DialReq . decodeFramesFail
|
||||
|
||||
dialReqEncode :: DialReq e -> ByteString
|
||||
dialReqEncode = \case
|
||||
DialReq xs -> encodeFrames xs
|
||||
|
||||
|
||||
newtype DialResp e = DialResp { unDialResp :: Frames }
|
||||
deriving stock (Generic)
|
||||
|
||||
dialRespDecode :: MonadFail m => ByteString -> m (DialResp e)
|
||||
dialRespDecode = fmap DialResp . decodeFramesFail
|
||||
|
||||
dialRespEncode :: DialResp e -> ByteString
|
||||
dialRespEncode = \case
|
||||
DialResp xs -> encodeFrames xs
|
||||
|
||||
---
|
||||
|
||||
data DialogProtoEnv m e = DialogProtoEnv
|
||||
{ dialogProtoEnvCallerEnv :: CallerEnv m
|
||||
}
|
||||
|
||||
newDialogProtoEnv ::
|
||||
( MonadIO m
|
||||
, Ord (Peer e)
|
||||
) => m (DialogProtoEnv m' e)
|
||||
newDialogProtoEnv = do
|
||||
dialogProtoEnvCallerEnv <- newCallerEnv
|
||||
pure DialogProtoEnv {..}
|
||||
|
||||
-- Adapters should share the same env
|
||||
|
||||
data DialReqProtoAdapter e (m :: * -> *) s = DialReqProtoAdapter
|
||||
{ dialReqProtoAdapterRouter :: DialogRequestRouter m
|
||||
-- , dialReqProtoAdapterEnv :: DialogProtoEnv e
|
||||
}
|
||||
|
||||
data DialRespProtoAdapter e (m :: * -> *) s = DialRespProtoAdapter
|
||||
{ dialRespProtoAdapterEnv :: DialogProtoEnv m e
|
||||
}
|
||||
|
||||
---
|
||||
|
||||
-- | Обрабатывается на стороне сервера
|
||||
dialReqProto :: forall e s m .
|
||||
( MonadIO m
|
||||
, Response e (DialReq e) m
|
||||
, Request e (DialResp e) m
|
||||
-- , Sessions e (KnownPeer e) m
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> DialReqProtoAdapter e m s
|
||||
-> DialReq e
|
||||
-> m ()
|
||||
dialReqProto DialReqProtoAdapter{..} = unDialReq >>> \frames -> do
|
||||
peer <- thatPeer dialReqProtoProxy
|
||||
|
||||
let dialReqEnv :: DialogRequestEnv m (Peer e) (Maybe (PeerData e))
|
||||
dialReqEnv = DialogRequestEnv
|
||||
{ dreqEnvPeer = peer
|
||||
, dreqEnvGetPeerData = pure Nothing -- undefined -- find (KnownPeerKey peer) id
|
||||
}
|
||||
|
||||
let replyToPeer :: Frames -> m ()
|
||||
replyToPeer = request peer . DialResp @e
|
||||
|
||||
routeDialogRequest dialReqProtoAdapterRouter dialReqEnv replyToPeer frames
|
||||
|
||||
where
|
||||
dialReqProtoProxy = Proxy @(DialReq e)
|
||||
|
||||
---
|
||||
|
||||
-- | Обрабатывает ответы сервера на стороне клиента
|
||||
dialRespProto :: forall e s m .
|
||||
( MonadIO m
|
||||
, Response e (DialResp e) m
|
||||
, e ~ L4Proto
|
||||
)
|
||||
=> DialRespProtoAdapter e m s
|
||||
-> DialResp e
|
||||
-> m ()
|
||||
dialRespProto DialRespProtoAdapter{..} = unDialResp >>> unFrames >>> \case
|
||||
"": xs -> do
|
||||
-- Ответили прямо нам сюда. Нужно как-то отреагировать на xs
|
||||
pure ()
|
||||
|
||||
callerIDRaw: xs -> do
|
||||
|
||||
-- Найти в окружении пира, соответствующего callerID, и продолжение для ответа ему
|
||||
-- Если нашли, передать xs в это продолжение (переслать ответ обратно спрашивавшему)
|
||||
case deserialiseOrFail (BSL.fromStrict callerIDRaw) of
|
||||
Left _ ->
|
||||
-- Если не нашли, ничего не предпринимать
|
||||
-- Клиент отключился
|
||||
pure ()
|
||||
|
||||
Right callerID -> do
|
||||
let env = dialogProtoEnvCallerEnv dialRespProtoAdapterEnv
|
||||
mh <- findCallerHandler env callerID
|
||||
forM_ mh \(CallerHandler h) -> h (Frames xs)
|
||||
|
||||
pure ()
|
||||
|
||||
_ -> do
|
||||
-- Прислали пустой ответ неизвестно кому? -- Никак не реагировать.
|
||||
pure ()
|
||||
|
||||
where
|
||||
dialRespProtoProxy = Proxy @(DialResp e)
|
||||
|
||||
|
|
@ -8,6 +8,9 @@ class OrDie m a where
|
|||
type family OrDieResult a :: Type
|
||||
orDie :: m a -> String -> m (OrDieResult a)
|
||||
|
||||
orDieM :: (Monad m, OrDie m a) => a -> String -> m (OrDieResult a)
|
||||
orDieM a msg = pure a `orDie` msg
|
||||
|
||||
instance MonadIO m => OrDie m (Maybe a) where
|
||||
type instance OrDieResult (Maybe a) = a
|
||||
orDie mv err = mv >>= \case
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
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 Dialog.Core
|
||||
import 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
|
||||
|
||||
|
|
@ -2,6 +2,7 @@ module Main where
|
|||
|
||||
import TestFakeMessaging
|
||||
import TestActors
|
||||
import DialogSpec
|
||||
-- import TestUniqProtoId
|
||||
import TestCrypto
|
||||
|
||||
|
|
@ -17,6 +18,7 @@ main =
|
|||
, testCase "testActorsBasic" testActorsBasic
|
||||
-- , testCase "testUniqProtoId" testUniqProtoId
|
||||
, testCrypto
|
||||
, testDialog
|
||||
]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ import HBS2.Net.Messaging.TCP
|
|||
import HBS2.Net.PeerLocator
|
||||
import HBS2.Net.Proto as Proto
|
||||
import HBS2.Net.Proto.Definition
|
||||
import HBS2.Net.Proto.Dialog
|
||||
import HBS2.Net.Proto.EncryptionHandshake
|
||||
import HBS2.Net.Proto.Event.PeerExpired
|
||||
import HBS2.Net.Proto.Peer
|
||||
|
|
@ -54,6 +55,8 @@ import RefLog qualified
|
|||
import RefLog (reflogWorker)
|
||||
import HttpWorker
|
||||
import ProxyMessaging
|
||||
import PeerMain.DialogCliCommand
|
||||
import PeerMain.PeerDialog
|
||||
import PeerMeta
|
||||
import CLI.RefChan
|
||||
import RefChan
|
||||
|
|
@ -98,8 +101,8 @@ import Text.InterpolatedString.Perl6 (qc)
|
|||
import UnliftIO.Exception qualified as U
|
||||
-- import UnliftIO.STM
|
||||
import UnliftIO.Async as U
|
||||
import Control.Monad.Trans.Resource
|
||||
|
||||
import Control.Monad.Trans.Resource
|
||||
import Streaming.Prelude qualified as S
|
||||
import Streaming qualified as S
|
||||
|
||||
|
|
@ -145,7 +148,6 @@ instance HasCfgKey PeerTrace1Key FeatureSwitch where
|
|||
instance HasCfgKey PeerListenKey (Maybe String) where
|
||||
key = "listen"
|
||||
|
||||
|
||||
instance HasCfgKey PeerKeyFileKey (Maybe String) where
|
||||
key = "key"
|
||||
|
||||
|
|
@ -240,6 +242,8 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
|
|||
<> command "peers" (info pPeers (progDesc "show known peers"))
|
||||
<> command "pexinfo" (info pPexInfo (progDesc "show pex"))
|
||||
<> command "log" (info pLog (progDesc "set logging level"))
|
||||
|
||||
<> command "dial" (info pDialog (progDesc "dialog commands"))
|
||||
)
|
||||
|
||||
confOpt = strOption ( long "config" <> short 'c' <> help "config" )
|
||||
|
|
@ -705,6 +709,10 @@ runPeer opts = U.handle (\e -> myException e
|
|||
|
||||
}
|
||||
|
||||
-- dialReqProtoAdapter <- do
|
||||
-- dialReqProtoAdapterRouter <- pure dialogRoutes
|
||||
-- pure DialReqProtoAdapter {..}
|
||||
|
||||
env <- ask
|
||||
|
||||
pnonce <- peerNonce @e
|
||||
|
|
@ -990,6 +998,7 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, makeResponse (refChanUpdateProto False pc refChanAdapter)
|
||||
, makeResponse (refChanRequestProto False refChanAdapter)
|
||||
, makeResponse (refChanNotifyProto False refChanAdapter)
|
||||
-- , makeResponse (dialReqProto dialReqProtoAdapter)
|
||||
]
|
||||
|
||||
void $ liftIO $ waitAnyCancel workers
|
||||
|
|
@ -1175,9 +1184,14 @@ runPeer opts = U.handle (\e -> myException e
|
|||
, rpcOnRefChanPropose = refChanProposeAction
|
||||
}
|
||||
|
||||
dialReqProtoAdapter <- do
|
||||
dialReqProtoAdapterRouter <- pure dialogRoutes
|
||||
pure DialReqProtoAdapter {..}
|
||||
|
||||
rpc <- async $ runRPC udp1 do
|
||||
runProto @e
|
||||
[ makeResponse (rpcHandler arpc)
|
||||
, makeResponse (dialReqProto dialReqProtoAdapter)
|
||||
]
|
||||
|
||||
menv <- newPeerEnv (AnyStorage s) (Fabriq mcast) (getOwnPeer mcast)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,269 @@
|
|||
{-# 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 ()
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
module PeerMain.PeerDialog where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Bool
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Map qualified as Map
|
||||
|
||||
import Dialog.Core
|
||||
import HBS2.Net.Proto.Types
|
||||
|
||||
|
||||
dialogRoutes :: forall m . MonadIO m => DialogRequestRouter m
|
||||
dialogRoutes = dialogRequestRoutes do
|
||||
|
||||
hand ["ping"] \req -> Right \reply -> do
|
||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0), "pong"])
|
||||
|
||||
hand ["spec"] \req -> Right \reply -> do
|
||||
let xs = Map.keys (unDialogRequestRouter (dialogRoutes @m))
|
||||
|
||||
forM_ (zip (zip [1..] xs) ((True <$ drop 1 xs) <> [False])) \((j,x),isMore) -> do
|
||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus (bool Success200 SuccessMore isMore) "") j)
|
||||
, BS.intercalate "/" x
|
||||
])
|
||||
|
||||
|
||||
hand ["debug", "no-response-header"] \req -> Right \reply -> do
|
||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "one"])
|
||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 1), "two"])
|
||||
reply (Frames [])
|
||||
|
||||
hand ["debug", "wrong-header"] \req -> Right \reply -> do
|
||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "correct-header"])
|
||||
reply (Frames ["wrong-header"])
|
||||
|
||||
hand ["debug", "timeout"] \req -> Right \reply -> do
|
||||
reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessMore "") 0), "false more"])
|
||||
|
||||
|
|
@ -20,6 +20,7 @@ import HBS2.System.Logger.Simple qualified as Log
|
|||
import PeerConfig
|
||||
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Codec.Serialise (serialise,deserialiseOrFail)
|
||||
import Control.Applicative
|
||||
import Control.Concurrent.STM
|
||||
|
|
@ -163,6 +164,7 @@ newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a }
|
|||
, MonadIO
|
||||
, MonadReader RPCEnv
|
||||
, MonadTrans
|
||||
, MonadUnliftIO
|
||||
)
|
||||
|
||||
runRPC :: ( MonadIO m
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@ common common-deps
|
|||
, directory
|
||||
, dns
|
||||
, filepath
|
||||
, generic-lens
|
||||
, hashable
|
||||
, microlens-platform
|
||||
, mtl
|
||||
|
|
@ -68,9 +69,11 @@ common common-deps
|
|||
, http-types
|
||||
, wai-extra
|
||||
, unliftio
|
||||
, unliftio-core
|
||||
, unix
|
||||
, heaps
|
||||
, psqueues
|
||||
, string-conversions
|
||||
|
||||
common shared-properties
|
||||
ghc-options:
|
||||
|
|
@ -108,7 +111,9 @@ common shared-properties
|
|||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, OverloadedLabels
|
||||
, QuasiQuotes
|
||||
, RankNTypes
|
||||
, RecordWildCards
|
||||
, RecursiveDo
|
||||
, ScopedTypeVariables
|
||||
|
|
@ -130,6 +135,8 @@ executable hbs2-peer
|
|||
, EncryptionKeys
|
||||
, Bootstrap
|
||||
, PeerInfo
|
||||
, PeerMain.DialogCliCommand
|
||||
, PeerMain.PeerDialog
|
||||
, PeerMeta
|
||||
, RPC
|
||||
, PeerTypes
|
||||
|
|
|
|||
Loading…
Reference in New Issue