log: make tx failure logging into a counter

Change-Id: I9986d5c9176c3c8f3aac803794b194c801c3514e

bench/Chainweb/Pact/Backend/ForkingBench.hs

@@ -318,7 +318,7 @@ withResources rdb trunkLength logLevel compact p f = C.envWithCleanup create des
 
     startPact version l bhdb pdb mempool sqlEnv = do
         reqQ <- newPactQueue pactQueueSize
-        a <- async $ runPactService version cid l reqQ mempool bhdb pdb sqlEnv testPactServiceConfig
+        a <- async $ runPactService version cid l Nothing reqQ mempool bhdb pdb sqlEnv testPactServiceConfig
             { _pactBlockGasLimit = 180_000
             , _pactPersistIntraBlockWrites = p
             }

changes/2024-05-30T150001-0400.txt

@@ -0,0 +1 @@
+Failed transactions are logged at Debug rather than Info

src/Chainweb/Chainweb.hs

@@ -384,33 +384,41 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re
         logg Info "finished pruning databases"
     logFunctionJson logger Info InitializingChainResources
 
+    txFailuresCounter <- newCounter @"txFailures"
+    let monitorTxFailuresCounter =
+            runForever (logFunctionText logger) "monitor txFailuresCounter" $ do
+                approximateThreadDelay 60_000_000 {- 1 minute -}
+                logFunctionCounter logger Info . (:[]) =<<
+                    roll txFailuresCounter
     logg Debug "start initializing chain resources"
     logFunctionText logger Info $ "opening pact db in directory " <> sshow pactDbDir
