quickfix

hbs2-core/lib/HBS2/Net/Proto/BlockChunks.hs

@@ -5,14 +5,18 @@ import HBS2.Events
 import HBS2.Hash
 import HBS2.Clock
 import HBS2.Net.Proto
+import HBS2.Net.Proto.Peer
 import HBS2.Prelude.Plated
 import HBS2.Storage
 import HBS2.Actors.Peer
+import HBS2.Net.Proto.Sessions
 
+import Data.Functor
 import Data.Word
 import Prettyprinter
 import Data.ByteString.Lazy (ByteString)
-import Data.Foldable
+import Data.Foldable hiding (find)
+import Data.Maybe
 
 import System.Random.Shuffle
 
@@ -82,69 +86,75 @@ blockChunksProto :: forall e m  . ( MonadIO m
                                   , Response e (BlockChunks e) m
                                   , HasDeferred e (BlockChunks e) m
                                   , HasOwnPeer e m
+                                  , Sessions e (KnownPeer e) m
                                   , Pretty (Peer e)
                                   )
                  => BlockChunksI e m
                  -> BlockChunks e
                  -> m ()
 
-blockChunksProto adapter (BlockChunks c p) =
+blockChunksProto adapter (BlockChunks c p) = do
-  case p of
 
-    BlockGetChunks h size n1 num -> do
+  peer <- thatPeer (Proxy @(BlockChunks e))
+  auth <- find (KnownPeerKey peer) id <&> isJust
+  when auth do
 
-      bsz' <- blkSize adapter h
+    case p of
 
-      maybe1 bsz' (pure ()) $ \bsz -> do
+      BlockGetChunks h size n1 num -> do
 
-        let offsets' = calcChunks bsz (fromIntegral size) :: [(Offset, Size)]
+        bsz' <- blkSize adapter h
-        let offsets = take (fromIntegral num) $ drop (fromIntegral n1) $ zip offsets' [0..]
 
-        -- liftIO $ print $ "sending " <+> pretty (length offsets)
+        maybe1 bsz' (pure ()) $ \bsz -> do
-        --                             <+> "chunks for block"
-        --                             <+> pretty h
 
-        -- for_ offsets $ \((o,sz),i) -> deferred proto do
+          let offsets' = calcChunks bsz (fromIntegral size) :: [(Offset, Size)]
-        for_ offsets $ \((o,sz),i) -> deferred proto do
+          let offsets = take (fromIntegral num) $ drop (fromIntegral n1) $ zip offsets' [0..]
-          -- liftIO $ print $ "send chunk " <+> pretty i <+> pretty sz
-          chunk <- blkChunk adapter h o sz
-          maybe (pure ()) (response_ . BlockChunk @e i) chunk
 
-    BlockGetAllChunks h size -> do
+          -- liftIO $ print $ "sending " <+> pretty (length offsets)
+          --                             <+> "chunks for block"
+          --                             <+> pretty h
 
-      me <- ownPeer @e
+          -- for_ offsets $ \((o,sz),i) -> deferred proto do
-      who <- thatPeer proto
+          for_ offsets $ \((o,sz),i) -> deferred proto do
+            -- liftIO $ print $ "send chunk " <+> pretty i <+> pretty sz
+            chunk <- blkChunk adapter h o sz
+            maybe (pure ()) (response_ . BlockChunk @e i) chunk
 
-      bsz' <- blkSize adapter h
+      BlockGetAllChunks h size -> do
 
-      maybe1 bsz' (pure ()) $ \bsz -> do
+        me <- ownPeer @e
+        who <- thatPeer proto
 
-        let offsets' = calcChunks bsz (fromIntegral size) :: [(Offset, Size)]
+        bsz' <- blkSize adapter h
-        let offsets = zip offsets' [0..]
 
-        -- liftIO $ print $ "sending " <+> pretty (length offsets)
+        maybe1 bsz' (pure ()) $ \bsz -> do
-        --                             <+> "chunks for block"
-        --                             <+> pretty h
 
-        for_ offsets $ \((o,sz),i) -> deferred proto do
+          let offsets' = calcChunks bsz (fromIntegral size) :: [(Offset, Size)]
-          chunk <- blkChunk adapter h o sz
+          let offsets = zip offsets' [0..]
-          maybe (pure ()) (response_ . BlockChunk @e i) chunk
 
-    BlockChunk n bs -> deferred proto do
+          -- liftIO $ print $ "sending " <+> pretty (length offsets)
-      who <- thatPeer proto
+          --                             <+> "chunks for block"
-      me <- ownPeer @e
+          --                             <+> pretty h
-      h <- blkGetHash adapter (who, c)
 
-      maybe1 h (response_ (BlockLost @e)) $ \hh -> do
+          for_ offsets $ \((o,sz),i) -> deferred proto do
-        void $ blkAcceptChunk adapter (c, who, hh, n, bs)
+            chunk <- blkChunk adapter h o sz
+            maybe (pure ()) (response_ . BlockChunk @e i) chunk
 
-    BlockNoChunks {} -> do
+      BlockChunk n bs -> deferred proto do
-      -- TODO: notification
+        who <- thatPeer proto
-      pure ()
+        me <- ownPeer @e
+        h <- blkGetHash adapter (who, c)
 
-    BlockLost{} -> do
+        maybe1 h (response_ (BlockLost @e)) $ \hh -> do
-      liftIO $ print "GOT BLOCK LOST MESSAGE - means IO ERROR"
+          void $ blkAcceptChunk adapter (c, who, hh, n, bs)
-      pure ()
+
+      BlockNoChunks {} -> do
+        -- TODO: notification
+        pure ()
+
+      BlockLost{} -> do
+        liftIO $ print "GOT BLOCK LOST MESSAGE - means IO ERROR"
+        pure ()
 
   where
     proto = Proxy @(BlockChunks e)

hbs2-core/lib/HBS2/Net/Proto/BlockInfo.hs

@@ -2,10 +2,13 @@ module HBS2.Net.Proto.BlockInfo where
 
 import HBS2.Prelude.Plated
 import HBS2.Net.Proto
+import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.Sessions
 import HBS2.Events
 import HBS2.Hash
 
+import Data.Functor
+import Data.Maybe
 
 data BlockInfo e = GetBlockSize (Hash HbSync)
                  | NoBlock (Hash HbSync)
@@ -21,6 +24,7 @@ blockSizeProto :: forall e m  . ( MonadIO m
                                 , Response e (BlockInfo e) m
                                 , HasDeferred e (BlockInfo e) m
                                 , EventEmitter e (BlockInfo e) m
+                                , Sessions e (KnownPeer e) m
                                 )
                => GetBlockSize  HbSync m
                -> HasBlockEvent HbSync e m
@@ -31,10 +35,13 @@ blockSizeProto getBlockSize evHasBlock =
   \case
     GetBlockSize h -> do
       -- liftIO $ print "GetBlockSize"
-      deferred (Proxy @(BlockInfo e))$ do
+      p <- thatPeer (Proxy @(BlockInfo e))
-        getBlockSize h >>= \case
+      auth <- find (KnownPeerKey p) id <&> isJust
-          Just size -> response (BlockSize @e h size)
+      when auth do
-          Nothing   -> response (NoBlock @e h)
+        deferred (Proxy @(BlockInfo e))$ do
+          getBlockSize h >>= \case
+            Just size -> response (BlockSize @e h size)
+            Nothing   -> response (NoBlock @e h)
 
     NoBlock h       -> do
       that <- thatPeer (Proxy @(BlockInfo e))