Validate ocert counter, change encoding of validation failures

crocodile-dentist · crocodile-dentist · commit c567868f225f · 2025-12-15T20:08:40.000+01:00
diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs
@@ -16,6 +16,7 @@ module DMQ.NodeToClient
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy (ByteString)
 import Data.Functor.Contravariant ((>$<))
+import Data.Typeable
 import Data.Void
 import Data.Word
 
@@ -137,15 +138,17 @@ _ntc_MAX_SIGS_TO_ACK = 1000
 -- | Construct applications for the node-to-client protocols
 --
 ntcApps
-  :: forall crypto idx ntcAddr failure m.
+  :: forall crypto idx ntcAddr m.
      ( MonadThrow m
      , MonadThread m
      , MonadSTM m
      , Crypto crypto
      , Aeson.ToJSON ntcAddr
      , Aeson.ToJSON (MempoolAddFail (Sig crypto))
+     , Show (MempoolAddFail (Sig crypto))
      , ShowProxy (MempoolAddFail (Sig crypto))
      , ShowProxy (Sig crypto)
+     , Typeable crypto
      )
   => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev))
   -> Configuration
diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs
@@ -1,13 +1,17 @@
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module DMQ.NodeToClient.LocalMsgSubmission where
 
 import Control.Concurrent.Class.MonadSTM
+import Control.Monad.Class.MonadThrow
 import Control.Tracer
 import Data.Aeson (ToJSON (..), object, (.=))
 import Data.Aeson qualified as Aeson
+import Data.Typeable
 
 import DMQ.Protocol.LocalMsgSubmission.Server
 import DMQ.Protocol.LocalMsgSubmission.Type
@@ -16,55 +20,80 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple
 -- | Local transaction submission server, for adding txs to the 'Mempool'
 --
 localMsgSubmissionServer ::
-     MonadSTM m
-  => (sig -> sigid)
+     forall msgid msg idx m.
+     ( MonadSTM m
+     , MonadThrow m
+     , Typeable msgid
+     , Typeable msg
+     , Show msgid
+     , Show (MempoolAddFail msg))
+  => (msg -> msgid)
   -- ^ get message id
-  -> Tracer m (TraceLocalMsgSubmission sig sigid)
-  -> MempoolWriter sigid sig failure idx m
+  -> Tracer m (TraceLocalMsgSubmission msg msgid)
+  -> MempoolWriter msgid msg idx m
   -- ^ duplicate error tag in case the mempool returns the empty list on failure
-  -> m (LocalMsgSubmissionServer sig m ())
+  -> m (LocalMsgSubmissionServer msg m ())
 localMsgSubmissionServer getMsgId tracer MempoolWriter { mempoolAddTxs } =
     pure server
   where
-    process (sigid, e@(SubmitFail reason)) =
-      (e, server) <$ traceWith tracer (TraceSubmitFailure sigid reason)
-    process (sigid, success) =
-      (success, server) <$ traceWith tracer (TraceSubmitAccept sigid)
+    process (Left (msgid, reason)) = do
+      (SubmitFail reason, server) <$ traceWith tracer (TraceSubmitFailure msgid reason)
+
+    process (Right [(msgid, e@(SubmitFail reason))]) =
+      (e, server) <$ traceWith tracer (TraceSubmitFailure msgid reason)
+
+    process (Right [(msgid, SubmitSuccess)]) =
+      (SubmitSuccess, server) <$ traceWith tracer (TraceSubmitAccept msgid)
+
+    process _ = throwIO (TooManyMessages @msgid @msg)
 
     server = LocalTxSubmissionServer {
-      recvMsgSubmitTx = \sig -> do
-        traceWith tracer $ TraceReceivedMsg (getMsgId sig)
-        process . head =<< mempoolAddTxs [sig]
+      recvMsgSubmitTx = \msg -> do
+        traceWith tracer $ TraceReceivedMsg (getMsgId msg)
+        process =<< mempoolAddTxs [msg]
 
     , recvMsgDone = ()
     }
 
 