-    concurrentWith
-        -- initialize chains concurrently
-        (\cid x -> do
-            let mcfg = validatingMempoolConfig cid v (_configBlockGasLimit conf) (_configMinGasPrice conf)
-            -- NOTE: the gas limit may be set based on block height in future, so this approach may not be valid.
-            let maxGasLimit = fromIntegral <$> maxBlockGasLimit v maxBound
-            case maxGasLimit of
-                Just maxGasLimit'
-                    | _configBlockGasLimit conf > maxGasLimit' ->
-                        logg Warn $ T.unwords
-                            [ "configured block gas limit is greater than the"
-                            , "maximum for this chain; the maximum will be used instead"
-                            ]
-                _ -> return ()
-            withChainResources
-                v
-                cid
-                rocksDb
-                (chainLogger cid)
-                mcfg
-                payloadDb
-                pactDbDir
-                (pactConfig maxGasLimit)
-                x
-        )
+    withAsync monitorTxFailuresCounter $ \_ ->
+        concurrentWith
+            -- initialize chains concurrently
+            (\cid x -> do
+                let mcfg = validatingMempoolConfig cid v (_configBlockGasLimit conf) (_configMinGasPrice conf)
+                -- NOTE: the gas limit may be set based on block height in future, so this approach may not be valid.
+                let maxGasLimit = fromIntegral <$> maxBlockGasLimit v maxBound
+                case maxGasLimit of
+                    Just maxGasLimit'
+                        | _configBlockGasLimit conf > maxGasLimit' ->
+                            logg Warn $ T.unwords
+                                [ "configured block gas limit is greater than the"
+                                , "maximum for this chain; the maximum will be used instead"
+                                ]
+                    _ -> return ()
+                withChainResources
+                    v
+                    cid
+                    rocksDb
+                    (chainLogger cid)
+                    mcfg
+                    payloadDb
+                    pactDbDir
+                    (pactConfig maxGasLimit)
+                    txFailuresCounter
+                    x
+            )
 
         -- initialize global resources after all chain resources are initialized
         (\cs -> do
@@ -805,7 +813,7 @@ runChainweb cw nowServing = do
     monitorConnectionsClosedByClient :: Counter "clientClosedConnections" -> IO ()
     monitorConnectionsClosedByClient clientClosedConnectionsCounter =
         runForever logg "ConnectionClosedByClient.counter" $ do
-            approximateThreadDelay 60000000 {- 1 minute -}
+            approximateThreadDelay 60_000_000 {- 1 minute -}
             logFunctionCounter (_chainwebLogger cw) Info . (:[]) =<<
                 roll clientClosedConnectionsCounter
 

src/Chainweb/Chainweb/ChainResources.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
 
 -- |
 -- Module: Chainweb.Chainweb.ChainResources
@@ -53,6 +54,7 @@ import Chainweb.Version
 import Chainweb.WebPactExecutionService
 
 import Chainweb.Storage.Table.RocksDB
+import Chainweb.Counter
 
 -- -------------------------------------------------------------------------- --
 -- Single Chain Resources
@@ -88,16 +90,17 @@ withChainResources
     -> FilePath
         -- ^ database directory for checkpointer
     -> PactServiceConfig
+    -> Counter "txFailures"
     -> (ChainResources logger -> IO a)
     -> IO a
 withChainResources
-  v cid rdb logger mempoolCfg0 payloadDb pactDbDir pactConfig inner =
+  v cid rdb logger mempoolCfg0 payloadDb pactDbDir pactConfig txFailuresCounter inner =
     withBlockHeaderDb rdb v cid $ \cdb -> do
       pexMv <- newEmptyMVar
       let mempoolCfg = mempoolCfg0 pexMv
       Mempool.withInMemoryMempool_ (setComponent "mempool" logger) mempoolCfg v $ \mempool -> do
         mpc <- MPCon.mkMempoolConsensus mempool cdb $ Just payloadDb
-        withPactService v cid logger mpc cdb
+        withPactService v cid logger (Just txFailuresCounter) mpc cdb
                         payloadDb pactDbDir pactConfig $ \requestQ -> do
             let pex = pes requestQ
             putMVar pexMv pex

src/Chainweb/Pact/PactService.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DataKinds #-}
 
 -- |
 -- Module: Chainweb.Pact.PactService
@@ -116,22 +117,24 @@ import Chainweb.Utils hiding (check)
 import Chainweb.Version
 import Chainweb.Version.Guards
 import Utils.Logging.Trace
+import Chainweb.Counter
 
 runPactService
     :: Logger logger
     => CanReadablePayloadCas tbl
     => ChainwebVersion
     -> ChainId
     -> logger
+    -> Maybe (Counter "txFailures")
     -> PactQueue
     -> MemPoolAccess
     -> BlockHeaderDb
     -> PayloadDb tbl
     -> SQLiteEnv
     -> PactServiceConfig
     -> IO ()
-runPactService ver cid chainwebLogger reqQ mempoolAccess bhDb pdb sqlenv config =
-    void $ withPactService ver cid chainwebLogger bhDb pdb sqlenv config $ do
+runPactService ver cid chainwebLogger txFailuresCounter reqQ mempoolAccess bhDb pdb sqlenv config =
+    void $ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config $ do
         initialPayloadState mempoolAccess ver cid
         serviceRequests mempoolAccess reqQ
 
@@ -140,13 +143,14 @@ withPactService
     => ChainwebVersion
     -> ChainId
     -> logger
+    -> Maybe (Counter "txFailures")
     -> BlockHeaderDb
     -> PayloadDb tbl
     -> SQLiteEnv
     -> PactServiceConfig
     -> PactServiceM logger tbl a
     -> IO (T2 a PactServiceState)
-withPactService ver cid chainwebLogger bhDb pdb sqlenv config act =
+withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config act =
     withProdRelationalCheckpointer checkpointerLogger (_pactModuleCacheLimit config) sqlenv (_pactPersistIntraBlockWrites config) ver cid $ \checkpointer -> do
         let !rs = readRewards
         let !pse = PactServiceEnv
@@ -165,6 +169,7 @@ withPactService ver cid chainwebLogger bhDb pdb sqlenv config act =
                     , _psGasLogger = gasLogger <$ guard (_pactLogGas config)
                     , _psBlockGasLimit = _pactBlockGasLimit config
                     , _psEnableLocalTimeout = _pactEnableLocalTimeout config
+                    , _psTxFailuresCounter = txFailuresCounter
                     }
             !pst = PactServiceState mempty
 
@@ -772,7 +777,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
                       Right{} -> do
                         let initialGas = initialGasOf $ P._cmdPayload cwtx
                         T3 cr _mc warns <- liftIO $ applyCmd
-                          _psVersion _psLogger _psGasLogger (_cpPactDbEnv dbEnv)
+                          _psVersion _psLogger _psGasLogger Nothing (_cpPactDbEnv dbEnv)
                           noMiner gasModel ctx spv cmd
                           initialGas mc ApplyLocal
 
@@ -1040,7 +1045,7 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do
                     , P.FlagDisableHistoryInTransactionalMode ] ++
                     disableReturnRTC (ctxVersion pd) (ctxChainId pd) (ctxCurrentBlockHeight pd)
 
