From ea881ac5079a596744a11e1c347df4f62a697fd6 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 10 Mar 2023 08:58:17 +0300 Subject: [PATCH] known-peer-options-for-config Squashed commit of the following: commit 343417c5d848c16e838144d372e1207b0254d20d Author: Vladimir Krutkin Date: Thu Mar 9 16:27:24 2023 +0300 Refactoring commit cadcfc38f15aa54b9785d690b72426bad7a9e264 Author: Vladimir Krutkin Date: Thu Mar 2 23:35:09 2023 +0300 Refactoring commit 02be353096f80279f3d112dbedf11e1d760f112a Author: Vladimir Krutkin Date: Thu Mar 2 23:24:13 2023 +0300 Add `known-peers-file` config option commit eaa4f38989c1f9ff2973264c959ec880efa59ce3 Author: Vladimir Krutkin Date: Thu Mar 2 15:22:41 2023 +0300 Refactoring commit 784fd2b43706e238b613d3f9c03f90193ea1613b Author: Vladimir Krutkin Date: Tue Feb 28 22:52:57 2023 +0300 Typo commit 4e487b3a03d444d520ec52759c6f142430b5f2c0 Author: Vladimir Krutkin Date: Tue Feb 28 22:54:39 2023 +0300 Add `known-peer` config option --- .fixme/log | 7 +++---- hbs2-peer/app/Bootstrap.hs | 30 +++++++++++++++++++++++++++ hbs2-peer/app/PeerConfig.hs | 41 ++++++++++++++++++++++--------------- hbs2-peer/app/PeerMain.hs | 4 +++- 4 files changed, 61 insertions(+), 21 deletions(-) diff --git a/.fixme/log b/.fixme/log index 9c94f63f..8b3ca0c7 100644 --- a/.fixme/log +++ b/.fixme/log @@ -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") diff --git a/hbs2-peer/app/Bootstrap.hs b/hbs2-peer/app/Bootstrap.hs index 66ffc748..b2fdc9ab 100644 --- a/hbs2-peer/app/Bootstrap.hs +++ b/hbs2-peer/app/Bootstrap.hs @@ -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 diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 1fc86223..9d1dd7a7 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 1f298db6..9233996c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -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"