Add signature validation tracer

Author: crocodile-dentist

dmq-node/app/Main.hs

@@ -83,6 +83,7 @@ runDMQ commandLineConfig = do
           dmqcPrettyLog            = I prettyLog,
           dmqcTopologyFile         = I topologyFile,
           dmqcHandshakeTracer      = I handshakeTracer,
+          dmqcValidationTracer     = I validationTracer,
           dmqcLocalHandshakeTracer = I localHandshakeTracer,
           dmqcCardanoNodeSocket    = I snocketPath,
           dmqcVersion              = I version
@@ -132,11 +133,14 @@ runDMQ commandLineConfig = do
         let sigSize :: Sig StandardCrypto -> SizeInBytes
             sigSize = fromIntegral . BSL.length . sigRawBytes
             mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel)
+            ntnValidationTracer = if validationTracer
+                                    then WithEventType "NtN Validation" >$< tracer
+                                    else nullTracer
             dmqNtNApps =
               let ntnMempoolWriter = Mempool.writerAdapter $
                     Mempool.getWriter sigId
                                       (poolValidationCtx $ stakePools nodeKernel)
-                                      (validateSig (hashKey . VKey))
+                                      (validateSig ntnValidationTracer (hashKey . VKey))
                                       SigDuplicate
                                       (mempool nodeKernel)
                in ntnApps tracer
@@ -152,11 +156,14 @@ runDMQ commandLineConfig = do
                                    (decodeRemoteAddress (maxBound @NodeToNodeVersion)))
                           dmqLimitsAndTimeouts
                           defaultSigDecisionPolicy
+            ntcValidationTracer = if validationTracer
+                                    then WithEventType "NtC Validation" >$< tracer
+                                    else nullTracer
             dmqNtCApps =
               let ntcMempoolWriter =
                     Mempool.getWriter sigId
                                       (poolValidationCtx $ stakePools nodeKernel)
-                                      (validateSig (hashKey . VKey))
+                                      (validateSig ntcValidationTracer (hashKey . VKey))
                                       SigDuplicate
                                       (mempool nodeKernel)
                in NtC.ntcApps tracer dmqConfig

dmq-node/src/DMQ/Configuration.hs

@@ -135,6 +135,7 @@ data Configuration' f =
     dmqcLocalServerTracer                          :: f Bool,
     dmqcLocalInboundGovernorTracer                 :: f Bool,
     dmqcDnsTracer                                  :: f Bool,
+    dmqcValidationTracer                           :: f Bool,
 
     -- low level verbose traces which trace protocol messages
     -- TODO: pref
@@ -256,6 +257,7 @@ defaultConfiguration = Configuration {
       dmqcLocalServerTracer                          = I False,
       dmqcLocalInboundGovernorTracer                 = I False,
       dmqcDnsTracer                                  = I False,
+      dmqcValidationTracer                           = I False,
 
       dmqcSigSubmissionClientProtocolTracer          = I False,
       dmqcSigSubmissionServerProtocolTracer          = I False,
@@ -349,6 +351,7 @@ instance FromJSON PartialConfig where
       dmqcLocalServerTracer                          <- Last <$> v .:? "LocalServerTracer"
       dmqcLocalInboundGovernorTracer                 <- Last <$> v .:? "LocalInboundGovernorTracer"
       dmqcDnsTracer                                  <- Last <$> v .:? "DnsTracer"
+      dmqcValidationTracer                           <- Last <$> v .:? "ValidationTracer"
 
       dmqcSigSubmissionClientProtocolTracer          <- Last <$> v .:? "SigSubmissionClientProtocolTracer"
       dmqcSigSubmissionServerProtocolTracer          <- Last <$> v .:? "SigSubmissionServerProtocolTracer"
@@ -427,6 +430,7 @@ instance ToJSON Configuration where
            , "LocalServerTracer"                          .= unI dmqcLocalServerTracer
            , "LocalInboundGovernorTracer"                 .= unI dmqcLocalInboundGovernorTracer
            , "DnsTracer"                                  .= unI dmqcDnsTracer
+           , "ValidationTracer"                           .= unI dmqcValidationTracer
            , "SigSubmissionClientProtocolTracer"          .= unI dmqcSigSubmissionClientProtocolTracer
            , "SigSubmissionServerProtocolTracer"          .= unI dmqcSigSubmissionServerProtocolTracer
            , "KeepAliveClientProtocolTracer"              .= unI dmqcKeepAliveClientProtocolTracer

dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE MultiWayIf         #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE PatternSynonyms    #-}
+{-# LANGUAGE RankNTypes         #-}
 {-# LANGUAGE TupleSections      #-}
 {-# LANGUAGE TypeFamilies       #-}
 {-# LANGUAGE TypeOperators      #-}
@@ -21,6 +22,7 @@ import Control.Monad.Class.MonadTime.SI
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Except.Extra
+import Control.Tracer (Tracer, traceWith)
 import Data.Aeson
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
@@ -116,27 +118,31 @@ validateSig :: forall crypto m.
                , Signable (KES crypto) ByteString
                , MonadSTM m
                )
-            => (DSIGN.VerKeyDSIGN (DSIGN crypto) -> KeyHash StakePool)
+            => Tracer m (Sig crypto, TxValidationFail (Sig crypto))
+            -> (DSIGN.VerKeyDSIGN (DSIGN crypto) -> KeyHash StakePool)
             -> [Sig crypto]
             -> PoolValidationCtx m
             -- ^ cardano pool id verification
             -> ExceptT (Sig crypto, TxValidationFail (Sig crypto)) m
                        [(Sig crypto, Either (TxValidationFail (Sig crypto)) ())]
-validateSig verKeyHashingFn sigs ctx = traverse process' sigs
+validateSig tracer verKeyHashingFn sigs ctx = traverse process' sigs
   where
     DMQPoolValidationCtx now mNextEpoch pools ocertCountersVar = ctx
 
-    process' sig = bimapExceptT (sig,) (sig,) $ process sig
-
-    process Sig { sigSignedBytes = signedBytes,
-                  sigKESPeriod,
-                  sigOpCertificate = SigOpCertificate ocert@OCert {
-                    ocertKESPeriod,
-                    ocertVkHot,
-                    ocertN
-                    },
-                  sigColdKey = SigColdKey coldKey,
-                  sigKESSignature = SigKESSignature kesSig
+    process' sig =
+      let result = process sig
+      in bimapExceptT (sig,) (sig,) $
+           result `catchLeftT` \e -> result <* lift (traceWith tracer (sig, e))
+
+    process sig@Sig { sigSignedBytes = signedBytes,
+                      sigKESPeriod,
+                      sigOpCertificate = SigOpCertificate ocert@OCert {
+                        ocertKESPeriod,
+                        ocertVkHot,
+                        ocertN
+                        },
+                      sigColdKey = SigColdKey coldKey,
+                      sigKESSignature = SigKESSignature kesSig
                 } = do
       sigKESPeriod < endKESPeriod
          ?! KESAfterEndOCERT endKESPeriod sigKESPeriod
@@ -191,7 +197,11 @@ validateSig verKeyHashingFn sigs ctx = traverse process' sigs
           Right ocertCounters' -> (void success, ocertCounters')
           Left  err            -> (throwE (SigInvalid err), ocertCounters)
       -- for eg. remember to run all results with possibly non-fatal errors
-      right e
+      let result = e
+      case result of
+        Left e' -> lift $ traceWith tracer (sig, e')
+        Right _ -> pure ()
+      right result
       where
         success = right $ Right ()