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"