From 2b223644a42bb3c0ed08924aee0a4f2191a7cdaa Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 20 Jan 2023 09:14:24 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Actors/Peer.hs | 34 +++++++-------- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 25 +++++------ hbs2-tests/hbs2-tests.cabal | 54 +++++++++++++----------- hbs2-tests/test/{Main.hs => PeerMain.hs} | 10 ----- 4 files changed, 59 insertions(+), 64 deletions(-) rename hbs2-tests/test/{Main.hs => PeerMain.hs} (98%) diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 2be9a6e9..3b034032 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/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) - , Hashable (SessionKey e) - ) => Sessions e (EngineM e m) where + , HasProtocol e p + ) => Sessions e p (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) + fetch upd def k fn = undefined + -- 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) + update def k f = undefined + -- 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 + expire k = undefined + -- se <- asks (view sessions) + -- 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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index a599a812..bc4838ad 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/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 SessionData e :: Type +data family SessionKey e p :: Type +data family SessionData e p :: Type class ( Monad m - , Eq (SessionKey e) - ) => Sessions e m where + , HasProtocol e p + ) => 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 - -> SessionData e -- ^ default value in case it's not found - -> SessionKey e -- ^ session key - -> (SessionData e -> a ) -- ^ modification function, i.e. lens + fetch :: Bool -- ^ do add new session if not exists + -> SessionData e p -- ^ default value in case it's not found + -> SessionKey e p -- ^ session key + -> (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 - -> SessionKey e -- ^ session key - -> (SessionData e -> SessionData e) -- ^ modification function, i.e. lens + update :: SessionData e p -- ^ default value in case it's not found + -> SessionKey e p -- ^ session key + -> (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 diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 69fa1c59..e2ec6398 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/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 - 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 + main-is: PeerMain.hs + diff --git a/hbs2-tests/test/Main.hs b/hbs2-tests/test/PeerMain.hs similarity index 98% rename from hbs2-tests/test/Main.hs rename to hbs2-tests/test/PeerMain.hs index 858cf49d..bb777be5 100644 --- a/hbs2-tests/test/Main.hs +++ b/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 }