diff --git a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs index 5196a756..cbe1ea4f 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs @@ -1,9 +1,10 @@ {-# Language RankNTypes #-} module HBS2.Net.Proto.BlockChunks where -import HBS2.Prelude.Plated +import HBS2.Events import HBS2.Hash import HBS2.Net.Proto +import HBS2.Prelude.Plated import HBS2.Storage import Data.Word @@ -61,6 +62,15 @@ instance Serialise (BlockChunksProto e) instance Serialise (BlockChunks e) +newtype instance EventKey e (BlockChunks e) = + BlockChunksEventKey (Hash HbSync) + deriving stock (Typeable, Eq) + deriving newtype (Hashable) + +newtype instance Event e (BlockChunks e) = + BlockReady (Hash HbSync) + deriving stock (Typeable) + blockChunksProto :: forall e m . ( MonadIO m , Response e (BlockChunks e) m , Pretty (Peer e) diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index b717f50c..848d6e34 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -93,6 +93,7 @@ type instance SessionData e (BlockChunks e) = BlockDownload newtype instance SessionKey e (BlockChunks e) = DownloadSessionKey (Peer e, Cookie e) deriving stock (Generic,Typeable) + deriving newtype (Hashable) newtype BlockSizeSession e = BlockSizeSession @@ -110,7 +111,7 @@ deriving newtype instance Hashable (SessionKey Fake (BlockChunks Fake)) deriving stock instance Eq (SessionKey Fake (BlockChunks Fake)) runTestPeer :: Peer Fake - -> (SimpleStorage HbSync -> IO ()) + -> (SimpleStorage HbSync -> ChunkWriter HbSync IO -> IO ()) -> IO () runTestPeer p zu = do @@ -128,7 +129,7 @@ runTestPeer p zu = do sw <- liftIO $ async $ simpleStorageWorker stor cw <- liftIO $ async $ runChunkWriter cww - zu stor + zu stor cww simpleStorageStop stor stopChunkWriter cww @@ -158,9 +159,7 @@ blockDownloadLoop :: forall e . ( HasProtocol e (BlockSize e) , Request e (BlockChunks e) (PeerM e IO) , EventListener e (BlockSize e) (PeerM e IO) , Sessions e (BlockSize e) (PeerM e IO) - , Hashable (SessionKey e (BlockChunks e)) - , Typeable (SessionKey e (BlockChunks e)) - , Eq (SessionKey e (BlockChunks e)) + , Sessions e (BlockChunks e) (PeerM e IO) , Num (Peer e) -- , Ord (Peer e) ) => PeerM e IO () @@ -195,17 +194,25 @@ blockDownloadLoop = do pause ( 0.85 :: Timeout 'Seconds ) next +-- NOTE: this is an adapter for a ResponseM monad +-- because response is working in ResponseM monad (ha!) +-- So don't be confused with types +-- mkAdapter :: forall e m . ( m ~ PeerM e IO , HasProtocol e (BlockChunks e) - ) => m (BlockChunksI e (ResponseM e m )) -mkAdapter = do - -- storage <- asks (view _envS + , Hashable (SessionKey e (BlockChunks e)) + , Sessions e (BlockChunks e) (ResponseM e m) + , EventEmitter e (BlockChunks e) m + , Pretty (Peer e) + ) + => ChunkWriter HbSync IO -> m (BlockChunksI e (ResponseM e m )) +mkAdapter cww = do storage <- getStorage pure $ BlockChunksI - { blkSize = hasBlock storage - , blkChunk = getChunk storage - , blkGetHash = \c -> find (DownloadSessionKey c) (view sBlockHash) + { blkSize = liftIO . hasBlock storage + , blkChunk = \h o s -> liftIO (getChunk storage h o s) + , blkGetHash = \c -> find (DownloadSessionKey @e c) (view sBlockHash) -- КАК ТОЛЬКО ПРИНЯЛИ ВСЕ ЧАНКИ (ПРИШЁЛ ПОСЛЕДНИЙ ЧАНК): -- СЧИТАЕМ ХЭШ ТОГО, ЧТО ПОЛУЧИЛОСЬ @@ -277,7 +284,7 @@ main = do let (p0:ps) = [0..1] :: [Peer Fake] -- others - others <- forM ps $ \p -> async $ runTestPeer p $ \s -> do + others <- forM ps $ \p -> async $ runTestPeer p $ \s cw -> do let findBlk = hasBlock s let size = 1024*1024 @@ -291,16 +298,16 @@ main = do debug $ "I'm" <+> pretty p <+> pretty root runPeerM (AnyStorage s) fake p $ do - adapter <- mkAdapter + adapter <- mkAdapter cw runProto @Fake [ makeResponse (blockSizeProto findBlk dontHandle) , makeResponse (blockChunksProto adapter) ] - our <- async $ runTestPeer p0 $ \s -> do + our <- async $ runTestPeer p0 $ \s cw -> do let blk = hasBlock s runPeerM (AnyStorage s) fake p0 $ do - adapter <- mkAdapter + adapter <- mkAdapter cw env <- ask as <- liftIO $ async $ withPeerM env blockDownloadLoop