mirror of https://github.com/voidlizard/hbs2
97 lines
3.0 KiB
Haskell
97 lines
3.0 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
module Bootstrap where
|
|
|
|
import HBS2.Prelude
|
|
import HBS2.Net.Proto.Types
|
|
import HBS2.Net.Proto.Peer
|
|
import HBS2.Clock
|
|
import HBS2.Net.IP.Addr
|
|
import HBS2.Net.Proto.Sessions
|
|
|
|
import PeerConfig
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import Data.Functor
|
|
import Network.DNS
|
|
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
|
|
import Network.Socket
|
|
import Control.Monad.Trans.Maybe
|
|
|
|
|
|
data PeerDnsBootStrapKey
|
|
|
|
data PeerKnownPeer
|
|
|
|
instance HasCfgKey PeerDnsBootStrapKey (Set String) where
|
|
key = "bootstrap-dns"
|
|
|
|
instance HasCfgKey PeerKnownPeer [String] where
|
|
key = "known-peer"
|
|
|
|
-- FIXME: tcp-addr-support-bootstrap
|
|
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)
|
|
-- , FromSockAddr 'UDP (Peer e)
|
|
, e ~ L4Proto
|
|
, MonadIO m
|
|
)
|
|
=> PeerConfig -> m ()
|
|
bootstrapDnsLoop conf = do
|
|
|
|
pause @'Seconds 2
|
|
|
|
rs <- liftIO $ makeResolvSeed defaultResolvConf
|
|
|
|
forever do
|
|
debug "I'm a bootstrapLoop"
|
|
|
|
let dns = cfgValue @PeerDnsBootStrapKey conf <> Set.singleton "bootstrap.hbs2.net"
|
|
|
|
-- FIXME: utf8-domains
|
|
for_ (Set.toList dns) $ \dn -> do
|
|
debug $ "bootstrapping from" <+> pretty dn
|
|
answers <- liftIO $ withResolver rs $ \resolver -> lookupTXT resolver (B8.pack dn) <&> either mempty id
|
|
void $ runMaybeT do
|
|
for_ answers $ \answ -> do
|
|
-- FIXME: tcp-addr-support-1
|
|
pa <- MaybeT $ pure $ fromStringMay @(PeerAddr L4Proto) (B8.unpack answ)
|
|
pip <- fromPeerAddr pa
|
|
debug $ "BOOTSTRAP:" <+> pretty pip
|
|
lift $ sendPing @e pip
|
|
|
|
-- FIXME: fix-bootstrapDnsLoop-time-hardcode
|
|
pause @'Seconds 300
|
|
|
|
|
|
-- FIXME: tcp-addr-support-known-peers-loop
|
|
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)
|
|
, e ~ L4Proto
|
|
, MonadIO m)
|
|
=> PeerConfig -> m ()
|
|
knownPeersPingLoop conf = do
|
|
-- FIXME: add validation and error handling
|
|
-- FIXME: tcp-addr-support-2
|
|
let parseKnownPeers xs = do
|
|
let pa = foldMap (maybeToList . fromStringMay) xs
|
|
mapM fromPeerAddr pa
|
|
|
|
knownPeers' <- liftIO $ parseKnownPeers $ cfgValue @PeerKnownPeer conf
|
|
forever do
|
|
forM_ knownPeers' (sendPing @e)
|
|
pause @'Minutes 20
|
|
|