wip

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

@@ -40,7 +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)
+  , _sessions  :: ()
   , bus        :: bus
   , defer      :: Pipeline IO ()
   }
@@ -114,24 +114,23 @@ instance (MonadIO m, HasProtocol e p) => Request e p (EngineM e m) where
 
 
 instance ( MonadIO m
-         , Eq (SessionKey e)
+         , HasProtocol e p
-         , Hashable (SessionKey e)
+         ) => Sessions e p (EngineM e m) where
-         ) => Sessions e (EngineM e m) where
 
-  fetch upd def k fn  = do
+  fetch upd def k fn  = undefined
-    se <- asks (view sessions)
+    -- se <- asks (view sessions)
-    w <- liftIO $ Cache.fetchWithCache se k (const $ pure def)
+    -- w <- liftIO $ Cache.fetchWithCache se k (const $ pure def)
-    when upd (liftIO $ Cache.insert se k def)
+    -- when upd (liftIO $ Cache.insert se k def)
-    pure (fn w)
+    -- pure (fn w)
 
-  update def k f = do
+  update def k f = undefined
-    se <- asks (view sessions)
+    -- se <- asks (view sessions)
-    w <- liftIO $ Cache.fetchWithCache se k (const $ pure def)
+    -- w <- liftIO $ Cache.fetchWithCache se k (const $ pure def)
-    liftIO $ Cache.insert se k (f w)
+    -- liftIO $ Cache.insert se k (f w)
 
-  expire k = do
+  expire k = undefined
-    se <- asks (view sessions)
+    -- se <- asks (view sessions)
-    liftIO $ Cache.delete se k
+    -- liftIO $ Cache.delete se k
 
 instance (HasProtocol e p, Serialise (Encoded e)) => Response e p (ResponseM e IO) where
 
@@ -164,7 +163,8 @@ newEnv :: forall e bus m . ( Monad m
 
 newEnv p pipe = do
   de <- liftIO $ newPipeline defProtoPipelineSize
-  se <- liftIO $ Cache.newCache (Just defCookieTimeout) -- FIXME: some more clever for timeout, i.e. typeclass
+  let se = ()
+  -- 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

@@ -48,32 +48,33 @@ class Request e p (m :: Type -> Type) | p -> e where
 --
 -- So it is that it is.
 
-data family SessionKey  e :: Type
+data family SessionKey  e p :: Type
-data family SessionData e :: Type
+data family SessionData e p :: Type
 
 class ( Monad m
-      , Eq (SessionKey e)
+      , HasProtocol e p
-      ) => Sessions e m  where
+      ) => Sessions e p m  | p -> e where
+
 
   -- | Session fetch function.
   -- | It will insert a new session, if default value is Just something.
 
-  fetch  :: Bool                   -- ^ do add new session if not exists
+  fetch  :: Bool                     -- ^ do add new session if not exists
-         -> SessionData e          -- ^ default value in case it's not found
+         -> SessionData e p          -- ^ default value in case it's not found
-         -> SessionKey e           -- ^ session key
+         -> SessionKey e p           -- ^ session key
-         -> (SessionData e -> a )  -- ^ modification function, i.e. lens
+         -> (SessionData e p -> a )  -- ^ modification function, i.e. lens
          -> m a
 
   -- | 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
+  update :: SessionData e p                      -- ^ default value in case it's not found
-         -> SessionKey e                     -- ^ session key
+         -> SessionKey e p                       -- ^ session key
-         -> (SessionData e -> SessionData e) -- ^ modification function, i.e. lens
+         -> (SessionData e p -> SessionData e p) -- ^ modification function, i.e. lens
          -> m ()
 
-  expire :: SessionKey e -> m ()
+  expire :: SessionKey e p -> m ()
 
 class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e  where
   type family ProtocolId p = (id :: Nat) | id -> p

hbs2-tests/hbs2-tests.cabal

@@ -16,6 +16,31 @@ extra-doc-files:    CHANGELOG.md
 common warnings
     ghc-options: -Wall
 
+common common-deps
+    build-depends:
+          base ^>=4.15.1.0, hbs2-core, hbs2-storage-simple
+        , async
+        , bytestring
+        , cache
+        , containers
+        , directory
+        , filepath
+        , hashable
+        , microlens-platform
+        , mtl
+        , prettyprinter
+        , QuickCheck
+        , random
+        , safe
+        , serialise
+        , stm
+        , streaming
+        , tasty
+        , tasty-hunit
+        , transformers
+        , uniplate
+        , vector
+
 common shared-properties
   ghc-options:
         -Wall
@@ -59,8 +84,9 @@ common shared-properties
                      , TypeFamilies
 
 
-test-suite test
+test-suite test-peer
     import:           shared-properties
+    import:           common-deps
     default-language: Haskell2010
 
     other-modules:
@@ -69,30 +95,8 @@ test-suite test
 
     type:             exitcode-stdio-1.0
     hs-source-dirs:   test
-    main-is:          Main.hs
+    main-is:          PeerMain.hs
-    build-depends:
+
-          base ^>=4.15.1.0, hbs2-core, hbs2-storage-simple
-        , async
-        , bytestring
-        , cache
-        , containers
-        , directory
-        , filepath
-        , hashable
-        , microlens-platform
-        , mtl
-        , prettyprinter
-        , QuickCheck
-        , random
-        , safe
-        , serialise
-        , stm
-        , streaming
-        , tasty
-        , tasty-hunit
-        , transformers
-        , uniplate
-        , vector
 
 
 

hbs2-tests/test/PeerMain.hs

@@ -160,16 +160,6 @@ expireSession se l = liftIO do
 -- 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 }