introduce security logs

node/ChainwebNode.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -26,8 +27,6 @@
 -- Maintainer: Lars Kuhtz <[email protected]>
 -- Stability: experimental
 --
--- TODO
---
 module Main
 (
 -- * Configuration
@@ -379,55 +378,66 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do
     baseBackend <- managed
         $ withBaseHandleBackend "ChainwebApp" mgr pkgInfoScopes (_logConfigBackend logCfg)
 
-    -- we don't log tx failures in replay
-    let !txFailureHandler =
-            if _configOnlySyncPact chainwebCfg
-            then dropLogHandler (Proxy :: Proxy TxFailureLog)
-            else passthroughLogHandler
+    -- Backend for message that are logged to the security log
+    -- These messages are also forwarded to the rest of the stack
+    --
+    securityBackend <- managed
+        $ mkTelemetryLogger_ @SomeSecurityLog "securitylog" getSubType mgr securityLogConfig
 
     -- Telemetry Backends
     monitorBackend <- managed
-        $ mkTelemetryLogger @CutHashes mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog CutHashes) mgr teleLogConfig
     p2pInfoBackend <- managed
-        $ mkTelemetryLogger @P2pSessionInfo mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog P2pSessionInfo) mgr teleLogConfig
     rtsBackend <- managed
-        $ mkTelemetryLogger @RTSStats mgr teleLogConfig
-    counterBackend <- managed $ configureHandler
-        (withJsonHandleBackend @CounterLog "connectioncounters" mgr pkgInfoScopes)
-        teleLogConfig
+        $ mkTelemetryLogger @(JsonLog RTSStats) mgr teleLogConfig
+    counterBackend <- managed
+        $ mkTelemetryLogger_ @(JsonLog CounterLog) "connectioncounters" (const Nothing) mgr teleLogConfig
     endpointBackend <- managed
-        $ mkTelemetryLogger @PactCmdLog mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog PactCmdLog) mgr teleLogConfig
     newBlockBackend <- managed
-        $ mkTelemetryLogger @NewMinedBlock mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog NewMinedBlock) mgr teleLogConfig
     orphanedBlockBackend <- managed
-        $ mkTelemetryLogger @OrphanedBlock mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog OrphanedBlock) mgr teleLogConfig
     miningStatsBackend <- managed
-        $ mkTelemetryLogger @MiningStats mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog MiningStats) mgr teleLogConfig
     requestLogBackend <- managed
-        $ mkTelemetryLogger @RequestResponseLog mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog RequestResponseLog) mgr teleLogConfig
     queueStatsBackend <- managed
-        $ mkTelemetryLogger @QueueStats mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog QueueStats) mgr teleLogConfig
     reintroBackend <- managed
-        $ mkTelemetryLogger @ReintroducedTxsLog mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog ReintroducedTxsLog) mgr teleLogConfig
     traceBackend <- managed
-        $ mkTelemetryLogger @Trace mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog Trace) mgr teleLogConfig
     mempoolStatsBackend <- managed
-        $ mkTelemetryLogger @MempoolStats mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog MempoolStats) mgr teleLogConfig
     blockUpdateBackend <- managed
-        $ mkTelemetryLogger @BlockUpdate mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog BlockUpdate) mgr teleLogConfig
     dbCacheBackend <- managed
-        $ mkTelemetryLogger @DbCacheStats mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog DbCacheStats) mgr teleLogConfig
     dbStatsBackend <- managed
-        $ mkTelemetryLogger @DbStats mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog DbStats) mgr teleLogConfig
     pactQueueStatsBackend <- managed
-        $ mkTelemetryLogger @PactQueueStats mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog PactQueueStats) mgr teleLogConfig
     topLevelStatusBackend <- managed
-        $ mkTelemetryLogger @ChainwebStatus mgr teleLogConfig
+        $ mkTelemetryLogger @(JsonLog ChainwebStatus) mgr teleLogConfig
 
     logger <- managed
         $ L.withLogger (_logConfigLogger logCfg) $ logHandles
