known-peer-options-for-config

Squashed commit of the following:

commit 343417c5d8
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Thu Mar 9 16:27:24 2023 +0300

    Refactoring

commit cadcfc38f1
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Thu Mar 2 23:35:09 2023 +0300

    Refactoring

commit 02be353096
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Thu Mar 2 23:24:13 2023 +0300

    Add `known-peers-file` config option

commit eaa4f38989
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Thu Mar 2 15:22:41 2023 +0300

    Refactoring

commit 784fd2b437
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Tue Feb 28 22:52:57 2023 +0300

    Typo

commit 4e487b3a03
Author: Vladimir Krutkin <krutkinvs@gmail.com>
Date:   Tue Feb 28 22:54:39 2023 +0300

    Add `known-peer` config option

.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")

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

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
+    config <- transformBiM (canonicalizeConfPaths ["key", "storage", "download"] dir) confData
-                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
 
     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

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"