support for IPv6 and logging of event counters

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

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

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

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

src/Chainweb/Chainweb/PeerResources.hs

@@ -1,6 +1,16 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
@@ -35,25 +45,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 +69,7 @@ import System.LogLevel
 
 -- internal modules
 
+import Chainweb.Counter
 import Chainweb.Graph
 import Chainweb.HostAddress
 import Chainweb.Logger
@@ -165,12 +171,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 +196,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 +217,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 +238,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