generarting some sort of cookie

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

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 Control.Concurrent.Async
-import Data.Foldable
 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 Lens.Micro.Platform
-import Control.Concurrent.Async
+import System.Random qualified as Random
-import Data.Kind
 
 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)
+
+

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

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