diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index fbff8bfe..d2315427 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -66,6 +66,7 @@ library exposed-modules: HBS2.Actors , HBS2.Actors.ChunkWriter + , HBS2.Actors.Peer , HBS2.Clock , HBS2.Data.Types , HBS2.Data.Types.Refs @@ -76,7 +77,6 @@ library , HBS2.Net.Messaging.Fake , HBS2.Net.PeerLocator , HBS2.Net.PeerLocator.Static - , HBS2.Net.Peer , HBS2.Net.Proto , HBS2.Net.Proto.Types , HBS2.Net.Proto.BlockInfo @@ -106,7 +106,9 @@ library , memory , microlens-platform , mtl + , murmur-hash , prettyprinter + , random , safe , serialise , stm diff --git a/hbs2-core/lib/HBS2/Net/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs similarity index 93% rename from hbs2-core/lib/HBS2/Net/Peer.hs rename to hbs2-core/lib/HBS2/Actors/Peer.hs index d2a1ab25..e2e6a920 100644 --- a/hbs2-core/lib/HBS2/Net/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -1,6 +1,6 @@ {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} -module HBS2.Net.Peer where +module HBS2.Actors.Peer where import HBS2.Prelude import HBS2.Prelude.Plated @@ -10,15 +10,19 @@ import HBS2.Clock import HBS2.Actors import HBS2.Defaults -import Lens.Micro.Platform -import Data.ByteString.Lazy ( ByteString ) -import Data.Foldable + +import Control.Concurrent.Async import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.ByteString.Lazy ( ByteString ) +import Data.Digest.Murmur32 +import Data.Foldable +import Data.Hashable +import Data.Kind import Data.Map qualified as Map import GHC.TypeLits -import Control.Monad.Trans.Maybe -import Control.Concurrent.Async -import Data.Kind +import Lens.Micro.Platform +import System.Random qualified as Random import Codec.Serialise hiding (encode,decode) @@ -176,3 +180,10 @@ runPeer env@(EngineEnv {bus = pipe, defer = d}) hh = do , handle = h }) -> maybe (pure ()) (runResponseM env pip . h) (decoder msg) +-- FIXME: slow and dumb +instance {-# OVERLAPPABLE #-} (MonadIO m, Num (Cookie e)) => GenCookie e (EngineM e m) where + genCookie salt = do + r <- liftIO $ Random.randomIO @Int + pure $ fromInteger $ fromIntegral $ asWord32 $ hash32 (hash salt + r) + + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index faf5b448..7a35ae9c 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -1,5 +1,6 @@ {-# Language TypeFamilyDependencies #-} {-# Language FunctionalDependencies #-} +{-# Language AllowAmbiguousTypes #-} module HBS2.Net.Proto.Types ( module HBS2.Net.Proto.Types ) where @@ -13,6 +14,8 @@ import Control.Monad.IO.Class -- e -> Transport (like, UDP or TChan) -- p -> L4 Protocol (like Ping/Pong) +class Monad m => GenCookie e m where + genCookie :: Hashable salt => salt -> m (Cookie e) class HasCookie e p | p -> e where type family Cookie e :: Type diff --git a/hbs2-tests/test/Main.hs b/hbs2-tests/test/Main.hs index 09f54cac..2a864ea4 100644 --- a/hbs2-tests/test/Main.hs +++ b/hbs2-tests/test/Main.hs @@ -1,5 +1,6 @@ {-# Language RankNTypes #-} {-# Language TemplateHaskell #-} +{-# Language AllowAmbiguousTypes #-} module Main where import HBS2.Prelude.Plated @@ -9,7 +10,7 @@ import HBS2.Hash import HBS2.Net.Proto import HBS2.Net.Proto.BlockInfo import HBS2.Net.Messaging.Fake -import HBS2.Net.Peer +import HBS2.Actors.Peer import HBS2.Defaults import HBS2.Storage.Simple @@ -373,15 +374,20 @@ test1 = do runEngineM e0 $ do - let h = fromString "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt" + let h = fromString "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ" -- TODO: #ASAP generate unique cookie!! -- -- FIXME: withAllCrap $ do ... let s0 = (fst . head) ee - let cKey@(_, cookie) = (p1, 0) -- <<~~~ FIXME: generate a good session id! + + newCookie <- genCookie @Fake (p1, h) -- <<~~~ FIXME: generate a good session id! + + let cKey@(_, cookie) = (p1, newCookie) let chsz = defChunkSize + debug $ "new cookie:" <+> pretty cookie + qblk <- liftIO Q.newTQueueIO let onBlockReady bh = do @@ -398,7 +404,6 @@ test1 = do request p0 (GetBlockSize @Fake (fromString "81JeD7LNR6Q7RYfyWBxfjJn1RsWzvegkUXae6FUNgrMZ")) request p0 (GetBlockSize @Fake (fromString "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt")) - -- TODO: #ASAP block ready notification debug $ "REQUEST BLOCK:" <+> pretty h <+> "from" <+> pretty p1 @@ -409,6 +414,14 @@ test1 = do debug $ "BLOCK READY:" <+> pretty blk + -- TODO: смотрим, что за блок + -- если Merkle - то качаем рекурсивно + -- если ссылка - то смотрим, что за ссылка + -- проверяем пруфы + -- качаем рекурсивно + + -- let mbLink = deserialiseOrFail @Merkle obj + pure () mapM_ cancel peerz