mirror of https://github.com/voidlizard/hbs2
94 lines
2.6 KiB
Haskell
94 lines
2.6 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.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.Maybe
|
|
import Data.Set qualified as Set
|
|
import Data.Set (Set)
|
|
import Control.Monad
|
|
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
|
|
, 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.singleton "bootstrap.hbs2.net"
|
|
|
|
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
|
|
|
|
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
|