so far so good

hbs2-core/hbs2-core.cabal

@@ -120,6 +120,7 @@ test-suite test
                   , TestActors
                   , TestBlockInfoActor
                   , TestAbstractDispatch
+                  , FakeMessaging
 
     -- other-extensions:
 
@@ -130,6 +131,7 @@ test-suite test
           base ^>=4.15.1.0, hbs2-core
         , async
         , bytestring
+        , cache
         , containers
         , hashable
         , microlens-platform

hbs2-core/lib/HBS2/Net/Messaging.hs

@@ -16,4 +16,5 @@ class IsPeer addr => Messaging bus addr msg  | bus -> addr, bus -> msg where
 
 
 
+-- data AnyMessaging p m = forall bus . Messaging bus (Peer p)
 

hbs2-core/test/TestAbstractDispatch.hs

@@ -1,34 +1,45 @@
+{-# Language FunctionalDependencies #-}
 module TestAbstractDispatch where
 
-
 import HBS2.Prelude
--- import HBS2.Net.Messaging
+import HBS2.Net.Proto
+import HBS2.Net.Messaging
+import HBS2.Clock
 
-import Data.Maybe
+import Data.Foldable
-import Data.ByteString (ByteString)
+import Data.Functor
--- concrete type or typeclass ?
+import Data.Function
+import Data.Cache (Cache)
+import Data.Cache qualified as Cache
 import Data.Kind
-import Data.Word
+import Data.Hashable
-import Data.Map (Map)
+import Data.Proxy
-import Data.Map qualified as Map
--- import Data.Proxy
 
-newtype Cookie = Cookie Word32
+import FakeMessaging
-                 deriving stock (Eq,Ord)
 
-data MessageWithCookie = MessageWithCookie Cookie ByteString
+-- newtype Cookie = Cookie Word32
+--                  deriving stock (Eq,Ord)
+--                  deriving newtype Hashable
 
-class IsMessageWithCookie msg where
+data family Cookie p :: Type
-  encode :: msg -> MessageWithCookie
-  decode :: MessageWithCookie -> Maybe msg
 
+class Monad m => CookieGenerator p m where
+  genCookie :: Hashable s => s -> m (Cookie p)
+
+class Monad m => HasTimeout msg m where
+  timeoutFor :: Proxy msg -> m (Timeout 'Seconds)
+
+-- still okay
+class IsEncoded p msg | msg -> p where
+  data family Encoded  p :: Type
+  encode :: msg -> Encoded p
+  decode :: Encoded p -> Maybe msg
+
+-- still okay
+data MessageWithCookie p = MessageWithCookie (Cookie p) (Encoded p)
 
 -- ЧТО МЫ ХОТИМ:
--- СООБЩЕНИЯ РАЗНЫХ ТИПОВ, ДОБАВЛЯТЬ НЕЗАВИСИМО
+-- СООБЩЕНИЯ РАЗНЫХ ТИПОВ. ОБРАБАТЫВАТЬ НЕЗАВИСИМО, В РАЗНЫХ ОБРАБОТЧИКАХ
---
--- ЗАЧЕМ: ХУЙ ЗНАЕТ НА САМОМ ДЕЛЕ
--- НО, ДОПУСТИМ, ХОТИМ НЕЗАВИСИМЫЕ ОБРАБОТЧИКИ ДЛЯ
--- КАЖДОГО ТИПА СООБЩЕНИЯ
 --
 -- ПОЧЕМУ МЫ ЭТОГО ХОТИМ:
 --
@@ -37,54 +48,73 @@ class IsMessageWithCookie msg where
 --   НАДО СДЕЛАТЬ, ЧТО БЫ МОЖНО БЫЛО ОТЛАДИТЬ ПО КУСКАМ
 --   ТЕМ БОЛЕЕ, ЧТО ОНИ ДРУГ ОТ ДРУГА НЕ ЗАВИСЯТ
 --
--- КАК-ТО ОБЕСПЕЧИМ УНИКАЛЬНОСТЬ КУКИ ДЛЯ КАЖДОГО ТИПА
---
---
 
+data Handler p m  = forall msg . IsEncoded p msg =>
+  Handler ( msg -> m () )
 
-data Handler  = forall a . Show a => Handler
+data Fabrique p = forall bus . Messaging bus (Peer p) (MessageWithCookie p)
-                                     { decodeMsg :: ByteString -> Maybe a
+  =>  Fabrique bus
-                                     , dispatch  :: a -> ()
+
+data Dispatcher p m =
+  Dispatcher
+  { self     :: Peer p
+  , handlers :: Cache (Cookie p) (Handler p m)
+  , fabriq   :: Fabrique p  -- СЮДОЙ ПИХАТЬ СООБЩЕНИЯ
   }
 
-newtype Dispatcher = Dispatcher { actions :: Map Cookie Handler }
+newDispatcher :: (MonadIO m, (Messaging bus (Peer p) (MessageWithCookie p)))
+              => Peer p
+              -> bus
+              -> m (Dispatcher p m)
 
--- sendRequest :: forall m msg . (MonadIO m, IsEncoded msg, HasCookie msg) => Dispatcher m -> msg  -> m ()
+newDispatcher me bus = do
-sendRequest :: forall m msg . (MonadIO m, IsMessageWithCookie msg) => msg -> m ()
+  let fab = Fabrique bus
-sendRequest msg = do
+  cache <- liftIO $ Cache.newCache Nothing
-  let coockoo = encode msg
+  pure $ Dispatcher me cache fab
-  let wtfmap = mempty :: Map Cookie ()
 
-  -- send (serialize coockoo)
+sendRequest :: forall p msg m. ( MonadIO m
+                               , IsEncoded p msg
+                               , Messaging (Fabrique p) p (MessageWithCookie p)
+                               , Hashable (Cookie p)
+                               , CookieGenerator p m
+                               , HasTimeout msg m
+                               )
+            => Dispatcher p m
+            -> Peer p
+            -> msg
+            -> Handler p m
+            -> m ()
 
-  undefined
+sendRequest d p msg answ = do
+  cookie  <- genCookie p
+  timeout <- timeoutFor (Proxy @msg) <&> Just . toTimeSpec
+  liftIO $ Cache.insert' (handlers d) timeout cookie answ
+  sendTo (fabriq d) (To p) (From (self d)) (MessageWithCookie cookie (encode msg))
 
-dispatcher :: MonadIO m => Dispatcher -> m ()
+dispatcher :: forall p m . ( MonadIO m, Hashable (Cookie p)
-dispatcher d = do
+                           , Messaging (Fabrique p) p (MessageWithCookie p)
-  -- получили нечто
+                           )
-  -- вытащили куку
+           => Dispatcher p m
+           -> m ()
 
-  -- КАК БЛЯДЬ? МЫ НЕ ЗНАЕМ ТУТ, ЧТО ЭТО ЗА СООБЩЕНИЕ. ЭТО ЧТО - ПОЛУДЕКОДИРОВАННОЕ
+dispatcher d = fix \next -> do
-  -- СООБЩЕНИЕ)
+
-  let (MessageWithCookie coo bs)  = undefined :: MessageWithCookie
+  -- FIXME: if receive is non-blocking we'll get a busy loop
+  -- FIXME: if receive is blocking - we'll block here forever
+  received <- receive (fabriq d) (To (self d))
+
+  for_ received $ \(MessageWithCookie coo bs) -> do
 
     -- поискали в мапе по куке
-  let found' = Map.lookup coo (actions d)
+    found <- liftIO $ Cache.lookup (handlers d) coo
-
-  -- нашли обработчик
-  let found = fromJust found'
 
+    case found of
+      Nothing -> pure () -- NO HANDLER FOUND FOR COOKIE CASE
     -- декодировали сообщение и пихнули в обработчик
-  let _ = let (Handler de dispatch) = found in dispatch (fromJust (de bs))
+      Just (Handler dispatch) -> maybe (pure ()) dispatch (decode bs)
+    --                                 ^^^^^^^^^ CAN NOT DECODE CASE
 
-  -- сработало: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  next
-  --
-
-  -- мы не знаем конкретный тип сообщения и нам пох. обработчик обрабатывает,
-  -- мы тут обеспечиваем общий механизм диспечеризации: заводим сессии, ждём
-  -- прибиваем сессии, рулим куками
-
-  undefined
 
 
 testAbstractDispatch :: IO ()

hbs2-core/test/TestFakeMessaging.hs

@@ -15,13 +15,7 @@ import Data.Word
 import Data.Set qualified as Set
 import Data.Map qualified as Map
 
-
+import FakeMessaging
-data Fake
-
-instance IsPeer Fake where
-  newtype instance Peer Fake = FakePeer Int
-                               deriving stock (Eq,Ord,Show)
-                               deriving newtype (Hashable,Num,Enum,Real,Integral)
 
 
 testFakeMessaging1 :: IO ()