fixed BZjzN7BjQ4 dns-bootstrap

.fixme/log

@@ -203,4 +203,5 @@ fixme-set "workflow" "wip" "BZjzN7BjQ4"
 fixme-set "assigned" "voidlizard" "BZjzN7BjQ4"
 fixme-set "assigned" "ivanovs" "4ZMqvoTMY3"
 fixme-set "assigned" "voidlizard" "AR3Ppzm1E2"
-fixme-set "workflow" "test" "AR3Ppzm1E2"
+fixme-set "workflow" "test" "AR3Ppzm1E2"
+fixme-set "workflow" "test" "BZjzN7BjQ4"

hbs2-core/lib/HBS2/Prelude.hs

@@ -7,8 +7,9 @@ module HBS2.Prelude
   , Hashable
   , lift
   , AsFileName(..)
-  , Pretty
+  -- , Pretty
   , FromStringMaybe(..)
+  , module Prettyprinter
   ) where
 
 import Data.String (IsString(..))

hbs2-peer/app/Bootstrap.hs

@@ -0,0 +1,63 @@
+{-# Language AllowAmbiguousTypes #-}
+module Bootstrap where
+
+import HBS2.Prelude
+import HBS2.Net.Proto.Types
+import HBS2.Net.Proto.Peer
+import HBS2.Clock
+import HBS2.Net.Messaging.UDP
+import HBS2.Net.IP.Addr
+import HBS2.Net.Proto.Sessions
+
+import PeerConfig
+import HBS2.System.Logger.Simple
+
+import Data.Functor
+import Network.DNS qualified as DNS
+import Network.DNS (Name(..),CharStr(..))
+import Data.ByteString.Char8 qualified as B8
+import Data.Foldable
+import Data.Set qualified as Set
+import Data.Set (Set)
+import Control.Monad
+import Network.Socket
+
+data PeerDnsBootStrapKey
+
+instance HasCfgKey PeerDnsBootStrapKey (Set String) where
+  key = "bootstrap-dns"
+
+bootstrapDnsLoop :: 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 ()
+bootstrapDnsLoop conf = do
+
+  pause @'Seconds 2
+
+  forever do
+    debug "I'm a bootstrapLoop"
+
+    let dns = cfgValue @PeerDnsBootStrapKey conf :: Set String
+
+    for_ (Set.toList dns) $ \dn -> do
+      debug $ "bootstrapping from" <+> pretty dn
+      answers <- liftIO $ DNS.queryTXT (Name $ fromString dn) <&> foldMap ( fmap mkStr . snd )
+      for_ answers $ \answ -> do
+        pips <-  liftIO $ parseAddr (fromString answ) <&> fmap (PeerUDP . addrAddress)
+        for_ pips $ \pip -> do
+          debug $ "got dns answer" <+> pretty pip
+          sendPing @e pip
+
+    -- FIXME: fix-bootstrapDnsLoop-time-hardcode
+    pause @'Seconds 300
+
+  where
+    mkStr (CharStr s) = B8.unpack s
+

hbs2-peer/app/PeerMain.hs

@@ -33,6 +33,7 @@ import PeerTypes
 import BlockDownload
 import PeerInfo
 import PeerConfig
+import Bootstrap
 
 import Data.Text qualified as Text
 import Data.Foldable (for_)
@@ -445,10 +446,10 @@ runPeer opts = Exception.handle myException $ do
                         here <- find @e (KnownPeerKey p) id <&> isJust
 
                         pfails <- fetch True npi (PeerInfoKey p) (view peerPingFailed)
+                        liftIO $ atomically $ writeTVar pfails 0
                         -- pdownfails <- fetch True npi (PeerInfoKey p) (view peerDownloadFail)
 
                         unless here do
-                          liftIO $ atomically $ writeTVar pfails 0
                           -- liftIO $ atomically $ writeTVar pdownfails 0
 
                           debug $ "Got authorized peer!" <+> pretty p
@@ -460,21 +461,24 @@ runPeer opts = Exception.handle myException $ do
                 request localMulticast (PeerAnnounce @e pnonce)
 
               let wo = fmap L.singleton
+              let peerThread = wo . liftIO . async . withPeerM env
 
               workers <- do
 
-                wo $ liftIO $ async $ withPeerM env $ forever $ do
+                peerThread $ forever $ do
                   pause defPeerAnnounceTime -- FIXME: setting!
                   debug "sending local peer announce"
                   request localMulticast (PeerAnnounce @e pnonce)
 
-                wo $ liftIO $ async $ withPeerM env (peerPingLoop @e)
+                peerThread (peerPingLoop @e)
 
-                wo $ liftIO $ async $ withPeerM env (pexLoop @e)
+                peerThread (bootstrapDnsLoop @e conf)
 
-                wo $ liftIO $ async $ withPeerM env (blockDownloadLoop denv)
+                peerThread (pexLoop @e)
 
-                wo $ liftIO $ async $ withPeerM env $ forever $ do
+                peerThread (blockDownloadLoop denv)
+
+                peerThread $ forever $ do
                           cmd <- liftIO $ atomically $ readTQueue rpcQ
                           case cmd of
                             POKE -> debug "on poke: alive and kicking!"
@@ -549,7 +553,7 @@ runPeer opts = Exception.handle myException $ do
                             _ -> pure ()
 
 
-                wo $ liftIO $ async $ withPeerM env $ do
+                peerThread do
                   runProto @e
                     [ makeResponse (blockSizeProto blk dontHandle)
                     , makeResponse (blockChunksProto adapter)

hbs2-peer/hbs2-peer.cabal

@@ -37,6 +37,7 @@ common common-deps
         , prettyprinter
         , random
         , random-shuffle
+        , resolv
         , safe
         , saltine >=0.2.0.1
         , suckless-conf
@@ -104,6 +105,7 @@ executable hbs2-peer
     main-is:          PeerMain.hs
 
     other-modules:    BlockDownload
+                    , Bootstrap
                     , PeerInfo
                     , PokePostponed
                     , RPC