From eaa2c41827a52eb767fce8b908a09b62af951251 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 27 Jan 2023 07:04:54 +0300 Subject: [PATCH] removed bytestring pinning from Peer --- flake.nix | 4 +-- hbs2-core/lib/HBS2/Actors/Peer.hs | 42 ++++++++---------------- hbs2-core/lib/HBS2/Net/Messaging/Fake.hs | 2 +- hbs2-tests/test/Peer2Main.hs | 30 +++++++++-------- 4 files changed, 33 insertions(+), 45 deletions(-) diff --git a/flake.nix b/flake.nix index bb194719..619deb98 100644 --- a/flake.nix +++ b/flake.nix @@ -33,8 +33,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: packagePostOverrides = { pkgs }: with pkgs; with haskell.lib; [ - enableExecutableProfiling - enableLibraryProfiling + disableExecutableProfiling + disableLibraryProfiling dontBenchmark dontCoverage dontDistribute diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 2eb2e9db..831875fa 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -17,7 +17,6 @@ import HBS2.Prelude.Plated import HBS2.Storage import Control.Monad.Trans.Maybe -import Codec.Serialise hiding (encode,decode) import Control.Concurrent.Async import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) @@ -47,6 +46,9 @@ instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString) getChunk (AnyStorage s) = getChunk s hasBlock (AnyStorage s) = hasBlock s +data AnyMessage e = AnyMessage Integer (Encoded e) + deriving stock (Generic) + class Monad m => HasOwnPeer e m where ownPeer :: m (Peer e) @@ -56,20 +58,15 @@ class Monad m => HasPeerLocator e m where class HasStorage m where getStorage :: m AnyStorage -data Fabriq e = forall bus . (Serialise (Encoded e), Messaging bus e ByteString) => Fabriq bus +data Fabriq e = forall bus . (Messaging bus e (AnyMessage e)) => Fabriq bus class HasFabriq e m where getFabriq :: m (Fabriq e) -instance HasPeer e => Messaging (Fabriq e) e ByteString where +instance (HasPeer e) => Messaging (Fabriq e) e (AnyMessage e) where sendTo (Fabriq bus) = sendTo bus receive (Fabriq bus) = receive bus -data AnyMessage e = AnyMessage Integer (Encoded e) - deriving stock (Generic) - -instance Serialise (Encoded e) => Serialise (AnyMessage e) - data AnyProtocol e m = forall p . ( HasProtocol e p , Response e p m @@ -197,14 +194,13 @@ instance ( MonadIO m instance ( MonadIO m , HasProtocol e p , HasFabriq e (PeerM e m) - , Serialise (Encoded e) ) => Request e p (PeerM e m) where request p msg = do let proto = protoId @e @p (Proxy @p) pipe <- getFabriq @e me <- ownPeer @e - let bs = serialise (AnyMessage @e proto (encode msg)) - sendTo pipe (To p) (From me) bs + sendTo pipe (To p) (From me) (AnyMessage @e proto (encode msg)) + instance ( HasProtocol e p , Typeable (EventHandler e p (PeerM e IO)) @@ -320,7 +316,6 @@ runProto :: forall e m . ( MonadIO m , HasOwnPeer e m , HasFabriq e m , HasPeer e - , Serialise (Encoded e) ) => [AnyProtocol e (ResponseM e m)] -> m () @@ -337,23 +332,16 @@ runProto hh = do messages <- receive pipe (To me) - for_ messages $ \(From pip, bs) -> do + for_ messages $ \(From pip, AnyMessage n msg) -> do - case deserialiseOrFail @(AnyMessage e) bs of + case Map.lookup n disp of + Nothing -> pure () - Left _-> pure () - - Right (AnyMessage n msg) -> do - - case Map.lookup n disp of - Nothing -> pure () - - Just (AnyProtocol { protoDecode = decoder - , handle = h - }) -> maybe (pure ()) (runResponseM pip . h) (decoder msg) + Just (AnyProtocol { protoDecode = decoder + , handle = h + }) -> maybe (pure ()) (runResponseM pip . h) (decoder msg) instance ( HasProtocol e p - , Serialise (Encoded e) , MonadTrans (ResponseM e) , HasStorage (PeerM e IO) , Pretty (Peer e) @@ -372,9 +360,7 @@ instance ( HasProtocol e p who <- asks (view answTo) self <- lift $ ownPeer @e fab <- lift $ getFabriq @e - let bs = serialise (AnyMessage @e proto (encode msg)) - sendTo fab (To who) (From self) bs - + sendTo fab (To who) (From self) (AnyMessage @e proto (encode msg)) instance ( MonadIO m , HasProtocol e p diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs index 75ae0212..a25f5ba9 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Fake.hs @@ -52,7 +52,7 @@ instance ( (HasPeer proto, Hashable (Peer proto)) atomically $ Chan.writeTChan chan (who, msg) receive bus (To me) = liftIO do - readChan =<< getChan bus me -- Cache.fetchWithCache (fakeP2p bus) me (const newTChanIO) + readChan =<< getChan bus me where readChan | blocking bus = atomically . (List.singleton <$>) . Chan.readTChan diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index 5ada7a53..c8382c8b 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -55,6 +55,8 @@ import Data.Hashable import Type.Reflection import Data.Fixed +import Data.Dynamic + import System.Random.MWC import qualified Data.Vector.Unboxed as U @@ -93,9 +95,9 @@ instance Pretty (Peer Fake) where instance HasProtocol Fake (BlockInfo Fake) where type instance ProtocolId (BlockInfo Fake) = 1 - type instance Encoded Fake = ByteString - decode = either (const Nothing) Just . deserialiseOrFail - encode = serialise + type instance Encoded Fake = Dynamic + decode = fromDynamic + encode = toDyn -- FIXME: 3 is for debug only! instance Expires (EventKey Fake (BlockInfo Fake)) where @@ -109,16 +111,15 @@ instance Expires (EventKey Fake (BlockAnnounce Fake)) where instance HasProtocol Fake (BlockChunks Fake) where type instance ProtocolId (BlockChunks Fake) = 2 - type instance Encoded Fake = ByteString - decode = either (const Nothing) Just . deserialiseOrFail - encode = serialise + type instance Encoded Fake = Dynamic + decode = fromDynamic + encode = toDyn instance HasProtocol Fake (BlockAnnounce Fake) where type instance ProtocolId (BlockAnnounce Fake) = 3 - type instance Encoded Fake = ByteString - decode = either (const Nothing) Just . deserialiseOrFail - encode = serialise - + type instance Encoded Fake = Dynamic + decode = fromDynamic + encode = toDyn type instance SessionData e (BlockInfo e) = BlockSizeSession e type instance SessionData e (BlockChunks e) = BlockDownload @@ -223,9 +224,9 @@ instance Typeable (SessionKey e (Stats e)) => Hashable (SessionKey e (Stats e)) instance HasProtocol Fake (Stats Fake) where type instance ProtocolId (Stats Fake) = 0xFFFFFFFE - type instance Encoded Fake = ByteString - decode = either (const Nothing) Just . deserialiseOrFail - encode = serialise + type instance Encoded Fake = Dynamic + decode = fromDynamic + encode = toDyn newtype Speed = Speed (Fixed E1) deriving newtype (Ord, Eq, Num, Real, Fractional, Show) @@ -265,7 +266,7 @@ updateStats updTime blknum = do blockDownloadLoop :: forall e m . ( m ~ PeerM e IO -- , e ~ Fake - , Serialise (Encoded e) + -- , Serialise (Encoded e) , MonadIO m , Request e (BlockInfo e) m , Request e (BlockAnnounce e) m @@ -283,6 +284,7 @@ blockDownloadLoop :: forall e m . ( m ~ PeerM e IO , Num (Peer e) , Pretty (Peer e) , Block ByteString ~ ByteString + -- , Encoded e ~ ByteString -- , Key HbSync ~ Hash HbSync ) => ChunkWriter HbSync IO -> m ()