proto peer locator

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -50,6 +50,9 @@ instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString)
 class Monad m => HasOwnPeer e m where
   ownPeer :: m (Peer e)
 
+class Monad m => HasPeerLocator e m where
+  getPeerLocator ::  m (AnyPeerLocator e)
+
 class HasStorage m where
   getStorage :: m AnyStorage
 
@@ -141,6 +144,9 @@ runResponseM peer f = runReaderT (fromResponse f) (ResponseEnv peer)
 instance Monad m => HasOwnPeer e (PeerM e m) where
   ownPeer = asks (view envSelf)
 
+instance Monad m => HasPeerLocator e (PeerM e m) where
+  getPeerLocator = asks (view envPeerLocator)
+
 instance Monad m => HasFabriq e (PeerM e m) where
   getFabriq = asks (view envFab)
 

hbs2-core/lib/HBS2/Defaults.hs

@@ -36,7 +36,7 @@ defBlockInfoTimeout :: TimeSpec
 defBlockInfoTimeout = toTimeSpec ( 10  :: Timeout 'Minutes)
 
 defSweepTimeout :: Timeout 'Seconds
-defSweepTimeout = 5 -- FIXME: only for debug!
+defSweepTimeout = 600 -- FIXME: only for debug!
 
 
 

hbs2-core/lib/HBS2/Net/PeerLocator.hs

@@ -1,3 +1,4 @@
+{-# Language AllowAmbiguousTypes #-}
 module HBS2.Net.PeerLocator where
 
 import HBS2.Prelude
@@ -13,3 +14,4 @@ instance HasPeer e => PeerLocator e (AnyPeerLocator e) where
   knownPeers (AnyPeerLocator l) = knownPeers  l
   addPeers (AnyPeerLocator l) = addPeers l
 
+

hbs2-tests/test/HmapMain.hs

@@ -1,76 +0,0 @@
-{-# LANGUAGE ExistentialQuantification, RankNTypes #-}
-module Main where
-
-import Data.Typeable
-import Data.Dynamic
-import Data.Proxy
-import Data.Kind
-
-import Prettyprinter
-
-
-data Key = forall a . (Unfuck a, Eq a) => Key (Proxy a) Dynamic
-
-class Typeable a => Unfuck a where
-  unfuck :: Proxy a -> Dynamic -> Maybe a
-
-instance Typeable a => Unfuck a where
-  unfuck _ = fromDynamic @a
-
-newKey :: forall a . (Eq a, Typeable a, Unfuck a) => a -> Key
-newKey s = Key (Proxy @a) (toDyn s)
-
-instance Eq Key where
-  (==) (Key p1 a) (Key p2 b) = unfuck p1 a == unfuck p1 b
-
-main :: IO ()
-main = do
-  let k1 = newKey 22
-  let k2 = newKey 33
-  let k3 = newKey "JOPA"
-
-  print $ "k1 == k1:" <+> pretty (k1 == k1)
-  print $ "k2 == k2:" <+> pretty (k2 == k2)
-  print $ "k1 == k2:" <+> pretty (k1 == k2)
-  print $ "k3 == k3:" <+> pretty (k3 == k3)
-  print $ "k3 == k2:" <+> pretty (k3 == k2)
-  print $ "k3 == k1:" <+> pretty (k3 == k1)
-
-
-  -- _ <- race ( pause ( 60 :: Timeout 'Seconds) ) $ forever $ do
-  --       let gen = arbitrary @MyKey
-  --       let n = 100
-  --       keys <- replicateM 10 (sample' @MyKey gen) <&> mconcat
-  --       vals <- replicateM 100 (randomIO @Int)
-
-  --       let kv = zip keys vals
-
-  --       forM_ kv $ \(k,v) -> do
-
-  --         m <- readTVarIO tm
-
-  --         let z = withKey k id
-
-  --         undefined
-
-          -- atomically $ writeTVar tm z
-          -- atomically $ modifyTVar km (k:)
-
-          -- kl <- readTVarIO km
-
-          -- when (length kl > 1000) $ do
-          --   let (a,b) = L.splitAt 1000 kl
-
-          --   m1 <- readTVarIO tm
-          --   forM_ b $ \z3 -> do
-          --     let m2 = withKey z3 $ \z3 -> delete z3 m1
-          --     pure ()
-
-          --   atomically $ writeTVar km b
-
-          --   pure ()
-
-
-
-  pure ()
-

hbs2-tests/test/Peer2Main.hs

@@ -157,18 +157,19 @@ handleBlockInfo (p, h, sz') = do
     let bsz = fromIntegral sz
     update @e def (BlockSizeKey h) (over bsBlockSizes (Map.insert p bsz))
 
-blockDownloadLoop :: forall e . ( HasProtocol e (BlockSize e)
+blockDownloadLoop :: forall e  m . ( m ~ PeerM e IO
-                                , HasProtocol e (BlockChunks e)
+                                   , HasProtocol e (BlockSize e)
-                                , Request e (BlockSize e) (PeerM e IO)
+                                   , HasProtocol e (BlockChunks e)
-                                , Request e (BlockChunks e) (PeerM e IO)
+                                   , Request e (BlockSize e) m
-                                , EventListener e (BlockSize e) (PeerM e IO)
+                                   , Request e (BlockChunks e) m
-                                , EventListener e (BlockChunks e) (PeerM e IO)
+                                   , EventListener e (BlockSize e) m
-                                , EventEmitter e (BlockChunks e) (PeerM e IO)
+                                   , EventListener e (BlockChunks e) m
-                                , Sessions e (BlockSize e) (PeerM e IO)
+                                   , EventEmitter e (BlockChunks e) m
-                                , Sessions e (BlockChunks e) (PeerM e IO)
+                                   , Sessions e (BlockSize e) m
-                                , Num (Peer e)
+                                   , Sessions e (BlockChunks e) m
-                                -- , Ord (Peer e)
+                                   , Num (Peer e)
-                                ) =>  PeerM e IO ()
+                                   , Pretty (Peer e)
+                                   ) =>  PeerM e IO ()
 blockDownloadLoop = do
 
   let blks = [ "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt"
@@ -185,7 +186,6 @@ blockDownloadLoop = do
       pure ()
 
     subscribe @e (BlockSizeEventKey h) $ \(BlockSizeEvent (p,h,s)) -> do
-      debug $  "can't believe this shit works" <+> pretty h
       coo <- genCookie (p,h)
       let key = DownloadSessionKey (p, coo)
       let chusz = defChunkSize
@@ -196,7 +196,11 @@ blockDownloadLoop = do
       update @e new key id
       request p (BlockChunks coo (BlockGetAllChunks @e h chusz)) -- FIXME: nicer construction
 
-    request 1 (GetBlockSize @e h)
+    peers <- getPeerLocator @e >>= knownPeers @e
+
+    for_ peers $ \p -> do
+      debug $ "WTF?" <+> pretty p
+      request p (GetBlockSize @e h)
 
   fix \next -> do
     liftIO $ print "piu!"
@@ -321,9 +325,9 @@ main = do
                   adapter <- mkAdapter cw
                   env <- ask
 
-                  npl <- newStaticPeerLocator ps
+                  pl <- getPeerLocator @Fake
 
-                  addPeers npl ps
+                  addPeers @Fake pl ps
 
                   as <- liftIO $ async $ withPeerM env blockDownloadLoop