Skip to content

Add message validation tracer #4

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
crocodile-dentist wants to merge 2 commits into
base: main
Choose a base branch
from
Open

Add message validation tracer #4

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
cef8afd
Add signature validation tracer
crocodile-dentist Dec 23, 2025
581990f
REMOVE show only hash prefixes
crocodile-dentist Dec 23, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
11 changes: 9 additions & 2 deletions dmq-node/app/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
4 changes: 4 additions & 0 deletions dmq-node/src/DMQ/Configuration.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -256,6 +257,7 @@ defaultConfiguration = Configuration {
dmqcLocalServerTracer = I False,
dmqcLocalInboundGovernorTracer = I False,
dmqcDnsTracer = I False,
dmqcValidationTracer = I False,
Copy link
Contributor

@coot coot Dec 23, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It should be on by default, we don't expect many invalid messages, and once it happen the connection is closed, so we won't be flooded by them.

Suggested change
dmqcValidationTracer = I False,
dmqcValidationTracer = I True,


dmqcSigSubmissionClientProtocolTracer = I False,
dmqcSigSubmissionServerProtocolTracer = I False,
Expand Down Expand Up @@ -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"
Expand Down Expand Up @@ -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
Expand Down
21 changes: 14 additions & 7 deletions dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Comment on lines +188 to +189
Copy link
Contributor

@coot coot Dec 23, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We shouldn't use Show for, could you just leave a TODO for adding a Display type class.


-- 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))
Expand Down
38 changes: 24 additions & 14 deletions dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 ()

Expand Down
3 changes: 2 additions & 1 deletion dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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))
Expand Down
Loading