wip

hbs2-core/lib/HBS2/Hash.hs

@@ -1,6 +1,6 @@
 {-# Language RankNTypes #-}
 module HBS2.Hash
-  ( Serialise(..)
+  ( Serialise
   , module HBS2.Hash
   )
   where

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

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 ()
+
+

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]