mirror of https://github.com/voidlizard/hbs2
106 lines
2.9 KiB
Haskell
106 lines
2.9 KiB
Haskell
{-# Language TypeFamilyDependencies #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module TestUniqProtoId where
|
|
|
|
import HasProtocol
|
|
|
|
import Data.Kind
|
|
import GHC.TypeLits
|
|
import Data.Proxy
|
|
import Data.Map qualified as Map
|
|
import Data.Map (Map)
|
|
import Control.Monad.Reader
|
|
|
|
data AnyProtocol e m = forall p a . ( HasProtocol p a
|
|
, KnownNat (ProtocolId a)
|
|
, Response p a m
|
|
, e ~ Encoded p
|
|
) =>
|
|
AnyProtocol
|
|
{ getProtoId :: Integer
|
|
, protoDecode :: Encoded p -> Maybe a
|
|
, protoEncode :: a -> Encoded p
|
|
, handle :: a -> m ()
|
|
}
|
|
|
|
|
|
data PingPong = Ping Int
|
|
| Pong Int
|
|
|
|
type family Encoding a :: Type
|
|
|
|
data Fake
|
|
|
|
instance HasPeer Fake where
|
|
type instance Peer Fake = Int
|
|
|
|
instance HasProtocol Fake PingPong where
|
|
type instance ProtocolId PingPong = 1
|
|
type instance Encoded Fake = String
|
|
decode = undefined
|
|
encode = undefined
|
|
|
|
class Response e p (m :: Type -> Type) where
|
|
response :: p -> m ()
|
|
|
|
makeResponse :: forall a p t m . ( MonadIO m
|
|
, Response a p (t m)
|
|
, HasProtocol a p
|
|
, KnownNat (ProtocolId p)
|
|
)
|
|
=> (p -> t m ()) -> AnyProtocol (Encoded a) (t m)
|
|
|
|
makeResponse h = AnyProtocol { getProtoId = natVal (Proxy @(ProtocolId p))
|
|
, protoDecode = decode @a
|
|
, protoEncode = encode @a
|
|
, handle = h
|
|
}
|
|
|
|
data EngineEnv = forall p . HasPeer p =>
|
|
EngineEnv
|
|
{ peer :: Maybe (Peer p)
|
|
}
|
|
|
|
newtype EngineM m a = EngineM { fromEngine :: ReaderT EngineEnv m a }
|
|
deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO )
|
|
|
|
runEngineM :: EngineEnv -> EngineM m a -> m a
|
|
runEngineM e f = runReaderT (fromEngine f) e
|
|
|
|
instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where
|
|
response _ = do
|
|
-- TODO: get bus
|
|
-- TODO: encode
|
|
-- TODO: sendTo
|
|
undefined
|
|
|
|
pingPongHandler :: forall a m . (MonadIO m, Response a PingPong m) => PingPong -> m ()
|
|
pingPongHandler =
|
|
\case
|
|
Ping c -> liftIO (print "effect: PING") >> response @a @PingPong (Pong c)
|
|
Pong _ -> liftIO (print "effect: PONG")
|
|
|
|
testUniqiProtoId :: IO ()
|
|
testUniqiProtoId = do
|
|
|
|
let env = EngineEnv @Fake Nothing
|
|
|
|
let pingpong = makeResponse pingPongHandler
|
|
|
|
let decoders = mempty :: Map Integer (AnyProtocol String (EngineM IO))
|
|
let dec = Map.insert 1 pingpong decoders
|
|
|
|
-- TODO: GET MESSAGE
|
|
-- TODO: GET RECIPIENT
|
|
-- TODO: GET PROTO-ID FROM MESSAGE
|
|
|
|
let message = "" :: Encoded Fake
|
|
|
|
-- FIXME: dispatcher!
|
|
case Map.lookup 1 dec of
|
|
Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM env . h) (decoder message)
|
|
Nothing -> pure ()
|
|
|
|
pure ()
|
|
|