wip

hbs2-core/lib/HBS2/Net/Messaging/TCP.hs

@@ -4,6 +4,7 @@ module HBS2.Net.Messaging.TCP
   , runMessagingTCP
   , newMessagingTCP
   , tcpOwnPeer
+  , tcpPeerConn
   , tcpCookie
   ) where
 
@@ -202,8 +203,6 @@ spawnConnection tp env so sa = liftIO do
   let newP = fromSockAddr @'TCP sa
 
   theirCookie <- handshake tp env  so
-  -- TCP address available
-  -- FIXME: how to use this info
 
   let connId = connectionId myCookie theirCookie
 

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

@@ -8,7 +8,6 @@ import System.Random.Shuffle (shuffleM)
 
 class PeerLocator e l where
   knownPeers   :: forall m . (HasPeer e, MonadIO m) => l -> m [Peer e]
-  -- knownListeningPeers   :: forall m . (HasPeer e, MonadIO m) => l -> m [Peer e]
   addPeers     :: forall m . (HasPeer e, MonadIO m) => l -> [Peer e] -> m ()
   delPeers     :: forall m . (HasPeer e, MonadIO m) => l -> [Peer e] -> m ()
   bestPeers    :: forall m . (HasPeer e, MonadIO m) => l -> m [Peer e]
@@ -18,7 +17,6 @@ data AnyPeerLocator e = forall a . PeerLocator e a => AnyPeerLocator a
 
 instance HasPeer e => PeerLocator e (AnyPeerLocator e) where
   knownPeers (AnyPeerLocator l) = knownPeers  l
-  -- knownListeningPeers (AnyPeerLocator l) = knownListeningPeers  l
   addPeers (AnyPeerLocator l) = addPeers l
   delPeers (AnyPeerLocator l) = delPeers l
   addExcluded (AnyPeerLocator l) = addExcluded l

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

@@ -33,12 +33,6 @@ instance (Ord (Peer e), Pretty (Peer e)) => PeerLocator  e (StaticPeerLocator e)
     excl <- liftIO $ readTVarIO e
     pure $ Set.toList (ps `Set.difference` excl)
 
-  -- knownListeningPeers (StaticPeerLocator peers e) = do
-  --   -- pips <- knownPeers @e pl >>= filterM (liftIO . atomically . readTVar . _peerTcpAvailable)
-  --   ps <- liftIO $ readTVarIO  peers
-  --   excl <- liftIO $ readTVarIO e
-  --   pure $ Set.toList (ps `Set.difference` excl)
-
   addPeers (StaticPeerLocator peers te) new = do
     excl <- liftIO $ readTVarIO te
     liftIO $ atomically $ modifyTVar' peers ((`Set.difference` excl) . (<> Set.fromList new))

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

@@ -105,7 +105,6 @@ peerExchangeProto msg = do
 
       pl   <- getPeerLocator @e
       pips <- knownPeers @e pl
-      -- pips <- knownListeningPeers @e pl
 
       case pex of
         PEX1 -> do

hbs2-peer/app/BlockHttpDownload.hs

@@ -12,6 +12,7 @@ import HBS2.Events
 import HBS2.Hash
 import HBS2.Merkle
 import HBS2.Net.IP.Addr
+import HBS2.Net.Messaging.TCP
 import HBS2.Net.PeerLocator
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Definition
@@ -153,8 +154,8 @@ fillPeerMeta :: forall e  m .
     , EventListener e ( PeerMetaProto e) m
     , e ~ L4Proto
     )
-    => m ()
+    => Maybe MessagingTCP -> m ()
-fillPeerMeta = do
+fillPeerMeta mtcp = do
   debug "I'm fillPeerMeta"
   pl <- getPeerLocator @e
   forever do
@@ -200,13 +201,19 @@ fillPeerMeta = do
                       -- 3) пробить, что есть tcp
                       forM_ (lookupDecode "listen-tcp" (unPeerMeta peerMeta)) \listenTCPPort -> lift do
                           peerTCPAddrPort <- replacePort p listenTCPPort
-                          -- 4) выяснить, можно ли к нему открыть соединение на этот порт
+                          p <- fromPeerAddr (L4Address TCP peerTCPAddrPort)
-                          -- возможно, с ним уже открыто соединение
+                          sendPing p
-                          -- или попробовать открыть или запомнить, что было открыто
+
-                          -- connectPeerTCP  ?
+                          forM_ mtcp \(tcp :: MessagingTCP) -> do
-                          -- 5) добавить этих пиров в пекс
+                              -- 4) выяснить, можно ли к нему открыть соединение на этот порт
-                          -- p :: Peer e <- fromPeerAddr (L4Address TCP (peerTCPAddrPort :: IPAddrPort L4Proto) :: PeerAddr e)
+                              -- возможно, с ним уже открыто соединение
-                          sendPing =<< fromPeerAddr (L4Address TCP peerTCPAddrPort)
+                              -- или попробовать открыть или запомнить, что было открыто
+                              -- connectPeerTCP  ?
+                              tcpAddressIsAvailable <- isJust <$> do
+                                  liftIO $ atomically $ readTVar (view tcpPeerConn tcp) <&> HashMap.lookup p
+                              when tcpAddressIsAvailable do
+                                  -- добавить этого пира в pex
+                                  addPeers pl [p]
 
                       port <- (MaybeT . pure) (lookupDecode "http-port" (unPeerMeta peerMeta))
 

hbs2-peer/app/PeerMain.hs

@@ -743,7 +743,7 @@ runPeer opts = Exception.handle myException $ do
 
                 peerThread "blockDownloadLoop " (blockDownloadLoop denv)
 
-                peerThread "fillPeerMeta" (fillPeerMeta)
+                peerThread "fillPeerMeta" (fillPeerMeta tcp)
 
                 -- FIXME: clumsy-code
                 -- Is it better now ?

hbs2-peer/app/PeerTypes.hs

@@ -65,7 +65,6 @@ data PeerInfo e =
   , _peerHttpApiAddress :: TVar (Either Int (Maybe String))
   , _peerHttpDownloaded :: TVar Int
   , _peerMeta           :: TVar (Maybe PeerMeta)
-  , _peerTcpAvailable   :: TVar Bool
   }
   deriving stock (Generic,Typeable)
 
@@ -90,7 +89,6 @@ newPeerInfo = liftIO do
            <*> newTVarIO (Left 0)
            <*> newTVarIO 0
            <*> newTVarIO Nothing
-           <*> newTVarIO False
 
 type instance SessionData e (PeerInfo e) = PeerInfo e