From cef8afd0d53f64360dda4be34cda8ac0a906a8ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 23 Dec 2025 14:32:32 +0100 Subject: [PATCH 1/2] Add signature validation tracer --- dmq-node/app/Main.hs | 11 +++++- dmq-node/src/DMQ/Configuration.hs | 4 ++ .../DMQ/Protocol/SigSubmission/Validate.hs | 38 ++++++++++++------- .../test/DMQ/Protocol/SigSubmission/Test.hs | 3 +- 4 files changed, 39 insertions(+), 17 deletions(-) diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 055eb38..ac7bdd1 100644 --- a/dmq-node/app/Main.hs +++ b/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 diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index b21764e..2a2cbce 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/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 diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs index 2d99962..e8e3fff 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs +++ b/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 () diff --git a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs index f8a86db..768725f 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs @@ -30,6 +30,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (zipWithM, (>=>)) import Control.Monad.ST (runST) import Control.Monad.Trans.Except +import Control.Tracer (nullTracer) import Data.Bifunctor (second) import Data.Binary qualified as Binary import Data.ByteString (ByteString) @@ -846,7 +847,7 @@ prop_validateSig constr = ioProperty do let validationCtx = DMQPoolValidationCtx (posixSecondsToUTCTime 0) Nothing Map.empty countersVar dummyHash = KeyHash . castHash . hashWith (BS.toStrict . Binary.encode . const (0 :: Int)) - result <- runExceptT $ validateSig dummyHash [sig] validationCtx + result <- runExceptT $ validateSig nullTracer dummyHash [sig] validationCtx return case result of Left err -> counterexample ("KES seed: " ++ show (ctx constr)) . counterexample ("KES vk key: " ++ show (ocertVkHot . getSigOpCertificate . sigOpCertificate $ sig)) From 581990fcaf71071fa44fd12dd8e916adb3bd95b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 23 Dec 2025 16:29:23 +0100 Subject: [PATCH 2/2] REMOVE show only hash prefixes --- .../src/DMQ/Protocol/SigSubmission/Type.hs | 21 ++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs index 6c925c9..a72d89c 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs @@ -36,6 +36,7 @@ import Data.ByteString.Base16 as BS.Base16 import Data.ByteString.Base16.Lazy as LBS.Base16 import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS.Char8 +import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Time.Clock.POSIX (POSIXTime) import Data.Typeable @@ -52,7 +53,10 @@ import Ouroboros.Network.Util.ShowProxy newtype SigHash = SigHash { getSigHash :: ByteString } - deriving stock (Show, Eq, Ord) + deriving stock (Eq, Ord) + +instance Show SigHash where + show (SigHash bs) = take 10 . Text.unpack . Text.decodeUtf8Lenient . BS.Base16.encode $ bs newtype SigId = SigId { getSigId :: SigHash } deriving stock (Show, Eq, Ord) @@ -135,7 +139,7 @@ instance Crypto crypto , sigRawOpCertificate , sigRawColdKey -} } = - object [ "id" .= show (getSigHash (getSigId sigRawId)) + object [ "id" .= sigRawId {- , "body" .= show (getSigBody sigRawBody) , "kesPeriod" .= sigRawKESPeriod , "expiresAt" .= show sigRawExpiresAt @@ -181,11 +185,14 @@ data Sig crypto = SigWithBytes { -- ^ the `SigRaw` data type along with signed bytes } -deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) - , Show (VerKeyKES (KES crypto)) - , Show (SigKES (KES crypto)) - ) - => Show (Sig crypto) +instance Show (Sig crypto) where + show Sig { sigId } = "Sig crypto ... " <> show sigId + +-- deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) +-- , Show (VerKeyKES (KES crypto)) +-- , Show (SigKES (KES crypto)) +-- ) +-- => Show (Sig crypto) deriving instance ( DSIGNAlgorithm (KES.DSIGN crypto) , Eq (VerKeyKES (KES crypto)) , Eq (SigKES (KES crypto))