Added listen-tcp to PeerMeta

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

@@ -31,18 +31,18 @@ peerMetaProto :: forall e m  . ( MonadIO m
                                 , EventEmitter e (PeerMetaProto e) m
                                 , Sessions e (KnownPeer e) m
                                 )
-               => m AnnMetaData
+               => AnnMetaData
                -> PeerMetaProto e
                -> m ()
 
-peerMetaProto getPeerMeta =
+peerMetaProto peerMeta =
   \case
     GetPeerMeta -> do
       p <- thatPeer (Proxy @(PeerMetaProto e))
       auth <- find (KnownPeerKey p) id <&> isJust
       when auth do
         deferred (Proxy @(PeerMetaProto e)) do
-          getPeerMeta >>= \meta -> response (ThePeerMeta @e meta)
+          response (ThePeerMeta @e peerMeta)
 
     ThePeerMeta meta -> do
       that <- thatPeer (Proxy @(PeerMetaProto e))

hbs2-peer/app/HttpWorker.hs

@@ -71,10 +71,7 @@ httpWorker conf e = do
               text [qc|{pretty val}|]
 
       get "/metadata" do
-          let mport = cfgValue @PeerHttpPortKey conf  <&>  fromIntegral
+          raw $ serialise $ mkPeerMeta conf
-          raw $ serialise . annMetaFromPeerMeta . PeerMeta . catMaybes $
-            [ mport <&> \port -> ("http-port", TE.encodeUtf8 . Text.pack . show $ port)
-            ]
 
       put "/" do
         -- FIXME: optional-header-based-authorization

hbs2-peer/app/PeerConfig.hs

@@ -41,10 +41,14 @@ type C = MegaParsec
 pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
 pattern Key n ns <- SymbolVal  n : ns
 
+data PeerListenTCPKey
 data PeerDownloadLogKey
 data PeerHttpPortKey
 data PeerUseHttpDownload
 
+instance HasCfgKey PeerListenTCPKey (Maybe String) where
+  key = "listen-tcp"
+
 instance HasCfgKey PeerHttpPortKey (Maybe Integer) where
   key = "http-port"
 

hbs2-peer/app/PeerMain.hs

@@ -93,7 +93,6 @@ defLocalMulticast :: String
 defLocalMulticast = "239.192.152.145:10153"
 
 data PeerListenKey
-data PeerListenTCPKey
 data PeerRpcKey
 data PeerKeyFileKey
 data PeerBlackListKey
@@ -119,9 +118,6 @@ instance HasCfgKey PeerTraceKey FeatureSwitch where
 instance HasCfgKey PeerListenKey (Maybe String) where
   key = "listen"
 
-instance HasCfgKey PeerListenTCPKey (Maybe String) where
-  key = "listen-tcp"
-
 instance HasCfgKey PeerRpcKey (Maybe String) where
   key = "rpc"
 
@@ -549,12 +545,6 @@ runPeer opts = Exception.handle myException $ do
 
   nbcache <- liftIO $ Cache.newCache (Just $ toTimeSpec ( 600 :: Timeout 'Seconds))
 
-  let mkPeerMeta = do
-        let mport = cfgValue @PeerHttpPortKey conf  <&>  fromIntegral
-        pure $ annMetaFromPeerMeta . PeerMeta . catMaybes $
-          [ mport <&> \port -> ("http-port", TE.encodeUtf8 . Text.pack . show $ port)
-          ]
-
   void $ async $ forever do
     pause @'Seconds 600
     liftIO $ Cache.purgeExpired nbcache
@@ -857,7 +847,7 @@ runPeer opts = Exception.handle myException $ do
                     , makeResponse peerExchangeProto
                     , makeResponse (refLogUpdateProto reflogAdapter)
                     , makeResponse (refLogRequestProto reflogReqAdapter)
-                    , makeResponse (peerMetaProto mkPeerMeta)
+                    , makeResponse (peerMetaProto (mkPeerMeta conf))
                     ]
 
               void $ liftIO $ waitAnyCatchCancel workers

hbs2-peer/app/PeerTypes.hs

@@ -9,6 +9,7 @@ import HBS2.Clock
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
+import HBS2.Net.IP.Addr
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.BlockInfo
@@ -17,10 +18,12 @@ import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
 import HBS2.Net.PeerLocator
+import HBS2.Net.Proto.PeerMeta
 import HBS2.System.Logger.Simple
 
 -- import PeerInfo
 import Brains
+import PeerConfig
 
 import Data.Foldable (for_)
 import Control.Concurrent.Async
@@ -38,6 +41,8 @@ import Data.Hashable
 import Type.Reflection
 import Data.IntMap (IntMap)
 import Data.IntSet (IntSet)
+import Data.Text qualified as Text
+import Data.Text.Encoding qualified as TE
 
 
 data PeerInfo e =
@@ -367,4 +372,16 @@ getKnownPeers  = do
     maybe1 pd' (pure mempty) (const $ pure [p])
   pure $ mconcat r
 
+mkPeerMeta conf = do
+    let mHttpPort = cfgValue @PeerHttpPortKey conf  <&> fromIntegral
+    let mTcpPort =
+          (
+          fmap (\(L4Address _ (IPAddrPort (_, p))) -> p)
+            . fromStringMay @(PeerAddr L4Proto)
+          )
+          =<< cfgValue @PeerListenTCPKey conf
+    annMetaFromPeerMeta . PeerMeta . catMaybes $
+      [ mHttpPort <&> \p -> ("http-port", TE.encodeUtf8 . Text.pack . show $ p)
+      , mTcpPort <&> \p -> ("listen-tcp", TE.encodeUtf8 . Text.pack . show $ p)
+      ]