-data TraceLocalMsgSubmission sig sigid =
-    TraceReceivedMsg sigid
+data TraceLocalMsgSubmission msg msgid =
+    TraceReceivedMsg msgid
   -- ^ A signature was received.
-  | TraceSubmitFailure sigid (MempoolAddFail sig)
-  | TraceSubmitAccept sigid
+  | TraceSubmitFailure msgid (MempoolAddFail msg)
+  | TraceSubmitAccept msgid
 
 deriving instance
-     (Show sig, Show sigid, Show (MempoolAddFail sig))
-  => Show (TraceLocalMsgSubmission sig sigid)
+     (Show msg, Show msgid, Show (MempoolAddFail msg))
+  => Show (TraceLocalMsgSubmission msg msgid)
+
+
+
+data MsgSubmissionServerException msgid msg =
+    MsgValidationException msgid (MempoolAddFail msg)
+  | TooManyMessages
+
+deriving instance (Show (MempoolAddFail msg), Show msgid)
+  => Show (MsgSubmissionServerException msgid msg)
+
+instance (Typeable msgid, Typeable msg, Show (MempoolAddFail msg), Show msgid)
+  => Exception (MsgSubmissionServerException msgid msg) where
+
 
-instance (ToJSON sigid, ToJSON (MempoolAddFail sig))
-      => ToJSON (TraceLocalMsgSubmission sig sigid) where
-  toJSON (TraceReceivedMsg sigid) =
+instance (ToJSON msgid, ToJSON (MempoolAddFail msg))
+      => ToJSON (TraceLocalMsgSubmission msg msgid) where
+  toJSON (TraceReceivedMsg msgid) =
     -- TODO: once we have verbosity levels, we could include the full tx, for
     -- now one can use `TraceSendRecv` tracer for the mini-protocol to see full
     -- msgs.
     object [ "kind" .= Aeson.String "TraceReceivedMsg"
-           , "sigId" .= sigid
+           , "sigId" .= msgid
            ]
-  toJSON (TraceSubmitFailure sigid reject) =
+  toJSON (TraceSubmitFailure msgid reject) =
     object [ "kind" .= Aeson.String "TraceSubmitFailure"
-           , "sigId" .= sigid
+           , "sigId" .= msgid
            , "reason" .= reject
            ]
-  toJSON (TraceSubmitAccept sigid) =
+  toJSON (TraceSubmitAccept msgid) =
     object [ "kind" .= Aeson.String "TraceSubmitAccept"
-           , "sigId" .= sigid
+           , "sigId" .= msgid
            ]
diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs
@@ -41,7 +41,6 @@ import Codec.CBOR.Encoding qualified as CBOR
 import Codec.CBOR.Read qualified as CBOR
 import Codec.CBOR.Term qualified as CBOR
 import Data.Aeson qualified as Aeson
-import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BL
 import Data.Functor.Contravariant ((>$<))
 import Data.Hashable (Hashable)
@@ -54,10 +53,7 @@ import Network.Mux.Types (Mode (..))
 import Network.Mux.Types qualified as Mx
 import Network.TypedProtocol.Codec (AnnotatedCodec, Codec)
 
-import Cardano.Crypto.DSIGN.Class qualified as DSIGN
-import Cardano.Crypto.KES.Class qualified as KES
 import Cardano.KESAgent.KES.Crypto (Crypto (..))