-              let buyGasEnv = TransactionEnv P.Transactional (_cpPactDbEnv dbEnv) l Nothing (ctxToPublicData pd) spv nid gasPrice rk gasLimit ec Nothing
+              let buyGasEnv = TransactionEnv P.Transactional (_cpPactDbEnv dbEnv) l Nothing (ctxToPublicData pd) spv nid gasPrice rk gasLimit ec Nothing Nothing
 
               cr <- liftIO
                 $! catchesPactError l CensorsUnexpectedError

src/Chainweb/Pact/PactService/ExecBlock.hs

@@ -423,6 +423,7 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGa
   logger <- view (psServiceEnv . psLogger)
   gasLogger <- view (psServiceEnv . psGasLogger)
   gasModel <- view (psServiceEnv . psGasModel)
+  txFailuresCounter <- view (psServiceEnv . psTxFailuresCounter)
   v <- view chainwebVersion
   let
     -- for errors so fatal that the tx doesn't make it in the block
@@ -471,7 +472,8 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGa
         let txGas (T3 r _ _) = fromIntegral $ P._crGas r
         T3 r c _warns <-
           tracePactBlockM' "applyCmd" (J.toJsonViaEncode hsh) txGas $ do
-            liftIO $ txTimeout $ applyCmd v logger gasLogger (_cpPactDbEnv dbEnv) miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas mcache ApplySend
+            liftIO $ txTimeout $
+              applyCmd v logger gasLogger txFailuresCounter (_cpPactDbEnv dbEnv) miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas mcache ApplySend
         pure $ T2 r c
 
     if isGenesis

src/Chainweb/Pact/Service/PactInProcApi.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module: Chainweb.Pact.Service.PactInProcApi
@@ -51,6 +52,7 @@ import Chainweb.Version
 import Data.LogMessage
 
 import GHC.Stack (HasCallStack)
+import Chainweb.Counter (Counter)
 
 -- | Initialization for Pact (in process) Api
 withPactService
@@ -59,16 +61,17 @@ withPactService
     => ChainwebVersion
     -> ChainId
     -> logger
+    -> Maybe (Counter "txFailures")
     -> MempoolConsensus
     -> BlockHeaderDb
     -> PayloadDb tbl
     -> FilePath
     -> PactServiceConfig
     -> (PactQueue -> IO a)
     -> IO a
-withPactService ver cid logger mpc bhdb pdb pactDbDir config action =
+withPactService ver cid logger txFailuresCounter mpc bhdb pdb pactDbDir config action =
     withSqliteDb cid logger pactDbDir (_pactResetDb config) $ \sqlenv ->
-        withPactService' ver cid logger mpa bhdb pdb sqlenv config action
+        withPactService' ver cid logger txFailuresCounter mpa bhdb pdb sqlenv config action
   where
     mpa = pactMemPoolAccess mpc $ addLabel ("sub-component", "MempoolAccess") logger
 
@@ -81,21 +84,22 @@ withPactService'
     => ChainwebVersion
     -> ChainId
     -> logger
+    -> Maybe (Counter "txFailures")
     -> MemPoolAccess
     -> BlockHeaderDb
     -> PayloadDb tbl
     -> SQLiteEnv
     -> PactServiceConfig
     -> (PactQueue -> IO a)
     -> IO a
-withPactService' ver cid logger memPoolAccess bhDb pdb sqlenv config action = do
+withPactService' ver cid logger txFailuresCounter memPoolAccess bhDb pdb sqlenv config action = do
     reqQ <- newPactQueue (_pactQueueSize config)
     race (concurrently_ (monitor reqQ) (server reqQ)) (action reqQ) >>= \case
         Left () -> error "Chainweb.Pact.Service.PactInProcApi: pact service terminated unexpectedly"
         Right a -> return a
   where
     server reqQ = runForever logg "pact-service"
-        $ PS.runPactService ver cid logger reqQ memPoolAccess bhDb pdb sqlenv config
+        $ PS.runPactService ver cid logger txFailuresCounter reqQ memPoolAccess bhDb pdb sqlenv config
     logg = logFunction logger
     monitor = runPactServiceQueueMonitor $ addLabel ("sub-component", "PactQueue") logger
 

