mirror of https://github.com/voidlizard/hbs2
fixed BZjzN7BjQ4 dns-bootstrap
This commit is contained in:
Dmitry Zuikov
parent
a41a3098fd
commit
12231d2e4d
|
|
@ -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"
|
||||
|
|
@ -7,8 +7,9 @@ module HBS2.Prelude
|
|||
, Hashable
|
||||
, lift
|
||||
, AsFileName(..)
|
||||
, Pretty
|
||||
-- , Pretty
|
||||
, FromStringMaybe(..)
|
||||
, module Prettyprinter
|
||||
) where
|
||||
|
||||
import Data.String (IsString(..))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue