Refactoring

hbs2-peer/app/Bootstrap.hs

@@ -17,6 +17,7 @@ import Network.DNS qualified as DNS
 import Network.DNS (Name(..),CharStr(..))
 import Data.ByteString.Char8 qualified as B8
 import Data.Foldable
+import Data.Maybe
 import Data.Set qualified as Set
 import Data.Set (Set)
 import Control.Monad
@@ -24,9 +25,14 @@ import Network.Socket
 
 data PeerDnsBootStrapKey
 
+data PeerKnownPeer
+
 instance HasCfgKey PeerDnsBootStrapKey (Set String) where
   key = "bootstrap-dns"
 
+instance HasCfgKey PeerKnownPeer [String] where
+  key = "known-peer"
+
 bootstrapDnsLoop :: forall e m . ( HasPeer e
                                  , Request e (PeerHandshake e) m
                                  , HasNonces (PeerHandshake e) m
@@ -61,3 +67,27 @@ bootstrapDnsLoop conf = do
   where
     mkStr (CharStr s) = B8.unpack s
 
+knownPeersPingLoop ::
+  forall e m.
+  ( HasPeer e,
+    Request e (PeerHandshake e) m,
+    HasNonces (PeerHandshake e) m,
+    Nonce (PeerHandshake e) ~ PingNonce,
+    Sessions e (PeerHandshake e) m,
+    Pretty (Peer e),
+    MonadIO m,
+    e ~ UDP
+  ) =>
+  PeerConfig ->
+  m ()
+knownPeersPingLoop conf = do
+  -- FIXME: add validation and error handling
+  let parseKnownPeers xs =
+        fmap (PeerUDP . addrAddress)
+          . catMaybes
+          <$> (fmap headMay . parseAddr . fromString)
+          `mapM` xs
+  knownPeers' <- liftIO $ parseKnownPeers $ cfgValue @PeerKnownPeer conf
+  forever do
+    forM_ knownPeers' (sendPing @e)
+    pause @'Minutes 20

hbs2-peer/app/PeerMain.hs

@@ -84,7 +84,6 @@ data PeerBlackListKey
 data PeerStorageKey
 data PeerAcceptAnnounceKey
 data PeerTraceKey
-data PeerKnownPeer
 
 data AcceptAnnounce = AcceptAnnounceAll
                     | AcceptAnnounceFrom (Set (PubKey 'Sign UDP))
@@ -117,8 +116,6 @@ instance HasCfgKey PeerBlackListKey (Set String) where
 instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where
   key = "accept-block-announce"
 
-instance HasCfgKey PeerKnownPeer [String] where
-  key = "known-peer"
 
 instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
   cfgValue (PeerConfig syn) = fromMaybe (AcceptAnnounceFrom lst) fromAll
@@ -392,12 +389,6 @@ runPeer opts = Exception.handle myException $ do
 
   let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce
 
-  -- FIXME: add validation and error handling
-  let parseKnownPeers xs = fmap (PeerUDP . addrAddress) . catMaybes 
-         <$> (fmap headMay . parseAddr . fromString) `mapM` xs
-
-  knownPeers' <- parseKnownPeers $ cfgValue @PeerKnownPeer conf
-
   print $ pretty accptAnn
 
   -- FIXME: move-peerBanned-somewhere
@@ -551,6 +542,8 @@ runPeer opts = Exception.handle myException $ do
 
                 peerThread (peerPingLoop @e)
 
+                peerThread (knownPeersPingLoop @e conf)
+
                 peerThread (bootstrapDnsLoop @e conf)
 
                 peerThread (pexLoop @e)
@@ -646,10 +639,6 @@ runPeer opts = Exception.handle myException $ do
                     , makeResponse peerExchangeProto
                     ]
 
-                wo $ liftIO $ async $ withPeerM env $ forever do
-                    forM_  knownPeers' (sendPing @e)
-                    pause @'Minutes 20
-
               void $ liftIO $ waitAnyCatchCancel workers
 
   let pokeAction _ = do