mirror of https://github.com/voidlizard/hbs2
peer-config, peer-blacklist, peer-accept-announce
This commit is contained in:
Dmitry Zuikov
parent
51c1c77151
commit
2c7c09a838
|
|
@ -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
|
||||
|
||||
Смотреть, если пир в чёрном списке --- от отвергать от него
|
||||
|
|
|
|||
57
flake.lock
57
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",
|
||||
|
|
|
|||
|
|
@ -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 = [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
]
|
||||
|
||||
|
|
@ -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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue