check peer nonce, dont download from unknown peer

docs/devlog.md

@@ -1,6 +1,10 @@
 
 ## 2023-02-06
 
+FIXME:  При вычислении burst надо каким-то образом
+        находить плато и не лезть выше него.
+
+
 FIXME:  Задержку в очередь пиров при рассылке
         GetBlockSize, что бы не спамить пиров,
         пока запрос не уехал в отстой. Надо

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

@@ -68,9 +68,6 @@ data Fabriq e = forall bus . (Messaging bus e (Encoded e)) => Fabriq bus
 class HasFabriq e m where
   getFabriq :: m (Fabriq e)
 
-class HasPeerNonce e m where
-  peerNonce :: m PeerNonce
-
 class Messaging (Fabriq e) e (AnyMessage (Encoded e) e) => PeerMessaging e
 
 instance Messaging (Fabriq e) e (AnyMessage (Encoded e) e) => PeerMessaging e
@@ -461,8 +458,10 @@ instance ( MonadIO m
 instance (Monad m, HasOwnPeer e m) => HasOwnPeer e (ResponseM e m) where
   ownPeer = lift ownPeer
 
-
 instance (Monad m, HasFabriq e m) => HasFabriq e (ResponseM e m) where
   getFabriq = lift getFabriq
 
+instance (Monad m, HasPeerNonce e m) => HasPeerNonce e (ResponseM e m) where
+  peerNonce = lift $ peerNonce @e
+
 

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

@@ -17,14 +17,13 @@ import Data.Hashable
 import Lens.Micro.Platform
 import Type.Reflection (someTypeRep)
 
-import Prettyprinter
-
 type PingSign  e = Signature e
 type PingNonce = BS.ByteString
 
-newtype PeerData e =
+data PeerData e =
   PeerData
-  { _peerSignKey :: PubKey 'Sign e
+  { _peerSignKey  :: PubKey 'Sign e
+  , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops
   }
   deriving stock (Typeable,Generic)
 
@@ -71,6 +70,7 @@ peerHandShakeProto :: forall e m . ( MonadIO m
                                    , Sessions e (PeerHandshake e) m
                                    , Sessions e (KnownPeer e) m
                                    , HasNonces (PeerHandshake e) m
+                                   , HasPeerNonce e m
                                    , Nonce (PeerHandshake e) ~ PingNonce
                                    , Signatures e
                                    , Pretty (Peer e)
@@ -90,8 +90,10 @@ peerHandShakeProto =
       -- TODO: подписать нонс
       let sign = makeSign @e (view peerSignSk creds) nonce
 
+      own <- peerNonce @e
+
       -- TODO: отправить обратно вместе с публичным ключом
-      response (PeerPong @e sign (PeerData (view peerSignPk creds)))
+      response (PeerPong @e sign (PeerData (view peerSignPk creds) own))
 
       -- TODO: да и пингануть того самим
 
@@ -113,6 +115,8 @@ peerHandShakeProto =
 
         expire (PeerHandshakeKey pip)
 
+        -- FIXME: check if peer is blacklisted
+        --        right here
         update (KnownPeer d) (KnownPeerKey pip) id
 
         emit AnyKnownPeerEventKey (KnownPeerEvent pip d)
@@ -165,12 +169,15 @@ deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e))
 instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e))
 
 instance ( Serialise (PubKey 'Sign e)
-         , Serialise (Signature e) )
+         , Serialise (Signature e)
+         , Serialise PeerNonce
+         )
 
   => Serialise (PeerData e)
 
 instance ( Serialise (PubKey 'Sign e)
          , Serialise (Signature e)
+         , Serialise PeerNonce
          )
 
   => Serialise (PeerHandshake e)

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

@@ -49,6 +49,9 @@ class HasCookie e p | p -> e where
 
 type PeerNonce = Nonce ()
 
+class HasPeerNonce e m where
+  peerNonce :: m PeerNonce
+
 data PeerCredentials e =
   PeerCredentials
   { _peerSignSk :: PrivKey 'Sign e

hbs2-peer/app/BlockDownload.hs

@@ -139,11 +139,11 @@ setBlockState h s = do
   sh <- asks (view blockState)
   liftIO $ atomically $ modifyTVar' sh (HashMap.insert h s)
 
-
+-- FIXME: что-то более обоснованное
 calcWaitTime :: MonadIO m => BlockDownloadM e m Double
 calcWaitTime = do
   wip <- asks (view blockWip) >>= liftIO . Cache.size
-  let wipn = realToFrac wip * 4
+  let wipn = realToFrac wip * 3
   let waiting = 5 + ( (realToFrac (toNanoSeconds defBlockWaitMax) * wipn) / 1e9 )
   pure waiting
 
@@ -218,7 +218,11 @@ removeFromWip h = do
   liftIO $ Cache.delete po h
   liftIO $ atomically $ modifyTVar' st (HashMap.delete h)
 
-withFreePeer :: (MyPeer e, MonadIO m)
+withFreePeer :: forall e m .
+                ( MyPeer e
+                , MonadIO m
+                , Sessions e (KnownPeer e) m
+                )
              => Peer e
              -> BlockDownloadM e m ()
              -> BlockDownloadM e m ()
@@ -226,12 +230,19 @@ withFreePeer :: (MyPeer e, MonadIO m)
 
 withFreePeer p n m = do
   busy <- asks (view peerBusy)
+
   avail <- liftIO $ atomically
                   $ stateTVar busy $
                       \s -> case HashMap.lookup p s of
                               Nothing -> (True, HashMap.insert p () s)
                               Just{}  -> (False, s)
-  if not avail
+
+  auth <- lift $ find (KnownPeerKey p) id <&> isJust
+
+  unless auth do
+    debug $ "peer " <+> pretty p <+> "not authorized (yet?)"
+
+  if not (avail && auth)
     then n
     else do
       r <- m
@@ -240,7 +251,7 @@ withFreePeer p n m = do
 
 -- NOTE: dangerous! if called in
 --       wrong place/wrong time,
---       if may cause a drastical
+--       it may cause a drastical
 --       download speed degradation
 
 dismissPeer  :: (MyPeer e, MonadIO m)
@@ -541,9 +552,8 @@ blockDownloadLoop :: forall e  m . ( m ~ PeerM e IO
                                    , EventEmitter e (BlockChunks e) m
                                    , Sessions e (BlockChunks e) m
                                    , Sessions e (PeerInfo e) m
+                                   , Sessions e (KnownPeer e) m
                                    , PeerSessionKey e (PeerInfo e)
-                                   -- , Typeable (SessionKey e (BlockChunks e))
-                                   -- , Typeable (SessionKey e (BlockInfo e))
                                    , HasStorage m
                                    , Pretty (Peer e)
                                    , Block ByteString ~ ByteString

hbs2-peer/app/PeerMain.hs

@@ -189,7 +189,8 @@ instance (Sessions e p m ) => Sessions e p (CredentialsM e m)  where
   update d k f = lift (update d k f)
   expire k = lift (expire  k)
 
--- instance (Monad m, HasProtocol e p, HasThatPeer e p m) => Response e p (CredentialsM e m) where
+instance (Monad m, HasPeerNonce e m) => HasPeerNonce e (CredentialsM e m) where
+  peerNonce = lift $ peerNonce @e
 
 instance Monad m => HasCredentials e (CredentialsM e m) where
   getCredentials = ask
@@ -293,14 +294,15 @@ runPeer opts = Exception.handle myException $ do
                   unless known $ sendPing pip
 
               subscribe @UDP AnyKnownPeerEventKey $ \(KnownPeerEvent p d) -> do
-                addPeers pl [p]
+                unless (pnonce == view peerOwnNonce d) $ do
+                  addPeers pl [p]
 
-                npi    <- newPeerInfo
+                  npi    <- newPeerInfo
-                pfails <- fetch True npi (PeerInfoKey p) (view peerPingFailed)
+                  pfails <- fetch True npi (PeerInfoKey p) (view peerPingFailed)
-                liftIO $ atomically $ writeTVar pfails 0
+                  liftIO $ atomically $ writeTVar pfails 0
 
-                debug $ "Got authorized peer!" <+> pretty p
+                  debug $ "Got authorized peer!" <+> pretty p
-                                               <+> pretty (AsBase58 (view peerSignKey d))
+                                                 <+> pretty (AsBase58 (view peerSignKey d))
 
               void $ liftIO $ async $ withPeerM env do
                 pause @'Seconds 1