From bcb488797461a841dac0298f9e87556503ff337f Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Wed, 18 Jan 2023 12:34:26 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Defaults.hs | 3 ++- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 9 +++++++-- hbs2-core/lib/HBS2/Storage.hs | 2 +- hbs2-tests/test/Main.hs | 25 ++++++++++++++----------- 4 files changed, 24 insertions(+), 15 deletions(-) diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index a58cc3fb..33fc1a9d 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -3,7 +3,8 @@ module HBS2.Defaults where import HBS2.Clock import Data.String -defChunkSize :: Integer +-- defChunkSize :: Integer +defChunkSize :: Integral a => a defChunkSize = 500 defBlockSize :: Integer diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 6e27b79e..faf5b448 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -13,8 +13,13 @@ import Control.Monad.IO.Class -- e -> Transport (like, UDP or TChan) -- p -> L4 Protocol (like Ping/Pong) -class HasCookie p where - type family Cookie p :: Type + +class HasCookie e p | p -> e where + type family Cookie e :: Type + getCookie :: p -> Maybe (Cookie e) + getCookie = const Nothing + +data WithCookie e p = WithCookie (Cookie e) p class (Hashable (Peer e), Eq (Peer e)) => HasPeer e where data family (Peer e) :: Type diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 6c926098..7e93494f 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/hbs2-core/lib/HBS2/Storage.hs @@ -11,7 +11,7 @@ import Prettyprinter class Pretty (Hash h) => IsKey h where - type Key h :: Type + type family Key h :: Type instance Key HbSync ~ Hash HbSync => IsKey HbSync where type instance Key HbSync = Hash HbSync diff --git a/hbs2-tests/test/Main.hs b/hbs2-tests/test/Main.hs index 9c16b24c..d2303419 100644 --- a/hbs2-tests/test/Main.hs +++ b/hbs2-tests/test/Main.hs @@ -52,29 +52,32 @@ newtype ChunkNum = ChunkNum Word16 type GetBlockChunk h = forall m . MonadIO m => Hash h -> Offset -> Size -> m (Maybe ByteString) -type MyCookie e = Cookie (BlockChunks e) data BlockChunksI e m = BlockChunksI { blkSize :: GetBlockSize HbSync m , blkChunk :: GetBlockChunk HbSync - , blkGetHash :: MyCookie e -> m (Maybe (Hash HbSync)) + , blkGetHash :: Cookie e -> m (Maybe (Hash HbSync)) , blkAcceptChunk :: (Hash HbSync, ChunkNum, ByteString) -> m () } -data BlockChunks e = BlockGetAllChunks (MyCookie e) (Hash HbSync) ChunkSize - | BlockNoChunks (MyCookie e) - | BlockChunk (MyCookie e) ChunkNum ByteString - | BlockLost (MyCookie e) + +instance HasCookie e (BlockChunks e) where + type instance Cookie e = Word32 + +data BlockChunks e = BlockGetAllChunks (Cookie e) (Hash HbSync) ChunkSize + | BlockNoChunks (Cookie e) + | BlockChunk (Cookie e) ChunkNum ByteString + | BlockLost (Cookie e) deriving stock (Generic) -instance HasCookie (BlockChunks e) where - type instance Cookie (BlockChunks e) = Word32 - instance Serialise ChunkSize instance Serialise ChunkNum instance Serialise (BlockChunks e) +-- instance Serialise (MyCookie e) +-- instance Serialise (Cookie e (BlockChunks e)) + blockChunksProto :: forall e m . ( MonadIO m , Response e (BlockChunks e) m @@ -179,7 +182,7 @@ runFakePeer env = do let handleBlockInfo (p, h, sz) = do debug $ pretty p <+> "has block" <+> pretty h <+> pretty sz - blkCookies <- Cache.newCache @(Cookie (BlockChunks e)) @(Hash HbSync) (Just defCookieTimeout) + blkCookies <- Cache.newCache @(Cookie e) @(Hash HbSync) (Just defCookieTimeout) let adapter = BlockChunksI @@ -234,7 +237,7 @@ test1 = do -- ОТСЮДА СЛЕДУЕТ: Cookie должны жить в Engine и быть там доступны -- В монаде Response тоже должна быть кука -- - -- Как быть с тем, что кука может не поддерживаться подпортоколом? + -- Как быть с тем, что кука может не поддерживаться подпротоколом? -- Требовать HasCookie у всех? pause ( 0.5 :: Timeout 'Seconds)