WTF-MTF

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -23,6 +23,8 @@ import Data.Map qualified as Map
 import GHC.TypeLits
 import Lens.Micro.Platform
 import System.Random qualified as Random
+import Data.Cache (Cache)
+import Data.Cache qualified as Cache
 
 import Codec.Serialise hiding (encode,decode)
 
@@ -38,6 +40,7 @@ data EngineEnv e  = forall bus  . ( Messaging bus e ByteString
   EngineEnv
   { _peer      :: Maybe (Peer e)
   , _self      :: Peer e
+  , _sessions  :: Cache (SessionKey e) (SessionData e)
   , bus        :: bus
   , defer      :: Pipeline IO ()
   }
@@ -109,6 +112,27 @@ instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where
         let bs = serialise (AnyMessage @e proto (encode msg))
         liftIO $ sendTo b (To p) (From s) bs
 
+
+instance ( MonadIO m
+         , Eq (SessionKey e)
+         , Hashable (SessionKey e)
+         ) => Sessions e (EngineM e m) where
+
+  fetch upd def k fn  = do
+    se <- asks (view sessions)
+    w <- liftIO $ Cache.fetchWithCache se k (const $ pure def)
+    when upd (liftIO $ Cache.insert se k def)
+    pure (fn w)
+
+  update def k f = do
+    se <- asks (view sessions)
+    w <- liftIO $ Cache.fetchWithCache se k (const $ pure def)
+    liftIO $ Cache.insert se k (f w)
+
+  expire k = do
+    se <- asks (view sessions)
+    liftIO $ Cache.delete se k
+
 instance (HasProtocol e p, Serialise (Encoded e)) => Response e p (ResponseM e IO) where
 
   thatPeer _ = asks (view respPeer)
@@ -140,7 +164,8 @@ newEnv :: forall e bus m . ( Monad m
 
 newEnv p pipe = do
   de <- liftIO $ newPipeline defProtoPipelineSize
-  pure $ EngineEnv Nothing p pipe de
+  se <- liftIO $ Cache.newCache (Just defCookieTimeout) -- FIXME: some more clever for timeout, i.e. typeclass
+  pure $ EngineEnv Nothing p se pipe de
 
 runPeer :: forall e m a . ( MonadIO m
                           )

hbs2-core/lib/HBS2/Net/Proto/Types.hs

@@ -37,23 +37,43 @@ class Request e p (m :: Type -> Type) | p -> e where
   request :: Peer e -> p -> m ()
 
 
-data family SessionKey  p :: Type
-data family SessionData p :: Type
+-- 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 :: Type
+data family SessionData e :: Type
 
 class ( Monad m
-      , HasProtocol e p
-      , Eq (SessionKey p)
-      ) => Sessions e p m | p -> e where
+      , Eq (SessionKey e)
+      ) => Sessions e m  where
 
-  fetch  :: SessionData p          -- ^ default value in case it's not found
-         -> SessionKey p           -- ^ session key
-         -> (SessionData p -> a )  -- ^ modification function, i.e. lens
+  -- | Session fetch function.
+  -- | It will insert a new session, if default value is Just something.
+
+  fetch  :: Bool                   -- ^ do add new session if not exists
+         -> SessionData e          -- ^ default value in case it's not found
+         -> SessionKey e           -- ^ session key
+         -> (SessionData e -> a )  -- ^ modification function, i.e. lens
          -> m a
 
-  update :: SessionKey p                      -- ^ session key
-         -> (SessionData p -> SessionData p)  -- ^ modification function, i.e. lens
+  -- | Session update function
+  -- | If will create a new session if it does not exist.
+  -- | A modified value (or default) value will we saved.
+
+  update :: SessionData e                    -- ^ default value in case it's not found
+         -> SessionKey e                     -- ^ session key
+         -> (SessionData e -> SessionData e) -- ^ modification function, i.e. lens
          -> m ()
 
+  expire :: SessionKey e -> m ()
 
 class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e  where
   type family ProtocolId p = (id :: Nat) | id -> p

hbs2-tests/test/Main.hs

@@ -157,6 +157,19 @@ delSession se l k = liftIO do
 expireSession se l = liftIO do
   Cache.purgeExpired (view l se)
 
+-- A questionable FIX to avoid "orphans" complains
+data Adapted e = Adapted
+
+data instance SessionKey (Adapted e) =
+    PeerKeyBlock  (Hash HbSync)
+  | PeerKeyCookie (Cookie e)
+  deriving stock (Eq,Generic)
+
+
+data instance SessionData (Adapted e) = PeerSession
+
+instance Hashable (SessionKey (Adapted e))
+
 
 -- newtype FullPeerM m a = RealPeerM { fromRealPeerM :: ReaderT }