-import Cardano.KESAgent.KES.OCert (OCertSignable)
 
 import DMQ.Configuration (Configuration, Configuration' (..), I (..))
 import DMQ.Diffusion.NodeKernel (NodeKernel (..))
@@ -202,8 +198,7 @@ ntnApps
       fetchClientRegistry
     , peerSharingRegistry
     , peerSharingAPI
-    , mempool
-    , evolutionConfig
+    -- , mempool
     , sigChannelVar
     , sigMempoolSem
     , sigSharedTxStateVar
diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs
@@ -10,8 +10,11 @@ import Codec.CBOR.Encoding qualified as CBOR
 import Codec.CBOR.Read qualified as CBOR
 import Control.Monad.Class.MonadST
 import Data.ByteString.Lazy (ByteString)
+import Data.Text qualified as T
+import Data.Tuple (swap)
 import Text.Printf
 
+import Cardano.Binary
 import Cardano.KESAgent.KES.Crypto (Crypto (..))
 
 import DMQ.Protocol.LocalMsgSubmission.Type
@@ -35,18 +38,53 @@ codecLocalMsgSubmission =
 
 encodeReject :: MempoolAddFail (Sig crypto) -> CBOR.Encoding
 encodeReject = \case
-  SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encodeString reason
-  SigDuplicate      -> CBOR.encodeListLen 1 <> CBOR.encodeWord 1
-  SigExpired        -> CBOR.encodeListLen 1 <> CBOR.encodeWord 2
+  SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 0 <> e
+    where
+      e = case reason of
+        InvalidKESSignature ocertKESPeriod sigKESPeriod err ->  mconcat [
+          CBOR.encodeListLen 4, CBOR.encodeWord8 0, toCBOR ocertKESPeriod, toCBOR sigKESPeriod, CBOR.encodeString (T.pack err)
+          ]
+        InvalidSignatureOCERT ocertN sigKESPeriod err -> mconcat [
+          CBOR.encodeListLen 4, CBOR.encodeWord8 1, CBOR.encodeWord64 ocertN, toCBOR sigKESPeriod, CBOR.encodeString (T.pack err)
+          ]
+        KESBeforeStartOCERT startKESPeriod sigKESPeriod -> mconcat [
+          CBOR.encodeListLen 3, CBOR.encodeWord8 2, toCBOR startKESPeriod, toCBOR sigKESPeriod
+          ]
+        KESAfterEndOCERT endKESPeriod sigKESPeriod ->  mconcat [
+          CBOR.encodeListLen 3, CBOR.encodeWord8 3, toCBOR endKESPeriod, toCBOR sigKESPeriod
+          ]
+        UnrecognizedPool -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 4
+        NotInitialized   -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 5
+        ClockSkew        -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 6
+        InvalidOCertCounter seen received
+          -> mconcat
+              [CBOR.encodeListLen 3, CBOR.encodeWord8 7, CBOR.encodeWord64 seen, CBOR.encodeWord64 received]
+  SigDuplicate      -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 1
+  SigExpired        -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 2
   SigResultOther reason
-                    -> CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> CBOR.encodeString reason
+                    -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 3 <> CBOR.encodeString reason
 
 decodeReject :: CBOR.Decoder s (MempoolAddFail (Sig crypto))
 decodeReject = do
   len <- CBOR.decodeListLen
-  tag <- CBOR.decodeWord
+  tag <- CBOR.decodeWord8
   case (tag, len) of
-    (0, 2)     -> SigInvalid <$> CBOR.decodeString
+    (0, 2) -> SigInvalid <$> decSigValidError
+      where
+        decSigValidError :: CBOR.Decoder s SigValidationError
+        decSigValidError = do
+          lenTag <- (,) <$> CBOR.decodeListLen <*> CBOR.decodeWord8
+          case swap lenTag of
+            (0, 4) -> InvalidKESSignature <$> fromCBOR <*> fromCBOR <*> (T.unpack <$> CBOR.decodeString)
+            (1, 4) -> InvalidSignatureOCERT <$> CBOR.decodeWord64 <*> fromCBOR <*> (T.unpack <$> CBOR.decodeString)
+            (2, 3) -> KESBeforeStartOCERT <$> fromCBOR <*> fromCBOR
+            (3, 4) -> KESAfterEndOCERT <$> fromCBOR <*> fromCBOR
+            (4, 1) -> pure UnrecognizedPool
+            (5, 1) -> pure NotInitialized
+            (6, 1) -> pure ClockSkew
+            (7, 3) -> InvalidOCertCounter <$> fromCBOR <*> fromCBOR
+            _otherwise -> fail $ printf "unrecognized (tag,len) = (%d, %d) when decoding SigInvalid tag" tag len
+
     (1, 1)     -> pure SigDuplicate
     (2, 1)     -> pure SigExpired
     (3, 2)     -> SigResultOther <$> CBOR.decodeString
diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs
