wip

hbs2-core/hbs2-core.cabal

@@ -120,7 +120,9 @@ test-suite test
                   , TestActors
                   , TestBlockInfoActor
                   , TestAbstractDispatch
+                  , TestUniqProtoId
                   , FakeMessaging
+                  , HasProtocol
 
     -- other-extensions:
 

hbs2-core/test/HasProtocol.hs

@@ -0,0 +1,16 @@
+{-# Language TypeFamilyDependencies  #-}
+module HasProtocol where
+
+import Data.Kind
+import Data.Proxy
+import GHC.TypeLits
+
+class HasProtocol a where
+  type family ProtocolId  a = (id :: Nat) | id -> a
+  type family Encoded a :: Type
+
+  protoId :: forall . KnownNat (ProtocolId a) => Proxy a -> Integer
+  protoId _ = natVal (Proxy @(ProtocolId a))
+
+  decode :: String -> Maybe a
+  encode :: a -> String

hbs2-core/test/TestAbstractDispatch.hs

@@ -20,8 +20,8 @@ import Data.Word
 import Data.Dynamic
 import Prettyprinter
 import System.Random qualified as Random
-import GHC.TypeLits
+-- import GHC.TypeLits
-import Data.Maybe
+-- import Data.Maybe
 
 import Debug.Trace
 
@@ -31,6 +31,8 @@ import FakeMessaging
 --                  deriving stock (Eq,Ord)
 --                  deriving newtype Hashable
 
+data family SessionType p :: Type
+
 data family Cookie p :: Type
 
 class Monad m => CookieGenerator p m where
@@ -42,7 +44,6 @@ class Monad m => HasTimeout msg m where
 class HasCookie p msg | msg -> p where
   getCookie :: msg -> Maybe (Cookie p)
 
-
 data DefAnswer p = forall msg . (IsEncoded p msg) => DefAnswer msg
 
 class HasDefAnswer p a | p -> a where
@@ -156,6 +157,10 @@ data PingPong p = Ping
                 | Pong
                 deriving stock (Typeable)
 
+data instance SessionType Fake =
+  PingPongSession
+  deriving stock (Eq,Ord,Enum)
+
 newtype instance Cookie Fake = CookieFake Word32
                                deriving stock (Eq)
                                deriving newtype (Hashable,Num,Pretty)
@@ -180,7 +185,7 @@ instance HasTimeout (PingPong Fake) IO where
   timeoutFor _ = pure 1
 
 instance HasDefAnswer Fake (Cookie Fake) where
-  defAnswer _ = let _ = trace "ATTEMPT TO SEND DEF ANSWER" in DefAnswer (Pong @Fake)
+  defAnswer _ = DefAnswer (Pong @Fake)
 
 testAbstractDispatch :: IO ()
 testAbstractDispatch = do

hbs2-core/test/TestUniqProtoId.hs

@@ -0,0 +1,110 @@
+{-# 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
+import Control.Monad.Identity
+
+data ProtocolA = ProtocolA
+
+data ProtocolB = ProtocolB
+
+instance HasProtocol ProtocolA where
+  type instance ProtocolId ProtocolA = 1
+  type instance Encoded ProtocolA = String
+  decode = undefined
+  encode = undefined
+
+
+instance HasProtocol ProtocolB where
+  type instance ProtocolId ProtocolB = 2
+  type instance Encoded ProtocolB = String
+  decode = undefined
+  encode = undefined
+
+-- class Response p (m :: Type -> Type) where
+--   answer :: p -> m ()
+
+data AnyProtocol m = forall a . ( HasProtocol a
+                                , KnownNat (ProtocolId a)
+                                , Response a m
+                                ) =>
+  AnyProtocol
+  { getProtoId  :: Integer
+  , protoDecode :: String -> Maybe a
+  , protoEncode :: a -> String
+  , handle      :: a -> m ()
+  }
+
+
+data PingPong = Ping Int
+              | Pong Int
+
+
+instance HasProtocol PingPong where
+  type instance ProtocolId PingPong = 3
+  type instance Encoded PingPong = PingPong
+  decode = undefined
+  encode = undefined
+
+
+class Response p (m :: Type -> Type) where
+  answer :: p -> m ()
+
+anyProtocol :: forall p  m   . ( MonadIO m
+                               , Response p m
+                               , HasProtocol p
+                               , KnownNat (ProtocolId p)
+                               )
+            => (p -> m ()) -> AnyProtocol m
+
+anyProtocol h = AnyProtocol { getProtoId  = natVal (Proxy @(ProtocolId p))
+                            , protoDecode = decode @p
+                            , protoEncode = encode @p
+                            , handle = h
+                            }
+
+
+newtype EngineM m a = EngineM { fromEngine :: ReaderT () m a }
+                      deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO )
+
+runEngineM :: EngineM m a -> m a
+runEngineM f = runReaderT (fromEngine f) ()
+
+instance (Monad m, HasProtocol p) => Response p m where
+  answer = undefined
+
+
+testUniqiProtoId :: IO ()
+testUniqiProtoId = do
+
+  let decoders = mempty :: Map Integer (AnyProtocol (EngineM IO))
+
+  -- TODO: GET MESSAGE
+  -- TODO: GET RECIPIENT
+  -- TODO: GET PROTO-ID FROM MESSAGE
+
+  let pingpong = anyProtocol @PingPong @(EngineM IO)
+        \case
+          Ping c -> lift (print "effect: PING") >> answer (Pong c)
+          Pong _ -> lift (print "effect: PONG")
+
+
+  -- FIXME: dispatcher!
+  case Map.lookup 3 decoders of
+    Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM . h) (decoder "AAA")
+    Nothing -> pure ()
+
+  -- let qq = natVal (Proxy @(ProtocolId ProtocolA))
+
+  pure ()
+
+
+