diff --git a/chainweb.cabal b/chainweb.cabal index eb1bfb2616..d6124199a8 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -32,13 +32,6 @@ source-repository head type: git location: https://github.com/kadena-io/chainweb.git -common warning-flags - ghc-options: - -Wall - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints - flag tls13 description: Enable TLSv1.3; depends on the master branch of the tls package. @@ -52,12 +45,32 @@ flag ed25519 default: False manual: True +flag debug + description: + Enable various debugging features + default: False + manual:True + +common debugging-flags + if flag(debug) + ghc-options: + -g + cpp-options: + -DDEBUG_MULTINODE_TEST=1 + +common warning-flags + ghc-options: + -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -- -------------------------------------------------------------------------- -- -- Chainweb Library -- -------------------------------------------------------------------------- -- library - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 hs-source-dirs: src exposed-modules: @@ -76,6 +89,7 @@ library , Chainweb.Chainweb.CutResources , Chainweb.Chainweb.MinerResources , Chainweb.Chainweb.PeerResources + , Chainweb.Counter , Chainweb.Crypto.MerkleLog , Chainweb.Cut , Chainweb.Cut.CutHashes @@ -298,7 +312,7 @@ library -- -------------------------------------------------------------------------- -- test-suite chainweb-tests - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 ghc-options: -threaded @@ -399,8 +413,9 @@ test-suite chainweb-tests -- -------------------------------------------------------------------------- -- -- Chainweb Benchmarking -- -------------------------------------------------------------------------- -- + benchmark chainweb-bench - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Bench.hs @@ -427,7 +442,7 @@ benchmark chainweb-bench -- The application that runs an chainweb node -- executable chainweb-node - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 ghc-options: -threaded @@ -464,11 +479,16 @@ executable chainweb-node , warp >= 3.2 , yet-another-logger >= 0.3.1 +-- -------------------------------------------------------------------------- -- +-- Slow Tests +-- -------------------------------------------------------------------------- -- + -- This is not classified as a test suite because that allows us to do a wider -- variety of testing such as using the network, etc--things that aren't allowed -- in a nix build sandbox. +-- executable slow-tests - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 ghc-options: -threaded @@ -534,6 +554,7 @@ executable slow-tests , stm , stm-chans , streaming >= 0.2.2 + , streaming-commons >= 0.2 , strict-tuple >= 0.1 , tasty >= 1.0 , tasty-golden >= 2.3 @@ -558,7 +579,7 @@ executable slow-tests -- -------------------------------------------------------------------------- -- executable blockheaderdb-example - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 ghc-options: -threaded @@ -583,7 +604,7 @@ executable blockheaderdb-example -- -------------------------------------------------------------------------- -- executable p2p-example - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 ghc-options: -threaded @@ -618,7 +639,7 @@ executable p2p-example -- -------------------------------------------------------------------------- -- executable transaction-generator - import: warning-flags + import: warning-flags, debugging-flags default-language: Haskell2010 ghc-options: -threaded diff --git a/node/ChainwebNode.hs b/node/ChainwebNode.hs index 60f64d3268..8c215f3089 100644 --- a/node/ChainwebNode.hs +++ b/node/ChainwebNode.hs @@ -64,7 +64,7 @@ import System.LogLevel import Chainweb.Chainweb import Chainweb.Chainweb.CutResources -import Chainweb.Chainweb.PeerResources +import Chainweb.Counter import Chainweb.Cut.CutHashes import Chainweb.CutDB import Chainweb.Graph @@ -194,17 +194,18 @@ withNodeLogger logConfig f = runManaged $ do $ mkTelemetryLogger @CutHashes mgr teleLogConfig p2pInfoBackend <- managed $ mkTelemetryLogger @P2pSessionInfo mgr teleLogConfig - managerBackend <- managed - $ mkTelemetryLogger @ConnectionManagerStats mgr teleLogConfig rtsBackend <- managed $ mkTelemetryLogger @RTSStats mgr teleLogConfig + counterBackend <- managed $ configureHandler + (withJsonHandleBackend @CounterLog "connectioncounters" mgr) + teleLogConfig logger <- managed $ L.withLogger (_logConfigLogger logConfig) $ logHandles [ logHandler monitorBackend , logHandler p2pInfoBackend - , logHandler managerBackend , logHandler rtsBackend + , logHandler counterBackend ] baseBackend liftIO $ f logger diff --git a/src/Chainweb/Chainweb.hs b/src/Chainweb/Chainweb.hs index 7450360d3e..a80d0248d4 100644 --- a/src/Chainweb/Chainweb.hs +++ b/src/Chainweb/Chainweb.hs @@ -305,7 +305,7 @@ runChainweb cw = do let cutDb = _cutResCutDb $ _chainwebCutResources cw cutPeerDb = _peerResDb $ _cutResPeer $ _chainwebCutResources cw - -- Startup sequnce: + -- Startup sequence: -- -- 1. Start serving Rest API -- 2. Start Clients diff --git a/src/Chainweb/Chainweb/ChainResources.hs b/src/Chainweb/Chainweb/ChainResources.hs index 9c644a6d41..f4d55efce2 100644 --- a/src/Chainweb/Chainweb/ChainResources.hs +++ b/src/Chainweb/Chainweb/ChainResources.hs @@ -148,7 +148,7 @@ runChainSyncClient -> IO () runChainSyncClient mgr chain = bracket create destroy go where - syncLogger = setComponent "sync" $ _chainResLogger chain + syncLogger = setComponent "header-sync" $ _chainResLogger chain netId = ChainNetwork (_chainId chain) syncLogg = logFunctionText syncLogger create = p2pCreateNode @@ -192,7 +192,7 @@ runMempoolSyncClient mgr chain = bracket create destroy go where create = do logg Debug "starting mempool p2p sync" - p2pCreateNode v netId peer (logFunction $ _chainResLogger chain) peerDb mgr $ + p2pCreateNode v netId peer (logFunction syncLogger) peerDb mgr $ mempoolSyncP2pSession chain go n = do -- Run P2P client node @@ -206,7 +206,9 @@ runMempoolSyncClient mgr chain = bracket create destroy go p2pConfig = _peerResConfig $ _chainResPeer chain peerDb = _peerResDb $ _chainResPeer chain netId = ChainNetwork $ _chainId chain - logg = logFunctionText (_chainResLogger chain) + + logg = logFunctionText syncLogger + syncLogger = setComponent "mempool-sync" $ _chainResLogger chain mempoolSyncP2pSession :: ChainResources logger -> P2pSession mempoolSyncP2pSession chain logg0 env = go diff --git a/src/Chainweb/Chainweb/PeerResources.hs b/src/Chainweb/Chainweb/PeerResources.hs index f8cb87e85c..082388e8e7 100644 --- a/src/Chainweb/Chainweb/PeerResources.hs +++ b/src/Chainweb/Chainweb/PeerResources.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | @@ -35,25 +30,20 @@ module Chainweb.Chainweb.PeerResources , withSocket , withPeerDb , withConnectionManger -, ConnectionManagerStats(..) ) where import Configuration.Utils hiding (Lens', (<.>), Error) import Control.Concurrent import Control.Concurrent.Async -import Control.DeepSeq import Control.Lens hiding ((.=), (<.>)) import Control.Monad import Control.Monad.Catch import qualified Data.ByteString.Char8 as B8 import qualified Data.HashSet as HS -import Data.IORef import Data.IxSet.Typed (getEQ, getOne) -import GHC.Generics - import qualified Network.HTTP.Client as HTTP import Network.Socket (Socket, close) import Network.Wai.Handler.Warp (Settings, defaultSettings, setHost, setPort) @@ -64,6 +54,7 @@ import System.LogLevel -- internal modules +import Chainweb.Counter import Chainweb.Graph import Chainweb.HostAddress import Chainweb.Logger @@ -165,12 +156,6 @@ withPeerDb_ v conf = bracket (startPeerDb_ v conf) (stopPeerDb conf) -- -------------------------------------------------------------------------- -- -- Connection Manager -data ConnectionManagerStats = ConnectionManagerStats - { _connectionManagerConnectionCount :: !Int - , _connectionManagerRequestCount :: !Int - } - deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, NFData) - -- Connection Manager -- withConnectionManger @@ -196,18 +181,17 @@ withConnectionManger logger cert key peerDb runInner = do -- total number of connections to keep alive. 512 is the default } - - connCountRef <- newIORef (0 :: Int) - reqCountRef <- newIORef (0 :: Int) + connCountRef <- newCounter @"connection-count" + reqCountRef <- newCounter @"request-count" + urlStats <- newCounterMap @"url-counts" mgr <- HTTP.newManager settings' { HTTP.managerTlsConnection = do mk <- HTTP.managerTlsConnection settings' - return $ \a b c -> do - atomicModifyIORef' connCountRef $ (,()) . succ - mk a b c + return $ \a b c -> inc connCountRef >> mk a b c , HTTP.managerModifyRequest = \req -> do - atomicModifyIORef' reqCountRef $ (,()) . succ + inc reqCountRef + incKey urlStats (sshow $ HTTP.getUri req) HTTP.managerModifyRequest settings req { HTTP.responseTimeout = HTTP.responseTimeoutMicro 1000000 -- overwrite the explicit connection timeout from servant-client @@ -218,10 +202,11 @@ withConnectionManger logger cert key peerDb runInner = do let logClientConnections = forever $ do threadDelay 60000000 {- 1 minute -} - stats <- ConnectionManagerStats - <$> readIORef connCountRef - <*> readIORef reqCountRef - logFunctionJson logger Info stats + logFunctionCounter logger Info =<< sequence + [ roll connCountRef + , roll reqCountRef + , roll urlStats + ] let runLogClientConnections umask = do umask logClientConnections `catchAllSynchronous` \e -> do @@ -238,5 +223,7 @@ withConnectionManger logger cert key peerDb runInner = do pe <- getOne . getEQ ha <$> peerDbSnapshot peerDb return $ pe >>= fmap peerIdToFingerprint . _peerId . _peerEntryInfo - serviceIdToHostAddress (h, p) = readHostAddressBytes $ B8.pack h <> ":" <> p + serviceIdToHostAddress (h, p) = HostAddress + <$> readHostnameBytes (B8.pack h) + <*> readPortBytes p diff --git a/src/Chainweb/Counter.hs b/src/Chainweb/Counter.hs new file mode 100644 index 0000000000..a1db0c83ad --- /dev/null +++ b/src/Chainweb/Counter.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Chainweb.Counter +-- Copyright: Copyright © 2019 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- TODO +-- +module Chainweb.Counter +( Counter +, newCounter +, inc +, incBy + +-- * Counter Map +, CounterMap +, newCounterMap +, incKey +, incKeyBy + +-- * Rolling of Counters +, CounterValue +, roll + +-- * Logging of Counters +, CounterLog +, LogFunctionCounter +, logFunctionCounter +) where + +import Control.DeepSeq + +import Data.Aeson +import Data.Foldable +import qualified Data.HashMap.Strict as HM +import Data.IORef +import qualified Data.Text as T +import qualified Data.Vector as V + +import GHC.Generics +import GHC.TypeLits + +import System.LogLevel + +-- internal modules + +import Chainweb.Logger +import Chainweb.Utils + +import Data.LogMessage + +-- -------------------------------------------------------------------------- -- +-- Typelevel Labeled Values + +newtype Labeled (s :: Symbol) a = Labeled a + deriving (Show, Eq, Ord, Generic) + deriving (Functor, Foldable, Traversable) + deriving newtype (Num, Enum, Bounded, Integral, Real, NFData) + +instance (KnownSymbol s, ToJSON a) => ToJSON (Labeled s a) where + toJSON (Labeled a) = object + [ symbolText @s @T.Text .= a + ] + {-# INLINE toJSON #-} + +pair :: forall s a . KnownSymbol s => Labeled s a -> (T.Text, a) +pair (Labeled a) = (symbolText @s, a) +{-# INLINE pair #-} + +jsonPair :: KnownSymbol s => ToJSON a => Labeled s a -> (T.Text, Value) +jsonPair = fmap toJSON . pair +{-# INLINE jsonPair #-} + +-- -------------------------------------------------------------------------- -- +-- Class of Counters + +class IsCounter c where + roll :: c -> IO CounterValue + +instance KnownSymbol s => IsCounter (Counter s) where + roll = rollCounter + {-# INLINE roll #-} + +instance KnownSymbol s => IsCounter (CounterMap s) where + roll = rollCounterMap + {-# INLINE roll #-} + +-- -------------------------------------------------------------------------- -- +-- Counter + +newtype Counter (s :: Symbol) = Counter (IORef Int) + deriving (Eq, Generic) + deriving newtype (NFData) + +-- | Roll the counter and return the value +-- +rollCounter :: forall s . KnownSymbol s => Counter s -> IO CounterValue +rollCounter (Counter ref) = CounterValue @s . Labeled <$> atomicModifyIORef' ref (0,) + +newCounter :: IO (Counter s) +newCounter = Counter <$> newIORef 0 + +inc :: Counter s -> IO () +inc (Counter ref) = atomicModifyIORef' ref $ (,()) . succ + +incBy :: Integral a => Counter s -> a -> IO () +incBy (Counter ref) i = atomicModifyIORef' ref $ (,()) . (+) (int i) + +-- -------------------------------------------------------------------------- -- +-- CounterMap + +newtype CounterMap (s :: Symbol) = CounterMap (IORef (HM.HashMap T.Text (IORef Int))) + deriving (Eq, Generic) + +newCounterMap :: IO (CounterMap s) +newCounterMap = CounterMap <$> newIORef mempty + +-- | Roll the counters in the map and return the values. +-- +-- This operation traverses the map twice. First for count the elements in the +-- map ('HM.size' is of /O(n)/) and then to copy the entries to the result +-- vector. Depending on the expected size of map this can take some time. When +-- this is a concern the log function should be called asynchronously. +-- +rollCounterMap :: forall s . KnownSymbol s => CounterMap s -> IO CounterValue +rollCounterMap (CounterMap ref) = CounterMapValue @s . Labeled <$> do + old <- atomicModifyIORef ref (mempty,) + V.mapM (traverse readIORef) $ V.fromListN (HM.size old) $ HM.toList old + -- We assume that 'V.mapM' and 'V.fromListN' get fused. + +incKeyBy :: Integral a => CounterMap s -> T.Text -> a -> IO () +incKeyBy cm@(CounterMap mref) k i = do + (HM.lookup k <$> readIORef mref) >>= \case + Just cref -> atomicModifyIORef' cref $ (, ()) . (+) (int i) + Nothing -> do + cref <- newIORef 0 + atomicModifyIORef mref $ \m -> (HM.insert k cref m, ()) + -- We don't for the result to reduce contention in the atomic + -- swap. (It might be that the implementation of + -- 'atomicModifyMutVar#' already takes care of this by adding + -- adding the thunk for the update before doing any computation. + -- But that's not obvious from the implementation of + -- @atomicModifyIORef'@ and the documentation isn't clear. + + incKey cm k + +incKey :: CounterMap s -> T.Text -> IO () +incKey c k = incKeyBy c k (1 :: Int) +{-# INLINE incKey #-} + +-- -------------------------------------------------------------------------- -- +-- Counter Value + +data CounterValue where + CounterValue :: KnownSymbol s => {-# UNPACK #-} !(Labeled s Int) -> CounterValue + CounterMapValue :: KnownSymbol s => {-# UNPACK #-} !(Labeled s (V.Vector (T.Text, Int))) -> CounterValue + +instance NFData CounterValue where + rnf (CounterValue v) = rnf v + rnf (CounterMapValue v) = rnf v + {-# INLINE rnf #-} + +-- -------------------------------------------------------------------------- -- +-- Logging of Counters + +-- | The Counters are rolled at the time the message is logged (not when it is +-- processed by the backend). This adds a small amount of overhead, but ensures +-- that the timestamp of the log matches the time when the logs are rolled. This +-- means that logs are rolled even when the message ends up being discarded by +-- the backend, which means that counts are lost along with the discarded +-- messages. This is consistent with the semantics of discarding log messages. +-- +newtype CounterLog = CounterLog (V.Vector CounterValue) + deriving (Generic) + deriving newtype (NFData) + +instance LogMessage CounterLog where + logText = encodeToText + {-# INLINE logText #-} + +instance ToJSON CounterLog where + toJSON (CounterLog v) = object $ V.toList $ V.map f v + where + f (CounterValue i) = jsonPair i + f (CounterMapValue m) = jsonPair $ fmap (object . V.toList . V.map (fmap toJSON)) m + {-# INLINE toJSON #-} + +logFunctionCounter + :: Logger l + => l + -> LogFunctionCounter +logFunctionCounter logger level = logFunction logger level + . CounterLog + . V.fromList + . toList +{-# INLINE logFunctionCounter #-} + +type LogFunctionCounter = forall f . Foldable f => LogLevel -> f CounterValue -> IO () diff --git a/src/Chainweb/HostAddress.hs b/src/Chainweb/HostAddress.hs index f9233f5d66..d98b2c314d 100644 --- a/src/Chainweb/HostAddress.hs +++ b/src/Chainweb/HostAddress.hs @@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -39,8 +40,15 @@ -- @1*digit@ designates the decimal representation of an octet. The specification -- takes the form of hostnames from section 2.1 RFC1123, but limiting the -- rightmost (top-most) label to the from given in section 3 of RFC1034, which --- allows to disambiguate domain names and IPv4 addresses. IPv6 Addresses are --- not supported. +-- allows to disambiguate domain names and IPv4 addresses. +-- +-- IPv6 Addresses are partially supported. IPv6 address are parsed as described +-- in RFC4291, but embedding of IPv4 addresses is not supported. IPv6 addresses +-- are printed exactly as they where parsed. No normalization is performed. In +-- particular the recommendations from RFC5952 are not considered. For host +-- addresses RFC3986 and RFC 5952 are followed by requiring that IPv6 literals +-- are enclosed in square brackets. Anything else from RFC3986, which is +-- concerning URIs is ignored. -- -- Additional restriction for hostname apply from RFC1123: labels must have not -- more than 63 octets, letters are case-insenstive. The maximum length must not @@ -59,11 +67,14 @@ module Chainweb.HostAddress , portToText , portFromText , pPort +, readPortBytes -- * Hostnames , Hostname , hostnameBytes , localhost +, localhostIPv4 +, localhostIPv6 , readHostnameBytes , hostnameToText , hostnameFromText @@ -125,9 +136,14 @@ import Chainweb.Utils -- -------------------------------------------------------------------------- -- -- Internal Parsers -hostParser :: Parser () -hostParser = () - <$ (hostNameParser <|> () <$ ipV4Parser) +data HostType = HostTypeName | HostTypeIPv4 | HostTypeIPv6 + deriving (Show, Eq, Ord, Generic, Hashable) + +hostParser :: Parser HostType +hostParser + = HostTypeName <$ hostNameParser + <|> HostTypeIPv4 <$ ipV4Parser + <|> HostTypeIPv6 <$ ipV6Parser "host" hostNameParser :: Parser () @@ -165,27 +181,70 @@ ipV4Parser = (,,,) octet = (decimal >>= \(d :: Integer) -> int d <$ guard (d < 256)) "octet" +ipV6Parser :: Parser [Maybe Word16] +ipV6Parser = p0 + where + p0 = l1 <$> elision <* endOfInput + <|> l3 <$> elision <*> h16 <*> p2 6 + <|> l2 <$> h16 <*> p1 7 + "IPv6address" + + p1 :: Int -> Parser [Maybe Word16] + p1 0 = l0 <$ endOfInput "IPv6 prefix: too many segments" + p1 i = l1 <$> elision <* endOfInput + <|> l3 <$> elision <*> h16 <*> p2 (i - 2) + <|> l2 <$ ":" <*> h16 <*> p1 (i - 1) + "IPv6 prefix" + + p2 :: Int -> Parser [Maybe Word16] + p2 0 = l0 <$ endOfInput "IPv6 suffix: too many segments" + p2 i = l2 <$ ":" <*> h16 <*> p2 (i - 1) + <|> l0 <$ endOfInput + "IPv6 suffix" + + elision :: Parser (Maybe Word16) + elision = Nothing <$ "::" + + h16 :: Parser (Maybe Word16) + h16 = Just <$> do + h <- hexadecimal @Integer + guard $ h < int (maxBound @Word16) + return (int h) + "h16" + + l0 = [] + l1 = pure + l2 = (:) + l3 a b t = a:b:t + portParser :: Parser Port portParser = Port <$> (decimal >>= \(d :: Integer) -> int d <$ guard (d < 2^(16 :: Int))) "port" +parseBytes :: MonadThrow m => T.Text -> Parser a -> B8.ByteString -> m a +parseBytes name parser b = either (throwM . TextFormatException . msg) return + $ parseOnly (parser <* endOfInput) b + where + msg e = "Failed to parse " <> sshow b <> " as " <> name <> ": " + <> T.pack e + -- -------------------------------------------------------------------------- -- -- Arbitrary Values -- | TODO should we exclude network, broadcast, otherwise special values? -- arbitraryIpV4 :: Gen Hostname -arbitraryIpV4 = Hostname . CI.mk . B8.intercalate "." . fmap sshow +arbitraryIpV4 = HostnameIPv4 . CI.mk . B8.intercalate "." . fmap sshow <$> replicateM 4 (arbitrary :: Gen Word8) arbitraryIpV6 :: Gen Hostname -arbitraryIpV6 = Hostname . CI.mk . B8.intercalate "." . fmap sshow +arbitraryIpV6 = HostnameIPv6 . CI.mk . B8.intercalate ":" . fmap sshow <$> replicateM 8 (arbitrary :: Gen Word8) arbitraryDomainName :: Gen Hostname arbitraryDomainName = sized $ \n -> resize (min n 254) - . fmap (Hostname . mconcat . L.intersperse ".") + . fmap (HostnameName . mconcat . L.intersperse ".") $ (<>) <$> listOf (arbitraryDomainLabel False) <*> vectorOf 1 (arbitraryDomainLabel True) @@ -216,8 +275,7 @@ newtype Port = Port Word16 deriving newtype (Show, Real, Integral, Num, Bounded, Enum, ToJSON, FromJSON) readPortBytes :: MonadThrow m => B8.ByteString -> m Port -readPortBytes = either (throwM . TextFormatException . T.pack) return - . parseOnly (portParser <* endOfInput) +readPortBytes = parseBytes "port" portParser {-# INLINE readPortBytes #-} arbitraryPort :: Gen Port @@ -249,33 +307,58 @@ pPort service = textOption -- -------------------------------------------------------------------------- -- -- Hostnames -newtype Hostname = Hostname (CI.CI B8.ByteString) +data Hostname + = HostnameName (CI.CI B8.ByteString) + | HostnameIPv4 (CI.CI B8.ByteString) + | HostnameIPv6 (CI.CI B8.ByteString) deriving (Eq, Ord, Generic) deriving anyclass (Hashable, NFData) - deriving newtype (Show) + +instance Show Hostname where + show = B8.unpack . hostnameBytes readHostnameBytes :: MonadThrow m => B8.ByteString -> m Hostname -readHostnameBytes b = Hostname - <$> either (throwM . TextFormatException . T.pack) return (parseOnly parser b) +readHostnameBytes b = parseBytes "hostname" parser b where - parser = CI.mk b <$ hostParser <* endOfInput + parser = hostParser <* endOfInput >>= \case + HostTypeName -> return $ HostnameName (CI.mk b) + HostTypeIPv4 -> return $ HostnameIPv4 (CI.mk b) + HostTypeIPv6 -> return $ HostnameIPv6 (CI.mk b) {-# INLINE readHostnameBytes #-} localhost :: Hostname -localhost = Hostname "localhost" +localhost = HostnameName "localhost" {-# INLINE localhost #-} +-- | Using explicit IP addresses and not to "localhost" greatly improves +-- networking performance and Mac OS X. +-- +localhostIPv4 :: Hostname +localhostIPv4 = HostnameIPv4 "127.0.0.1" +{-# INLINE localhostIPv4 #-} + +-- | Using explicit IP addresses and not to "localhost" greatly improves +-- networking performance and Mac OS X. +-- +localhostIPv6 :: Hostname +localhostIPv6 = HostnameIPv6 "::1" +{-# INLINE localhostIPv6 #-} + hostnameBytes :: Hostname -> B8.ByteString -hostnameBytes (Hostname b) = CI.original b +hostnameBytes (HostnameName b) = CI.original b +hostnameBytes (HostnameIPv4 b) = CI.original b +hostnameBytes (HostnameIPv6 b) = CI.original b {-# INLINE hostnameBytes #-} arbitraryHostname :: Gen Hostname arbitraryHostname = oneof [ arbitraryIpV4 + , arbitraryIpV4 , arbitraryDomainName -- Note that not every valid domain name is also a valid host name. -- Generally, a hostname has at least one associated IP address. -- Also, syntactic restriction apply for certain top-level domains. + , pure (HostnameName "localhost") , pure localhost ] @@ -330,14 +413,32 @@ data HostAddress = HostAddress makeLenses ''HostAddress hostAddressBytes :: HostAddress -> B8.ByteString -hostAddressBytes a = hostnameBytes (_hostAddressHost a) - <> ":" <> sshow (_hostAddressPort a) +hostAddressBytes a = host <> ":" <> sshow (_hostAddressPort a) + where + ha = _hostAddressHost a + host = case ha of + HostnameIPv6 _ -> "[" <> hostnameBytes ha <> "]" + _ -> hostnameBytes ha {-# INLINE hostAddressBytes #-} readHostAddressBytes :: MonadThrow m => B8.ByteString -> m HostAddress -readHostAddressBytes bytes = do - let (h,p) = B8.break (== ':') bytes - HostAddress <$> readHostnameBytes h <*> readPortBytes (B8.drop 1 p) +readHostAddressBytes bytes = parseBytes "hostaddress" (hostAddressParser bytes) bytes + +-- | Parser a host address. The input bytestring isn't used for parsing but for +-- the constructing the reslt HostAddress. +-- +hostAddressParser :: B8.ByteString -> Parser HostAddress +hostAddressParser b = HostAddress + <$> hostnameParser' + <* ":" + <*> portParser + where + host = B8.init $ fst $ B8.breakEnd (== ':') b + hostnameParser' + = HostnameName (CI.mk host) <$ hostNameParser + <|> HostnameIPv4 (CI.mk host) <$ ipV4Parser + <|> HostnameIPv6 (CI.mk $ B8.init $ B8.tail host) <$ "[" <* ipV6Parser <* "]" + "host" hostAddressToText :: HostAddress -> T.Text hostAddressToText = T.decodeUtf8 . hostAddressBytes diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index 2dd3cf24dd..487cfa1e4f 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} @@ -143,6 +144,9 @@ module Chainweb.Utils -- * Filesystem , withTempDir +-- * Type Level +, symbolText + ) where import Configuration.Utils @@ -173,6 +177,7 @@ import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.Monoid (Endo) +import Data.Proxy import Data.Serialize.Get (Get) import Data.Serialize.Put (Put) import Data.String (IsString(..)) @@ -183,6 +188,7 @@ import Data.Word (Word64) import GHC.Generics import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownSymbol, symbolVal) import Numeric.Natural @@ -744,3 +750,10 @@ withTempDir tag f = bracket create delete f delete :: Path Absolute -> IO () delete = toAbsoluteFilePath >=> removeDirectoryRecursive + +-- -------------------------------------------------------------------------- -- +-- Typelevel + +symbolText :: forall s a . KnownSymbol s => IsString a => a +symbolText = fromString $ symbolVal (Proxy @s) + diff --git a/src/P2P/Peer.hs b/src/P2P/Peer.hs index 5d5f4033f4..beb640d66d 100644 --- a/src/P2P/Peer.hs +++ b/src/P2P/Peer.hs @@ -254,7 +254,7 @@ data PeerConfig = PeerConfig , _peerConfigInterface :: !HostPreference -- ^ The network interface that the peer binds to. Default is to - -- bind to all available interfaces (0.0.0.0). + -- bind to all available interfaces ('*'). , _peerConfigCertificate :: !(Maybe X509CertPem) -- ^ The X509 certificate of the peer. If this is Nothing a new ephemeral @@ -286,7 +286,7 @@ peerConfigHost = peerConfigAddr . hostAddressHost defaultPeerConfig :: PeerConfig defaultPeerConfig = PeerConfig { _peerConfigAddr = HostAddress localhost 0 - , _peerConfigInterface = fromString "0.0.0.0" + , _peerConfigInterface = fromString "*" , _peerConfigCertificate = Nothing , _peerConfigKey = Nothing } diff --git a/test/Chainweb/Test/MultiNode.hs b/test/Chainweb/Test/MultiNode.hs index 9b711979f2..8b8a01ae5d 100644 --- a/test/Chainweb/Test/MultiNode.hs +++ b/test/Chainweb/Test/MultiNode.hs @@ -34,7 +34,9 @@ -- module Chainweb.Test.MultiNode ( test ) where +#ifndef DEBUG_MULTINODE_TEST #define DEBUG_MULTINODE_TEST 0 +#endif import Control.Concurrent import Control.Concurrent.Async @@ -48,6 +50,7 @@ import Data.Foldable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Data.List +import Data.Streaming.Network (HostPreference) import qualified Data.Text as T #if DEBUG_MULTINODE_TEST import qualified Data.Text.IO as T @@ -106,6 +109,12 @@ import P2P.Peer -- similulate a full-scale chain in a miniaturized settings. -- +host :: Hostname +host = unsafeHostnameFromText "::1" + +interface :: HostPreference +interface = "::1" + -- | Test Configuration for a scaled down Test chainweb. -- config @@ -121,10 +130,14 @@ config v n nid chainDbDir = defaultChainwebConfiguration v & set configNodeId nid -- Set the node id. - & set (configP2p . p2pConfigPeer . peerConfigInterface) "127.0.0.1" + & set (configP2p . p2pConfigPeer . peerConfigHost) host + & set (configP2p . p2pConfigPeer . peerConfigInterface) interface -- Only listen on the loopback device. On Mac OS X this prevents the -- firewall dialog form poping up. + & set (configP2p . p2pConfigKnownPeers . _head . peerAddr . hostAddressHost) host + -- Set bootstrap host + & set (configP2p . p2pConfigMaxPeerCount) (n * 2) -- We make room for all test peers in peer db. @@ -166,11 +179,14 @@ bootstrapConfig conf = conf & set (configP2p . p2pConfigKnownPeers) [] where peerConfig = (head $ bootstrapPeerConfig $ _configChainwebVersion conf) - & set (peerConfigAddr . hostAddressPort) 0 + & set peerConfigPort 0 -- Normally, the port of bootstrap nodes is hard-coded. But in -- test-suites that may run concurrently we want to use a port that is -- assigned by the OS. + & set peerConfigHost host + & set peerConfigInterface interface + -- -------------------------------------------------------------------------- -- -- Minimal Node Setup that logs conensus state to the given mvar @@ -189,8 +205,9 @@ node loglevel write stateVar bootstrapPortVar conf = when (nid == NodeId 0) $ putMVar bootstrapPortVar (cwPort cw) runChainweb cw `finally` do - logFunctionText logger Info "write sample consensus state" + logFunctionText logger Info "write sample data" sample cw + logFunctionText logger Info "shutdown node" where nid = _configNodeId conf