voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Refactoring

This commit is contained in:
Vladimir Krutkin 2023-03-02 15:22:41 +03:00
parent 784fd2b437
commit eaa4f38989
2 changed files with 32 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
hbs2-peer/app/Bootstrap.hs
View File

@ -17,6 +17,7 @@ import Network.DNS qualified as DNS
import Network.DNS (Name(..),CharStr(..)) import Network.DNS (Name(..),CharStr(..))
import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Char8 qualified as B8
import Data.Foldable import Data.Foldable
import Data.Maybe
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Set (Set) import Data.Set (Set)
import Control.Monad import Control.Monad
@ -24,9 +25,14 @@ import Network.Socket
data PeerDnsBootStrapKey data PeerDnsBootStrapKey
data PeerKnownPeer
instance HasCfgKey PeerDnsBootStrapKey (Set String) where instance HasCfgKey PeerDnsBootStrapKey (Set String) where
key = "bootstrap-dns" key = "bootstrap-dns"
instance HasCfgKey PeerKnownPeer [String] where
key = "known-peer"
bootstrapDnsLoop :: forall e m . ( HasPeer e bootstrapDnsLoop :: forall e m . ( HasPeer e
, Request e (PeerHandshake e) m , Request e (PeerHandshake e) m
, HasNonces (PeerHandshake e) m , HasNonces (PeerHandshake e) m
@ -61,3 +67,27 @@ bootstrapDnsLoop conf = do
where where
mkStr (CharStr s) = B8.unpack s 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

15
hbs2-peer/app/PeerMain.hs
View File

@ -84,7 +84,6 @@ data PeerBlackListKey
data PeerStorageKey data PeerStorageKey
data PeerAcceptAnnounceKey data PeerAcceptAnnounceKey
data PeerTraceKey data PeerTraceKey
data PeerKnownPeer
data AcceptAnnounce = AcceptAnnounceAll data AcceptAnnounce = AcceptAnnounceAll
| AcceptAnnounceFrom (Set (PubKey 'Sign UDP)) | AcceptAnnounceFrom (Set (PubKey 'Sign UDP))
@ -117,8 +116,6 @@ instance HasCfgKey PeerBlackListKey (Set String) where
instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where
key = "accept-block-announce" key = "accept-block-announce"
instance HasCfgKey PeerKnownPeer [String] where
key = "known-peer"
instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
cfgValue (PeerConfig syn) = fromMaybe (AcceptAnnounceFrom lst) fromAll cfgValue (PeerConfig syn) = fromMaybe (AcceptAnnounceFrom lst) fromAll
@ -392,12 +389,6 @@ runPeer opts = Exception.handle myException $ do
let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce
-- FIXME: add validation and error handling
let parseKnownPeers xs = fmap (PeerUDP . addrAddress) . catMaybes
<$> (fmap headMay . parseAddr . fromString) `mapM` xs
knownPeers' <- parseKnownPeers $ cfgValue @PeerKnownPeer conf
print $ pretty accptAnn print $ pretty accptAnn
-- FIXME: move-peerBanned-somewhere -- FIXME: move-peerBanned-somewhere
@ -551,6 +542,8 @@ runPeer opts = Exception.handle myException $ do
peerThread (peerPingLoop @e) peerThread (peerPingLoop @e)
peerThread (knownPeersPingLoop @e conf)
peerThread (bootstrapDnsLoop @e conf) peerThread (bootstrapDnsLoop @e conf)
peerThread (pexLoop @e) peerThread (pexLoop @e)
@ -646,10 +639,6 @@ runPeer opts = Exception.handle myException $ do
, makeResponse peerExchangeProto , makeResponse peerExchangeProto
] ]
wo $ liftIO $ async $ withPeerM env $ forever do
forM_ knownPeers' (sendPing @e)
pause @'Minutes 20
void $ liftIO $ waitAnyCatchCancel workers void $ liftIO $ waitAnyCatchCancel workers
let pokeAction _ = do let pokeAction _ = do