peer-config, peer-blacklist, peer-accept-announce

docs/devlog.md

@@ -1,6 +1,15 @@
 
 ## 2023-02-12
 
+FIXME: busyloop-postponed
+
+  Когда остаются одни posponed блоки в очереди,
+  которых ни у кого нет --- возникает busyloop
+  и флуд GetBlockSize
+
+  Кажется, надо в ключ HasTimeLimits добавить
+  хэш пингуемого блока.
+
 TODO: introduce-peer-config
 
   1. На одном хосте может быть несколько пиров.
@@ -17,7 +26,6 @@ TODO: introduce-peer-config
 TODO: introduce-peer-black-list
 
 
-
 TODO: peer-accept-block-announce-feature
 
   Смотреть, если пир в чёрном списке --- от отвергать от него

flake.lock

@@ -82,6 +82,21 @@
         "type": "github"
       }
     },
+    "flake-utils_5": {
+      "locked": {
+        "lastModified": 1644229661,
+        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
     "haskell-flake-utils": {
       "inputs": {
         "flake-utils": "flake-utils"
@@ -156,6 +171,24 @@
         "type": "github"
       }
     },
+    "haskell-flake-utils_5": {
+      "inputs": {
+        "flake-utils": "flake-utils_5"
+      },
+      "locked": {
+        "lastModified": 1672412555,
+        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "type": "github"
+      }
+    },
     "hspup": {
       "inputs": {
         "haskell-flake-utils": "haskell-flake-utils_4",
@@ -213,7 +246,8 @@
         "haskell-flake-utils": "haskell-flake-utils_3",
         "hspup": "hspup",
         "nixpkgs": "nixpkgs_2",
-        "saltine": "saltine"
+        "saltine": "saltine",
+        "suckless-conf": "suckless-conf_2"
       }
     },
     "saltine": {
@@ -251,6 +285,27 @@
         "repo": "suckless-conf",
         "type": "github"
       }
+    },
+    "suckless-conf_2": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_5",
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1675946914,
+        "narHash": "sha256-OE0R9dnB+ZXpf30g1xVSMur68iKUDB53pnyA3K2e788=",
+        "owner": "voidlizard",
+        "repo": "suckless-conf",
+        "rev": "995e1cd52cfe2e9aa4e00ea5cd016548f7932e5a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "voidlizard",
+        "repo": "suckless-conf",
+        "type": "github"
+      }
     }
   },
   "root": "root",

flake.nix

