From e0efd2ac1d8b1eb7eeeecfbcc934f86e81fc8d79 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Sun, 22 Jan 2023 06:06:26 +0300
Subject: [PATCH] wip

---
 hbs2-core/hbs2-core.cabal                |  1 +
 hbs2-core/lib/HBS2/Events.hs             | 38 ++++++++++++++++++++++++
 hbs2-core/lib/HBS2/Net/Proto/Sessions.hs | 16 ++--------
 hbs2-tests/test/Peer2Main.hs             | 12 ++++++++
 4 files changed, 54 insertions(+), 13 deletions(-)
 create mode 100644 hbs2-core/lib/HBS2/Events.hs

diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal
index 64fb9160..b23d3258 100644
--- a/hbs2-core/hbs2-core.cabal
+++ b/hbs2-core/hbs2-core.cabal
@@ -71,6 +71,7 @@ library
                     , HBS2.Data.Types
                     , HBS2.Data.Types.Refs
                     , HBS2.Defaults
+                    , HBS2.Events
                     , HBS2.Hash
                     , HBS2.Merkle
                     , HBS2.Net.Messaging
diff --git a/hbs2-core/lib/HBS2/Events.hs b/hbs2-core/lib/HBS2/Events.hs
new file mode 100644
index 00000000..b1ad8ca6
--- /dev/null
+++ b/hbs2-core/lib/HBS2/Events.hs
@@ -0,0 +1,38 @@
+{-# Language FunctionalDependencies #-}
+module HBS2.Events where
+
+import Data.Kind
+
+
+-- General Events class.
+--
+-- It's may be way too general.
+--
+-- e is an 'engine' or 'program' or whatever.
+-- If we will not introduce 'e' type,
+-- there will be only one type of event
+-- per "protocol" (a ) or a any concrete type per program.
+--
+-- Assume we need different type of event for testing
+-- purposes and for production or so on.
+--
+-- For this situation we introduce 'e', that
+-- allow us to do so.
+--
+-- In our case, e corresponds to an 'engine' that is
+-- a concrete network fabrique implementations (UDP, TCP, whatever)
+-- that could be implemented with 'e'.
+--
+-- And 'a' is corresponding to a concrete sub-protocol.
+--
+-- I suspect that 'e' has a global meaning and
+-- represent an 'interpreter'.
+
+class Monad m => HasEvents e a m | a -> e where
+
+  data family EventKey e a :: Type
+  type family Event e a    :: Type
+
+  subscribe  :: EventKey e a -> Event e a -> m ()
+
+
diff --git a/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs b/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs
index 681cdcc9..42186a24 100644
--- a/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs
+++ b/hbs2-core/lib/HBS2/Net/Proto/Sessions.hs
@@ -28,17 +28,6 @@ instance Eq SKey where
   (==) (SKey p1 a) (SKey p2 b) = unKey p1 a == unKey p1 b
 
 
--- we probably can not separate sessions
--- by sub-protocol types without
--- really crazy types.
---
--- And if we really need this, it may be done
--- by injecting a protocol type into 'e' or
--- introducing a common ADT for all session types
--- for common 'e' i.e. 'engine' or 'transport'
---
--- So it is that it is.
-
 data family SessionKey  e p :: Type
 type family SessionData e p :: Type
 
@@ -52,8 +41,9 @@ class ( Monad m
 
 
 
-  -- | Session fetch function.
-  -- | It will insert a new session, if default value is Just something.
+  -- | Session find function.
+  -- | It is useful when we want to check if session even
+  -- | exists and it will not start a new session.
 
   find :: SessionKey e p           -- ^ session key
        -> (SessionData e p -> a)  -- ^ modification function, i.e. lens
diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs
index 83a5e705..c86db5e5 100644
--- a/hbs2-tests/test/Peer2Main.hs
+++ b/hbs2-tests/test/Peer2Main.hs
@@ -7,6 +7,7 @@ module Main where
 import HBS2.Actors.ChunkWriter
 import HBS2.Actors.Peer
 import HBS2.Clock
+import HBS2.Events
 import HBS2.Hash
 import HBS2.Net.Messaging.Fake
 import HBS2.Net.Proto
@@ -144,13 +145,24 @@ handleBlockInfo (p, h, sz') = do
     -- lift $ runEngineM env $ emitBlockSizeEvent ev h (p, h, Just sz) -- TODO: fix this crazy shit
 
 
+instance HasEvents Fake (BlockSize Fake) (PeerM Fake IO) where
+  data instance EventKey Fake (BlockSize Fake) = BlockSizeEvent ()
+  type instance Event Fake (BlockSize Fake) = ()
+
+  subscribe = undefined
+
 blockDownloadLoop :: forall e . ( HasProtocol e (BlockSize e)
                                 , Request e (BlockSize e) (PeerM e IO)
+                                , HasEvents e (BlockSize e) (PeerM e IO)
                                 , Num (Peer e)
                                 ) =>  PeerM e IO ()
 blockDownloadLoop = do
 
   -- w <- subscribe ???
+  --
+
+  -- subscribe @(GetBlockSize e) $ \(p,h,i) -> do
+  --   debug "WE GOT BLOCK!"
 
   request 1 (GetBlockSize @e "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt")
   request 1 (GetBlockSize @e "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ")