mirror of https://github.com/voidlizard/hbs2
443 lines
13 KiB
Haskell
443 lines
13 KiB
Haskell
{-# 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
|
|
|