mirror of https://github.com/voidlizard/hbs2
146 lines
4.2 KiB
Haskell
146 lines
4.2 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
|
|
module HBS2.Net.Proto.Dialog
|
|
( module HBS2.Net.Proto.Dialog
|
|
, module HBS2.Net.Dialog.Core
|
|
, module HBS2.Net.Dialog.Client
|
|
) where
|
|
|
|
import Codec.Serialise (deserialiseOrFail)
|
|
import Control.Arrow
|
|
import Control.Monad
|
|
import Data.ByteString (ByteString)
|
|
import Data.ByteString.Lazy qualified as BSL
|
|
import Data.Generics.Product.Fields ()
|
|
import Data.Kind
|
|
import Lens.Micro.Platform
|
|
|
|
import HBS2.Data.Types
|
|
import HBS2.Net.Dialog.Client
|
|
import HBS2.Net.Dialog.Core
|
|
import HBS2.Net.Proto
|
|
import HBS2.Prelude.Plated hiding (at)
|
|
|
|
---
|
|
|
|
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
|
|
|
|
---
|
|
|
|
newtype 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 :: Type -> Type) s = DialReqProtoAdapter
|
|
{ dialReqProtoAdapterDApp :: DApp IO
|
|
, dialReqProtoAdapterNT :: Peer e -> forall a . m a -> IO a
|
|
}
|
|
|
|
newtype DialRespProtoAdapter e (m :: Type -> Type) 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 adapter = 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
|
|
|
|
let replyToPeerIO :: Frames -> IO ()
|
|
replyToPeerIO = dialReqProtoAdapterNT adapter peer <$> replyToPeer
|
|
|
|
liftIO $ (dialReqProtoAdapterDApp adapter) frames replyToPeerIO
|
|
|
|
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)
|
|
|