src/Chainweb/Pact/TransactionExec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -68,7 +69,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Short as SB
 import Data.Decimal (Decimal, roundTo)
 import Data.Default (def)
-import Data.Foldable (fold, for_)
+import Data.Foldable (fold, for_, traverse_)
 import Data.IORef
 import qualified Data.HashMap.Strict as HM
 import qualified Data.List as List
@@ -81,6 +82,7 @@ import qualified System.LogLevel as L
 
 -- internal Pact modules
 
+import Chainweb.Counter
 import Chainweb.Pact.Backend.Types (_cpPactDbEnv)
 import Pact.Eval (eval, liftTerm)
 import Pact.Gas (freeGasEnv)
@@ -172,6 +174,7 @@ applyCmd
       -- ^ Pact logger
     -> Maybe logger
       -- ^ Pact gas logger
+    -> Maybe (Counter "txFailures")
     -> PactDbEnv p
       -- ^ Pact db environment
     -> Miner
@@ -191,7 +194,7 @@ applyCmd
     -> ApplyCmdExecutionContext
       -- ^ is this a local or send execution context?
     -> IO (T3 (CommandResult [TxLogJson]) ModuleCache (S.Set PactWarning))
-applyCmd v logger gasLogger pdbenv miner gasModel txCtx spv cmd initialGas mcache0 callCtx = do
+applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx spv cmd initialGas mcache0 callCtx = do
     T2 cr st <- runTransactionM cenv txst applyBuyGas
 
     let cache = _txCache st
@@ -214,7 +217,7 @@ applyCmd v logger gasLogger pdbenv miner gasModel txCtx spv cmd initialGas mcach
       <> flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)
 
     cenv = TransactionEnv Transactional pdbenv logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice
-      requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee
+      requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee txFailuresCounter
 
     !requestKey = cmdToRequestKey cmd
     !gasPrice = view cmdGasPrice cmd
@@ -358,6 +361,7 @@ applyGenesisCmd logger dbEnv spv txCtx cmd =
           -- after the block height where pact4.4 is on.
           <> S.fromList [ FlagDisableInlineMemCheck, FlagDisablePact44 ]
         , _txQuirkGasFee = Nothing
+        , _txTxFailuresCounter = Nothing
         }
     txst = TransactionState
         { _txCache = mempty
@@ -444,7 +448,7 @@ applyCoinbase v logger dbEnv (Miner mid mks@(MinerKeys mk)) reward@(ParsedDecima
       , flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)
       ]
     tenv = TransactionEnv Transactional dbEnv logger Nothing (ctxToPublicData txCtx) noSPVSupport
-           Nothing 0.0 rk 0 ec Nothing
+           Nothing 0.0 rk 0 ec Nothing Nothing
     txst = TransactionState mc mempty 0 Nothing (_geGasModel freeGasEnv) mempty
     initState = setModuleCache mc $ initCapabilities [magic_COINBASE]
     rk = RequestKey chash
@@ -519,7 +523,7 @@ applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig =
     !gasPrice = view cmdGasPrice cmd
     !gasLimit = view cmdGasLimit cmd
     tenv = TransactionEnv Local dbEnv logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice
-           rk (fromIntegral gasLimit) execConfig Nothing
+           rk (fromIntegral gasLimit) execConfig Nothing Nothing
     txst = TransactionState mc mempty 0 Nothing gasModel mempty
     gas0 = initialGasOf (_cmdPayload cmdIn)
     currHeight = ctxCurrentBlockHeight txCtx
@@ -581,7 +585,7 @@ readInitModules = do
     nid = Nothing
     chash = pactInitialHash
     tenv = TransactionEnv Local dbEnv logger Nothing (ctxToPublicData txCtx) noSPVSupport nid 0.0
-           rk 0 def Nothing
+           rk 0 def Nothing Nothing
     txst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty
     interp = defaultInterpreter
     die msg = throwM $ PactInternalError $ "readInitModules: " <> msg
@@ -709,8 +713,10 @@ failTxWith err msg = do
     rk <- view txRequestKey
     l <- view txLogger
 
-    liftIO $ logFunction l L.Info
+    liftIO $ logFunction l L.Debug
       (TxFailureLog rk err msg)
+    liftIO . traverse_ inc
+      =<< view txTxFailuresCounter
 
     return $! CommandResult rk Nothing (PactResult (Left err))
       gas (Just logs) Nothing Nothing []