@@ -12,6 +12,9 @@ inputs = {
     fixme.url = "github:voidlizard/fixme";
     fixme.inputs.nixpkgs.follows = "nixpkgs";
 
+    suckless-conf.url = "github:voidlizard/suckless-conf";
+    suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
+
     saltine = {
       url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d";
       flake = false;
@@ -27,6 +30,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
    name = "hbs2";
 
    haskellFlakes = with inputs; [
+     suckless-conf
    ];
 
    packageNames = [

hbs2-core/lib/HBS2/Net/Auth/Credentials.hs

@@ -152,6 +152,14 @@ instance ( Serialise  (PeerCredentials e)
 instance Pretty (AsBase58 Sign.PublicKey) where
   pretty (AsBase58 pk) = pretty $ B8.unpack $ toBase58 (Crypto.encode pk)
 
+-- FIXME: test-from-string-maybe-sign-pub-key
+--
+instance FromStringMaybe Sign.PublicKey where
+  fromStringMay s = de
+    where
+      de = bs >>= Crypto.decode
+      bs = fromBase58 (fromString s)
+
 instance Pretty (AsBase58 a) => Pretty (AsCredFile (AsBase58 a)) where
   pretty (AsCredFile pc) =  "# hbs2 credentials file" <> line
                          <> "# keep it private" <> line <> line

hbs2-core/lib/HBS2/Prelude.hs

@@ -8,6 +8,7 @@ module HBS2.Prelude
   , lift
   , AsFileName(..)
   , Pretty
+  , FromStringMaybe(..)
   ) where
 
 import Data.String (IsString(..))
@@ -37,3 +38,7 @@ instance Pretty a => Pretty (AsFileName a) where
       x = show (pretty f) & Text.pack
                           & Text.filter (not . Char.isPunctuation)
 
+class FromStringMaybe a where
+  fromStringMay :: String -> Maybe a
+
+

hbs2-peer/app/PeerConfig.hs

@@ -0,0 +1,132 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+{-# Language PatternSynonyms #-}
+module PeerConfig
+  ( module PeerConfig
+  , module Data.Config.Suckless
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.System.Logger.Simple
+import HBS2.Base58
+
+import Data.Config.Suckless
+
+import Control.Exception
+import Data.Either
+import Data.Functor
+import Data.Kind
+import Data.Maybe
+import Prettyprinter
+import System.Directory
+import System.FilePath
+import Data.Set qualified as Set
+import Data.Set (Set)
+import Data.Text qualified as Text
+
+class HasCfgKey a b where
+  -- type family CfgValue a :: Type
+  key :: Id
+
+class HasCfgKey a b => HasCfgValue a b where
+  cfgValue :: PeerConfig -> b
+
+type C = MegaParsec
+
+pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
+pattern Key n ns <- SymbolVal  n : ns
+
+cfgName :: FilePath
+cfgName = "config"
+
+newtype PeerConfig =
+  PeerConfig [Syntax C]
+  deriving newtype (Monoid, Semigroup)
+
+
+peerConfigDefault :: MonadIO m => m FilePath
+peerConfigDefault = liftIO $
+  catchAny (getXdgDirectory XdgConfig "hbs2-peer" <&> (</> cfgName))
+           (const $ pure ".hbs2-peer.conf")
+
+  where
+    catchAny :: IO a -> (SomeException -> IO a) -> IO a
+    catchAny = Control.Exception.catch
+
+
+peerConfigInit :: Maybe FilePath -> IO ()
+peerConfigInit mbfp = do
+  debug $ "peerConfigInit" <+> pretty mbfp
+
+  defDir <- peerConfigDefault <&> takeDirectory
+
+  let dir = fromMaybe defDir mbfp
+
+  createDirectoryIfMissing True dir
+
+  let conf = dir </> cfgName
+
+  here <- liftIO $ doesFileExist conf
+
+  unless here do
+    appendFile (dir</>cfgName) ";; hbs2-peer config file"
+
+peerConfigRead :: MonadIO m => Maybe FilePath -> m PeerConfig
+peerConfigRead mbfp = do
+  debug $ "peerConfigRead" <+> pretty mbfp
+
+  xdg <- peerConfigDefault
+
+  let cfgPath = fromMaybe xdg mbfp </> cfgName
+  let dir = takeDirectory cfgPath
+
+  here <- liftIO $ doesFileExist cfgPath
+
+  if not here then do
+    debug "no config found"
+    pure mempty
+
+  else do
+
+    -- FIXME: config-parse-error-handling
+    --  Handle parse errors
+
+    confData <- liftIO $ readFile cfgPath <&> parseTop
+
+    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)) ]
+
+                x -> pure x
+
+    pure $ PeerConfig $ fromRight mempty config
+
+
+instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) where
+  cfgValue (PeerConfig syn) = val
+    where
+      val =
+        lastMay [ fromString (show $ pretty e)
+                | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b)
+                ]
+
+
+instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a [b]) => HasCfgValue a [b] where
+  cfgValue (PeerConfig syn) = val
+    where
+      val = [ fromString (show $ pretty e)
+            | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @[b]
+            ]
+
+instance {-# OVERLAPPABLE #-} (Ord b, IsString b, HasCfgKey a (Set b)) => HasCfgValue a (Set b) where
+  cfgValue (PeerConfig syn) = Set.fromList val
+    where
+      val = [ fromString (show $ pretty e)
+            | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Set b)
+            ]
+

hbs2-peer/app/PeerMain.hs

