From 12231d2e4d5bda0eed2557fc57b4c6807630e52a Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 23 Feb 2023 06:54:10 +0300 Subject: [PATCH] fixed BZjzN7BjQ4 dns-bootstrap --- .fixme/log | 3 +- hbs2-core/lib/HBS2/Prelude.hs | 3 +- hbs2-peer/app/Bootstrap.hs | 63 +++++++++++++++++++++++++++++++++++ hbs2-peer/app/PeerMain.hs | 18 ++++++---- hbs2-peer/hbs2-peer.cabal | 2 ++ 5 files changed, 80 insertions(+), 9 deletions(-) create mode 100644 hbs2-peer/app/Bootstrap.hs diff --git a/.fixme/log b/.fixme/log index 72745f2d..7d506465 100644 --- a/.fixme/log +++ b/.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" \ No newline at end of file +fixme-set "workflow" "test" "AR3Ppzm1E2" +fixme-set "workflow" "test" "BZjzN7BjQ4" \ No newline at end of file diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index b7206c6d..cbd56d59 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/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(..)) diff --git a/hbs2-peer/app/Bootstrap.hs b/hbs2-peer/app/Bootstrap.hs new file mode 100644 index 00000000..bd074ad5 --- /dev/null +++ b/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 + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 80d5f30c..445c98dc 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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) diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 1b31ef06..75f1c6bd 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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