diff --git a/hbs2-core/lib/HBS2/Hash.hs b/hbs2-core/lib/HBS2/Hash.hs index 1d5dc04c..c6c9fd27 100644 --- a/hbs2-core/lib/HBS2/Hash.hs +++ b/hbs2-core/lib/HBS2/Hash.hs @@ -1,6 +1,6 @@ {-# Language RankNTypes #-} module HBS2.Hash - ( Serialise(..) + ( Serialise , module HBS2.Hash ) where diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index f169b8f2..2965d814 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -96,7 +96,7 @@ test-suite test-peer type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: PeerMain.hs + main-is: Peer2Main.hs test-suite test-hmap diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs new file mode 100644 index 00000000..8f03a4b4 --- /dev/null +++ b/hbs2-tests/test/Peer2Main.hs @@ -0,0 +1,177 @@ +{-# Language TemplateHaskell #-} +{-# Language UndecidableInstances #-} +{-# Language RankNTypes #-} +{-# Language AllowAmbiguousTypes #-} +module Main where + +import HBS2.Prelude.Plated +import HBS2.Hash +import HBS2.Storage +import HBS2.Net.Proto +import HBS2.Net.Proto.BlockChunks +import HBS2.Net.Proto.BlockInfo +import HBS2.Net.Messaging + +import Control.Monad.Reader +import Data.Foldable +import Control.Monad +import Codec.Serialise hiding (encode,decode) +import Data.ByteString.Lazy (ByteString) +import Data.Default +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Word +import GHC.TypeLits +import Lens.Micro.Platform +import Prettyprinter + +data Fake + +data BlockDownload = + BlockDownload + { _sBlockHash :: Hash HbSync + , _sBlockSize :: Size + , _sBlockChunkSize :: ChunkSize + , _sBlockOffset :: Offset + , _sBlockWritten :: Size + } + +makeLenses 'BlockDownload + + +instance HasPeer Fake where + newtype instance Peer Fake = FakePeer Word8 + deriving newtype (Hashable,Num,Enum,Real,Integral) + deriving stock (Eq,Ord,Show) + + +instance Pretty (Peer Fake) where + pretty (FakePeer n) = parens ("peer" <+> pretty n) + + +instance HasProtocol Fake (BlockSize Fake) where + type instance ProtocolId (BlockSize Fake) = 1 + type instance Encoded Fake = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + +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 SessionData Fake (BlockSize Fake) = BlockSizeSession Fake +type instance SessionData Fake (BlockChunks Fake) = BlockDownload + +newtype instance SessionKey Fake (BlockChunks Fake) = + DownloadSessionKey (Peer Fake, Cookie Fake) + deriving newtype (Eq, Hashable) + deriving stock (Generic) + +newtype BlockSizeSession e = + BlockSizeSession + { _bsBlockSizes :: Map (Peer e) Size + } + +makeLenses 'BlockSizeSession + +instance Ord (Peer e) => Default (BlockSizeSession e) where + def = BlockSizeSession mempty + +deriving stock instance Show (BlockSizeSession Fake) + +data Env e = forall bus . ( Messaging bus e ByteString ) => + Env + { envSelf :: Peer e + , envBus :: bus + } + +class Monad m => HasOwnPeer e m where + ownPeer :: m (Peer e) + +class Messaging bus e msg => HasMessaging e msg bus m where + getMessaging :: m 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 + ) => + AnyProtocol + { myProtoId :: Integer + , protoDecode :: Encoded e -> Maybe p + , protoEncode :: p -> Encoded e + , handle :: p -> m () + } + +makeResponse :: forall e p m . ( MonadIO m + , Response e p m + , HasProtocol e p + ) + => (p -> m ()) -> AnyProtocol e m + +makeResponse h = AnyProtocol { myProtoId = natVal (Proxy @(ProtocolId p)) + , protoDecode = decode + , protoEncode = encode + , handle = h + } + +class IsResponse e m where + responseTo :: m (Peer e) + + +type ResponseM e = ReaderT (Peer e) + +runResponseM :: forall e m . Monad m => Peer e -> ResponseM e m () -> m () +runResponseM peer f = runReaderT f peer + +runPeer :: forall e bus m p . ( MonadIO m + , HasOwnPeer e m + , HasMessaging e ByteString bus m + , Response e p m + , HasProtocol e p + , Serialise (Encoded e) + ) + => [AnyProtocol e (ResponseM e m)] + -> m () + +runPeer hh = do + me <- ownPeer @e @m + pipe <- getMessaging @e @ByteString @bus + + let resp = [ (pid, a) | a@AnyProtocol { myProtoId = pid } <- hh ] + + let disp = Map.fromList resp + + forever $ do + + messages <- receive pipe (To me) + + for_ messages $ \(From pip, bs) -> do + + case deserialiseOrFail @(AnyMessage e) bs of + + 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) + +main :: IO () +main = do + print "preved" + pure () + + diff --git a/hbs2-tests/test/PeerMain.hs b/hbs2-tests/test/PeerMain.hs index 44bbbbad..957f4310 100644 --- a/hbs2-tests/test/PeerMain.hs +++ b/hbs2-tests/test/PeerMain.hs @@ -201,9 +201,34 @@ emitBlockReadyEvent pe h = do in (mconcat (maybeToList ev), Map.delete h m) -runFakePeer :: forall e b . ( e ~ Fake +-- Бежал ридер по ридеру, видит ридер сидит на ридере +-- ридер. Схватил ридер ридера за хуй да и выкинул нахуй. +-- +newtype PeerM e m a = PeerM { fromPeerM :: ReaderT () (EngineM e m) a } + deriving newtype ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader () + ) + +-- instance MonadTrans (PeerM e) where +-- lift = lift . lift + + +runPeerM p0 bus f = do + env <- newEnv p0 bus + runEngineM env (runReaderT (fromPeerM f) ()) + + +instance Request Fake (BlockSize Fake) (PeerM e IO) where + request p proto = undefined + + +runFakePeer :: forall e b . ( e ~ Fake -- , MonadIO m , Messaging b e ByteString + -- , Monad m -- , Sessions Fake (BlockSize Fake) -- , m ~ ResponseM Fake IO -- , MonadIO m @@ -213,7 +238,7 @@ runFakePeer :: forall e b . ( e ~ Fake => PeerEvents e (EngineM e IO) -> Peer e -> b - -> EngineM e IO () + -> PeerM e IO () -> IO () runFakePeer ev p0 bus work = do @@ -324,7 +349,7 @@ runFakePeer ev p0 bus work = do , makeResponse (blockChunksProto adapter) ] - runEngineM env work + runPeerM p0 bus work simpleStorageStop storage @@ -357,7 +382,18 @@ runFakePeer ev p0 bus work = do -- -blockDownloadLoop ev0 p1 = do +blockDownloadLoop :: forall e . PeerM e IO () +blockDownloadLoop = do + + let who = FakePeer 1 + let blkHash = "" + request who (GetBlockSize @Fake blkHash) + + pure () + + +-- blockDownloadLoop :: PeerEvents Fake m -> Peer e -> PeerM () m () +blockDownloadLoop1 ev0 p1 = do let ini = [ "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt" @@ -469,8 +505,9 @@ test1 = do p1Thread <- async $ runFakePeer ev1 p1 fake $ forever $ liftIO yield p0Thread <- async $ runFakePeer ev0 p0 fake $ do + blockDownloadLoop - blockDownloadLoop ev0 p1 + -- blockDownloadLoop ev0 p1 let peerz = p0Thread : [p1Thread]