@@ -2,6 +2,7 @@
 {-# Language TemplateHaskell #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language UndecidableInstances #-}
+{-# Language MultiWayIf #-}
 module Main where
 
 import HBS2.Actors.Peer
@@ -31,7 +32,10 @@ import RPC
 import PeerTypes
 import BlockDownload
 import PeerInfo
+import PeerConfig
 
+import Data.Text qualified as Text
+import Data.Foldable (for_)
 import Data.Maybe
 import Crypto.Saltine (sodiumInit)
 import Data.Function
@@ -52,6 +56,7 @@ import Prettyprinter
 import System.Directory
 import System.Exit
 import System.IO
+import Data.Set (Set)
 
 defStorageThreads :: Integral a => a
 defStorageThreads = 4
@@ -65,6 +70,53 @@ defRpcUDP = "localhost:13331"
 defLocalMulticast :: String
 defLocalMulticast = "239.192.152.145:10153"
 
+
+data PeerListenKey
+data PeerRpcKey
+data PeerKeyFileKey
+data PeerBlackListKey
+data PeerStorageKey
+data PeerAcceptAnnounceKey
+
+data AcceptAnnounce = AcceptAnnounceAll
+                    | AcceptAnnounceFrom (Set (PubKey 'Sign UDP))
+
+instance Pretty AcceptAnnounce where
+  pretty = \case
+    AcceptAnnounceAll     -> parens ("accept-announce" <+> "*")
+
+    -- FIXME: better-pretty-for-AcceptAnnounceFrom
+    AcceptAnnounceFrom xs -> parens ("accept-announce" <+> pretty (fmap AsBase58 (Set.toList xs)))
+
+instance HasCfgKey PeerListenKey (Maybe String) where
+  key = "listen"
+
+instance HasCfgKey PeerRpcKey (Maybe String) where
+  key = "rpc"
+
+instance HasCfgKey PeerKeyFileKey (Maybe String) where
+  key = "key"
+
+instance HasCfgKey PeerStorageKey (Maybe String) where
+  key = "storage"
+
+instance HasCfgKey PeerBlackListKey (Set String) where
+  key = "blacklist"
+
+instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where
+  key = "accept-block-announce"
+
+instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
+  cfgValue (PeerConfig syn) = fromMaybe (AcceptAnnounceFrom lst) fromAll
+    where
+      fromAll = headMay [ AcceptAnnounceAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ]
+      lst = Set.fromList $
+                catMaybes [ fromStringMay @(PubKey 'Sign UDP) (Text.unpack e)
+                          | ListVal @C (Key s [LitStrVal e]) <- syn, s == kk
+                          ]
+      kk = key @PeerAcceptAnnounceKey @AcceptAnnounce
+
+
 data RPCCommand =
     POKE
   | ANNOUNCE (Hash HbSync)
@@ -75,9 +127,10 @@ data RPCCommand =
 data PeerOpts =
   PeerOpts
   { _storage       :: Maybe StoragePrefix
-  , _listenOn      :: String
+  , _listenOn      :: Maybe String
-  , _listenRpc     :: String
+  , _listenRpc     :: Maybe String
-  , _peerCredFile  :: FilePath
+  , _peerCredFile  :: Maybe FilePath
+  , _peerConfig    :: Maybe FilePath
   }
   deriving stock (Data)
 
@@ -106,7 +159,8 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
   )
   where
     parser ::  Parser (IO ())
-    parser = hsubparser (  command "run"       (info pRun  (progDesc "run peer"))
+    parser = hsubparser (  command "init"      (info pInit (progDesc "creates default config"))
+                        <> command "run"       (info pRun  (progDesc "run peer"))
                         <> command "poke"      (info pPoke (progDesc "poke peer by rpc"))
                         <> command "announce"  (info pAnnounce (progDesc "announce block"))
                         <> command "ping"      (info pPing (progDesc "ping another peer"))
@@ -117,20 +171,18 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
       pref <- optional $ strOption ( short 'p' <> long "prefix"
                                                <> help "storage prefix" )
 
-      l    <- strOption ( short 'l' <> long "listen"
+      l    <- optional $ strOption ( short 'l' <> long "listen"
-                                    <> help "addr:port"
+                                    <> help "addr:port" )
-                                    <> value defListenUDP )
 
-      r    <- strOption ( short 'r' <> long "rpc"
+      r    <- optional $ strOption ( short 'r' <> long "rpc"
-                                    <> help "addr:port"
+                                    <> help "addr:port" )
-                                    <> value defRpcUDP )
 
-      k    <- strOption ( short 'k' <> long "key"
+      k    <- optional $ strOption ( short 'k' <> long "key"
-                                    <> help "peer keys file"
+                                    <> help "peer keys file" )
-                        )
 
+      c <- optional $ strOption ( long "config"  <> short 'c' <> help "config" )
 
-      pure $ PeerOpts pref l r k
+      pure $ PeerOpts pref l r k c
 
     pRun = do
       runPeer <$> common
@@ -160,6 +212,10 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
       h   <- strArgument ( metavar "ADDR" )
       pure $ runRpcCommand rpc (PING h Nothing)
 
+    pInit = do
+      pref <- optional $ strArgument ( metavar "DIR" )
+      pure $ peerConfigInit pref
+
 myException :: SomeException -> IO ()
 myException e = die ( show e ) >> exitFailure
 
@@ -225,12 +281,51 @@ instance ( Monad m
 runPeer :: forall e . e ~ UDP => PeerOpts -> IO ()
 runPeer opts = Exception.handle myException $ do
 
+  xdg <- getXdgDirectory XdgData defStorePath <&> fromString
+
+  conf <- peerConfigRead (view peerConfig opts)
+
+  -- let (PeerConfig syn) = conf
+  -- print $ pretty syn
+
+  let listenConf = cfgValue @PeerListenKey conf
+  let rpcConf = cfgValue @PeerRpcKey conf
+  let keyConf = cfgValue @PeerKeyFileKey conf
+  let storConf = cfgValue @PeerStorageKey conf <&> StoragePrefix
+
+  let listenSa = view listenOn opts <|> listenConf <|> Just defListenUDP
+  let rpcSa = view listenRpc opts <|> rpcConf <|> Just defRpcUDP
+  credFile <- pure (view peerCredFile opts <|> keyConf) `orDie` "credentials not set"
+
+  let pref = view storage opts <|> storConf <|> Just xdg
+
+  debug $ "storage prefix:" <+> pretty pref
+
+  let bls = cfgValue @PeerBlackListKey conf :: Set String
+
+  let blkeys = Set.fromList
+                    $ catMaybes [ fromStringMay x | x <- Set.toList bls
+                                ] :: Set (PubKey 'Sign UDP)
+
+  let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce
+
+  print $ pretty accptAnn
+
+  -- FIXME: move-peerBanned-somewhere
+  let peerBanned p d = do
+        let k = view peerSignKey d
+        pure $ k `Set.member` blkeys
+
+  let acceptAnnounce p d = do
+        case accptAnn of
+          AcceptAnnounceAll    -> pure True
+          AcceptAnnounceFrom s -> pure $ view peerSignKey d `Set.member` s
 
   rpcQ <- newTQueueIO @RPCCommand
 
   let ps = mempty
 
-  pc' <- LBS.readFile (view peerCredFile opts)
+  pc' <- LBS.readFile credFile
             <&> parseCredentials @e . AsCredFile
                                     . LBS.toStrict
                                     . LBS.take 4096
@@ -239,9 +334,7 @@ runPeer opts = Exception.handle myException $ do
 
   notice $ "run peer" <+> pretty (AsBase58 (view peerSignPk pc))
 
-  xdg <- getXdgDirectory XdgData defStorePath <&> fromString
 
-  let pref = uniLastDef xdg (view storage opts) :: StoragePrefix
 
   s <- simpleStorageInit @HbSync (Just pref)
   let blk = liftIO . hasBlock s
@@ -255,13 +348,13 @@ runPeer opts = Exception.handle myException $ do
 
   notice $ "multicast:" <+> pretty localMulticast
 
-  mess <- newMessagingUDP False (Just (view listenOn opts))
+  mess <- newMessagingUDP False listenSa
             `orDie` "unable listen on the given addr"
 
   udp <- async $ runMessagingUDP mess
                    `catch` (\(e::SomeException) -> throwIO e )
 
-  udp1 <- newMessagingUDP False (Just (view listenRpc opts))
+  udp1 <- newMessagingUDP False rpcSa
             `orDie` "Can't start RPC listener"
 
   mrpc <- async $ runMessagingUDP udp1
@@ -292,20 +385,27 @@ runPeer opts = Exception.handle myException $ do
               subscribe @e PeerAnnounceEventKey $ \(PeerAnnounceEvent pip nonce) -> do
                 unless (nonce == pnonce) $ do
                   debug $ "Got peer announce!" <+> pretty pip
-                  known <- find (KnownPeerKey pip) id <&> isJust
+                  pd <- find (KnownPeerKey pip) id -- <&> isJust
+                  banned <- maybe (pure False) (peerBanned pip) pd
+                  let known = isJust pd && not banned
                   unless known $ sendPing pip
 
               subscribe @e AnyKnownPeerEventKey $ \(KnownPeerEvent p d) -> do
 
                 let thatNonce = view peerOwnNonce d
 
-                -- FIXME: check if we've got a reference to ourselves
+                banned <- peerBanned p d
-                if pnonce == thatNonce then  do
-                  delPeers pl [p]
-                  addExcluded pl [p]
-                  expire (KnownPeerKey p)
 
-                else do
+                -- FIXME: check if we've got a reference to ourselves
+                if | pnonce == thatNonce -> do
+                    delPeers pl [p]
+                    addExcluded pl [p]
+                    expire (KnownPeerKey p)
+
+                   | banned -> do
+                       notice $ pretty p <+> "banned"
+
+                   | otherwise -> do
 
                     pd' <- knownPeers @e pl >>=
                               \peers -> forM peers $ \pip -> do
@@ -387,14 +487,31 @@ runPeer opts = Exception.handle myException $ do
                                               <+> pretty h
 
                                 case peer of
-                                  Nothing -> sendPing @e pip
+                                  Nothing -> do
-                                  Just{}  -> do
+                                    sendPing @e pip
-                                    debug "announce from a known peer"
+                                    -- TODO: enqueue-announce-from-unknown-peer?
-                                    debug "preparing to dowload shit"
-                                    debug "checking policy, blah-blah-blah. tomorrow"
 
-                                    withDownload denv $ do
+                                  Just pd  -> do
-                                      processBlock h
+
+                                    banned <- peerBanned pip pd
+
+                                    notAccepted <- acceptAnnounce pip pd <&> not
+
+                                    if | banned -> do
+
+                                          notice $ pretty pip <+> "banned"
+
+                                       | notAccepted -> do
+
+                                          debug $ pretty pip <+> "announce-not-accepted"
+
+                                       | otherwise -> do
+
+                                          debug "announce from a known peer"
+                                          debug "preparing to dowload shit"
+
+                                          withDownload denv $ do
+                                            processBlock h
 
                             _ -> pure ()
 

hbs2-peer/examples/config/config

@@ -0,0 +1,20 @@
+;; hbs2-peer config file
+
+;; dquotes cause number literals
+;; starts from digit!
+
+listen "0.0.0.0:7353"
+rpc    "127.0.0.1:13333"
+key    "./key"
+
+
+storage "./storage"
+
+;; other parameters
+
+blacklist "G4SPdgMAd3Vvu7fHaDuHSDUAB82nAWnovwaRYdxwvwS1"
+
+;; blacklist "AAh9rjcgg2Zfmd9c8xAhVPBEmUCyYM7wHGxjjqYDZYRb"
+
+;; accept-block-announce *
+;; accept-block-announce "AAh9rjcgg2Zfmd9c8xAhVPBEmUCyYM7wHGxjjqYDZYRb"

hbs2-peer/hbs2-peer.cabal

@@ -39,6 +39,7 @@ common common-deps
         , random-shuffle
         , safe
         , saltine >=0.2.0.1
+        , suckless-conf
         , serialise
         , split
         , stm
@@ -106,6 +107,7 @@ executable hbs2-peer
                     , PokePostponed
                     , RPC
                     , PeerTypes
+                    , PeerConfig
 
     -- other-extensions:
     build-depends:    base