-            [ logFilterHandle (_logConfigFilter logCfg)
-            , txFailureHandler
+
+            -- we don't log tx failures in replay
+            [ staticLogFilterHandler @TxFailureLog (_configOnlySyncPact chainwebCfg)
+
+            -- apply log filter
+            , logFilterHandler (_logConfigFilter logCfg)
+
+            -- handle security log messages. All messages are
+            -- re-emitted for further processing.
+            , maybeLogHandler $ \msg -> do
+                securityBackend msg
+                return (Just $ toLogMessage <$> msg)
+
+            -- apply handlers for telemetry messages
             , logHandler monitorBackend
             , logHandler p2pInfoBackend
             , logHandler rtsBackend
@@ -454,16 +464,54 @@ withNodeLogger logCfg chainwebCfg v f = runManaged $ do
         $ logger
   where
     teleLogConfig = _logConfigTelemetryBackend logCfg
+    securityLogConfig = _logConfigSecurityBackend logCfg
+
+    -- sub-type lable function for security logs
+    getSubType (SomeSecurityLog a) = Just $ sshow $ innerType $ typeOf a
 
+-- | Provide backend for telemetry messages.
+--
+-- The type label of the backend is derived from the first type parameter of the
+-- function. When the Elasticsearch backend is used the type label is used as
+-- the name of the index.
+--
 mkTelemetryLogger
     :: forall a b
-    . (Typeable a, ToJSON a)
+    . Typeable a
+    => ToJSON a
     => HTTP.Manager
     -> EnableConfig BackendConfig
-    -> (Backend (JsonLog a) -> IO b)
+    -> (Backend a -> IO b)
     -> IO b
-mkTelemetryLogger mgr = configureHandler
-    $ withJsonHandleBackend @a (sshow $ typeRep $ Proxy @a) mgr pkgInfoScopes
+mkTelemetryLogger mgr = configureBackend
+    $ withJsonHandleBackend @a typ (const Nothing) mgr pkgInfoScopes
+  where
+    typ = sshow $ innerType $ typeRep $ Proxy @a
+
+-- | Same as 'mkTelemetryLogger', but also allows to set the type and sub-type
+-- labels.
+--
+mkTelemetryLogger_
+    :: forall a b
+    . Typeable a
+    => ToJSON a
+    => T.Text
+        -- ^ fixed type label (index for elasticsearch backend)
+    -> (a -> Maybe T.Text)
+        -- ^ sub-type label function
+    -> HTTP.Manager
+    -> EnableConfig BackendConfig
+    -> (Backend a -> IO b)
+    -> IO b
+mkTelemetryLogger_ typ subtyp mgr = configureBackend
+    $ withJsonHandleBackend @a typ subtyp mgr pkgInfoScopes
+
+-- Heuristically return the innermost type of a TypeRep.
+--
+innerType :: TypeRep -> TypeRep
+innerType t = case typeRepArgs t of
+    [] -> t
+    l -> innerType (last l)
 
 -- -------------------------------------------------------------------------- --
 -- Service Date

src/Chainweb/Chainweb.hs

@@ -122,6 +122,7 @@ import qualified Data.Vector as V
 import GHC.Generics
 
 import qualified Network.HTTP.Client as HTTP
+import qualified Network.HTTP.Types.Status as HTTP
 import Network.Socket (Socket)
 import Network.Wai
 import Network.Wai.Handler.Warp hiding (Port)
@@ -174,7 +175,7 @@ import Chainweb.WebPactExecutionService
 
 import Chainweb.Storage.Table.RocksDB
 
-import Data.LogMessage (LogFunctionText)
+import Data.LogMessage (LogFunctionText, JsonLog(..), SecurityLog(..))
 
 import P2P.Node.Configuration
 import P2P.Node.PeerDB (PeerDb)
@@ -665,6 +666,7 @@ runChainweb cw = do
         -- 1. Start serving Rest API
         [ (if tls then serve else servePlain)
             $ httpLog
+            . securityHttpLog
             . throttle (_chainwebPutPeerThrottler cw)
             . throttle (_chainwebMempoolThrottler cw)
             . throttle (_chainwebThrottler cw)
@@ -678,6 +680,7 @@ runChainweb cw = do
         , threadDelay 500000 >> do
             serveServiceApi
                 $ serviceHttpLog
+                . serviceSecurityHttpLog
                 . serviceRequestSizeLimit
                 . serviceApiValidationMiddleware
         ]
@@ -808,7 +811,18 @@ runChainweb cw = do
         defaultRequestSizeLimitSettings
 
     httpLog :: Middleware
-    httpLog = requestResponseLogger $ setComponent "http:p2p-api" (_chainwebLogger cw)
+    httpLog = requestResponseLogger''
+        (\_ -> Just Info)
+        (\r -> if HTTP.statusCode (responseStatus r) > 500 then Just Warn else Just Info)
+        JsonLog
+        (setComponent "http:p2p-api" (_chainwebLogger cw))
+
+    securityHttpLog :: Middleware
+    securityHttpLog = requestResponseLogger''
+        (\_ -> Nothing)
+        (\r -> if HTTP.statusCode (responseStatus r) > 400 then Just Error else Nothing)
+        (SecurityLog . JsonLog)
+        (addLabel ("sub-component", "security") $ setComponent "http:p2p-api" (_chainwebLogger cw))
 
     loggServerError (Just r) e = "HTTP server error: " <> sshow e <> ". Request: " <> sshow r
     loggServerError Nothing e = "HTTP server error: " <> sshow e
@@ -846,7 +860,18 @@ runChainweb cw = do
         (_serviceApiPayloadBatchLimit . _configServiceApi $ _chainwebConfig cw)
 
     serviceHttpLog :: Middleware
-    serviceHttpLog = requestResponseLogger $ setComponent "http:service-api" (_chainwebLogger cw)
+    serviceHttpLog = requestResponseLogger''
+        (\_ -> Just Info)
+        (\r -> if HTTP.statusCode (responseStatus r) > 500 then Just Warn else Just Info)
+        JsonLog
+        (setComponent "http:service-api" (_chainwebLogger cw))
+
+    serviceSecurityHttpLog :: Middleware
+    serviceSecurityHttpLog = requestResponseLogger''
+        (\_ -> Nothing)
+        (\r -> if HTTP.statusCode (responseStatus r) > 400 then Just Error else Nothing)
+        (SecurityLog . JsonLog)
+        (addLabel ("sub-component", "security") $ setComponent "http:service-api" (_chainwebLogger cw))
 
     loggServiceApiServerError (Just r) e = "HTTP service API server error: " <> sshow e <> ". Request: " <> sshow r
     loggServiceApiServerError Nothing e = "HTTP service API server error: " <> sshow e

src/Chainweb/Logging/Config.hs

@@ -80,6 +80,7 @@ data LogConfig = LogConfig
     { _logConfigLogger :: !LoggerConfig
     , _logConfigBackend :: !BackendConfig
     , _logConfigTelemetryBackend :: !(EnableConfig BackendConfig)
+    , _logConfigSecurityBackend :: !(EnableConfig BackendConfig)
     , _logConfigClusterId :: !(Maybe ClusterId)
     , _logConfigFilter :: !LogFilter
     }
@@ -92,6 +93,7 @@ defaultLogConfig = LogConfig
     { _logConfigLogger = defaultLoggerConfig
     , _logConfigBackend = defaultBackendConfig
     , _logConfigTelemetryBackend = defaultEnableConfig defaultBackendConfig
+    , _logConfigSecurityBackend = defaultEnableConfig defaultBackendConfig
     , _logConfigClusterId = Nothing
     , _logConfigFilter = mempty
     }
@@ -101,12 +103,14 @@ validateLogConfig o = do
     validateLoggerConfig $ _logConfigLogger o
     validateBackendConfig $ _logConfigBackend o
     validateEnableConfig validateBackendConfig $ _logConfigTelemetryBackend o
+    validateEnableConfig validateBackendConfig $ _logConfigSecurityBackend o
 
 instance ToJSON LogConfig where
     toJSON o = object
         [ "logger" .= _logConfigLogger o
         , "backend" .= _logConfigBackend o
         , "telemetryBackend" .= _logConfigTelemetryBackend o
+        , "securityBackend" .= _logConfigSecurityBackend o
         , "clusterId" .= _logConfigClusterId o
         , "filter" .= _logConfigFilter o
         ]
@@ -116,6 +120,7 @@ instance FromJSON (LogConfig -> LogConfig) where
         <$< logConfigLogger %.: "logger" % o
         <*< logConfigBackend %.: "backend" % o
         <*< logConfigTelemetryBackend %.: "telemetryBackend" % o
+        <*< logConfigSecurityBackend %.: "securityBackend" % o
         <*< logConfigClusterId ..: "clusterId" % o
         <*< logConfigFilter . fromLeftMonoidalUpdate %.: "filter" % o
 
@@ -134,6 +139,8 @@ pLogConfig_ prefix = id
     <*< logConfigBackend %:: pBackendConfig_ prefix
     <*< logConfigTelemetryBackend %::
         pEnableConfig "telemetry-logger" (pBackendConfig_ $ "telemetry-" <> prefix)
+    <*< logConfigSecurityBackend %::
+        pEnableConfig "security-logger" (pBackendConfig_ $ "security-" <> prefix)
     <*< logConfigClusterId .:: fmap Just % textOption
         % prefixLong maybePrefix "cluster-id"
         <> help "a label that is added to all log messages from this node"