mirror of https://github.com/voidlizard/hbs2
known-peer-options-for-config
Squashed commit of the following: commit343417c5d8Author: Vladimir Krutkin <krutkinvs@gmail.com> Date: Thu Mar 9 16:27:24 2023 +0300 Refactoring commitcadcfc38f1Author: Vladimir Krutkin <krutkinvs@gmail.com> Date: Thu Mar 2 23:35:09 2023 +0300 Refactoring commit02be353096Author: Vladimir Krutkin <krutkinvs@gmail.com> Date: Thu Mar 2 23:24:13 2023 +0300 Add `known-peers-file` config option commiteaa4f38989Author: Vladimir Krutkin <krutkinvs@gmail.com> Date: Thu Mar 2 15:22:41 2023 +0300 Refactoring commit784fd2b437Author: Vladimir Krutkin <krutkinvs@gmail.com> Date: Tue Feb 28 22:52:57 2023 +0300 Typo commit4e487b3a03Author: Vladimir Krutkin <krutkinvs@gmail.com> Date: Tue Feb 28 22:54:39 2023 +0300 Add `known-peer` config option
This commit is contained in:
Dmitry Zuikov
parent
704187c12e
commit
ea881ac507
|
|
@ -214,9 +214,6 @@ fixme-del "F7whmzJkZX"
|
|||
fixme-set "workflow" "test" "5vVyZS7fsN"
|
||||
fixme-set "workflow" "wip" "BhME2nDpbd"
|
||||
fixme-set "assigned" "voidlizard" "BhME2nDpbd"
|
||||
|
||||
|
||||
|
||||
fixme-set "workflow" "test" "BhME2nDpbd"
|
||||
fixme-set "workflow" "wip" "39Fc5R5uXU"
|
||||
fixme-set "assigned" "voidlizard" "39Fc5R5uXU"
|
||||
|
|
@ -243,10 +240,12 @@ fixme-set "workflow" "backlog" "G8FMaRmAga"
|
|||
(fixme-set "workflow" "test" "6taLaHDEpJ")
|
||||
(fixme-set "workflow" "test" "6taLaHDEpJ")
|
||||
(fixme-set "workflow" "test" "3YEidKkHwW")
|
||||
|
||||
(fixme-set "assigned" "voidlizard" "8TFq4jSHUM")
|
||||
(fixme-set "workflow" "test" "8TFq4jSHUM")
|
||||
fixme-merged "EGPR1m3NNr" "5RbVNm9SRz"
|
||||
fixme-del "3jyeE9RkML"
|
||||
fixme-del "2sDdEc1kA6"
|
||||
fixme-del "B4SztMBNcU"
|
||||
(fixme-set "assigned" "voidlizard" "5RbVNm9SRz")
|
||||
(fixme-set "workflow" "test" "5RbVNm9SRz")
|
||||
(fixme-set "workflow" "wip" "AKoEsF2q7t")
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ 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
|
||||
|
|
@ -24,9 +25,14 @@ 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
|
||||
|
|
@ -61,3 +67,27 @@ bootstrapDnsLoop conf = do
|
|||
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
|
||||
|
|
|
|||
|
|
@ -46,6 +46,11 @@ data PeerDownloadLogKey
|
|||
instance HasCfgKey PeerDownloadLogKey (Maybe String) where
|
||||
key = "download-log"
|
||||
|
||||
data PeerKnownPeersFile
|
||||
|
||||
instance HasCfgKey PeerKnownPeersFile [String] where
|
||||
key = "known-peers-file"
|
||||
|
||||
cfgName :: FilePath
|
||||
cfgName = "config"
|
||||
|
||||
|
|
@ -126,29 +131,33 @@ peerConfigRead mbfp = do
|
|||
|
||||
debug $ pretty cfgPath
|
||||
|
||||
confData' <- liftIO $ readFile cfgPath <&> parseTop <&> either mempty id
|
||||
let parseConf f = liftIO $ readFile f <&> parseTop <&> either mempty id
|
||||
|
||||
let confData = confData' <> either mempty id (parseTop peerConfDef)
|
||||
confData' <- parseConf cfgPath
|
||||
|
||||
knownPeersFiles <- mapM (canonicalizePath' dir) (cfgValue @PeerKnownPeersFile $ PeerConfig confData')
|
||||
|
||||
knownPeersConfData <- concat <$> mapM parseConf knownPeersFiles
|
||||
|
||||
let confData = confData' <> either mempty id (parseTop peerConfDef) <> knownPeersConfData
|
||||
|
||||
-- debug $ pretty confData
|
||||
|
||||
config <- flip transformBiM confData $ \case
|
||||
List co (Key "key" [LitStrVal p]) -> do
|
||||
kp <- liftIO $ canonicalizePath (dir </> Text.unpack p)
|
||||
pure $ List @C co [Symbol co "key", Literal co (mkLit (Text.pack kp)) ]
|
||||
|
||||
List co (Key "storage" [LitStrVal p]) -> do
|
||||
kp <- liftIO $ canonicalizePath (dir </> Text.unpack p)
|
||||
pure $ List @C co [Symbol co "storage", Literal co (mkLit (Text.pack kp)) ]
|
||||
|
||||
List co (Key "download-log" [LitStrVal p]) -> do
|
||||
kp <- liftIO $ canonicalizePath (dir </> Text.unpack p)
|
||||
pure $ List @C co [Symbol co "download-log", Literal co (mkLit (Text.pack kp)) ]
|
||||
|
||||
x -> pure x
|
||||
config <- transformBiM (canonicalizeConfPaths ["key", "storage", "download"] dir) confData
|
||||
|
||||
pure $ PeerConfig config
|
||||
where
|
||||
canonicalizePath' :: MonadIO m => FilePath -> FilePath -> m FilePath
|
||||
canonicalizePath' dir = liftIO . canonicalizePath . (dir </>)
|
||||
|
||||
canonicalizeConfPaths :: MonadIO m => [Id] -> FilePath -> Syntax C -> m (Syntax C)
|
||||
canonicalizeConfPaths keys dir x@(List co (Key k [LitStrVal path])) =
|
||||
if k `elem` keys
|
||||
then do
|
||||
canonicalPath <- canonicalizePath' dir $ Text.unpack path
|
||||
pure $ List @C co [Symbol co k, Literal co (mkLit (Text.pack canonicalPath))]
|
||||
else pure x
|
||||
canonicalizeConfPaths _ _ x = pure x
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) where
|
||||
cfgValue (PeerConfig syn) = val
|
||||
|
|
|
|||
|
|
@ -541,6 +541,8 @@ runPeer opts = Exception.handle myException $ do
|
|||
|
||||
peerThread (peerPingLoop @e)
|
||||
|
||||
peerThread (knownPeersPingLoop @e conf)
|
||||
|
||||
peerThread (bootstrapDnsLoop @e conf)
|
||||
|
||||
peerThread (pexLoop @e)
|
||||
|
|
@ -748,7 +750,7 @@ withRPC o cmd = do
|
|||
as <- parseAddr (fromString saddr) <&> fmap (PeerUDP . addrAddress)
|
||||
let rpc' = headMay $ L.sortBy (compare `on` addrPriority) as
|
||||
|
||||
rpc <- pure rpc' `orDie` "Can't parse RPC endpoing"
|
||||
rpc <- pure rpc' `orDie` "Can't parse RPC endpoint"
|
||||
|
||||
udp1 <- newMessagingUDP False Nothing `orDie` "Can't start RPC"
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue