diff --git a/docs/devlog.md b/docs/devlog.md index b1a90c4e..192f48ff 100644 --- a/docs/devlog.md +++ b/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 Смотреть, если пир в чёрном списке --- от отвергать от него diff --git a/flake.lock b/flake.lock index a6776d36..87dd59a6 100644 --- a/flake.lock +++ b/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", diff --git a/flake.nix b/flake.nix index 849d74de..566e016a 100644 --- a/flake.nix +++ b/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 = [ diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 08ec6b43..535d5508 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 924735b9..b7206c6d 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/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 + + diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs new file mode 100644 index 00000000..11b0bb74 --- /dev/null +++ b/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 (dircfgName) ";; 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) + ] + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 86a83bc2..bc962805 100644 --- a/hbs2-peer/app/PeerMain.hs +++ 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 - , _listenRpc :: String - , _peerCredFile :: FilePath + , _listenOn :: Maybe String + , _listenRpc :: Maybe String + , _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" - <> help "addr:port" - <> value defListenUDP ) + l <- optional $ strOption ( short 'l' <> long "listen" + <> help "addr:port" ) - r <- strOption ( short 'r' <> long "rpc" - <> help "addr:port" - <> value defRpcUDP ) + r <- optional $ strOption ( short 'r' <> long "rpc" + <> help "addr:port" ) - k <- strOption ( short 'k' <> long "key" - <> help "peer keys file" - ) + k <- optional $ strOption ( short 'k' <> long "key" + <> 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 - if pnonce == thatNonce then do - delPeers pl [p] - addExcluded pl [p] - expire (KnownPeerKey p) + banned <- peerBanned p d - 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 - Just{} -> do - debug "announce from a known peer" - debug "preparing to dowload shit" - debug "checking policy, blah-blah-blah. tomorrow" + Nothing -> do + sendPing @e pip + -- TODO: enqueue-announce-from-unknown-peer? - withDownload denv $ do - processBlock h + Just pd -> do + + 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 () diff --git a/hbs2-peer/examples/config/config b/hbs2-peer/examples/config/config new file mode 100644 index 00000000..79a4d3b1 --- /dev/null +++ b/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" diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 97188a1b..2655b508 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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