From 92e1fc328f3010aefe2fb020fa3059caa261eecb Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 7 Jan 2026 10:34:09 +0100 Subject: [PATCH 01/11] LocalMsgSubmission: haddocks --- dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs index 438a1a0..d830787 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs @@ -60,7 +60,9 @@ data TraceLocalMsgSubmission msg msgid = TraceReceivedMsg msgid -- ^ A signature was received. | TraceSubmitFailure msgid (TxValidationFail msg) + -- ^ A signature was rejected with the given validation failure. | TraceSubmitAccept msgid + -- ^ A signature was validated and accepted into the mempool. deriving instance (Show msg, Show msgid, Show (TxValidationFail msg)) From ecc73724f4b275471169c1d7cebc4b3209141ea1 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 7 Jan 2026 15:48:22 +0100 Subject: [PATCH 02/11] SigSubmission: prop_codec_sig_encoding property Verify that `Sig` encoding produces a valid CBOR. --- .../test/DMQ/Protocol/SigSubmission/Test.hs | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs index 768725f..add066b 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs @@ -26,6 +26,7 @@ module DMQ.Protocol.SigSubmission.Test (tests) where import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Write qualified as CBOR +import Codec.CBOR.FlatTerm qualified as CBOR import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (zipWithM, (>=>)) import Control.Monad.ST (runST) @@ -86,6 +87,7 @@ tests = [ testGroup "MockCrypto" [ testProperty "OCert" prop_codec_ocert_mockcrypto , testProperty "Sig" prop_codec_sig_mockcrypto + , testProperty "Sig.encoding" prop_codec_sig_encoding_mockcrypto , testProperty "codec" prop_codec_mockcrypto , testProperty "codec id" prop_codec_id_mockcrypto , testProperty "codec 2-splits" $ withMaxSize 20 @@ -103,6 +105,7 @@ tests = , testGroup "StandardCrypto" [ testProperty "OCert" prop_codec_ocert_standardcrypto , testProperty "Sig" prop_codec_sig_standardcrypto + , testProperty "Sig.encoding" prop_codec_sig_encoding_standardcrypto , testProperty "codec" prop_codec_standardcrypto , testProperty "codec id" prop_codec_id_standardcrypto , testProperty "codec 2-splits" $ withMaxSize 20 @@ -716,6 +719,27 @@ prop_codec_sig_standardcrypto prop_codec_sig_standardcrypto = prop_codec_sig . getBlind +prop_codec_sig_encoding + :: forall crypto. Crypto crypto + => WithConstrKES (SeedSizeKES (KES crypto)) (KES crypto) (Sig crypto) + -> Property +prop_codec_sig_encoding constr = ioProperty $ do + sig <- runWithConstr constr + let encoding = encodeSig sig + return . counterexample (show sig) + $ CBOR.validFlatTerm (CBOR.toFlatTerm encoding) + +prop_codec_sig_encoding_mockcrypto + :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto)) + -> Property +prop_codec_sig_encoding_mockcrypto = prop_codec_sig_encoding . getBlind + +prop_codec_sig_encoding_standardcrypto + :: Blind (WithConstrKES (SeedSizeKES (KES StandardCrypto)) (KES StandardCrypto) (Sig StandardCrypto)) + -> Property +prop_codec_sig_encoding_standardcrypto = prop_codec_sig_encoding . getBlind + + type AnySigMessage crypto = WithConstrKESList (SeedSizeKES (KES crypto)) (KES crypto) (AnyMessage (SigSubmission crypto)) From 92a8fbb3f78956c3b198d884149e4e65f50f9d02 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 6 Jan 2026 17:21:51 +0100 Subject: [PATCH 03/11] SigSubmissionV2: protocol definition `SigSubmissionV2` protocol based on `ObjectDiffusion` from Peras. The client requests signatures while the server provides them (dual to `TxSubmission`). The patch provides: * protocol definition and GADT wrappers * CBOR codec * cddl specification checked against the codec * codec provides valid CBOR encoding (checked as a regular QC test rather than with the `cddl` tool) --- dmq-node/cddl/Main.hs | 146 +++++++-- dmq-node/cddl/specs/sig-submission-v2.cddl | 30 ++ dmq-node/cddl/specs/sig.cddl | 1 + dmq-node/dmq-node.cabal | 19 +- .../src/DMQ/Protocol/SigSubmissionV2/Codec.hs | 295 +++++++++++++++++ .../DMQ/Protocol/SigSubmissionV2/Inbound.hs | 124 ++++++++ .../DMQ/Protocol/SigSubmissionV2/Outbound.hs | 115 +++++++ .../src/DMQ/Protocol/SigSubmissionV2/Type.hs | 296 ++++++++++++++++++ .../Protocol/SigSubmissionV2/Codec/CDDL.hs | 21 ++ .../DMQ/Protocol/SigSubmissionV2/Direct.hs | 69 ++++ .../test/DMQ/Protocol/SigSubmissionV2/Test.hs | 247 +++++++++++++++ dmq-node/test/Main.hs | 2 + 12 files changed, 1334 insertions(+), 31 deletions(-) create mode 100644 dmq-node/cddl/specs/sig-submission-v2.cddl create mode 100644 dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs create mode 100644 dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs create mode 100644 dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs create mode 100644 dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs create mode 100644 dmq-node/test/DMQ/Protocol/SigSubmissionV2/Codec/CDDL.hs create mode 100644 dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs create mode 100644 dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs diff --git a/dmq-node/cddl/Main.hs b/dmq-node/cddl/Main.hs index 2e5ef24..77124d0 100644 --- a/dmq-node/cddl/Main.hs +++ b/dmq-node/cddl/Main.hs @@ -11,9 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -37,6 +35,7 @@ import Data.Bool (bool) import Data.ByteString.Base16.Lazy qualified as BL.Base16 import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy.Char8 qualified as BL.Char8 +import Data.Functor ((<&>)) import Text.Printf import System.Directory (doesDirectoryExist) @@ -55,12 +54,16 @@ import DMQ.Protocol.LocalMsgNotification.Codec import DMQ.Protocol.LocalMsgNotification.Type as LocalMsgNotification import DMQ.Protocol.SigSubmission.Codec import DMQ.Protocol.SigSubmission.Type +import DMQ.Protocol.SigSubmissionV2.Type (SigSubmissionV2) +import DMQ.Protocol.SigSubmissionV2.Type qualified as SigSubmissionV2 +import DMQ.Protocol.SigSubmissionV2.Test qualified as SigSubmissionV2.Test +import DMQ.Protocol.SigSubmissionV2.Codec.CDDL -- import Test.QuickCheck hiding (Result (..)) import Test.QuickCheck.Instances.ByteString () import Test.Tasty (TestTree, adjustOption, defaultMain, testGroup) import Test.Tasty.HUnit -import Test.Tasty.QuickCheck (QuickCheckMaxSize (..)) +import Test.Tasty.QuickCheck main :: IO () main = do @@ -69,7 +72,8 @@ main = do tests :: CDDLSpecs -> TestTree tests CDDLSpecs { cddlSig, - cddlLocalMsgNotification + cddlLocalMsgNotification, + cddlSigSubmissionV2 } = adjustOption (const $ QuickCheckMaxSize 10) $ testGroup "cddl" @@ -77,8 +81,11 @@ tests CDDLSpecs { cddlSig, -- validate decoder by generating messages from the specification [ testCase "Sig" (unit_decodeSig cddlSig) , testCase "LocalMsgNotification" (unit_decodeLocalMsgNotification cddlLocalMsgNotification) + , testCase "SigSubmissionV2" (unit_decodeSigSubmissionV2 cddlSigSubmissionV2) ] - -- TODO: validate `LocalMsgNotification` encoder + -- TODO: validate `LocalMsgNotification` encoder (this should be done in + -- `DMQ.Protocol.LocalMsgNotification.Test` module, see + -- `DMQ.Protocol.SigSubmissionV2.Test.prop_encoding` for an example) ] newtype CDDLSpec ps = CDDLSpec BL.ByteString @@ -87,13 +94,14 @@ type AnnSigRawWithSignedBytes = BL.ByteString -> SigRawWithSignedBytes StandardC data CDDLSpecs = CDDLSpecs { cddlSig :: CDDLSpec AnnSigRawWithSignedBytes, - cddlLocalMsgNotification :: CDDLSpec (LocalMsgNotification (Sig StandardCrypto)) + cddlLocalMsgNotification :: CDDLSpec (LocalMsgNotification (Sig StandardCrypto)), + cddlSigSubmissionV2 :: CDDLSpec (SigSubmissionV2 SigSubmissionV2.Test.SigId SigSubmissionV2.Test.Sig) } unit_decodeSig :: CDDLSpec AnnSigRawWithSignedBytes -> Assertion -unit_decodeSig spec = validateDecoder spec decodeSig 100 +unit_decodeSig spec = validateDecoder' spec decodeSig 100 unit_decodeLocalMsgNotification :: CDDLSpec (LocalMsgNotification (Sig StandardCrypto)) -> Assertion @@ -121,6 +129,21 @@ unit_decodeLocalMsgNotification spec = term -> term +unit_decodeSigSubmissionV2 + :: CDDLSpec (SigSubmissionV2 SigSubmissionV2.Test.SigId SigSubmissionV2.Test.Sig) + -> Assertion +unit_decodeSigSubmissionV2 spec = + validateDecoder + (Just indefiniteListFix) + spec + sigSubmissionV2Codec + [ SomeAgency $ SigSubmissionV2.SingSigIds SigSubmissionV2.SingBlocking + , SomeAgency $ SigSubmissionV2.SingSigIds SigSubmissionV2.SingNonBlocking + , SomeAgency SigSubmissionV2.SingSigs + , SomeAgency SigSubmissionV2.SingIdle + ] + 100 + -- -- utils -- @@ -133,9 +156,9 @@ unit_decodeLocalMsgNotification spec = -- The `CDDL_INCLUDE_PATH` environment variable must be set. cddlc :: FilePath -> IO BL.ByteString cddlc path = do - (exitCode, cddl, _) <- readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty + (exitCode, cddl, stderr) <- readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty unless (exitCode == ExitSuccess) $ - die $ printf "cddlc failed on \"%s\" with %s " path (show exitCode) + die $ printf "cddlc failed on \"%s\" with %s\n%s " path (show exitCode) (BL.Char8.unpack stderr) return cddl @@ -148,18 +171,72 @@ readCDDLSpecs = do sigSpec <- cddlc (dir "sig.cddl") localMessageNotificationSpec <- cddlc (dir "local-msg-notification.cddl") + sigSubmissionV2Spec <- cddlc (dir "sig-submission-v2.cddl") return CDDLSpecs { cddlSig = CDDLSpec sigSpec, - cddlLocalMsgNotification = CDDLSpec localMessageNotificationSpec + cddlLocalMsgNotification = CDDLSpec localMessageNotificationSpec, + cddlSigSubmissionV2 = CDDLSpec sigSubmissionV2Spec } +validateDecoder :: Maybe (CBOR.Term -> CBOR.Term) + -- ^ transform a generated term + -> CDDLSpec ps + -> Codec ps CBOR.DeserialiseFailure IO BL.ByteString + -> [SomeAgency ps] + -> Int + -> Assertion +validateDecoder transform (CDDLSpec spec) codec stoks rounds = do + eterms <- runExceptT $ generateCBORFromSpec spec rounds + case eterms of + Left err -> assertFailure err + Right terms -> + forM_ terms $ \(generated_term, encoded_term) -> do + let encoded_term' = case transform of + Nothing -> encoded_term + Just tr -> case CBOR.deserialiseFromBytes CBOR.decodeTerm encoded_term of + Right (rest, term) | BL.null rest + -> CBOR.toLazyByteString (CBOR.encodeTerm (tr term)) + Right _ -> error "validateDecoder: trailing bytes" + Left err -> error $ "validateDecoder: decoding error: " + ++ show err + Right (_, decoded_term) = + CBOR.deserialiseFromBytes CBOR.decodeTerm encoded_term' + res <- decodeMsg encoded_term' + case res of + Just errs -> assertFailure $ concat + [ "decoding failures:\n" + , unlines (map show errs) + , "while decoding:\n" + , show decoded_term + , "\n" + , "generated term:\n" + , BL.Char8.unpack generated_term + ] + Nothing -> return () + where + -- | Try decode at all given agencies. If one succeeds return + -- 'Nothing' otherwise return all 'DeserialiseFailure's. + -- + decodeMsg :: BL.ByteString + -> IO (Maybe [CBOR.DeserialiseFailure]) + decodeMsg bs = + -- sequence [Nothing, ...] = Nothing + fmap (sequence :: [Maybe CBOR.DeserialiseFailure] -> Maybe [CBOR.DeserialiseFailure]) $ + forM stoks $ \(SomeAgency (stok :: StateToken st)) -> do + decoder <- (decode codec stok :: IO (DecodeStep BL.ByteString CBOR.DeserialiseFailure IO (SomeMessage st))) + res <- runDecoder [bs] decoder + return $ case res of + Left err -> Just err + Right {} -> Nothing + + -validateDecoder :: CDDLSpec a +validateDecoder' :: CDDLSpec a -> (forall s. CBOR.Decoder s a) -> Int -> Assertion -validateDecoder (CDDLSpec spec) decoder rounds = do +validateDecoder' (CDDLSpec spec) decoder rounds = do eterms <- runExceptT $ generateCBORFromSpec spec rounds case eterms of Left err -> assertFailure err @@ -215,8 +292,8 @@ validateAnnotatedDecoder transform (CDDLSpec spec) codec stoks rounds = do Just tr -> case CBOR.deserialiseFromBytes CBOR.decodeTerm encoded_term of Right (rest, term) | BL.null rest -> CBOR.toLazyByteString (CBOR.encodeTerm (tr term)) - Right _ -> error "validateDecoder: trailing bytes" - Left err -> error $ "validateDecoder: decoding error: " + Right _ -> error "validateAnnotatedDecoder: trailing bytes" + Left err -> error $ "validateAnnotatedDecoder: decoding error: " ++ show err Right (_, decoded_term) = @@ -243,7 +320,7 @@ validateAnnotatedDecoder transform (CDDLSpec spec) codec stoks rounds = do decodeMsg bs = -- sequence [Nothing, ...] = Nothing fmap sequence $ - forM stoks $ \(a@(SomeAgency (stok :: StateToken st))) -> do + forM stoks $ \a@(SomeAgency (stok :: StateToken st)) -> do decoder <- decode codec stok res <- runDecoder [bs] decoder return $ case res of @@ -270,17 +347,28 @@ generateCBORFromSpec spec rounds = do . readProcessWithExitCode "diag2cbor.rb" ["-"] - unpackResult :: IO (ExitCode, BL.ByteString, BL.ByteString) - -> IO (Either String BL.ByteString) - unpackResult r = r >>= \case - (ExitFailure _, _, err) -> return (Left $ BL.Char8.unpack err) - (ExitSuccess, bytes, _) -> return (Right bytes) - - - withTemporaryFile :: BL.ByteString - -> (FilePath -> IO a) -> IO a - withTemporaryFile bs k = - withTempFile "." "tmp" $ - \fileName h -> BL.hPut h bs - >> hClose h - >> k fileName +-- | The cddl spec cannot differentiate between fix-length list encoding and +-- infinite-length encoding. The cddl tool always generates fix-length +-- encoding but tx-submission and object-diffusion codecs are accepting only +-- indefinite-length encoding. +-- +indefiniteListFix :: CBOR.Term -> CBOR.Term +indefiniteListFix term = + case term of + TList [TInt tag, TList l] -> TList [TInt tag, TListI l] + _ -> term + + +unpackResult :: IO (ExitCode, BL.ByteString, BL.ByteString) + -> IO (Either String BL.ByteString) +unpackResult r = r <&> \case + (ExitFailure _, _, err) -> (Left $ BL.Char8.unpack err) + (ExitSuccess, bytes, _) -> (Right bytes) + + +withTemporaryFile :: BL.ByteString -> (FilePath -> IO a) -> IO a +withTemporaryFile bs k = + withTempFile "." "tmp" $ + \fileName h -> BL.hPut h bs + >> hClose h + >> k fileName diff --git a/dmq-node/cddl/specs/sig-submission-v2.cddl b/dmq-node/cddl/specs/sig-submission-v2.cddl new file mode 100644 index 0000000..b22a574 --- /dev/null +++ b/dmq-node/cddl/specs/sig-submission-v2.cddl @@ -0,0 +1,30 @@ +; +; SigSubmission v2 mini-protocol +; + +; reference implementation of the codec in: +; dmq-node/src/DMQ/Protocol/SigSubmission/V2/Codec.hs + +sigSubmissionV2Message + = + ; corresponds to either MsgRequestSigIdsBlocking or + ; MsgRequestSigIdsNonBlocking in the spec + msgRequestSigIds + / msgReplySigIds + / msgReplyNoSigIds + / msgRequestSigs + / msgReplySigs + / msgDone + + +msgRequestSigIds = [1, blocking, sigCount, sigCount] +msgReplySigIds = [2, [*sig.messageId] ] +msgReplyNoSigIds = [3] +msgRequestSigs = [4, [*sig.messageId] ] +msgReplySigs = [5, [*sig.message] ] +msgDone = [6] + +blocking = false / true +sigCount = sig.word16 + +;# import sig as sig diff --git a/dmq-node/cddl/specs/sig.cddl b/dmq-node/cddl/specs/sig.cddl index 10740d1..e1a41d0 100644 --- a/dmq-node/cddl/specs/sig.cddl +++ b/dmq-node/cddl/specs/sig.cddl @@ -19,5 +19,6 @@ operationalCertificate = [ bstr .size 32, word64, word64, bstr .size 64 ] coldVerificationKey = bstr .size 32 expiresAt = word32 +word16 = uint .size 2; 2 bytes word32 = uint .size 4; 4 bytes word64 = uint .size 8; 8 bytes diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index afcd389..6971831 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -83,6 +83,10 @@ library DMQ.Protocol.SigSubmission.Codec DMQ.Protocol.SigSubmission.Type DMQ.Protocol.SigSubmission.Validate + DMQ.Protocol.SigSubmissionV2.Codec + DMQ.Protocol.SigSubmissionV2.Type + DMQ.Protocol.SigSubmissionV2.Inbound + DMQ.Protocol.SigSubmissionV2.Outbound DMQ.Tracer build-depends: @@ -113,11 +117,13 @@ library kes-agent-crypto ^>=0.1, network ^>=3.2.7, network-mux ^>=0.9.1, + nothunks, optparse-applicative >=0.18 && <0.20, ouroboros-consensus, ouroboros-consensus-cardano, ouroboros-consensus-diffusion, ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.23, + quiet, random ^>=1.2, singletons, text >=1.2.4 && <2.2, @@ -171,6 +177,9 @@ test-suite dmq-tests DMQ.Protocol.LocalMsgNotification.Test DMQ.Protocol.LocalMsgSubmission.Test DMQ.Protocol.SigSubmission.Test + DMQ.Protocol.SigSubmissionV2.Test + DMQ.Protocol.SigSubmissionV2.Direct + DMQ.Protocol.SigSubmissionV2.Codec.CDDL Test.DMQ.NodeToClient Test.DMQ.NodeToNode @@ -219,8 +228,11 @@ test-suite dmq-cddl extensions type: exitcode-stdio-1.0 - hs-source-dirs: cddl + hs-source-dirs: cddl, test main-is: Main.hs + other-modules: + DMQ.Protocol.SigSubmissionV2.Test + DMQ.Protocol.SigSubmissionV2.Codec.CDDL if flag(cddl) buildable: True @@ -229,6 +241,7 @@ test-suite dmq-cddl default-language: Haskell2010 build-depends: + QuickCheck, base >=4.14 && <4.23, base16-bytestring, bytestring, @@ -236,8 +249,10 @@ test-suite dmq-cddl directory, dmq-node, filepath, + io-classes:{io-classes}, kes-agent-crypto, mtl, + ouroboros-network:{api, protocols-tests-lib, tests-lib}, process-extras, quickcheck-instances, serialise, @@ -245,7 +260,7 @@ test-suite dmq-cddl tasty-hunit, tasty-quickcheck, temporary, - typed-protocols, + typed-protocols:{typed-protocols, codec-properties}, ghc-options: -threaded diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs new file mode 100644 index 0000000..c81c9f4 --- /dev/null +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module DMQ.Protocol.SigSubmissionV2.Codec + ( codecSigSubmissionV2 + , codecSigSubmissionV2Id + , byteLimitsSigSubmissionV2 + , timeLimitsSigSubmissionV2 + , encodeSigSubmissionV2 + ) where + +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.CBOR.Read qualified as CBOR +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadTime.SI +import Data.ByteString.Lazy (ByteString) +import Data.Kind (Type) +import Data.List.NonEmpty qualified as NonEmpty +import DMQ.Protocol.SigSubmissionV2.Type +import Network.TypedProtocol.Codec.CBOR +import Ouroboros.Network.Protocol.Limits +import Text.Printf + +-- | Byte Limits. +byteLimitsSigSubmissionV2 + :: forall bytes sigId sig. + (bytes -> Word) + -> ProtocolSizeLimits (SigSubmissionV2 sigId sig) bytes +byteLimitsSigSubmissionV2 = ProtocolSizeLimits stateToLimit + where + stateToLimit + :: forall (st :: SigSubmissionV2 sigId sig). + ActiveState st + => StateToken st + -> Word + stateToLimit (SingSigIds SingBlocking) = largeByteLimit + stateToLimit (SingSigIds SingNonBlocking) = largeByteLimit + stateToLimit SingSigs = largeByteLimit + stateToLimit SingIdle = smallByteLimit + stateToLimit a@SingDone = notActiveState a + +-- | 'SigSubmissionV2' time limits. +-- +-- +---------------------------------+---------------+ +-- | 'SigSubmissionV2' state | timeout (s) | +-- +=================================+===============+ +-- | `StIdle` | `waitForever` | +-- +---------------------------------+---------------+ +-- | @'StSigIds' 'StBlocking'@ | `Just 20` | +-- +---------------------------------+---------------+ +-- | @'StOSigIds' 'StNonBlocking'@ | `shortWait` | +-- +---------------------------------+---------------+ +-- | `StObjects` | `shortWait` | +-- +---------------------------------+---------------+ +timeLimitsSigSubmissionV2 + :: forall (sigId :: Type) (sig :: Type). + ProtocolTimeLimits (SigSubmissionV2 sigId sig) +timeLimitsSigSubmissionV2 = ProtocolTimeLimits stateToLimit + where + stateToLimit + :: forall (st :: SigSubmissionV2 sigId sig). + ActiveState st + => StateToken st + -> Maybe DiffTime + stateToLimit (SingSigIds SingBlocking) = Just 20 + stateToLimit (SingSigIds SingNonBlocking) = shortWait + stateToLimit SingSigs = shortWait + stateToLimit SingIdle = waitForever + stateToLimit a@SingDone = notActiveState a + + +codecSigSubmissionV2 + :: forall (sigId :: Type) (sig :: Type) m. + MonadST m + => (sigId -> CBOR.Encoding) -- ^ encode `sigId` + -> (forall s. CBOR.Decoder s sigId) -- ^ decode `sigId` + -> (sig -> CBOR.Encoding) -- ^ encode `sig` + -> (forall s. CBOR.Decoder s sig) -- ^ decode `sig` + -> Codec (SigSubmissionV2 sigId sig) CBOR.DeserialiseFailure m ByteString +codecSigSubmissionV2 + encodeSigId decodeSigId + encodeSig decodeSig + = + mkCodecCborLazyBS + (encodeSigSubmissionV2 encodeSigId encodeSig) + decode + where + decode + :: forall (st :: SigSubmissionV2 sigId sig). + ActiveState st + => StateToken st + -> forall s. CBOR.Decoder s (SomeMessage st) + decode stok = do + len <- CBOR.decodeListLen + key <- CBOR.decodeWord + decodeSigSubmissionV2 decodeSigId decodeSig stok len key + + +encodeSigSubmissionV2 + :: forall (sigId :: Type) (sig :: Type) + (st :: SigSubmissionV2 sigId sig) + (st' :: SigSubmissionV2 sigId sig). + (sigId -> CBOR.Encoding) -- ^ encode 'sigId' + -> (sig -> CBOR.Encoding) -- ^ encode 'sig' + -> Message (SigSubmissionV2 sigId sig) st st' + -> CBOR.Encoding +encodeSigSubmissionV2 encodeObjectId encodeObject = encode + where + encode + :: forall st0 st1. + Message (SigSubmissionV2 sigId sig) st0 st1 + -> CBOR.Encoding + encode (MsgRequestSigIds blocking (NumIdsAck ackNo) (NumIdsReq reqNo)) = + CBOR.encodeListLen 4 + <> CBOR.encodeWord 1 + <> CBOR.encodeBool + ( case blocking of + SingBlocking -> True + SingNonBlocking -> False + ) + <> CBOR.encodeWord16 ackNo + <> CBOR.encodeWord16 reqNo + + encode (MsgReplySigIds objIds) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 2 + <> CBOR.encodeListLenIndef + <> foldMap encodeObjectId objIds + <> CBOR.encodeBreak + + encode MsgReplyNoSigIds = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 3 + + encode (MsgRequestSigs objIds) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 4 + <> CBOR.encodeListLenIndef + <> foldMap encodeObjectId objIds + <> CBOR.encodeBreak + + encode (MsgReplySigs objects) = + CBOR.encodeListLen 2 + <> CBOR.encodeWord 5 + <> CBOR.encodeListLenIndef + <> foldMap encodeObject objects + <> CBOR.encodeBreak + + encode MsgDone = + CBOR.encodeListLen 1 + <> CBOR.encodeWord 6 + + +decodeSigSubmissionV2 + :: forall (sigId :: Type) (sig :: Type) + (st :: SigSubmissionV2 sigId sig) s. + ActiveState st + => (forall s'. CBOR.Decoder s' sigId) -- ^ decode 'sigId' + -> (forall s'. CBOR.Decoder s' sig) -- ^ decode sig + -> StateToken st + -> Int + -> Word + -> CBOR.Decoder s (SomeMessage st) +decodeSigSubmissionV2 decodeSigId decodeSig = decode + where + decode + :: forall (st' :: SigSubmissionV2 sigId sig). + ActiveState st' + => StateToken st' + -> Int + -> Word + -> CBOR.Decoder s (SomeMessage st') + decode stok len key = do + case (stok, len, key) of + (SingIdle, 4, 1) -> do + blocking <- CBOR.decodeBool + ackNo <- NumIdsAck <$> CBOR.decodeWord16 + reqNo <- NumIdsReq <$> CBOR.decodeWord16 + return $! if blocking + then SomeMessage $ MsgRequestSigIds SingBlocking ackNo reqNo + else SomeMessage $ MsgRequestSigIds SingNonBlocking ackNo reqNo + + (SingSigIds b, 2, 2) -> do + CBOR.decodeListLenIndef + sigIds <- CBOR.decodeSequenceLenIndef + (flip (:)) + [] + reverse + decodeSigId + case (b, sigIds) of + (SingBlocking, t : ts) -> + return + $ SomeMessage + $ MsgReplySigIds (BlockingReply (t NonEmpty.:| ts)) + + (SingNonBlocking, ts) -> + return + $ SomeMessage + $ MsgReplySigIds (NonBlockingReply ts) + + (SingBlocking, []) -> + fail "codecSigSubmissionV2: MsgReplySigIds: empty list not permitted" + + (SingSigIds SingBlocking, 1, 3) -> + return (SomeMessage MsgReplyNoSigIds) + + (SingIdle, 2, 4) -> do + CBOR.decodeListLenIndef + sigIds <- CBOR.decodeSequenceLenIndef + (flip (:)) + [] + reverse + decodeSigId + return $ SomeMessage $ MsgRequestSigs sigIds + + (SingSigs, 2, 5) -> do + CBOR.decodeListLenIndef + sigIds <- CBOR.decodeSequenceLenIndef + (flip (:)) + [] + reverse + decodeSig + return $ SomeMessage $ MsgReplySigs sigIds + + (SingIdle, 1, 6) -> + return $ SomeMessage MsgDone + + (SingDone, _, _) -> notActiveState stok + + -- failures + (_, _, _) -> + fail $ printf "codecSigSubmissionV2 (%s) unexpected key %d, length %d" (show stok) key len + + +codecSigSubmissionV2Id + :: forall sigId sig m. + Monad m + => Codec + (SigSubmissionV2 sigId sig) + CodecFailure + m + (AnyMessage (SigSubmissionV2 sigId sig)) +codecSigSubmissionV2Id = Codec {encode, decode} + where + encode + :: forall st st'. + ( ActiveState st + , StateTokenI st + ) + => Message (SigSubmissionV2 sigId sig) st st' + -> AnyMessage (SigSubmissionV2 sigId sig) + encode = AnyMessage + + decode + :: forall (st :: SigSubmissionV2 sigId sig). + ActiveState st + => StateToken st + -> m (DecodeStep + (AnyMessage (SigSubmissionV2 sigId sig)) + CodecFailure + m + (SomeMessage st) + ) + decode stok = return $ DecodePartial $ \bytes -> + return $ case (stok, bytes) of + (SingIdle, Just (AnyMessage msg@(MsgRequestSigIds SingBlocking _ _))) -> + DecodeDone (SomeMessage msg) Nothing + (SingIdle, Just (AnyMessage msg@(MsgRequestSigIds SingNonBlocking _ _))) -> + DecodeDone (SomeMessage msg) Nothing + (SingIdle, Just (AnyMessage msg@(MsgRequestSigs {}))) -> + DecodeDone (SomeMessage msg) Nothing + (SingSigs, Just (AnyMessage msg@(MsgReplySigs {}))) -> + DecodeDone (SomeMessage msg) Nothing + (SingSigIds b, Just (AnyMessage msg)) -> case (b, msg) of + (SingBlocking, MsgReplySigIds (BlockingReply {})) -> + DecodeDone (SomeMessage msg) Nothing + (SingBlocking, MsgReplyNoSigIds) -> + DecodeDone (SomeMessage msg) Nothing + (SingNonBlocking, MsgReplySigIds (NonBlockingReply {})) -> + DecodeDone (SomeMessage msg) Nothing + (_, _) -> + DecodeFail $ CodecFailure "codecSigSubmissionV2Id: no matching message" + (SingIdle, Just (AnyMessage msg@MsgDone)) -> + DecodeDone (SomeMessage msg) Nothing + (SingDone, _) -> + notActiveState stok + (_, _) -> + DecodeFail $ CodecFailure "codecSigSubmissionV2Id: no matching message" diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs new file mode 100644 index 0000000..99958a4 --- /dev/null +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A view of the sig submission protocol from the point of view of the +-- inbound/client peer. +-- +-- This provides a view that uses less complex types and should be easier to use +-- than the underlying typed protocol itself. +-- +-- For execution, a conversion into the typed protocol is provided. +module DMQ.Protocol.SigSubmissionV2.Inbound + ( -- * Protocol type for the inbound + SigSubmissionInboundPipelined (..) + , InboundStIdle (..) + , Collect (..) + -- * Execution as a typed protocol + , sigSubmissionV2InboundPeerPipelined + ) where + +import Data.List.NonEmpty qualified as NonEmpty +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer (Peer, PeerPipelined (..)) +import Network.TypedProtocol.Peer.Client +import DMQ.Protocol.SigSubmissionV2.Type + +data SigSubmissionInboundPipelined sigId sig m a where + SigSubmissionInboundPipelined + :: InboundStIdle Z sigId sig m a + -> SigSubmissionInboundPipelined sigId sig m a + +-- | This is the type of the pipelined results, collected by 'CollectPipelined'. +-- This protocol can pipeline requests for identifiers and signatures, so we use +-- a sum of either for collecting the responses. +-- +data Collect sigId sig + = -- | The result of 'SendMsgRequestSigIdsPipelined'. It also carries + -- the number of sigIds originally requested. + CollectSigIds NumIdsReq [sigId] + + | -- | The result of 'SendMsgRequestSigsPipelined'. The actual reply only + -- contains the signatures sent, but this pairs them up with the + -- requested identifiers. This is for the peer to determine whether some + -- signatures are no longer needed. + CollectSigs [sigId] [sig] + + +data InboundStIdle (n :: N) sigId sig m a where + SendMsgRequestSigIdsBlocking + :: NumIdsAck -- ^ number of sigIds to acknowledge + -> NumIdsReq -- ^ number of sigIds to request + -> ([sigId] -> m (InboundStIdle Z sigId sig m a)) + -> InboundStIdle Z sigId sig m a + + SendMsgRequestSigIdsPipelined + :: NumIdsAck + -> NumIdsReq + -> m (InboundStIdle (S n) sigId sig m a) + -> InboundStIdle n sigId sig m a + + SendMsgRequestSigsPipelined + :: [sigId] + -> m (InboundStIdle (S n) sigId sig m a) + -> InboundStIdle n sigId sig m a + + CollectPipelined + :: Maybe (InboundStIdle (S n) sigId sig m a) + -> (Collect sigId sig -> m (InboundStIdle n sigId sig m a)) + -> InboundStIdle (S n) sigId sig m a + + SendMsgDone + :: m a + -> InboundStIdle Z sigId sig m a + + +-- | Transform a 'SigSubmissionInboundPipelined' into a 'PeerPipelined'. +-- +sigSubmissionV2InboundPeerPipelined + :: forall sigId sig m a. + (Functor m) + => SigSubmissionInboundPipelined sigId sig m a + -> PeerPipelined (SigSubmissionV2 sigId sig) AsClient StIdle m a +sigSubmissionV2InboundPeerPipelined (SigSubmissionInboundPipelined inboundSt) = + PeerPipelined $ run inboundSt + where + run :: InboundStIdle n sigId sig m a + -> Peer (SigSubmissionV2 sigId sig) AsClient (Pipelined n (Collect sigId sig)) StIdle m a + + run (SendMsgRequestSigIdsBlocking ackNo reqNo k) = + Yield (MsgRequestSigIds SingBlocking ackNo reqNo) $ + Await \case + MsgReplySigIds (BlockingReply sigIds) -> + Effect $ run <$> k (NonEmpty.toList sigIds) + + MsgReplyNoSigIds -> + Effect $ run <$> k [] + + run (SendMsgRequestSigIdsPipelined ackNo reqNo k) = + YieldPipelined + (MsgRequestSigIds SingNonBlocking ackNo reqNo) + (ReceiverAwait + $ \(MsgReplySigIds (NonBlockingReply sigIds)) -> + ReceiverDone (CollectSigIds reqNo sigIds) + ) + (Effect $ run <$> k) + + run (SendMsgRequestSigsPipelined sigIds k) = + YieldPipelined + (MsgRequestSigs sigIds) + (ReceiverAwait + $ \(MsgReplySigs sigs) -> + ReceiverDone (CollectSigs sigIds sigs) + ) + (Effect $ run <$> k) + + run (CollectPipelined none collect) = + Collect + (run <$> none) + (Effect . fmap run . collect) + + run (SendMsgDone done) = + Effect $ Yield MsgDone . Done <$> done diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs new file mode 100644 index 0000000..a3f0f3f --- /dev/null +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A view of the sig diffusion protocol from the point of view of +-- the outbound/server peer. +-- +-- This provides a view that uses less complex types and should be easier to +-- use than the underlying typed protocol itself. +-- +-- For execution, 'sigSubmissionOutboundPeer' is provided for conversion +-- into the typed protocol. +module DMQ.Protocol.SigSubmissionV2.Outbound + ( -- * Protocol type for the outbound + SigSubmissionOutbound (..) + , OutboundStIdle (..) + , OutboundStSigIds (..) + , OutboundStSigs (..) + -- * Execution as a typed protocol + , sigSubmissionV2OutboundPeer + ) where + +import Data.Functor ((<&>)) +import Data.Singletons (SingI) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Peer (Peer) +import Network.TypedProtocol.Peer.Server + +import DMQ.Protocol.SigSubmissionV2.Type + +-- | The outbound side of the sig diffusion protocol. +-- +-- The peer in the outbound/server role submits sigs to the peer in the +-- inbound/client role. +newtype SigSubmissionOutbound sigId sig m a = SigSubmissionOutbound { + runSigSubmissionOutbound :: m (OutboundStIdle sigId sig m a) + } + +-- | In the 'StIdle' protocol state, the outbound does not have agency. Instead +-- it is waiting for: +-- +-- * a request for sig ids (blocking or non-blocking) +-- * a request for a given list of sigs +-- * a termination message +-- +-- It must be prepared to handle any of these. +data OutboundStIdle sigId sig m a = OutboundStIdle { + recvMsgRequestSigIds :: forall blocking. + SingBlockingStyle blocking + -> NumIdsAck + -> NumIdsReq + -> m (OutboundStSigIds blocking sigId sig m a), + + recvMsgRequestSigs :: [sigId] + -> m (OutboundStSigs sigId sig m a), + + recvMsgDone :: m a + } + +data OutboundStSigIds blocking sigId sig m a where + SendMsgReplySigIds + :: SingI blocking + => BlockingReplyList blocking sigId + -> OutboundStIdle sigId sig m a + -> OutboundStSigIds blocking sigId sig m a + + SendMsgReplyNoSigIds + :: OutboundStIdle sigId sig m a + -> OutboundStSigIds StBlocking sigId sig m a + +data OutboundStSigs sigId sig m a where + SendMsgReplySigs + :: [sig] + -> OutboundStIdle sigId sig m a + -> OutboundStSigs sigId sig m a + + +-- | A non-pipelined 'Peer' representing the 'SigSubmissionOutbound'. +sigSubmissionV2OutboundPeer + :: forall sigId sig m a. + Monad m + => SigSubmissionOutbound sigId sig m a + -> Peer (SigSubmissionV2 sigId sig) AsServer NonPipelined StIdle m a +sigSubmissionV2OutboundPeer (SigSubmissionOutbound outboundSt) = + Effect (run <$> outboundSt) + where + run :: OutboundStIdle sigId sig m a + -> Peer (SigSubmissionV2 sigId sig) AsServer NonPipelined StIdle m a + run OutboundStIdle {recvMsgRequestSigIds, recvMsgRequestSigs, recvMsgDone} = + Await $ \case + MsgRequestSigIds blocking ackNo reqNo -> Effect $ do + recvMsgRequestSigIds blocking ackNo reqNo <&> \case + + SendMsgReplySigIds sigIds k -> + Yield + (MsgReplySigIds sigIds) + (run k) + + SendMsgReplyNoSigIds k -> + Yield + MsgReplyNoSigIds + (run k) + + MsgRequestSigs sigIds -> Effect $ do + recvMsgRequestSigs sigIds <&> \case + SendMsgReplySigs sigs k -> + Yield + (MsgReplySigs sigs) + (run k) + + MsgDone -> Effect $ Done <$> recvMsgDone diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs new file mode 100644 index 0000000..cf9976a --- /dev/null +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The type of the signature diffusion protocol. +-- +-- This is used to diffuse generic signatures between nodes. +-- +-- It is based on `Ouroboros.Network.Protocol.ObjectDiffusion` mini-protocol +-- originally designed for Peras. +-- +module DMQ.Protocol.SigSubmissionV2.Type + ( SigSubmissionV2 (..) + , Message (..) + , SingSigSubmissionV2 (..) + , NumIdsAck (..) + , NumIdsReq (..) + , NumReq (..) + , NumUnacknowledged (..) + -- Signature types + , module SigSubmission + -- re-exports + , BlockingReplyList (..) + , SingBlockingStyle (..) + , SizeInBytes (..) + , StBlockingStyle (..) + ) where + +import Control.DeepSeq (NFData (..)) +import Data.Kind (Type) +import Data.Monoid (Sum (..)) +import Data.Singletons +import Data.Word (Word16) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks (..)) +import Quiet (Quiet (..)) + +import Network.TypedProtocol.Core + +import DMQ.Protocol.SigSubmission.Type as SigSubmission (SigId (..), SigBody (..), SigKESSignature (..), SigOpCertificate (..), SigColdKey (..), SigRaw (..), SigRawWithSignedBytes (..), Sig (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type (BlockingReplyList (..), + SingBlockingStyle (..), StBlockingStyle (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) + +-- | The kind of the object diffusion protocol, and the types of the states in +-- the protocol state machine. +-- +-- We describe this protocol using indiscriminately the labels \"inbound\"/\"client\" +-- for the peer that is receiving objects, and \"outbound\"/\"server\" for the one +-- sending them. +type SigSubmissionV2 :: Type -> Type -> Type +data SigSubmissionV2 sigId sig where + -- | The inbound node has agency; it can either terminate, ask for object + -- identifiers or ask for objects. + -- + -- There is no timeout in this state. + StIdle :: SigSubmissionV2 sigId sig + + -- | The outbound node has agency; it must reply with a list of object + -- identifiers that it wishes to submit. + -- + -- There are two sub-states for this, for blocking and non-blocking cases. + StSigIds :: StBlockingStyle -> SigSubmissionV2 sigId sig + + -- | The outbound node has agency; it must reply with the list of + -- objects. + StSigs :: SigSubmissionV2 sigId sig + + -- | Nobody has agency; termination state. + StDone :: SigSubmissionV2 sigId sig + +instance ( ShowProxy sigId + , ShowProxy sig + ) + => ShowProxy (SigSubmissionV2 sigId sig) where + showProxy _ = + concat + [ "SigSubmissionV2 ", + showProxy (Proxy :: Proxy sigId), + " ", + showProxy (Proxy :: Proxy sig) + ] + +instance ShowProxy (StIdle :: SigSubmissionV2 sigId sig) where + showProxy _ = "StIdle" + + +type SingSigSubmissionV2 + :: SigSubmissionV2 sigId sig + -> Type +data SingSigSubmissionV2 k where + SingIdle :: SingSigSubmissionV2 StIdle + SingSigIds :: SingBlockingStyle stBlocking + -> SingSigSubmissionV2 (StSigIds stBlocking) + SingSigs :: SingSigSubmissionV2 StSigs + SingDone :: SingSigSubmissionV2 StDone + +deriving instance Show (SingSigSubmissionV2 st) + +instance StateTokenI StIdle where stateToken = SingIdle +instance SingI stBlocking + => StateTokenI (StSigIds stBlocking) where stateToken = SingSigIds sing +instance StateTokenI StSigs where stateToken = SingSigs +instance StateTokenI StDone where stateToken = SingDone + + +newtype NumIdsAck = NumIdsAck {getNumIdsAck :: Word16} + deriving (Eq, Ord, NFData, Generic) + deriving newtype (Num, Enum, Real, Integral, Bounded, NoThunks) + deriving Semigroup via (Sum Word16) + deriving Monoid via (Sum Word16) + deriving Show via (Quiet NumIdsAck) + +newtype NumIdsReq = NumIdsReq {getNumIdsReq :: Word16} + deriving (Eq, Ord, NFData, Generic) + deriving newtype (Num, Enum, Real, Integral, Bounded, NoThunks) + deriving Semigroup via (Sum Word16) + deriving Monoid via (Sum Word16) + deriving Show via (Quiet NumIdsReq) + +newtype NumReq = NumReq {getNumReq :: Word16} + deriving (Eq, Ord, NFData, Generic) + deriving newtype (Num, Enum, Real, Integral, Bounded, NoThunks) + deriving Semigroup via (Sum Word16) + deriving Monoid via (Sum Word16) + deriving Show via (Quiet NumReq) + +newtype NumUnacknowledged = NumUnacknowledged {getNumUnacknowledged :: Word16} + deriving (Eq, Ord, NFData, Generic) + deriving newtype (Num, Enum, Real, Integral, Bounded, NoThunks) + deriving Semigroup via (Sum Word16) + deriving Monoid via (Sum Word16) + deriving Show via (Quiet NumUnacknowledged) + + +-- | There are some constraints of the protocol that are not captured in the +-- types of the messages, but are documented with the messages. Violation +-- of these constraints is also a protocol error. The constraints are intended +-- to ensure that implementations are able to work in bounded space. +instance Protocol (SigSubmissionV2 sigId sig) where + -- | The messages in the object diffusion protocol. + -- + -- In this protocol the consumer (inbound side, client role) always + -- initiates and the producer (outbound side, server role) replies. + -- This makes it a pull based protocol where the receiver manages the + -- control flow. + -- + -- The protocol involves asking for object identifiers, and then + -- asking for objects corresponding to the identifiers of interest. + -- + -- There are two ways to ask for object identifiers, blocking and + -- non-blocking. They otherwise have the same semantics. + -- + -- The protocol maintains a notional FIFO of "outstanding" object + -- identifiers that have been provided but not yet acknowledged. Only + -- objects that are outstanding can be requested: they can be + -- requested in any order, but at most once. Object identifiers are + -- acknowledged in the same FIFO order they were provided in. The + -- acknowledgement is included in the same messages used to ask for more + -- object identifiers. + data Message (SigSubmissionV2 sigId sig) from to where + + -- | Request a list of identifiers from the server, and confirm a + -- number of outstanding identifiers. + -- + -- With 'TokBlocking' this is a blocking operation but it's not guaranteed + -- taht the server will respond with signatures. The server might block for + -- only a limited time waiting for signaures, if it times out it will reply + -- with `MsgReplyNoSigs` to let the client regain control of the protocol. + -- + -- With 'TokNonBlocking' this is a non-blocking operation: the response may + -- be an empty list and this does expect a prompt response. This covers high + -- throughput use cases where we wish to pipeline, by interleaving requests + -- for additional identifiers with requests for signatures, which + -- requires these requests not block. + -- + -- The request gives the maximum number of identifiers that can be + -- accepted in the response. This must be greater than zero in the + -- 'TokBlocking' case. In the 'TokNonBlocking' case either the numbers + -- acknowledged or the number requested __MUST__ be non-zero. In either + -- case, the number requested __MUST__ not put the total outstanding over + -- the fixed protocol limit. + -- + -- The request also gives the number of outstanding identifiers that + -- can now be acknowledged. The actual signatures to acknowledge are known + -- to the server based on the FIFO order in which they were provided. + -- + -- There is no choice about when to use the blocking case versus the + -- non-blocking case, it depends on whether there are any remaining + -- unacknowledged signatures (after taking into account the ones + -- acknowledged in this message): + -- + -- * The blocking case __MUST__ be used when there are zero remaining + -- unacknowledged signatures. + -- + -- * The non-blocking case __MUST__ be used when there are non-zero + -- remaining unacknowledged signatures. + + MsgRequestSigIds + :: forall (blocking :: StBlockingStyle) sigId sig. + SingBlockingStyle blocking + -> NumIdsAck -- ^ Acknowledge this number of outstanding signatures + -> NumIdsReq -- ^ Request up to this number of identifiers + -> Message (SigSubmissionV2 sigId sig) StIdle (StSigIds blocking) + -- | Reply with a list of object identifiers for available objects, along + -- with the size of each object. + -- + -- The list must not be longer than the maximum number requested. + -- + -- In the 'StSigIds' 'Blocking' state the list must be non-empty while in + -- the 'StSigIds' 'NonBlocking' state the list may be empty. + -- + -- These objects are added to the notional FIFO of outstanding object + -- identifiers for the protocol. + -- + -- The order in which these object identifiers are returned must be the + -- order in which they are submitted to the mempool, to preserve dependent + -- objects. + + MsgReplySigIds + :: BlockingReplyList blocking sigId + -> Message (SigSubmissionV2 sigId sig) (StSigIds blocking) StIdle + + -- | The blocking request `MsgRequestSigIds` can be replied with no + -- signatures to let the client regain the control of the protocol. + -- + MsgReplyNoSigIds + :: Message (SigSubmissionV2 sidId sig) (StSigIds StBlocking) StIdle + + -- | Request one or more objects corresponding to the given identifiers. + -- + -- While it is the responsibility of the server to keep within + -- pipelining in-flight limits, the client must also cooperate by keeping + -- the total requested across all in-flight requests within the limits. + -- + -- It is an error to ask for identifiers that were not + -- previously announced (via 'MsgReplySigIds'). + -- + -- It is an error to ask for identifiers that are not + -- outstanding or that were already asked for. + MsgRequestSigs + :: [sigId] + -> Message (SigSubmissionV2 sigId sig) StIdle StSigs + + -- | Reply with the requested signatures, or implicitly discard. + -- + -- Signatures can become invalid between the time the identifier was + -- sent and the signatures being requested. Invalid (including committed) + -- signatures do not need to be sent. + -- + -- Any identifiers requested but not provided in this reply + -- should be considered as if this peer had never announced them. (Note + -- that this is no guarantee that the signature is invalid, it may still be + -- valid and available from another peer). + + MsgReplySigs + :: [sig] + -> Message (SigSubmissionV2 sigId sig) StSigs StIdle + + -- | Termination message, initiated by the client side when idle. + MsgDone + :: Message (SigSubmissionV2 sigId sig) StIdle StDone + + type StateAgency StIdle = ClientAgency + type StateAgency (StSigIds b) = ServerAgency + type StateAgency StSigs = ServerAgency + type StateAgency StDone = NobodyAgency + + type StateToken = SingSigSubmissionV2 + +instance ( NFData sigId + , NFData sig + ) + => NFData (Message (SigSubmissionV2 sigId sig) from to) where + rnf (MsgRequestSigIds tkbs w1 w2) = rnf tkbs `seq` rnf w1 `seq` rnf w2 + rnf (MsgReplySigIds brl) = rnf brl + rnf MsgReplyNoSigIds = () + rnf (MsgRequestSigs sigIds) = rnf sigIds + rnf (MsgReplySigs sigs) = rnf sigs + rnf MsgDone = () + +deriving instance (Eq sigId, Eq sig) + => Eq (Message (SigSubmissionV2 sigId sig) from to) + +deriving instance (Show sigId, Show sig) + => Show (Message (SigSubmissionV2 sigId sig) from to) diff --git a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Codec/CDDL.hs b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Codec/CDDL.hs new file mode 100644 index 0000000..b995cd4 --- /dev/null +++ b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Codec/CDDL.hs @@ -0,0 +1,21 @@ +module DMQ.Protocol.SigSubmissionV2.Codec.CDDL where + +import Codec.CBOR.Read qualified as CBOR +import Codec.Serialise.Class qualified as Serialise +import Data.ByteString.Lazy qualified as BL + +import Network.TypedProtocol.Codec + +import DMQ.Protocol.SigSubmissionV2.Codec +import DMQ.Protocol.SigSubmissionV2.Test (Sig, SigId) +import DMQ.Protocol.SigSubmissionV2.Type hiding (Sig, SigId) + + +sigSubmissionV2Codec :: Codec (SigSubmissionV2 SigId Sig) + CBOR.DeserialiseFailure IO BL.ByteString +sigSubmissionV2Codec = + codecSigSubmissionV2 + Serialise.encode + Serialise.decode + Serialise.encode + Serialise.decode diff --git a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs new file mode 100644 index 0000000..ffa0be6 --- /dev/null +++ b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DMQ.Protocol.SigSubmissionV2.Direct (directPipelined) where + +import Data.List.NonEmpty qualified as NonEmpty + +import Network.TypedProtocol.Core +import Network.TypedProtocol.Proofs (Queue (..), enqueue) + +import DMQ.Protocol.SigSubmissionV2.Inbound +import DMQ.Protocol.SigSubmissionV2.Outbound +import DMQ.Protocol.SigSubmissionV2.Type (BlockingReplyList (..), + SingBlockingStyle (..)) + + +directPipelined + :: forall sigId sig m a. + Monad m + => SigSubmissionOutbound sigId sig m a + -> SigSubmissionInboundPipelined sigId sig m a + -> m a +directPipelined (SigSubmissionOutbound mOutbound) + (SigSubmissionInboundPipelined inbound) = do + outbound <- mOutbound + directSender EmptyQ inbound outbound + where + directSender :: forall (n :: N). + Queue n (Collect sigId sig) + -> InboundStIdle n sigId sig m a + -> OutboundStIdle sigId sig m a + -> m a + directSender q (SendMsgRequestSigIdsBlocking ackNo reqNo inboundNext) + OutboundStIdle{recvMsgRequestSigIds} = do + reply <- recvMsgRequestSigIds SingBlocking ackNo reqNo + case reply of + SendMsgReplySigIds (BlockingReply sigIds) outbound' -> do + inbound' <- inboundNext (NonEmpty.toList sigIds) + directSender q inbound' outbound' + + SendMsgReplyNoSigIds outbound' -> do + inbound' <- inboundNext [] + directSender q inbound' outbound' + + directSender q (SendMsgRequestSigIdsPipelined ackNo reqNo inboundNext) + OutboundStIdle{recvMsgRequestSigIds} = do + reply <- recvMsgRequestSigIds SingNonBlocking ackNo reqNo + case reply of + SendMsgReplySigIds (NonBlockingReply sigIds) outbound' -> do + inbound' <- inboundNext + directSender (enqueue (CollectSigIds reqNo sigIds) q) inbound' outbound' + + directSender q (SendMsgRequestSigsPipelined sigIds inboundNext) + OutboundStIdle{recvMsgRequestSigs} = do + SendMsgReplySigs sigs outbound' <- recvMsgRequestSigs sigIds + inbound' <- inboundNext + directSender (enqueue (CollectSigs sigIds sigs) q) inbound' outbound' + + directSender q (CollectPipelined (Just noWaitInbound') _inboundNext) outbound = do + directSender q noWaitInbound' outbound + + directSender (ConsQ c q) (CollectPipelined _maybeNoWaitInbound' inboundNext) outbound = do + inbound' <- inboundNext c + directSender q inbound' outbound + + directSender EmptyQ (SendMsgDone v) _outbound = v diff --git a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs new file mode 100644 index 0000000..73138ea --- /dev/null +++ b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module DMQ.Protocol.SigSubmissionV2.Test + ( tests + , SigId (..) + , Sig (..) + ) where + +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.ST (runST) +import Codec.CBOR.FlatTerm qualified as CBOR +import Data.ByteString.Lazy (ByteString) +import Data.List.NonEmpty qualified as NonEmpty +import GHC.Generics + +import Codec.Serialise (DeserialiseFailure, Serialise) +import Codec.Serialise qualified as Serialise (decode, encode) + +import Network.TypedProtocol.Codec +import Network.TypedProtocol.Codec.Properties (prop_codecM, prop_codec_splitsM) + +import Ouroboros.Network.Util.ShowProxy + +import DMQ.Protocol.SigSubmissionV2.Codec +import DMQ.Protocol.SigSubmissionV2.Type hiding (Sig, SigId) + +import Test.Data.CDDL (Any (..)) +import Test.Ouroboros.Network.Protocol.Utils (prop_codec_cborM, + prop_codec_valid_cbor_encoding, splits2, splits3) +import Test.Ouroboros.Network.Utils (renderRanges) + +import Test.QuickCheck as QC +import Test.QuickCheck.Instances.ByteString () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +-- +-- Test cases +-- + + +tests :: TestTree +tests = + testGroup "DMQ.Protocol" + [ testGroup "SigSubmissionV2" + [ testProperty "codec" prop_codec + , testProperty "encoding" prop_encoding + , testProperty "codec id" prop_codec_id + , testProperty "codec 2-splits" $ withMaxSize 50 + prop_codec_splits2 + , testProperty "codec 3-splits" $ withMaxSize 10 + prop_codec_splits3 + , testProperty "codec cbor" prop_codec_cbor + , testProperty "codec valid cbor" prop_codec_valid_cbor + ] + ] + +-- +-- Common types & clients and servers used in the tests in this module. +-- + +newtype Sig = Sig SigId + deriving (Eq, Show, Arbitrary, Serialise, Generic) + +instance ShowProxy Sig where + showProxy _ = "Sig" + +-- | We use any `CBOR.Term`. This allows us to use `any` in cddl specs. +-- +newtype SigId = SigId Any + deriving (Eq, Ord, Show, Arbitrary, Serialise, Generic) + +instance ShowProxy SigId where + showProxy _ = "SigId" + +deriving newtype instance Arbitrary NumIdsAck +deriving newtype instance Arbitrary NumIdsReq + +instance Arbitrary (AnyMessage (SigSubmissionV2 SigId Sig)) where + arbitrary = oneof + [ AnyMessage + <$> ( MsgRequestSigIds SingBlocking + <$> arbitrary + <*> arbitrary + ) + + , AnyMessage + <$> ( MsgRequestSigIds SingNonBlocking + <$> arbitrary + <*> arbitrary + ) + + , AnyMessage + <$> MsgReplySigIds + <$> ( BlockingReply + . NonEmpty.fromList + . QC.getNonEmpty + ) + <$> arbitrary + + , AnyMessage + <$> MsgReplySigIds + <$> NonBlockingReply + <$> arbitrary + + , AnyMessage + <$> pure MsgReplyNoSigIds + + , AnyMessage + <$> MsgRequestSigs + <$> arbitrary + + , AnyMessage + <$> MsgReplySigs + <$> arbitrary + + , AnyMessage + <$> pure MsgDone + ] + +instance (Eq sigId + , Eq sig + ) + => Eq (AnyMessage (SigSubmissionV2 sigId sig)) where + + (==) (AnyMessage (MsgRequestSigIds SingBlocking ackNo reqNo)) + (AnyMessage (MsgRequestSigIds SingBlocking ackNo' reqNo')) = + (ackNo, reqNo) == (ackNo', reqNo') + + (==) (AnyMessage (MsgRequestSigIds SingNonBlocking ackNo reqNo)) + (AnyMessage (MsgRequestSigIds SingNonBlocking ackNo' reqNo')) = + (ackNo, reqNo) == (ackNo', reqNo') + + (==) (AnyMessage (MsgReplySigIds (BlockingReply sigIds))) + (AnyMessage (MsgReplySigIds (BlockingReply sigIds'))) = + sigIds == sigIds' + + (==) (AnyMessage (MsgReplySigIds (NonBlockingReply sigIds))) + (AnyMessage (MsgReplySigIds (NonBlockingReply sigIds'))) = + sigIds == sigIds' + + (==) (AnyMessage MsgReplyNoSigIds) + (AnyMessage MsgReplyNoSigIds) = True + + (==) (AnyMessage (MsgRequestSigs sigIds)) + (AnyMessage (MsgRequestSigs sigIds')) = sigIds == sigIds' + + (==) (AnyMessage (MsgReplySigs txs)) + (AnyMessage (MsgReplySigs txs')) = txs == txs' + + (==) (AnyMessage MsgDone) + (AnyMessage MsgDone) = True + + (==) _ _ = False + + +codec :: MonadST m + => Codec + (SigSubmissionV2 SigId Sig) + DeserialiseFailure + m ByteString +codec = codecSigSubmissionV2 + Serialise.encode Serialise.decode + Serialise.encode Serialise.decode + + +-- | Check the codec round trip property. +-- +prop_codec + :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_codec msg = + runST (prop_codecM codec msg) + + +prop_encoding :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_encoding msg@(AnyMessage msg') = + let enc = encodeSigSubmissionV2 Serialise.encode Serialise.encode msg' + terms = CBOR.toFlatTerm enc + in counterexample (show msg) + . counterexample ("terms: " ++ show terms) + $ CBOR.validFlatTerm terms + + +-- | Check the codec round trip property for the id codec. +-- +prop_codec_id + :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_codec_id msg = + runST (prop_codecM codecSigSubmissionV2Id msg) + +-- | Check for data chunk boundary problems in the codec using 2 chunks. +-- +prop_codec_splits2 + :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_codec_splits2 msg = + runST (prop_codec_splitsM splits2 codec msg) + +-- | Check for data chunk boundary problems in the codec using 3 chunks. +-- +prop_codec_splits3 + :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_codec_splits3 msg = + labelMsg msg $ + runST (prop_codec_splitsM splits3 codec msg) + +prop_codec_cbor + :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_codec_cbor msg = + runST (prop_codec_cborM codec msg) + +-- | Check that the encoder produces a valid CBOR. +-- +prop_codec_valid_cbor + :: AnyMessage (SigSubmissionV2 SigId Sig) + -> Property +prop_codec_valid_cbor = prop_codec_valid_cbor_encoding codec + + +labelMsg :: AnyMessage (SigSubmissionV2 sigId sig) -> Property -> Property +labelMsg (AnyMessage msg) = + label (case msg of + MsgRequestSigIds {} -> "MsgRequestSigIds" + MsgReplySigIds as -> "MsgReplySigIds " ++ renderRanges 3 (length as) + MsgReplyNoSigIds -> "MsgReplyNoSigIds" + MsgRequestSigs as -> "MsgRequestSigs " ++ renderRanges 3 (length as) + MsgReplySigs as -> "MsgReplySigs " ++ renderRanges 3 (length as) + MsgDone -> "MsgDone" + ) diff --git a/dmq-node/test/Main.hs b/dmq-node/test/Main.hs index 880fa9c..e2813f1 100644 --- a/dmq-node/test/Main.hs +++ b/dmq-node/test/Main.hs @@ -10,6 +10,7 @@ import Test.DMQ.NodeToNode qualified import DMQ.Protocol.LocalMsgNotification.Test qualified import DMQ.Protocol.LocalMsgSubmission.Test qualified import DMQ.Protocol.SigSubmission.Test qualified +import DMQ.Protocol.SigSubmissionV2.Test qualified import Test.Tasty @@ -28,6 +29,7 @@ tests = -- protocols , DMQ.Protocol.SigSubmission.Test.tests + , DMQ.Protocol.SigSubmissionV2.Test.tests , DMQ.Protocol.LocalMsgSubmission.Test.tests , DMQ.Protocol.LocalMsgNotification.Test.tests ] From 0bb272014331d83be63dfd9d3e37e64706c6ce75 Mon Sep 17 00:00:00 2001 From: edgr Date: Wed, 14 Jan 2026 17:37:03 +0800 Subject: [PATCH 04/11] SigSubmission implementation --- dmq-node/dmq-node.cabal | 23 +- dmq-node/src/DMQ/SigSubmission/Inbound.hs | 217 +++++++ .../src/DMQ/SigSubmission/Inbound/Decision.hs | 500 ++++++++++++++++ .../src/DMQ/SigSubmission/Inbound/Policy.hs | 83 +++ .../src/DMQ/SigSubmission/Inbound/Registry.hs | 548 +++++++++++++++++ .../src/DMQ/SigSubmission/Inbound/State.hs | 563 ++++++++++++++++++ .../src/DMQ/SigSubmission/Inbound/Types.hs | 455 ++++++++++++++ dmq-node/src/DMQ/SigSubmission/Outbound.hs | 206 +++++++ 8 files changed, 2589 insertions(+), 6 deletions(-) create mode 100644 dmq-node/src/DMQ/SigSubmission/Inbound.hs create mode 100644 dmq-node/src/DMQ/SigSubmission/Inbound/Decision.hs create mode 100644 dmq-node/src/DMQ/SigSubmission/Inbound/Policy.hs create mode 100644 dmq-node/src/DMQ/SigSubmission/Inbound/Registry.hs create mode 100644 dmq-node/src/DMQ/SigSubmission/Inbound/State.hs create mode 100644 dmq-node/src/DMQ/SigSubmission/Inbound/Types.hs create mode 100644 dmq-node/src/DMQ/SigSubmission/Outbound.hs diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index 6971831..9861294 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -84,9 +84,16 @@ library DMQ.Protocol.SigSubmission.Type DMQ.Protocol.SigSubmission.Validate DMQ.Protocol.SigSubmissionV2.Codec - DMQ.Protocol.SigSubmissionV2.Type DMQ.Protocol.SigSubmissionV2.Inbound DMQ.Protocol.SigSubmissionV2.Outbound + DMQ.Protocol.SigSubmissionV2.Type + DMQ.SigSubmission.Inbound + DMQ.SigSubmission.Inbound.Decision + DMQ.SigSubmission.Inbound.Policy + DMQ.SigSubmission.Inbound.Registry + DMQ.SigSubmission.Inbound.State + DMQ.SigSubmission.Inbound.Types + DMQ.SigSubmission.Outbound DMQ.Tracer build-depends: @@ -105,6 +112,7 @@ library cardano-ledger-core, cardano-ledger-shelley, cardano-slotting, + cardano-strict-containers, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer >=0.1 && <0.3, @@ -177,9 +185,9 @@ test-suite dmq-tests DMQ.Protocol.LocalMsgNotification.Test DMQ.Protocol.LocalMsgSubmission.Test DMQ.Protocol.SigSubmission.Test - DMQ.Protocol.SigSubmissionV2.Test - DMQ.Protocol.SigSubmissionV2.Direct DMQ.Protocol.SigSubmissionV2.Codec.CDDL + DMQ.Protocol.SigSubmissionV2.Direct + DMQ.Protocol.SigSubmissionV2.Test Test.DMQ.NodeToClient Test.DMQ.NodeToNode @@ -228,11 +236,14 @@ test-suite dmq-cddl extensions type: exitcode-stdio-1.0 - hs-source-dirs: cddl, test + hs-source-dirs: + cddl + test + main-is: Main.hs other-modules: - DMQ.Protocol.SigSubmissionV2.Test DMQ.Protocol.SigSubmissionV2.Codec.CDDL + DMQ.Protocol.SigSubmissionV2.Test if flag(cddl) buildable: True @@ -249,7 +260,7 @@ test-suite dmq-cddl directory, dmq-node, filepath, - io-classes:{io-classes}, + io-classes, kes-agent-crypto, mtl, ouroboros-network:{api, protocols-tests-lib, tests-lib}, diff --git a/dmq-node/src/DMQ/SigSubmission/Inbound.hs b/dmq-node/src/DMQ/SigSubmission/Inbound.hs new file mode 100644 index 0000000..06f334a --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Inbound.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DMQ.SigSubmission.Inbound + ( -- * SigSubmision Inbound client + sigSubmissionInboundV2 + -- * Supporting types and APIs + , module Submission + , SigDecisionPolicy (..) + , defaultSigDecisionPolicy + ) where + +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set + +import Control.Exception (assert) +import Control.Monad (unless, when) +import Control.Monad.Class.MonadAsync (MonadAsync (..)) +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI +import Control.Tracer (Tracer, traceWith) +import Network.TypedProtocol + +import Ouroboros.Network.ControlMessage (ControlMessageSTM, + timeoutWithControlMessage) + +import Ouroboros.Network.TxSubmission.Inbound.V2.Types ( + TxSubmissionMempoolWriter (..)) + +import DMQ.Protocol.SigSubmissionV2.Inbound + +import DMQ.SigSubmission.Inbound.Policy +import DMQ.SigSubmission.Inbound.Registry as Submission +import DMQ.SigSubmission.Inbound.State +import DMQ.SigSubmission.Inbound.Types as Submission + +-- | A sig-submission inbound side (client, sic!). +-- +-- The client blocks on receiving `SigDecision` from the decision logic. If +-- there are sig's to download it pipelines two requests: first for sig's second +-- for sigid's. If there are no sig's to download, it either sends a blocking or +-- non-blocking request for sigid's. +-- +sigSubmissionInboundV2 + :: forall sigid sig idx m. + ( MonadDelay m + , MonadThrow m + , MonadAsync m + , Ord sigid + ) + => Tracer m (TraceSigSubmissionInbound sigid sig) + -> SigSubmissionInitDelay + -> TxSubmissionMempoolWriter sigid sig idx m + -> PeerSigAPI m sigid sig + -> ControlMessageSTM m + -> SigSubmissionInboundPipelined sigid sig m () +sigSubmissionInboundV2 + tracer + initDelay + TxSubmissionMempoolWriter { txId } + PeerSigAPI { + readSigDecision, + handleReceivedSigIds, + handleReceivedSigs, + submitSigToMempool + } + controlMessageSTM + = + SigSubmissionInboundPipelined $ do + case initDelay of + SigSubmissionInitDelay delay -> threadDelay delay + NoSigSubmissionInitDelay -> return () + inboundIdle + where + inboundIdle + :: m (InboundStIdle Z sigid sig m ()) + inboundIdle = do + -- TODO + -- readSigDecision is blocking on next decision because takeMVar and ControlMessageSTM is blocking + sigDecision <- async readSigDecision + msigd <- timeoutWithControlMessage controlMessageSTM (waitSTM sigDecision) + case msigd of + Nothing -> pure (SendMsgDone $ return ()) + Just sigd@SigDecision + { sigdSigsToRequest = sigsToRequest + , sigdSigsToMempool = TxsToMempool { listOfTxsToMempool } + } -> do + traceWith tracer (TraceSigInboundDecision sigd) + + let !collected = length listOfTxsToMempool + + -- Only attempt to add sigs if we have some work to do + when (collected > 0) $ do + -- submitTxToMempool traces: + -- * `TraceTxSubmissionProcessed`, + -- * `TraceTxInboundAddedToMempool`, and + -- * `TraceTxInboundRejectedFromMempool` + -- events. + mapM_ (uncurry $ submitSigToMempool tracer) listOfTxsToMempool + + -- TODO: + -- We can update the state so that other `sig-submission` servers will + -- not try to add these sigs to the mempool. + if Map.null sigsToRequest + then serverReqSigIds Zero sigd + else serverReqSigs sigd + + + -- Pipelined request of sigs + serverReqSigs :: SigDecision sigid sig + -> m (InboundStIdle Z sigid sig m ()) + serverReqSigs sigd@SigDecision { sigdSigsToRequest = sigdSigsToRequest } = + pure $ SendMsgRequestSigsPipelined sigdSigsToRequest + (serverReqSigIds (Succ Zero) sigd) + + serverReqSigIds :: forall (n :: N). + Nat n + -> SigDecision sigid sig + -> m (InboundStIdle n sigid sig m ()) + serverReqSigIds + n SigDecision { sigdSigIdsToRequest = 0 } + = + case n of + Zero -> inboundIdle + Succ _ -> handleReplies n + + serverReqSigIds + -- if there are no unacknowledged sigids, the protocol requires sending + -- a blocking `MsgRequestSigIds` request. This is important, as otherwise + -- the client side wouldn't have a chance to terminate the + -- mini-protocol. + Zero SigDecision { sigdSigIdsToAcknowledge = sigIdsToAck, + sigdPipelineSigIds = False, + sigdSigIdsToRequest = sigIdsToReq + } + = + pure $ SendMsgRequestSigIdsBlocking + sigIdsToAck sigIdsToReq + (\sigids -> do + let sigidsSeq = StrictSeq.fromList $ fst <$> sigids + sigidsMap = Map.fromList sigids + unless (StrictSeq.length sigidsSeq <= fromIntegral sigIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedSigIds sigIdsToReq sigidsSeq sigidsMap + inboundIdle + ) + + serverReqSigIds + n@Zero SigDecision { sigdSigIdsToAcknowledge = sigIdsToAck, + sigdPipelineSigIds = True, + sigdSigIdsToRequest = sigIdsToReq + } + = + pure $ SendMsgRequestSigIdsPipelined + sigIdsToAck sigIdsToReq + (handleReplies (Succ n)) + + serverReqSigIds + n@Succ{} SigDecision { sigdSigIdsToAcknowledge = sigIdsToAck, + sigdPipelineSigIds, + sigdSigIdsToRequest = sigIdsToReq + } + = + -- it is impossible that we have had `sig`'s to request (Succ{} - is an + -- evidence for that), but no unacknowledged `sigid`s. + assert sigdPipelineSigIds $ + pure $ SendMsgRequestSigIdsPipelined + sigIdsToAck sigIdsToReq + (handleReplies (Succ n)) + + + handleReplies :: forall (n :: N). + Nat (S n) + -> m (InboundStIdle (S n) sigid sig m ()) + handleReplies (Succ n'@Succ{}) = + pure $ CollectPipelined + Nothing + (handleReply (handleReplies n')) + + handleReplies (Succ Zero) = + pure $ CollectPipelined + Nothing + (handleReply inboundIdle) + + handleReply :: forall (n :: N). + m (InboundStIdle n sigid sig m ()) + -- continuation + -> Collect sigid sig + -> m (InboundStIdle n sigid sig m ()) + handleReply k = \case + CollectSigIds sigIdsToReq sigids -> do + let sigidsSeq = StrictSeq.fromList $ fst <$> sigids + sigidsMap = Map.fromList sigids + unless (StrictSeq.length sigidsSeq <= fromIntegral sigIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedSigIds sigIdsToReq sigidsSeq sigidsMap + k + CollectSigs sigids sigs -> do + let requested = Map.keysSet sigids + received = Map.fromList [ (txId sig, sig) | sig <- sigs ] + + unless (Map.keysSet received `Set.isSubsetOf` requested) $ + throwIO ProtocolErrorTxNotRequested + + mbe <- handleReceivedSigs sigids received + traceWith tracer $ TraceSigSubmissionCollected (txId `map` sigs) + case mbe of + -- one of `sig`s had a wrong size + Just e -> traceWith tracer (TraceSigInboundError e) + >> throwIO e + Nothing -> k diff --git a/dmq-node/src/DMQ/SigSubmission/Inbound/Decision.hs b/dmq-node/src/DMQ/SigSubmission/Inbound/Decision.hs new file mode 100644 index 0000000..1b3c398 --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Inbound/Decision.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module DMQ.SigSubmission.Inbound.Decision + ( SigDecision (..) + , emptySigDecision + -- * Internal API exposed for testing + , makeDecisions + , filterActivePeers + , pickSigsToDownload + ) where + +import Control.Arrow ((>>>)) +import Control.Exception (assert) + +import Data.Bifunctor (second) +import Data.Hashable +import Data.List qualified as List +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import System.Random (random) + +import Data.Sequence.Strict qualified as StrictSeq +import Ouroboros.Network.Protocol.TxSubmission2.Type + +import DMQ.SigSubmission.Inbound.Policy +import DMQ.SigSubmission.Inbound.State +import DMQ.SigSubmission.Inbound.Types + + +-- | Make download decisions. +-- +makeDecisions + :: forall peeraddr sigid sig. + ( Ord peeraddr + , Ord sigid + , Hashable peeraddr + ) + => SigDecisionPolicy + -- ^ decision policy + -> SharedSigState peeraddr sigid sig + -- ^ decision context + -> Map peeraddr (PeerSigState sigid sig) + -- ^ list of available peers. + -- + -- This is a subset of `peerSigStates` of peers which either: + -- * can be used to download a `sig`, + -- * can acknowledge some `sigid`s. + -- + -> ( SharedSigState peeraddr sigid sig + , Map peeraddr (SigDecision sigid sig) + ) +makeDecisions policy st = + let (salt, rng') = random (peerRng st) + st' = st { peerRng = rng' } + in fn + . pickSigsToDownload policy st' + . orderByRejections salt + where + fn :: forall a. + (a, [(peeraddr, SigDecision sigid sig)]) + -> (a, Map peeraddr (SigDecision sigid sig)) + fn (a, as) = (a, Map.fromList as) + + +-- | Order peers by how useful the sigs they have provided are. +-- +-- sigs delivered late will fail to apply because they were included in +-- a recently adopted block. Peers can race against each other by setting +-- `sigInflightMultiplicity` to > 1. In case of a tie a hash of the peeraddr +-- is used as a tie breaker. Since every invocation use a new salt a given +-- peeraddr does not have an advantage over time. +-- +orderByRejections :: Hashable peeraddr + => Int + -> Map peeraddr (PeerSigState sigid sig) + -> [(peeraddr, PeerSigState sigid sig)] +orderByRejections salt = + List.sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) + . Map.toList + + +-- | Internal state of `pickSigsToDownload` computation. +-- +data St peeraddr sigid sig = + St { stInflightSize :: !SizeInBytes, + -- ^ size of all `sig`s in-flight. + + stInflight :: !(Map sigid Int), + -- ^ `sigid`s in-flight. + + stAcknowledged :: !(Map sigid Int), + -- ^ acknowledged `sigid` with multiplicities. It is used to update + -- `referenceCounts`. + + stInSubmissionToMempoolTxs :: !(Set sigid) + -- ^ sigs on their way to the mempool. Used to prevent issueing new + -- fetch requests for them. + } + + +-- | Distribute `sig`'s to download among available peers. Peers are considered +-- in the given order. +-- +-- * pick sigs from the set of available sig's (in `sigid` order, note these sets +-- might be different for different peers). +-- * pick sigs until the peers in-flight limit (we can go over the limit by one sig) +-- (`sigsSizeInflightPerPeer` limit) +-- * pick sigs until the overall in-flight limit (we can go over the limit by one sig) +-- (`maxSigsSizeInflight` limit) +-- * each sig can be downloaded simultaneously from at most +-- `sigInflightMultiplicity` peers. +-- +pickSigsToDownload + :: forall peeraddr sigid sig. + ( Ord peeraddr + , Ord sigid + ) + => SigDecisionPolicy + -- ^ decision policy + -> SharedSigState peeraddr sigid sig + -- ^ shared state + + -> [(peeraddr, PeerSigState sigid sig)] + -> ( SharedSigState peeraddr sigid sig + , [(peeraddr, SigDecision sigid sig)] + ) + +pickSigsToDownload policy@SigDecisionPolicy { sigsSizeInflightPerPeer, + maxSigsSizeInflight, + sigInflightMultiplicity } + sharedState@SharedSigState { peerSigStates, + inflightSigs, + inflightSigsSize, + bufferedSigs, + inSubmissionToMempoolSigs, + referenceCounts } = + -- outer fold: fold `[(peeraddr, PeerSigState sigid sig)]` + List.mapAccumR + accumFn + -- initial state + St { stInflight = inflightSigs, + stInflightSize = inflightSigsSize, + stAcknowledged = Map.empty, + stInSubmissionToMempoolTxs = Map.keysSet inSubmissionToMempoolSigs } + + >>> + gn + where + accumFn :: St peeraddr sigid sig + -> (peeraddr, PeerSigState sigid sig) + -> ( St peeraddr sigid sig + , ( (peeraddr, PeerSigState sigid sig) + , SigDecision sigid sig + ) + ) + accumFn + st@St { stInflight, + stInflightSize, + stAcknowledged, + stInSubmissionToMempoolTxs } + ( peeraddr + , peerSigState@PeerSigState { availableSigIds, + unknownSigs, + requestedSigsInflight, + requestedSigsInflightSize + } + ) + = + let sizeInflightAll :: SizeInBytes + sizeInflightOther :: SizeInBytes + + sizeInflightAll = stInflightSize + sizeInflightOther = sizeInflightAll - requestedSigsInflightSize + + in if sizeInflightAll >= maxSigsSizeInflight + then let ( numIdsAck + , numIdsReq + , txsToMempool@TxsToMempool { listOfTxsToMempool } + , RefCountDiff { txIdsToAck } + , peerSigState' + ) = acknowledgeSigIds policy sharedState peerSigState + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + stInSubmissionToMempoolTxs' = stInSubmissionToMempoolTxs + <> Set.fromList (map fst listOfTxsToMempool) + in + if requestedSigIdsInflight peerSigState' > 0 + then + -- we have sigids to request + ( st { stAcknowledged = stAcknowledged' + , stInSubmissionToMempoolTxs = stInSubmissionToMempoolTxs' } + , ( (peeraddr, peerSigState') + , SigDecision { sigdSigIdsToAcknowledge = numIdsAck, + sigdSigIdsToRequest = numIdsReq, + sigdPipelineSigIds = not + . StrictSeq.null + . unacknowledgedSigIds + $ peerSigState', + sigdSigsToRequest = Map.empty, + sigdSigsToMempool = txsToMempool + } + ) + ) + else + -- there are no `sigid`s to request, nor we can request `sig`s due + -- to in-flight size limits + ( st + , ( (peeraddr, peerSigState') + , emptySigDecision + ) + ) + else + let requestedSigsInflightSize' :: SizeInBytes + sigsToRequestMap :: Map sigid SizeInBytes + + (requestedSigsInflightSize', sigsToRequestMap) = + -- inner fold: fold available `sigid`s + -- + -- Note: although `Map.foldrWithKey` could be used here, it + -- does not allow to short circuit the fold, unlike + -- `foldWithState`. + foldWithState + (\(sigid, (sigSize, inflightMultiplicity)) sizeInflight -> + if -- note that we pick `sigid`'s as long the `s` is + -- smaller or equal to `sigsSizeInflightPerPeer`. + sizeInflight <= sigsSizeInflightPerPeer + -- overall `sig`'s in-flight must be smaller than + -- `maxSigsSizeInflight` + && sizeInflight + sizeInflightOther <= maxSigsSizeInflight + -- the signature must not be downloaded from more + -- than `sigInflightMultiplicity` peers simultaneously + && inflightMultiplicity < sigInflightMultiplicity + -- TODO: we must validate that `sigSize` is smaller than + -- maximum sigs size + then Just (sizeInflight + sigSize, (sigid, sigSize)) + else Nothing + ) + (Map.assocs $ + -- merge `availableSigIds` with `stInflight`, so we don't + -- need to lookup into `stInflight` on every `sigid` which + -- is in `availableSigIds`. + Map.merge (Map.mapMaybeMissing \_sigid -> Just . (,0)) + Map.dropMissing + (Map.zipWithMatched \_sigid -> (,)) + + availableSigIds + stInflight + -- remove `sig`s which were already downloaded by some + -- other peer or are in-flight or unknown by this peer. + `Map.withoutKeys` ( + Map.keysSet bufferedSigs + <> requestedSigsInflight + <> unknownSigs + <> stInSubmissionToMempoolTxs + ) + ) + requestedSigsInflightSize + -- pick from `sigid`'s which are available from that given + -- peer. Since we are folding a dictionary each `sigid` + -- will be selected only once from a given peer (at least + -- in each round). + + sigsToRequest = Map.keysSet sigsToRequestMap + peerSigState' = peerSigState { + requestedSigsInflightSize = requestedSigsInflightSize', + requestedSigsInflight = requestedSigsInflight + <> sigsToRequest + } + + ( numIdsAck + , numIdsReq + , txsToMempool@TxsToMempool { listOfTxsToMempool } + , RefCountDiff { txIdsToAck } + , peerSigState'' + ) = acknowledgeSigIds policy sharedState peerSigState' + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + + stInflightDelta :: Map sigid Int + stInflightDelta = Map.fromSet (\_ -> 1) sigsToRequest + -- note: this is right since every `sigid` + -- could be picked at most once + + stInflight' :: Map sigid Int + stInflight' = Map.unionWith (+) stInflightDelta stInflight + + stInSubmissionToMempoolTxs' = stInSubmissionToMempoolTxs + <> Set.fromList (map fst listOfTxsToMempool) + in + if requestedSigIdsInflight peerSigState'' > 0 + then + -- we can request `sigid`s & `sig`s + ( St { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedSigsInflightSize', + stAcknowledged = stAcknowledged', + stInSubmissionToMempoolTxs = stInSubmissionToMempoolTxs' } + , ( (peeraddr, peerSigState'') + , SigDecision { sigdSigIdsToAcknowledge = numIdsAck, + sigdPipelineSigIds = not + . StrictSeq.null + . unacknowledgedSigIds + $ peerSigState'', + sigdSigIdsToRequest = numIdsReq, + sigdSigsToRequest = sigsToRequestMap, + sigdSigsToMempool = txsToMempool + } + ) + ) + else + -- there are no `sigid`s to request, only `sig`s. + ( st { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedSigsInflightSize', + stInSubmissionToMempoolTxs = stInSubmissionToMempoolTxs' + } + , ( (peeraddr, peerSigState'') + , emptySigDecision { sigdSigsToRequest = sigsToRequestMap } + ) + ) + + gn :: ( St peeraddr sigid sig + , [((peeraddr, PeerSigState sigid sig), SigDecision sigid sig)] + ) + -> ( SharedSigState peeraddr sigid sig + , [(peeraddr, SigDecision sigid sig)] + ) + gn + ( St { stInflight, + stInflightSize, + stAcknowledged } + , as + ) + = + let peerSigStates' = Map.fromList ((\(a,_) -> a) <$> as) + <> peerSigStates + + referenceCounts' = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> if x > y then Just $! x - y + else Nothing) + referenceCounts + stAcknowledged + + liveSet = Map.keysSet referenceCounts' + + bufferedSigs' = bufferedSigs + `Map.restrictKeys` + liveSet + + inSubmissionToMempoolSigs' = + List.foldl' updateInSubmissionToMempoolSigs inSubmissionToMempoolSigs as + + in ( sharedState { + peerSigStates = peerSigStates', + inflightSigs = stInflight, + inflightSigsSize = stInflightSize, + bufferedSigs = bufferedSigs', + referenceCounts = referenceCounts', + inSubmissionToMempoolSigs = inSubmissionToMempoolSigs'} + , -- exclude empty results + mapMaybe (\((a, _), b) -> case b of + SigDecision { sigdSigIdsToAcknowledge = 0, + sigdSigIdsToRequest = 0, + sigdSigsToRequest, + sigdSigsToMempool = TxsToMempool { listOfTxsToMempool } } + | null sigdSigsToRequest + , null listOfTxsToMempool + -> Nothing + _ -> Just (a, b) + ) + as + ) + + where + updateInSubmissionToMempoolSigs + :: forall a. + Map sigid Int + -> (a, SigDecision sigid sig) + -> Map sigid Int + updateInSubmissionToMempoolSigs m (_,SigDecision { sigdSigsToMempool } ) = + List.foldl' fn m (listOfTxsToMempool sigdSigsToMempool) + where + fn :: Map sigid Int + -> (sigid,sig) + -> Map sigid Int + fn x (sigid,_) = Map.alter (\case Nothing -> Just 1 + Just n -> Just $! succ n) sigid x + + +-- | Filter peers which can either download a `sig` or acknowledge `sigid`s. +-- +filterActivePeers + :: forall peeraddr sigid sig. + Ord sigid + => SigDecisionPolicy + -> SharedSigState peeraddr sigid sig + -> Map peeraddr (PeerSigState sigid sig) +filterActivePeers + policy@SigDecisionPolicy { + maxUnacknowledgedSigIds, + sigsSizeInflightPerPeer, + maxSigsSizeInflight, + sigInflightMultiplicity + } + sharedSigState@SharedSigState { + peerSigStates, + bufferedSigs, + inflightSigs, + inflightSigsSize, + inSubmissionToMempoolSigs + } + | inflightSigsSize > maxSigsSizeInflight + -- we might be able to request sigids, we cannot download sigs + = Map.filter fn peerSigStates + | otherwise + -- we might be able to request sigids or sigs. + = Map.filter gn peerSigStates + where + unrequestable = Map.keysSet (Map.filter (>= sigInflightMultiplicity) inflightSigs) + <> Map.keysSet bufferedSigs + + fn :: PeerSigState sigid sig -> Bool + fn peerSigState@PeerSigState { + requestedSigIdsInflight + } = + requestedSigIdsInflight == 0 + -- if a peer has sigids in-flight, we cannot request more sigids or sigs. + && requestedSigIdsInflight + numOfUnacked <= maxUnacknowledgedSigIds + && sigIdsToRequest > 0 + where + -- Split `unacknowledgedSigIds'` into the longest prefix of `sigid`s which + -- can be acknowledged and the unacknowledged `sigid`s. + (sigIdsToRequest, _, unackedSigIds) = splitAcknowledgedSigIds policy sharedSigState peerSigState + numOfUnacked = fromIntegral (StrictSeq.length unackedSigIds) + + gn :: PeerSigState sigid sig -> Bool + gn peerSigState@PeerSigState { unacknowledgedSigIds, + requestedSigIdsInflight, + requestedSigsInflight, + requestedSigsInflightSize, + availableSigIds, + unknownSigs + } = + ( requestedSigIdsInflight == 0 + && requestedSigIdsInflight + numOfUnacked <= maxUnacknowledgedSigIds + && sigIdsToRequest > 0 + ) + || (underSizeLimit && not (Map.null downloadable)) + where + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedSigIds) + underSizeLimit = requestedSigsInflightSize <= sigsSizeInflightPerPeer + downloadable = availableSigIds + `Map.withoutKeys` requestedSigsInflight + `Map.withoutKeys` unknownSigs + `Map.withoutKeys` unrequestable + `Map.withoutKeys` Map.keysSet inSubmissionToMempoolSigs + + -- Split `unacknowledgedTxIds'` into the longest prefix of `sigid`s which + -- can be acknowledged and the unacknowledged `sigid`s. + (sigIdsToRequest, _, _) = splitAcknowledgedSigIds policy sharedSigState peerSigState + +-- +-- Auxiliary functions +-- + +-- | A fold with state implemented as a `foldr` to take advantage of fold-build +-- fusion optimisation. +-- +foldWithState + :: forall s a b c. + Ord b + => (a -> s -> Maybe (s, (b, c))) + -> [a] -> s -> (s, Map b c) +{-# INLINE foldWithState #-} + +foldWithState f = foldr cons nil + where + cons :: a + -> (s -> (s, Map b c)) + -> (s -> (s, Map b c)) + cons a k = \ !s -> + case f a s of + Nothing -> nil s + Just (!s', (!b, !c)) -> + case Map.insert b c `second` k s' of + r@(!_s, !_bs) -> r + + nil :: s -> (s, Map b c) + nil = \ !s -> (s, Map.empty) diff --git a/dmq-node/src/DMQ/SigSubmission/Inbound/Policy.hs b/dmq-node/src/DMQ/SigSubmission/Inbound/Policy.hs new file mode 100644 index 0000000..6be74f5 --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Inbound/Policy.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE NumericUnderscores #-} + +module DMQ.SigSubmission.Inbound.Policy + ( SigDecisionPolicy (..) + , defaultSigDecisionPolicy + , max_SIG_SIZE + -- * Re-exports + , NumIdsReq (..) + ) where + +import Control.DeepSeq +import Control.Monad.Class.MonadTime.SI +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) + +import DMQ.Protocol.SigSubmissionV2.Type (NumIdsReq) + + +-- | Maximal sig size. +-- +-- Affects: +-- +-- * `SigDecisionPolicy` +-- * `maximumIngressQueue` for `sig-submission` mini-protocol, see +-- `DMQ.NodeToNode.sigSubmissionProtocolLimits` +-- +max_SIG_SIZE :: SizeInBytes +max_SIG_SIZE = 65_540 + + +-- | Policy for making decisions +-- +data SigDecisionPolicy = SigDecisionPolicy { + maxNumSigIdsToRequest :: !NumIdsReq, + -- ^ a maximal number of sigids requested at once. + + maxUnacknowledgedSigIds :: !NumIdsReq, + -- ^ maximal number of unacknowledgedSigIds. Measured in `NumIdsReq` + -- since we enforce this policy by requesting not more sigids than what + -- this limit allows. + + -- + -- Configuration of sig decision logic. + -- + + sigsSizeInflightPerPeer :: !SizeInBytes, + -- ^ a limit of sig size in-flight from a single peer. + -- It can be exceed by max sig size. + + maxSigsSizeInflight :: !SizeInBytes, + -- ^ a limit of sig size in-flight from all peers. + -- It can be exceed by max sig size. + + sigInflightMultiplicity :: !Int, + -- ^ from how many peers download the `sigid` simultaneously + + bufferedSigsMinLifetime :: !DiffTime, + -- ^ how long sigs that have been added to the mempool will be + -- kept in the `bufferedSigs` cache. + + scoreRate :: !Double, + -- ^ rate at which "rejected" sigs drain. Unit: sig/seconds. + + scoreMax :: !Double + -- ^ Maximum number of "rejections". Unit: seconds + + } + deriving Show + +instance NFData SigDecisionPolicy where + rnf SigDecisionPolicy{} = () + +defaultSigDecisionPolicy :: SigDecisionPolicy +defaultSigDecisionPolicy = + SigDecisionPolicy { + maxNumSigIdsToRequest = 3, + maxUnacknowledgedSigIds = 10, -- must be the same as sigSubmissionMaxUnacked + sigsSizeInflightPerPeer = max_SIG_SIZE * 6, + maxSigsSizeInflight = max_SIG_SIZE * 20, + sigInflightMultiplicity = 2, + bufferedSigsMinLifetime = 2, + scoreRate = 0.1, + scoreMax = 15 * 60 + } diff --git a/dmq-node/src/DMQ/SigSubmission/Inbound/Registry.hs b/dmq-node/src/DMQ/SigSubmission/Inbound/Registry.hs new file mode 100644 index 0000000..bf16ce0 --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Inbound/Registry.hs @@ -0,0 +1,548 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DMQ.SigSubmission.Inbound.Registry + ( SigChannels (..) + , SigChannelsVar + , SigMempoolSem + , SharedSigStateVar + , newSharedSigStateVar + , newSigChannelsVar + , newSigMempoolSem + , PeerSigAPI (..) + , decisionLogicThreads + , withPeer + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Concurrent.Class.MonadSTM.TSem +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Tracer (Tracer, traceWith) + +import Data.Foldable as Foldable (foldl', traverse_) +import Data.Hashable +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set +import Data.Typeable (Typeable) +import Data.Void (Void) + +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Mempool.Reader + +import Ouroboros.Network.TxSubmission.Inbound.V2 (TxSubmissionMempoolWriter(..)) + +import DMQ.SigSubmission.Inbound.Decision +import DMQ.SigSubmission.Inbound.Policy +import DMQ.SigSubmission.Inbound.State +import DMQ.SigSubmission.Inbound.Types + +-- | Communication channels between `SigSubmission` client mini-protocol and +-- decision logic. +-- +newtype SigChannels m peeraddr sigid sig = SigChannels { + sigChannelMap :: Map peeraddr (StrictMVar m (SigDecision sigid sig)) + } + +type SigChannelsVar m peeraddr sigid sig = StrictMVar m (SigChannels m peeraddr sigid sig) + +newSigChannelsVar :: MonadMVar m => m (SigChannelsVar m peeraddr sigid sig) +newSigChannelsVar = newMVar (SigChannels Map.empty) + +newtype SigMempoolSem m = SigMempoolSem (TSem m) + +newSigMempoolSem :: MonadSTM m => m (SigMempoolSem m) +newSigMempoolSem = SigMempoolSem <$> atomically (newTSem 1) + +-- | API to access `PeerSigState` inside `PeerSigStateVar`. +-- +data PeerSigAPI m sigid sig = PeerSigAPI { + readSigDecision :: m (SigDecision sigid sig), + -- ^ a blocking action which reads `SigDecision` + + handleReceivedSigIds :: NumIdsReq + -> StrictSeq sigid + -- ^ received sigids + -> Map sigid SizeInBytes + -- ^ received sizes of advertised sig's + -> m (), + -- ^ handle received sigids + + handleReceivedSigs :: Map sigid SizeInBytes + -- ^ requested sigids + -> Map sigid sig + -- ^ received sigs + -> m (Maybe TxSubmissionProtocolError), + -- ^ handle received sigs + + submitSigToMempool :: Tracer m (TraceSigSubmissionInbound sigid sig) + -> sigid -> sig -> m () + -- ^ submit the given (sigid, sig) to the mempool. + } + + +data SigMempoolResult = SigAccepted | SigRejected + +-- | A bracket function which registers / de-registers a new peer in +-- `SharedSigStateVar` and `PeerSigStateVar`s, which exposes `PeerSigStateAPI`. +-- `PeerSigStateAPI` is only safe inside the `withPeer` scope. +-- +withPeer + :: forall sig peeraddr sigid idx m a. + ( MonadMask m + , MonadMVar m + , MonadSTM m + , MonadMonotonicTime m + , Ord sigid + , Show sigid + , Typeable sigid + , Ord peeraddr + , Show peeraddr + ) + => Tracer m (TraceSigLogic peeraddr sigid sig) + -> SigChannelsVar m peeraddr sigid sig + -> SigMempoolSem m + -> SigDecisionPolicy + -> SharedSigStateVar m peeraddr sigid sig + -> TxSubmissionMempoolReader sigid sig idx m + -> TxSubmissionMempoolWriter sigid sig idx m + -> (sig -> SizeInBytes) + -> peeraddr + -- ^ new peer + -> (PeerSigAPI m sigid sig -> m a) + -- ^ callback which gives access to `PeerSigStateAPI` + -> m a +withPeer tracer + channelsVar + (SigMempoolSem mempoolSem) + policy@SigDecisionPolicy { bufferedSigsMinLifetime } + sharedStateVar + TxSubmissionMempoolReader { mempoolGetSnapshot } + TxSubmissionMempoolWriter { mempoolAddTxs } + sigSize + peeraddr io = + bracket + (do -- create a communication channel + !peerSigAPI <- + modifyMVar channelsVar + \ SigChannels { sigChannelMap } -> do + chann <- newEmptyMVar + let (chann', sigChannelMap') = + Map.alterF (\mbChann -> + let !chann'' = fromMaybe chann mbChann + in (chann'', Just chann'')) + peeraddr + sigChannelMap + return + ( SigChannels { sigChannelMap = sigChannelMap' } + , PeerSigAPI { readSigDecision = takeMVar chann', + handleReceivedSigIds, + handleReceivedSigs, + submitSigToMempool } + ) + + atomically $ modifyTVar sharedStateVar registerPeer + return peerSigAPI + ) + -- the handler is a short blocking operation, thus we need to use + -- `uninterruptibleMask_` + (\_ -> uninterruptibleMask_ do + atomically $ modifyTVar sharedStateVar unregisterPeer + modifyMVar_ channelsVar + \ SigChannels { sigChannelMap } -> + return SigChannels { sigChannelMap = Map.delete peeraddr sigChannelMap } + ) + io + where + registerPeer :: SharedSigState peeraddr sigid sig + -> SharedSigState peeraddr sigid sig + registerPeer st@SharedSigState { peerSigStates } = + st { peerSigStates = + Map.insert + peeraddr + PeerSigState { + availableSigIds = Map.empty, + requestedSigIdsInflight = 0, + requestedSigsInflightSize = 0, + requestedSigsInflight = Set.empty, + unacknowledgedSigIds = StrictSeq.empty, + unknownSigs = Set.empty, + score = 0, + scoreTs = Time 0, + downloadedSigs = Map.empty, + toMempoolSigs = Map.empty } + peerSigStates + } + + -- TODO: this function needs to be tested! + -- Issue: https://github.com/IntersectMBO/ouroboros-network/issues/5151 + unregisterPeer :: SharedSigState peeraddr sigid sig + -> SharedSigState peeraddr sigid sig + unregisterPeer st@SharedSigState { peerSigStates, + bufferedSigs, + referenceCounts, + inflightSigs, + inflightSigsSize, + inSubmissionToMempoolSigs } = + st { peerSigStates = peerSigStates', + bufferedSigs = bufferedSigs', + referenceCounts = referenceCounts', + inflightSigs = inflightSigs', + inflightSigsSize = inflightSigsSize', + inSubmissionToMempoolSigs = inSubmissionToMempoolSigs' } + where + (PeerSigState { unacknowledgedSigIds, + requestedSigsInflight, + requestedSigsInflightSize, + toMempoolSigs } + , peerSigStates') + = + Map.alterF + (\case + Nothing -> error ("SigSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + Just a -> (a, Nothing)) + peeraddr + peerSigStates + + referenceCounts' = + Foldable.foldl' + (flip $ Map.update \cnt -> + if cnt > 1 + then Just $! pred cnt + else Nothing + ) + referenceCounts + unacknowledgedSigIds + + liveSet = Map.keysSet referenceCounts' + + bufferedSigs' = bufferedSigs + `Map.restrictKeys` + liveSet + + inflightSigs' = Foldable.foldl' purgeInflightSigs inflightSigs requestedSigsInflight + inflightSigsSize' = inflightSigsSize - requestedSigsInflightSize + + -- When we unregister a peer, we need to subtract all sigs in the + -- `toMempoolSigs`, as they will not be submitted to the mempool. + inSubmissionToMempoolSigs' = + Foldable.foldl' (flip $ Map.update \cnt -> + if cnt > 1 + then Just $! pred cnt + else Nothing + ) + inSubmissionToMempoolSigs + (Map.keysSet toMempoolSigs) + + purgeInflightSigs m sigid = Map.alter fn sigid m + where + fn (Just n) | n > 1 = Just $! pred n + fn _ = Nothing + + -- + -- PeerSigAPI + -- + + submitSigToMempool :: Tracer m (TraceSigSubmissionInbound sigid sig) -> sigid -> sig -> m () + submitSigToMempool sigTracer sigid sig = + bracket_ (atomically $ waitTSem mempoolSem) + (atomically $ signalTSem mempoolSem) + $ do + start <- getMonotonicTime + res <- addSig + end <- getMonotonicTime + atomically $ modifyTVar sharedStateVar (updateBufferedSig end res) + let duration = end `diffTime` start + case res of + SigAccepted -> traceWith sigTracer (TraceSigInboundAddedToMempool [sigid] duration) + SigRejected -> traceWith sigTracer (TraceSigInboundRejectedFromMempool [sigid] duration) + + where + -- add the sig to the mempool + addSig :: m SigMempoolResult + addSig = do + mpSnapshot <- atomically mempoolGetSnapshot + + -- Note that checking if the mempool contains a sig before + -- spending several ms attempting to add it to the pool has + -- been judged immoral. + if mempoolHasTx mpSnapshot sigid + then do + !now <- getMonotonicTime + !s <- countRejectedSigs now 1 + traceWith sigTracer $ TraceSigSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0 + , ptxcRejected = 1 + , ptxcScore = s + } + return SigRejected + else do + acceptedSigs <- mempoolAddTxs [sig] + end <- getMonotonicTime + if null acceptedSigs + then do + !s <- countRejectedSigs end 1 + traceWith sigTracer $ TraceSigSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 0 + , ptxcRejected = 1 + , ptxcScore = s + } + return SigRejected + else do + !s <- countRejectedSigs end 0 + traceWith sigTracer $ TraceSigSubmissionProcessed ProcessedTxCount { + ptxcAccepted = 1 + , ptxcRejected = 0 + , ptxcScore = s + } + return SigAccepted + + updateBufferedSig :: Time + -> SigMempoolResult + -> SharedSigState peeraddr sigid sig + -> SharedSigState peeraddr sigid sig + updateBufferedSig _ SigRejected st@SharedSigState { peerSigStates + , inSubmissionToMempoolSigs } = + st { peerSigStates = peerSigStates' + , inSubmissionToMempoolSigs = inSubmissionToMempoolSigs' } + where + inSubmissionToMempoolSigs' = + Map.update (\case 1 -> Nothing; n -> Just $! pred n) + sigid inSubmissionToMempoolSigs + + peerSigStates' = Map.update fn peeraddr peerSigStates + where + fn ps = Just $! ps { toMempoolSigs = Map.delete sigid (toMempoolSigs ps)} + + updateBufferedSig now SigAccepted + st@SharedSigState { peerSigStates + , bufferedSigs + , referenceCounts + , timedSigs + , inSubmissionToMempoolSigs } = + st { peerSigStates = peerSigStates' + , bufferedSigs = bufferedSigs' + , timedSigs = timedSigs' + , referenceCounts = referenceCounts' + , inSubmissionToMempoolSigs = inSubmissionToMempoolSigs' + } + where + inSubmissionToMempoolSigs' = + Map.update (\case 1 -> Nothing; n -> Just $! pred n) + sigid inSubmissionToMempoolSigs + + timedSigs' = Map.alter fn (addTime bufferedSigsMinLifetime now) timedSigs + where + fn :: Maybe [sigid] -> Maybe [sigid] + fn Nothing = Just [sigid] + fn (Just sigids) = Just $! (sigid:sigids) + + referenceCounts' = Map.alter fn sigid referenceCounts + where + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! succ n + + bufferedSigs' = Map.insert sigid (Just sig) bufferedSigs + + peerSigStates' = Map.update fn peeraddr peerSigStates + where + fn ps = Just $! ps { toMempoolSigs = Map.delete sigid (toMempoolSigs ps)} + + handleReceivedSigIds :: NumIdsReq + -> StrictSeq sigid + -> Map sigid SizeInBytes + -> m () + handleReceivedSigIds numIdsReq sigidsSeq sigidsMap = + receivedSigIds tracer + sharedStateVar + mempoolGetSnapshot + peeraddr + numIdsReq + sigidsSeq + sigidsMap + + + handleReceivedSigs :: Map sigid SizeInBytes + -- ^ requested sigids with their announced size + -> Map sigid sig + -- ^ received sigs + -> m (Maybe TxSubmissionProtocolError) + handleReceivedSigs = + collectSigs tracer sigSize sharedStateVar peeraddr + + -- Update `score` & `scoreTs` fields of `PeerSigState`, return the new + -- updated `score`. + -- + -- PRECONDITION: the `Double` argument is non-negative. + countRejectedSigs :: Time + -> Double + -> m Double + countRejectedSigs _ n | n < 0 = + error ("SigSubmission.countRejectedSigs: invariant violation for peer " ++ show peeraddr) + countRejectedSigs now n = atomically $ stateTVar sharedStateVar $ \st -> + let (result, peerSigStates') = Map.alterF fn peeraddr (peerSigStates st) + in (result, st { peerSigStates = peerSigStates' }) + where + fn :: Maybe (PeerSigState sigid sig) -> (Double, Maybe (PeerSigState sigid sig)) + fn Nothing = error ("SigSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + fn (Just ps) = (score ps', Just $! ps') + where + ps' = updateRejects policy now n ps + + +updateRejects :: SigDecisionPolicy + -> Time + -> Double + -> PeerSigState sigid sig + -> PeerSigState sigid sig +updateRejects _ now 0 pts | score pts == 0 = pts {scoreTs = now} +updateRejects SigDecisionPolicy { scoreRate, scoreMax } now n + pts@PeerSigState { score, scoreTs } = + let duration = diffTime now scoreTs + !drain = realToFrac duration * scoreRate + !drained = max 0 $ score - drain in + pts { score = min scoreMax $ drained + n + , scoreTs = now + } + + +drainRejectionThread + :: forall m peeraddr sigid sig. + ( MonadDelay m + , MonadSTM m + , MonadThread m + , Ord sigid + ) + => Tracer m (TraceSigLogic peeraddr sigid sig) + -> SigDecisionPolicy + -> SharedSigStateVar m peeraddr sigid sig + -> m Void +drainRejectionThread tracer policy sharedStateVar = do + labelThisThread "sig-rejection-drain" + now <- getMonotonicTime + go $ addTime drainInterval now + where + drainInterval :: DiffTime + drainInterval = 7 + + go :: Time -> m Void + go !nextDrain = do + threadDelay 1 + + !now <- getMonotonicTime + st'' <- atomically $ do + st <- readTVar sharedStateVar + let ptss = if now > nextDrain then Map.map (updateRejects policy now 0) (peerSigStates st) + else peerSigStates st + st' = tickTimedSigs now st + { peerSigStates = ptss } + writeTVar sharedStateVar st' + return st' + traceWith tracer (TraceSharedTxState "drainRejectionThread" st'') + + if now > nextDrain + then go $ addTime drainInterval now + else go nextDrain + + +decisionLogicThread + :: forall m peeraddr sigid sig. + ( MonadDelay m + , MonadMVar m + , MonadSTM m + , MonadMask m + , MonadFork m + , Ord peeraddr + , Ord sigid + , Hashable peeraddr + ) + => Tracer m (TraceSigLogic peeraddr sigid sig) + -> Tracer m TxSubmissionCounters + -> SigDecisionPolicy + -> SigChannelsVar m peeraddr sigid sig + -> SharedSigStateVar m peeraddr sigid sig + -> m Void +decisionLogicThread tracer counterTracer policy sigChannelsVar sharedStateVar = do + labelThisThread "sig-decision" + go + where + go :: m Void + go = do + -- We rate limit the decision making process, it could overwhelm the CPU + -- if there are too many inbound connections. + threadDelay _DECISION_LOOP_DELAY + + (decisions, st) <- atomically do + sharedSigState <- readTVar sharedStateVar + let activePeers = filterActivePeers policy sharedSigState + + -- block until at least one peer is active + check (not (Map.null activePeers)) + + let (sharedState, decisions) = makeDecisions policy sharedSigState activePeers + writeTVar sharedStateVar sharedState + return (decisions, sharedState) + traceWith tracer (TraceSharedTxState "decisionLogicThread" st) + traceWith tracer (TraceSigDecisions decisions) + SigChannels { sigChannelMap } <- readMVar sigChannelsVar + traverse_ + (\(mvar, d) -> modifyMVarWithDefault_ mvar d (\d' -> pure (d' <> d))) + (Map.intersectionWith (,) + sigChannelMap + decisions) + traceWith counterTracer (mkTxSubmissionCounters st) + go + + -- Variant of modifyMVar_ that puts a default value if the MVar is empty. + modifyMVarWithDefault_ :: StrictMVar m a -> a -> (a -> m a) -> m () + modifyMVarWithDefault_ m d io = + mask $ \restore -> do + mbA <- tryTakeMVar m + case mbA of + Just a -> do + a' <- restore (io a) `onException` putMVar m a + putMVar m a' + Nothing -> putMVar m d + + +-- | Run `decisionLogicThread` and `drainRejectionThread`. +-- +decisionLogicThreads + :: forall m peeraddr sigid sig. + ( MonadDelay m + , MonadMVar m + , MonadMask m + , MonadAsync m + , MonadFork m + , Ord peeraddr + , Ord sigid + , Hashable peeraddr + ) + => Tracer m (TraceSigLogic peeraddr sigid sig) + -> Tracer m TxSubmissionCounters + -> SigDecisionPolicy + -> SigChannelsVar m peeraddr sigid sig + -> SharedSigStateVar m peeraddr sigid sig + -> m Void +decisionLogicThreads tracer counterTracer policy sigChannelsVar sharedStateVar = + uncurry (<>) <$> + drainRejectionThread tracer policy sharedStateVar + `concurrently` + decisionLogicThread tracer counterTracer policy sigChannelsVar sharedStateVar + + +-- `5ms` delay +_DECISION_LOOP_DELAY :: DiffTime +_DECISION_LOOP_DELAY = 0.005 diff --git a/dmq-node/src/DMQ/SigSubmission/Inbound/State.hs b/dmq-node/src/DMQ/SigSubmission/Inbound/State.hs new file mode 100644 index 0000000..63390b9 --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Inbound/State.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DMQ.SigSubmission.Inbound.State + ( -- * Core API + SharedSigState (..) + , PeerSigState (..) + , SharedSigStateVar + , newSharedSigStateVar + , receivedSigIds + , collectSigs + , acknowledgeSigIds + , splitAcknowledgedSigIds + , tickTimedSigs + , const_MAX_SIG_SIZE_DISCREPENCY + -- * Internals, only exported for testing purposes: + , RefCountDiff (..) + , updateRefCounts + , receivedSigIdsImpl + , collectSigsImpl + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Monad.Class.MonadTime.SI +import Control.Tracer (Tracer, traceWith) + +import Data.Foldable (fold, toList) +import Data.Foldable qualified as Foldable +import Data.Functor (($>)) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, maybeToList) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set +import Data.Typeable (Typeable) +import GHC.Stack (HasCallStack) +import System.Random (StdGen) + +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.State (RefCountDiff (..), + updateRefCounts) + +import DMQ.Protocol.SigSubmissionV2.Type (NumIdsAck) + +import DMQ.SigSubmission.Inbound.Policy +import DMQ.SigSubmission.Inbound.Types + + +-- +-- Pure public API +-- + +acknowledgeSigIds + :: forall peeraddr sig sigid. + Ord sigid + => SigDecisionPolicy + -> SharedSigState peeraddr sigid sig + -> PeerSigState sigid sig + -> ( NumIdsAck + , NumIdsReq + , TxsToMempool sigid sig + , RefCountDiff sigid + , PeerSigState sigid sig + ) + -- ^ number of sigid to acknowledge, requests, sigs which we can submit to the + -- mempool, sigids to acknowledge with multiplicities, updated PeerSigState. +{-# INLINE acknowledgeSigIds #-} + +acknowledgeSigIds + policy + sharedSigState + ps@PeerSigState { availableSigIds, + unknownSigs, + requestedSigIdsInflight, + downloadedSigs, + score, + toMempoolSigs + } + = + -- We can only acknowledge sigids when we can request new ones, since + -- a `MsgRequestSigIds` for 0 sigids is a protocol error. + if sigIdsToRequest > 0 + then + ( sigIdsToAcknowledge + , sigIdsToRequest + , TxsToMempool sigsToMempool + , refCountDiff + , ps { unacknowledgedSigIds = unacknowledgedSigIds', + availableSigIds = availableSigIds', + unknownSigs = unkownSigs', + requestedSigIdsInflight = requestedSigIdsInflight + + sigIdsToRequest, + downloadedSigs = downloadedSigs', + score = score', + toMempoolSigs = toMempoolSigs' } + ) + else + ( 0 + , 0 + , TxsToMempool sigsToMempool + , RefCountDiff Map.empty + , ps { toMempoolSigs = toMempoolSigs' } + ) + where + -- Split `unacknowledgedSigIds'` into the longest prefix of `sigid`s which + -- can be acknowledged and the unacknowledged `sigid`s. + (sigIdsToRequest, acknowledgedSigIds, unacknowledgedSigIds') + = splitAcknowledgedSigIds policy sharedSigState ps + + sigsToMempool = [ (sigid, sig) + | sigid <- toList toMempoolSigIds + , sigid `Map.notMember` bufferedSigs sharedSigState + , sig <- maybeToList $ sigid `Map.lookup` downloadedSigs + ] + (toMempoolSigIds, _) = + StrictSeq.spanl (`Map.member` downloadedSigs) acknowledgedSigIds + + + sigsToMempoolMap = Map.fromList sigsToMempool + + toMempoolSigs' = toMempoolSigs <> sigsToMempoolMap + + (downloadedSigs', ackedDownloadedSigs) = Map.partitionWithKey (\sigid _ -> sigid `Set.member` liveSet) downloadedSigs + -- lateSigs: sigs which were downloaded by another peer before we + -- downloaded them; it relies on that `txToMempool` filters out + -- `bufferedSigs`. + lateSigs = Map.filterWithKey (\sigid _ -> sigid `Map.notMember` sigsToMempoolMap) ackedDownloadedSigs + score' = score + fromIntegral (Map.size lateSigs) + + -- the set of live `sigids` + liveSet = Set.fromList (toList unacknowledgedSigIds') + + availableSigIds' = availableSigIds + `Map.restrictKeys` + liveSet + + -- We remove all acknowledged `sigid`s which are not in + -- `unacknowledgedSigIds''`, but also return the unknown set before any + -- modifications (which is used to compute `unacknowledgedSigIds''` + -- above). + unkownSigs' = unknownSigs `Set.intersection` liveSet + + refCountDiff = RefCountDiff + $ foldr (Map.alter fn) + Map.empty acknowledgedSigIds + where + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! n + 1 + + sigIdsToAcknowledge :: NumIdsAck + sigIdsToAcknowledge = fromIntegral $ StrictSeq.length acknowledgedSigIds + + +-- | Split unacknowledged sigids into acknowledged and unacknowledged parts, also +-- return number of sigids which can be requested. +-- +splitAcknowledgedSigIds + :: Ord sigid + => SigDecisionPolicy + -> SharedSigState peer sigid sig + -> PeerSigState sigid sig + -> (NumIdsReq, StrictSeq.StrictSeq sigid, StrictSeq.StrictSeq sigid) + -- ^ number of sigids to request, acknowledged sigids, unacknowledged sigids +splitAcknowledgedSigIds + SigDecisionPolicy { + maxUnacknowledgedSigIds, + maxNumSigIdsToRequest + } + SharedSigState { + bufferedSigs + } + PeerSigState { + unacknowledgedSigIds, + unknownSigs, + downloadedSigs, + requestedSigsInflight, + requestedSigIdsInflight + } + = + (sigIdsToRequest, acknowledgedSigIds', unacknowledgedSigIds') + where + (acknowledgedSigIds', unacknowledgedSigIds') + = StrictSeq.spanl (\sigid -> + sigid `Set.notMember` requestedSigsInflight + && ( + sigid `Map.member` downloadedSigs + || sigid `Set.member` unknownSigs + || sigid `Map.member` bufferedSigs + ) + ) + unacknowledgedSigIds + + numOfUnacked = StrictSeq.length unacknowledgedSigIds + numOfAcked = StrictSeq.length acknowledgedSigIds' + unackedAndRequested = fromIntegral numOfUnacked + requestedSigIdsInflight + + sigIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedSigIds) $ + assert (requestedSigIdsInflight <= maxNumSigIdsToRequest) $ + (maxUnacknowledgedSigIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumSigIdsToRequest - requestedSigIdsInflight) + + +tickTimedSigs :: forall peeraddr sig sigid. + (Ord sigid) + => Time + -> SharedSigState peeraddr sigid sig + -> SharedSigState peeraddr sigid sig +tickTimedSigs now st@SharedSigState{ timedSigs + , referenceCounts + , bufferedSigs } = + let (expiredSigs', timedSigs') = + case Map.splitLookup now timedSigs of + (expired, Just sigids, timed) -> + (expired, -- Map.split doesn't include the `now` entry in the map + Map.insert now sigids timed) + (expired, Nothing, timed) -> + (expired, timed) + refDiff = Map.foldl' fn Map.empty expiredSigs' + referenceCounts' = updateRefCounts referenceCounts (RefCountDiff refDiff) + liveSet = Map.keysSet referenceCounts' + bufferedSigs' = bufferedSigs `Map.restrictKeys` liveSet in + st { timedSigs = timedSigs' + , referenceCounts = referenceCounts' + , bufferedSigs = bufferedSigs' + } + where + fn :: Map sigid Int + -> [sigid] + -> Map sigid Int + fn m sigids = Foldable.foldl' gn m sigids + + gn :: Map sigid Int + -> sigid + -> Map sigid Int + gn m sigid = Map.alter af sigid m + + af :: Maybe Int + -> Maybe Int + af Nothing = Just 1 + af (Just n) = Just $! succ n + +-- +-- Pure internal API +-- + +-- | Insert received `sigid`s and return the number of sigids to be acknowledged +-- and the updated `SharedSigState`. +-- +receivedSigIdsImpl + :: forall peeraddr sig sigid. + (Ord sigid, Ord peeraddr, HasCallStack) + => (sigid -> Bool) -- ^ check if sigid is in the mempool, ref + -- 'mempoolHasSig' + -> peeraddr + -> NumIdsReq + -- ^ number of requests to subtract from + -- `requestedSigIdsInflight` + + -> StrictSeq sigid + -- ^ sequence of received `sigids` + -> Map sigid SizeInBytes + -- ^ received `sigid`s with sizes + + -> SharedSigState peeraddr sigid sig + -> SharedSigState peeraddr sigid sig + +receivedSigIdsImpl + mempoolHasSig + peeraddr reqNo sigidsSeq sigidsMap + st@SharedSigState{ peerSigStates, + bufferedSigs, + referenceCounts } + = + -- using `alterF` so the update of `PeerSigState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerSigStates of + ( st', peerSigStates' ) -> + st' { peerSigStates = peerSigStates' } + + where + -- update `PeerSigState` and return number of `sigid`s to acknowledged and + -- updated `SharedSigState`. + fn :: PeerSigState sigid sig + -> ( SharedSigState peeraddr sigid sig + , PeerSigState sigid sig + ) + fn ps@PeerSigState { availableSigIds, + requestedSigIdsInflight, + unacknowledgedSigIds } = + (st', ps') + where + -- + -- Handle new `sigid`s + -- + + -- Divide the new sigids in two: those that are already in the mempool + -- and those that are not. We'll request some sigs from the latter. + (ignoredSigIds, availableSigIdsMap) = + Map.partitionWithKey + (\sigid _ -> mempoolHasSig sigid) + sigidsMap + + -- Add all `sigids` from `availableSigIdsMap` which are not + -- unacknowledged or already buffered. Unacknowledged sigids must have + -- already been added to `availableSigIds` map before. + availableSigIds' = + Map.foldlWithKey + (\m sigid sizeInBytes -> Map.insert sigid sizeInBytes m) + availableSigIds + (Map.filterWithKey + (\sigid _ -> sigid `notElem` unacknowledgedSigIds + && sigid `Map.notMember` bufferedSigs) + availableSigIdsMap) + + -- Add received sigids to `unacknowledgedSigIds`. + unacknowledgedSigIds' = unacknowledgedSigIds <> sigidsSeq + + -- Add ignored `sigs` to buffered ones. + -- Note: we prefer to keep the `sig` if it's already in `bufferedSigs`. + bufferedSigs' = bufferedSigs + <> Map.map (const Nothing) ignoredSigIds + + referenceCounts' = + Foldable.foldl' + (flip $ Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt)) + referenceCounts + sigidsSeq + + st' = st { bufferedSigs = bufferedSigs', + referenceCounts = referenceCounts' } + ps' = assert (requestedSigIdsInflight >= reqNo) + ps { availableSigIds = availableSigIds', + unacknowledgedSigIds = unacknowledgedSigIds', + requestedSigIdsInflight = requestedSigIdsInflight - reqNo } + +-- | We check advertised sizes up in a fuzzy way. The advertised and received +-- sizes need to agree up to `const_MAX_SIG_SIZE_DISCREPENCY`. +-- +const_MAX_SIG_SIZE_DISCREPENCY :: SizeInBytes +const_MAX_SIG_SIZE_DISCREPENCY = 32 + +collectSigsImpl + :: forall peeraddr sig sigid. + ( Ord peeraddr + , Ord sigid + , Show sigid + , Typeable sigid + ) + => (sig -> SizeInBytes) -- ^ compute sig size + -> peeraddr + -> Map sigid SizeInBytes -- ^ requested sigids + -> Map sigid sig -- ^ received sigs + -> SharedSigState peeraddr sigid sig + -> Either TxSubmissionProtocolError + (SharedSigState peeraddr sigid sig) + -- ^ Return list of `sigid` which sizes didn't match or a new state. + -- If one of the `sig` has wrong size, we return an error. The + -- mini-protocol will throw, which will clean the state map from this peer. +collectSigsImpl sigSize peeraddr requestedSigIdsMap receivedSigs + st@SharedSigState { peerSigStates } = + + -- using `alterF` so the update of `PeerSigState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerSigStates of + (Right st', peerSigStates') -> + Right st' { peerSigStates = peerSigStates' } + (Left e, _) -> + Left $ ProtocolErrorTxSizeError e + + where + -- Update `PeerSigState` and partially update `SharedSigState` (except of + -- `peerSigStates`). + fn :: PeerSigState sigid sig + -> ( Either [(sigid, SizeInBytes, SizeInBytes)] + (SharedSigState peeraddr sigid sig) + , PeerSigState sigid sig + ) + fn ps = + case wrongSizedSigs of + [] -> ( Right st' + , ps'' + ) + _ -> ( Left wrongSizedSigs + , ps + ) + where + wrongSizedSigs :: [(sigid, SizeInBytes, SizeInBytes)] + wrongSizedSigs = + map (\(a, (b,c)) -> (a,b,c)) + . Map.toList + $ Map.merge + Map.dropMissing + Map.dropMissing + (Map.zipWithMaybeMatched \_ receivedSize advertisedSize -> + if receivedSize `checkSigSize` advertisedSize + then Nothing + else Just (receivedSize, advertisedSize) + ) + (sigSize `Map.map` receivedSigs) + requestedSigIdsMap + + checkSigSize :: SizeInBytes + -> SizeInBytes + -> Bool + checkSigSize received advertised + | received > advertised + = received - advertised <= const_MAX_SIG_SIZE_DISCREPENCY + | otherwise + = advertised - received <= const_MAX_SIG_SIZE_DISCREPENCY + + requestedSigIds = Map.keysSet requestedSigIdsMap + notReceived = requestedSigIds Set.\\ Map.keysSet receivedSigs + downloadedSigs' = downloadedSigs ps <> receivedSigs + -- Add not received sigs to `unkownSigs` before acknowledging sigids. + unkownSigs' = unknownSigs ps <> notReceived + + requestedSigsInflight' = + assert (requestedSigIds `Set.isSubsetOf` requestedSigsInflight ps) $ + requestedSigsInflight ps Set.\\ requestedSigIds + + requestedSize = fold $ availableSigIds ps `Map.restrictKeys` requestedSigIds + requestedSigsInflightSize' = + assert (requestedSigsInflightSize ps >= requestedSize) $ + requestedSigsInflightSize ps - requestedSize + + -- subtract requested from in-flight + inflightSigs'' = + Map.merge + (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + let z = x - y in + if z > 0 + then Just z + else Nothing) + (inflightSigs st) + (Map.fromSet (const 1) requestedSigIds) + + inflightSigsSize'' = assert (inflightSigsSize st >= requestedSize) $ + inflightSigsSize st - requestedSize + + st' = st { inflightSigs = inflightSigs'', + inflightSigsSize = inflightSigsSize'' + } + + -- + -- Update PeerSigState + -- + + -- Remove the downloaded `sigid`s from the availableSigIds map, this + -- guarantees that we won't attempt to download the `sigids` from this peer + -- once we collect the `sigid`s. Also restrict keys to `liveSet`. + -- + -- NOTE: we could remove `notReceived` from `availableSigIds`; and + -- possibly avoid using `unkownSigs` field at all. + -- + availableSigIds'' = availableSigIds ps + `Map.withoutKeys` + requestedSigIds + + -- Remove all acknowledged `sigid`s from unknown set, but only those + -- which are not present in `unacknowledgedSigIds'` + unkownSigs'' = unkownSigs' + `Set.intersection` + live + where + -- We cannot use `liveSet` as `unknown <> notReceived` might + -- contain `sigids` which are in `liveSet` but are not `live`. + live = Set.fromList (toList (unacknowledgedSigIds ps)) + + ps'' = ps { availableSigIds = availableSigIds'', + unknownSigs = unkownSigs'', + requestedSigsInflightSize = requestedSigsInflightSize', + requestedSigsInflight = requestedSigsInflight', + downloadedSigs = downloadedSigs' } + +-- +-- Monadic public API +-- + +type SharedSigStateVar m peeraddr sigid sig = StrictTVar m (SharedSigState peeraddr sigid sig) + +newSharedSigStateVar :: MonadSTM m + => StdGen + -> m (SharedSigStateVar m peeraddr sigid sig) +newSharedSigStateVar rng = newTVarIO SharedSigState { + peerSigStates = Map.empty, + inflightSigs = Map.empty, + inflightSigsSize = 0, + bufferedSigs = Map.empty, + referenceCounts = Map.empty, + timedSigs = Map.empty, + inSubmissionToMempoolSigs = Map.empty, + peerRng = rng + } + + +-- | Acknowledge `sigid`s, return the number of `sigids` to be acknowledged to the +-- remote side. +-- +receivedSigIds + :: forall m peeraddr idx sig sigid. + (MonadSTM m, Ord sigid, Ord peeraddr) + => Tracer m (TraceSigLogic peeraddr sigid sig) + -> SharedSigStateVar m peeraddr sigid sig + -> STM m (MempoolSnapshot sigid sig idx) + -> peeraddr + -> NumIdsReq + -- ^ number of requests to subtract from + -- `requestedSigIdsInflight` + -> StrictSeq sigid + -- ^ sequence of received `sigids` + -> Map sigid SizeInBytes + -- ^ received `sigid`s with sizes + -> m () +receivedSigIds tracer sharedVar getMempoolSnapshot peeraddr reqNo sigidsSeq sigidsMap = do + st <- atomically $ do + MempoolSnapshot{mempoolHasTx} <- getMempoolSnapshot + stateTVar sharedVar ((\a -> (a,a)) . receivedSigIdsImpl mempoolHasTx peeraddr reqNo sigidsSeq sigidsMap) + traceWith tracer (TraceSharedTxState "receivedSigIds" st) + + +-- | Include received `sig`s in `SharedSigState`. Return number of `sigids` +-- to be acknowledged and list of `sig` to be added to the mempool. +-- +collectSigs + :: forall m peeraddr sig sigid. + (MonadSTM m, Ord sigid, Ord peeraddr, + Show sigid, Typeable sigid) + => Tracer m (TraceSigLogic peeraddr sigid sig) + -> (sig -> SizeInBytes) + -> SharedSigStateVar m peeraddr sigid sig + -> peeraddr + -> Map sigid SizeInBytes -- ^ set of requested sigids with their announced size + -> Map sigid sig -- ^ received sigs + -> m (Maybe TxSubmissionProtocolError) + -- ^ number of sigids to be acknowledged and sigs to be added to the + -- mempool +collectSigs tracer sigSize sharedVar peeraddr sigidsRequested sigsMap = do + r <- atomically $ do + st <- readTVar sharedVar + case collectSigsImpl sigSize peeraddr sigidsRequested sigsMap st of + r@(Right st') -> writeTVar sharedVar st' + $> r + r@Left {} -> pure r + case r of + Right st -> traceWith tracer (TraceSharedTxState "collectSigs" st) + $> Nothing + Left e -> return (Just e) diff --git a/dmq-node/src/DMQ/SigSubmission/Inbound/Types.hs b/dmq-node/src/DMQ/SigSubmission/Inbound/Types.hs new file mode 100644 index 0000000..ed93b48 --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Inbound/Types.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DMQ.SigSubmission.Inbound.Types + ( -- * PeerSigState + PeerSigState (..) + -- * SharedSigState + , SharedSigState (..) + -- * Decisions + , TxsToMempool (..) + , SigDecision (..) + , emptySigDecision + , TraceSigLogic (..) + , SigSubmissionInitDelay (..) + , defaultSigSubmissionInitDelay + + -- * Types shared with V1 + -- ** Various + , ProcessedTxCount (..) + -- ** Traces + , TraceSigSubmissionInbound (..) + , TxSubmissionCounters (..) + , mkTxSubmissionCounters + -- ** Protocol Error + , TxSubmissionProtocolError (..) + ) where + +import Control.DeepSeq +import Control.Monad.Class.MonadTime.SI +import Data.Aeson (ToJSON (toJSON), Value (String), object, (.=)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Monoid (Sum (..)) +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (pack) +import GHC.Generics (Generic) +import System.Random (StdGen) + +import NoThunks.Class (NoThunks (..)) + +import Ouroboros.Network.ControlMessage (ControlMessage) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.V2 (ProcessedTxCount (..), + TxsToMempool (..), TxSubmissionCounters (..), + TxSubmissionProtocolError (..)) + +import DMQ.Protocol.SigSubmissionV2.Type (NumIdsAck, NumIdsReq) + +-- +-- PeerSigState, SharedSigState +-- + +data PeerSigState sigid sig = PeerSigState { + -- | Those signatures (by their identifier) that the client has told + -- us about, and which we have not yet acknowledged. This is kept in + -- the order in which the client gave them to us. This is the same order + -- in which we submit them to the mempool (or for this example, the final + -- result order). It is also the order we acknowledge in. + -- + unacknowledgedSigIds :: !(StrictSeq sigid), + + -- | Set of known signature ids which can be requested from this peer. + -- + availableSigIds :: !(Map sigid SizeInBytes), + + -- | The number of signature identifiers that we have requested but + -- which have not yet been replied to. We need to track this it keep + -- our requests within the limit on the number of unacknowledged sigids. + -- + requestedSigIdsInflight :: !NumIdsReq, + + -- | The size in bytes of signatures that we have requested but which + -- have not yet been replied to. We need to track this to keep our + -- requests within the `maxSigsSizeInflight` limit. + -- + requestedSigsInflightSize :: !SizeInBytes, + + -- | The set of requested `sigid`s. + -- + requestedSigsInflight :: !(Set sigid), + + -- | A subset of `unacknowledgedSigIds` which were unknown to the peer + -- (i.e. requested but not received). We need to track these `sigid`s + -- since they need to be acknowledged. + -- + -- We track these `sigid` per peer, rather than in `bufferedSigs` map, + -- since that could potentially lead to corrupting the node, not being + -- able to download a `sig` which is needed & available from other nodes. + -- + unknownSigs :: !(Set sigid), + + -- | Score is a metric that tracks how usefull a peer has been. + -- The larger the value the less usefull peer. It slowly decays towards + -- zero. + score :: !Double, + + -- | Timestamp for the last time `score` was drained. + scoreTs :: !Time, + + -- | A set of sigs downloaded from the peer. They are not yet + -- acknowledged and haven't been sent to the mempool yet. + -- + -- Life cycle of entries: + -- * added when a sig is downloaded (see `collectSigsImpl`) + -- * follows `unacknowledgedSigIds` (see `acknowledgeSigIds`) + -- + downloadedSigs :: !(Map sigid sig), + + -- | A set of sigs on their way to the mempool. + -- Tracked here so that we can cleanup `inSubmissionToMempoolSigs` if the + -- peer dies. + -- + -- Life cycle of entries: + -- * added by `acknowledgeSigIds` (where decide which sigs can be + -- submitted to the mempool) + -- * removed by `withMempoolSem` + -- + toMempoolSigs :: !(Map sigid sig) + + } + deriving (Eq, Show, Generic, NFData) + +instance ( NoThunks sigid + , NoThunks sig + ) => NoThunks (PeerSigState sigid sig) + + +-- | Shared state of all `SigSubmission` clients. +-- +-- New `sigid` enters `unacknowledgedSigIds` it is also added to `availableSigIds` +-- and `referenceCounts` (see `acknowledgeTxIdsImpl`). +-- +-- When a `sigid` id is selected to be downloaded, it's added to +-- `requestedSigsInflightSize` (see +-- `DMQ.SigSubmission.Inbound.Decision.pickSigsToDownload`). +-- +-- When the request arrives, the `sigid` is removed from `inflightSigs`. It +-- might be added to `unknownSigs` if the server didn't have that `sigid`, or +-- it's added to `bufferedSigs` (see `collectSigsImpl`). +-- +-- Whenever we choose `sigid` to acknowledge (either in `acknowledtxsIdsImpl`, +-- `collectSigsImpl` or +-- `DMQ.SigSubmission.Inbound.Decision.pickSigsToDownload`, we also +-- recalculate `referenceCounts` and only keep live `sigid`s in other maps (e.g. +-- `availableSigIds`, `bufferedSigs`, `unknownSigs`). +-- +data SharedSigState peeraddr sigid sig = SharedSigState { + + -- | Map of peer states. + -- + -- /Invariant:/ for peeraddr's which are registered using `withPeer`, + -- there's always an entry in this map even if the set of `sigid`s is + -- empty. + -- + peerSigStates :: !(Map peeraddr (PeerSigState sigid sig)), + + -- | Set of signatures which are in-flight (have already been + -- requested) together with multiplicities (from how many peers it is + -- currently in-flight) + -- + -- This set can intersect with `availableSigIds`. + -- + inflightSigs :: !(Map sigid Int), + + -- | Overall size of all `sig`s in-flight. + -- + inflightSigsSize :: !SizeInBytes, + + -- | Map of `sig` which: + -- + -- * were downloaded and added to the mempool, + -- * are already in the mempool (`Nothing` is inserted in that case), + -- + -- We only keep live `sigid`, e.g. ones which `sigid` is unacknowledged by + -- at least one peer or has a `timedSigs` entry. + -- + -- /Note:/ `sigid`s which `sig` were unknown by a peer are tracked + -- separately in `unknownSigs`. + -- + -- /Note:/ previous implementation also needed to explicitly track + -- `sigid`s which were already acknowledged, but are still unacknowledged. + -- In this implementation, this is done using reference counting. + -- + -- This map is useful to acknowledge `sigid`s, it's basically taking the + -- longest prefix which contains entries in `bufferedSigs` or `unknownSigs`. + -- + bufferedSigs :: !(Map sigid (Maybe sig)), + + -- | We track reference counts of all unacknowledged and timedSigs sigids. + -- Once the count reaches 0, a sig is removed from `bufferedSigs`. + -- + -- The `bufferedSig` map contains a subset of `sigid` which + -- `referenceCounts` contains. + -- + -- /Invariants:/ + -- + -- * the sigid count is equal to multiplicity of sigid in all + -- `unacknowledgedSigIds` sequences; + -- * @Map.keysSet bufferedSigs `Set.isSubsetOf` Map.keysSet referenceCounts@; + -- * all counts are positive integers. + -- + referenceCounts :: !(Map sigid Int), + + -- | A set of timeouts for sigids that have been added to bufferedSigs after being + -- inserted into the mempool. + -- + -- We need these short timeouts to avoid re-downloading a `sig`. We could + -- acknowledge this `sigid` to all peers, when a peer from another + -- continent presents us it again. + -- + -- Every sigid entry has a reference count in `referenceCounts`. + -- + timedSigs :: !(Map Time [sigid]), + + -- | A set of sigids that have been downloaded by a peer and are on their + -- way to the mempool. We won't issue further fetch-requests for sigs in + -- this state. We track these sigs to not re-download them from another + -- peer. + -- + -- * We subtract from the counter when a given sig is added or rejected by + -- the mempool or do that for all sigs in `toMempoolTxs` when a peer is + -- unregistered. + -- * We add to the counter when a given sig is selected to be added to the + -- mempool in `pickSigsToDownload`. + -- + inSubmissionToMempoolSigs :: !(Map sigid Int), + + -- | Rng used to randomly order peers + peerRng :: !StdGen + } + deriving (Eq, Show, Generic, NFData) + +instance ( NoThunks peeraddr + , NoThunks sig + , NoThunks sigid + , NoThunks StdGen + ) => NoThunks (SharedSigState peeraddr sigid sig) + + +-- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- +-- /note:/ it is rather non-standard to represent a choice between requesting +-- `sigid`s and `sig`'s as a product rather than a sum type. The client will +-- need to download `sig`s first and then send a request for more sigids (and +-- acknowledge some `sigid`s). Due to pipelining each client will request +-- decision from the decision logic quite often (every two pipelined requests), +-- but with this design a decision once taken will make the peer non-active +-- (e.g. it won't be returned by `filterActivePeers`) for longer, and thus the +-- expensive `makeDecision` computation will not need to take that peer into +-- account. +-- +data SigDecision sigid sig = SigDecision { + sigdSigIdsToAcknowledge :: !NumIdsAck, + -- ^ id's to acknowledge + + sigdSigIdsToRequest :: !NumIdsReq, + -- ^ number of id's to request + + sigdPipelineSigIds :: !Bool, + -- ^ the sig-submission protocol only allows to pipeline `sigid`'s requests + -- if we have non-acknowledged `sigid`s. + + sigdSigsToRequest :: !(Map sigid SizeInBytes), + -- ^ sigid's to download. + + sigdSigsToMempool :: !(TxsToMempool sigid sig) + -- ^ list of `sig`s to submit to the mempool. + } + deriving (Show, Eq) + +instance (NFData sigid, NFData sig) => NFData (SigDecision sigid sig) where + -- all fields except `sigdSigsToMempool` when evaluated to WHNF evaluate to NF. + rnf SigDecision {sigdSigsToMempool} = rnf sigdSigsToMempool + +-- | A non-commutative semigroup instance. +-- +-- /note:/ this instance must be consistent with `pickSigsToDownload` and how +-- `PeerSigState` is updated. It is designed to work with `TMergeVar`s. +-- +instance Ord sigid => Semigroup (SigDecision sigid sig) where + SigDecision { sigdSigIdsToAcknowledge, + sigdSigIdsToRequest, + sigdPipelineSigIds = _ignored, + sigdSigsToRequest, + sigdSigsToMempool } + <> + SigDecision { sigdSigIdsToAcknowledge = sigdSigIdsToAcknowledge', + sigdSigIdsToRequest = sigdSigIdsToRequest', + sigdPipelineSigIds = sigdPipelineSigIds', + sigdSigsToRequest = sigdSigsToRequest', + sigdSigsToMempool = sigdSigsToMempool' } + = + SigDecision { sigdSigIdsToAcknowledge = sigdSigIdsToAcknowledge + sigdSigIdsToAcknowledge', + sigdSigIdsToRequest = sigdSigIdsToRequest + sigdSigIdsToRequest', + sigdPipelineSigIds = sigdPipelineSigIds', + sigdSigsToRequest = sigdSigsToRequest <> sigdSigsToRequest', + sigdSigsToMempool = sigdSigsToMempool <> sigdSigsToMempool' + } + +-- | A no-op decision. +emptySigDecision :: SigDecision sigid sig +emptySigDecision = SigDecision { + sigdSigIdsToAcknowledge = 0, + sigdSigIdsToRequest = 0, + sigdPipelineSigIds = False, + sigdSigsToRequest = Map.empty, + sigdSigsToMempool = mempty + } + + +-- | SigLogic tracer. +-- +data TraceSigLogic peeraddr sigid sig = + TraceSharedTxState String (SharedSigState peeraddr sigid sig) + | TraceSigDecisions (Map peeraddr (SigDecision sigid sig)) + deriving Show + +instance ( Show addr + , Show sigid + , Show sig + ) + => ToJSON (TraceSigLogic addr sigid sig) where + toJSON (TraceSharedTxState tag st) = + object [ "kind" .= String "SharedSigState" + , "tag" .= String (pack tag) + , "sharedSigState" .= String (pack . show $ st) + ] + toJSON (TraceSigDecisions decisions) = + object [ "kind" .= String "SigDecisions" + , "decisions" .= String (pack . show $ decisions) + ] + + +data TraceSigSubmissionInbound sigid sig = + -- | Number of signatures just about to be inserted. + TraceSigSubmissionCollected [sigid] + -- | Just processed signature pass/fail breakdown. + | TraceSigSubmissionProcessed ProcessedTxCount + | TraceSigInboundCanRequestMoreSigs Int + | TraceSigInboundCannotRequestMoreSigs Int + | TraceSigInboundAddedToMempool [sigid] DiffTime + | TraceSigInboundRejectedFromMempool [sigid] DiffTime + | TraceSigInboundError TxSubmissionProtocolError + + -- + -- messages emitted by the new implementation of the server in + -- "DMQ.SigSubmission.Outbound"; some of them are also + -- used in this module. + -- + + -- | Server received 'MsgDone' + | TraceSigInboundTerminated + | TraceSigInboundDecision (SigDecision sigid sig) + | TraceControlMessage ControlMessage + deriving (Eq, Show) + +instance ( ToJSON sigid + , ToJSON sig + , Show sigid + , Show sig + ) + => ToJSON (TraceSigSubmissionInbound sigid sig) where + toJSON (TraceSigSubmissionCollected count) = + object + [ "kind" .= String "SigSubmissionCollected" + , "count" .= toJSON count + ] + toJSON (TraceSigSubmissionProcessed processed) = + object + [ "kind" .= String "SigSubmissionProcessed" + , "accepted" .= toJSON (ptxcAccepted processed) + , "rejected" .= toJSON (ptxcRejected processed) + ] + toJSON (TraceSigInboundCanRequestMoreSigs count) = + object + [ "kind" .= String "SigInboundCanRequestMoreSigs" + , "count" .= toJSON count + ] + toJSON (TraceSigInboundCannotRequestMoreSigs count) = + object + [ "kind" .= String "SigInboundCannotRequestMoreSigs" + , "count" .= toJSON count + ] + toJSON (TraceSigInboundAddedToMempool sigids diffTime') = + object + [ "kind" .= String "SigInboundAddedToMempool" + , "sigids" .= toJSON sigids + , "time" .= diffTime' + ] + toJSON (TraceSigInboundRejectedFromMempool sigids diffTime') = + object + [ "kind" .= String "SigInboundRejectedFromMempool" + , "sigids" .= toJSON sigids + , "time" .= diffTime' + ] + toJSON (TraceSigInboundError err) = + object + [ "kind" .= String "SigInboundError" + , "error" .= String (pack $ show err) + ] + toJSON TraceSigInboundTerminated = + object + [ "kind" .= String "SigInboundTerminated" + ] + toJSON (TraceSigInboundDecision decision) = + object + [ "kind" .= String "SigInboundDecision" + -- TODO: this is too verbose, it will show full sig's + , "decision" .= String (pack $ show decision) + ] + toJSON (TraceControlMessage controlMessage) = + object + [ "kind" .= String "ControlMessage" + , "controlMessage" .= String (pack $ show controlMessage) + ] + + +mkTxSubmissionCounters + :: Ord sigid + => SharedSigState peeraddr sigid sig + -> TxSubmissionCounters +mkTxSubmissionCounters + SharedSigState { + inflightSigs, + bufferedSigs, + referenceCounts, + inSubmissionToMempoolSigs + } + = + TxSubmissionCounters { + numOfOutstandingTxIds = Set.size $ Map.keysSet referenceCounts + Set.\\ Map.keysSet bufferedSigs + Set.\\ Map.keysSet inSubmissionToMempoolSigs, + numOfBufferedTxs = Map.size bufferedSigs, + numOfInSubmissionToMempoolTxs = Map.size inSubmissionToMempoolSigs, + numOfTxIdsInflight = getSum $ foldMap Sum inflightSigs + } + + +data SigSubmissionInitDelay = + SigSubmissionInitDelay DiffTime + | NoSigSubmissionInitDelay + deriving (Eq, Show) + +defaultSigSubmissionInitDelay :: SigSubmissionInitDelay +defaultSigSubmissionInitDelay = SigSubmissionInitDelay 60 diff --git a/dmq-node/src/DMQ/SigSubmission/Outbound.hs b/dmq-node/src/DMQ/SigSubmission/Outbound.hs new file mode 100644 index 0000000..03fb3ff --- /dev/null +++ b/dmq-node/src/DMQ/SigSubmission/Outbound.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DMQ.SigSubmission.Outbound + ( sigSubmissionOutbound + , TraceSigSubmissionOutbound (..) + , SigSubmissionProtocolError (..) + ) where + +import Data.Aeson (ToJSON (toJSON), Value (String), object, KeyValue ((.=))) +import Data.Foldable (find) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (catMaybes, isNothing, mapMaybe) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as Seq +import Data.Word (Word16) + +import Control.Exception (assert) +import Control.Monad (unless, when) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer (..), traceWith) + +import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), + TxSubmissionMempoolReader (..)) + +import DMQ.Protocol.SigSubmissionV2.Outbound +import DMQ.Protocol.SigSubmissionV2.Type + + +data TraceSigSubmissionOutbound sigId sig + = TraceSigSubmissionOutboundRecvMsgRequestSigs + [sigId] + -- ^ The IDs of the signatures requested. + | TraceSigSubmissionOutboundSendMsgReplySigs + [sig] + -- ^ The sigs to be sent in the response. + deriving Show + +instance (ToJSON sigId, ToJSON sig) + => ToJSON (TraceSigSubmissionOutbound sigId sig) where + toJSON (TraceSigSubmissionOutboundRecvMsgRequestSigs sigIds) = + object + [ "kind" .= String "SigSubmissionOutboundRecvMsgRequestSigs" + , "sigIds" .= sigIds + ] + toJSON (TraceSigSubmissionOutboundSendMsgReplySigs sigs) = + object + [ "kind" .= String "SigSubmissionOutboundSendMsgReplySigs" + , "sigs" .= sigs + ] + +data SigSubmissionProtocolError = + ProtocolErrorAckedTooManySigIds + | ProtocolErrorRequestedNothing + | ProtocolErrorRequestedTooManySigIds NumIdsReq Word16 NumIdsAck + | ProtocolErrorRequestBlocking + | ProtocolErrorRequestNonBlocking + | ProtocolErrorRequestedUnavailableSig + deriving Show + +instance Exception SigSubmissionProtocolError where + displayException ProtocolErrorAckedTooManySigIds = + "The peer tried to acknowledged more sigIds than are available to do so." + + displayException (ProtocolErrorRequestedTooManySigIds reqNo unackedNo maxUnacked) = + "The peer requested " ++ show reqNo ++ " sigIds which would put the " + ++ "total in flight over the limit of " ++ show maxUnacked ++ "." + ++ " Number of unacked sigIds " ++ show unackedNo + + displayException ProtocolErrorRequestedNothing = + "The peer requested zero sigIds." + + displayException ProtocolErrorRequestBlocking = + "The peer made a blocking request for more sigIds when there are still " + ++ "unacknowledged sigIds. It should have used a non-blocking request." + + displayException ProtocolErrorRequestNonBlocking = + "The peer made a non-blocking request for more sigIds when there are " + ++ "no unacknowledged sigIds. It should have used a blocking request." + + displayException ProtocolErrorRequestedUnavailableSig = + "The peer requested a signature which is not available, either " + ++ "because it was never available or because it was previously requested." + + +sigSubmissionOutbound + :: forall version sigId sig idx m. + (Ord sigId, Ord idx, MonadSTM m, MonadThrow m) + => Tracer m (TraceSigSubmissionOutbound sigId sig) + -> NumIdsAck -- ^ Maximum number of unacknowledged sigIds allowed + -> TxSubmissionMempoolReader sigId sig idx m + -> version + -> SigSubmissionOutbound sigId sig m () +sigSubmissionOutbound tracer maxUnacked TxSubmissionMempoolReader{..} _version = + SigSubmissionOutbound (pure (client Seq.empty mempoolZeroIdx)) + where + client :: StrictSeq (sigId, idx) -> idx -> OutboundStIdle sigId sig m () + client !unackedSeq !lastIdx = + OutboundStIdle { recvMsgRequestSigIds, recvMsgRequestSigs, recvMsgDone } + where + -- TODO Do I need to do something here? + recvMsgDone :: m () + recvMsgDone = pure () + + recvMsgRequestSigIds :: forall blocking. + SingBlockingStyle blocking + -> NumIdsAck + -> NumIdsReq + -> m (OutboundStSigIds blocking sigId sig m ()) + recvMsgRequestSigIds blocking ackNo reqNo = do + when (getNumIdsAck ackNo > fromIntegral (Seq.length unackedSeq)) $ + throwIO ProtocolErrorAckedTooManySigIds + + let unackedNo = fromIntegral (Seq.length unackedSeq) + when ( unackedNo + - getNumIdsAck ackNo + + getNumIdsReq reqNo + > getNumIdsAck maxUnacked) $ + throwIO (ProtocolErrorRequestedTooManySigIds reqNo unackedNo maxUnacked) + + -- Update our tracking state to remove the number of sigIds that the + -- peer has acknowledged. + let !unackedSeq' = Seq.drop (fromIntegral ackNo) unackedSeq + + -- Update our tracking state with any extra sigs available. + let update sigs = + -- These sigs should all be fresh + assert (all (\(_, idx, _) -> idx > lastIdx) sigs) $ + let !unackedSeq'' = unackedSeq' <> Seq.fromList + [ (sigId, idx) | (sigId, idx, _) <- sigs ] + !lastIdx' + | null sigs = lastIdx + | otherwise = idx where (_, idx, _) = last sigs + sigs' :: [(sigId, SizeInBytes)] + sigs' = [ (sigId, size) | (sigId, _, size) <- sigs ] + client' = client unackedSeq'' lastIdx' + in (sigs', client') + + -- Grab info about any new sigs after the last sig idx we've seen, + -- up to the number that the peer has requested. + case blocking of + SingBlocking -> do + when (reqNo == 0) $ + throwIO ProtocolErrorRequestedNothing + unless (Seq.null unackedSeq') $ + throwIO ProtocolErrorRequestBlocking + + sigs <- atomically $ + do + MempoolSnapshot{mempoolTxIdsAfter} <- mempoolGetSnapshot + let sigs = mempoolTxIdsAfter lastIdx + check (not $ null sigs) + pure (take (fromIntegral reqNo) sigs) + + let !(sigs', client') = update sigs + sigs'' = case NonEmpty.nonEmpty sigs' of + Just x -> x + -- Assert sigs is non-empty: we blocked until sigs was non-null, + -- and we know reqNo > 0, hence `take reqNo sigs` is non-null. + Nothing -> error "sigSubmissionOutbound: empty signature list" + pure (SendMsgReplySigIds (BlockingReply sigs'') client') + + SingNonBlocking -> do + when (reqNo == 0 && ackNo == 0) $ + throwIO ProtocolErrorRequestedNothing + when (Seq.null unackedSeq') $ + throwIO ProtocolErrorRequestNonBlocking + + sigs <- atomically $ do + MempoolSnapshot{mempoolTxIdsAfter} <- mempoolGetSnapshot + let sigs = mempoolTxIdsAfter lastIdx + return (take (fromIntegral reqNo) sigs) + + let !(sigs', client') = update sigs + pure (SendMsgReplySigIds (NonBlockingReply sigs') client') + + recvMsgRequestSigs :: [sigId] + -> m (OutboundStSigs sigId sig m ()) + recvMsgRequestSigs sigIds = do + -- Trace the IDs of the signatures requested. + traceWith tracer (TraceSigSubmissionOutboundRecvMsgRequestSigs sigIds) + + MempoolSnapshot{mempoolLookupTx} <- atomically mempoolGetSnapshot + + -- The window size is expected to be small (currently 10) so the find is acceptable. + let sigIdxs = [ find (\(t,_) -> t == sigId) unackedSeq | sigId <- sigIds ] + sigIdxs' = map snd $ catMaybes sigIdxs + + when (any isNothing sigIdxs) $ + throwIO ProtocolErrorRequestedUnavailableSig + + -- The 'mempoolLookupTx' will return nothing if the signature is no + -- longer in the mempool. This is good. Neither the sending nor + -- receiving side wants to forward sigs that are no longer of interest. + let sigs = mapMaybe mempoolLookupTx sigIdxs' + client' = client unackedSeq lastIdx + + -- Trace the sigs to be sent in the response. + traceWith tracer (TraceSigSubmissionOutboundSendMsgReplySigs sigs) + + return $ SendMsgReplySigs sigs client' From 89bb6209578bcdcdfbd16509e588f7dd87ffbe00 Mon Sep 17 00:00:00 2001 From: edgr Date: Wed, 14 Jan 2026 17:49:02 +0800 Subject: [PATCH 05/11] SigSubmissionV2 message type fix --- .../DMQ/Protocol/SigSubmissionV2/Inbound.hs | 16 +++--- .../DMQ/Protocol/SigSubmissionV2/Outbound.hs | 2 +- .../src/DMQ/Protocol/SigSubmissionV2/Type.hs | 55 ++++++++++++++++--- 3 files changed, 58 insertions(+), 15 deletions(-) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs index 99958a4..e1f1db6 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Inbound.hs @@ -21,6 +21,8 @@ module DMQ.Protocol.SigSubmissionV2.Inbound ) where import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Network.TypedProtocol.Core import Network.TypedProtocol.Peer (Peer, PeerPipelined (..)) import Network.TypedProtocol.Peer.Client @@ -28,7 +30,7 @@ import DMQ.Protocol.SigSubmissionV2.Type data SigSubmissionInboundPipelined sigId sig m a where SigSubmissionInboundPipelined - :: InboundStIdle Z sigId sig m a + :: m (InboundStIdle Z sigId sig m a) -> SigSubmissionInboundPipelined sigId sig m a -- | This is the type of the pipelined results, collected by 'CollectPipelined'. @@ -38,20 +40,20 @@ data SigSubmissionInboundPipelined sigId sig m a where data Collect sigId sig = -- | The result of 'SendMsgRequestSigIdsPipelined'. It also carries -- the number of sigIds originally requested. - CollectSigIds NumIdsReq [sigId] + CollectSigIds NumIdsReq [(sigId, SizeInBytes)] | -- | The result of 'SendMsgRequestSigsPipelined'. The actual reply only -- contains the signatures sent, but this pairs them up with the -- requested identifiers. This is for the peer to determine whether some -- signatures are no longer needed. - CollectSigs [sigId] [sig] + CollectSigs (Map sigId SizeInBytes) [sig] data InboundStIdle (n :: N) sigId sig m a where SendMsgRequestSigIdsBlocking :: NumIdsAck -- ^ number of sigIds to acknowledge -> NumIdsReq -- ^ number of sigIds to request - -> ([sigId] -> m (InboundStIdle Z sigId sig m a)) + -> ([(sigId, SizeInBytes)] -> m (InboundStIdle Z sigId sig m a)) -> InboundStIdle Z sigId sig m a SendMsgRequestSigIdsPipelined @@ -61,7 +63,7 @@ data InboundStIdle (n :: N) sigId sig m a where -> InboundStIdle n sigId sig m a SendMsgRequestSigsPipelined - :: [sigId] + :: Map sigId SizeInBytes -> m (InboundStIdle (S n) sigId sig m a) -> InboundStIdle n sigId sig m a @@ -83,7 +85,7 @@ sigSubmissionV2InboundPeerPipelined => SigSubmissionInboundPipelined sigId sig m a -> PeerPipelined (SigSubmissionV2 sigId sig) AsClient StIdle m a sigSubmissionV2InboundPeerPipelined (SigSubmissionInboundPipelined inboundSt) = - PeerPipelined $ run inboundSt + PeerPipelined $ Effect (run <$> inboundSt) where run :: InboundStIdle n sigId sig m a -> Peer (SigSubmissionV2 sigId sig) AsClient (Pipelined n (Collect sigId sig)) StIdle m a @@ -108,7 +110,7 @@ sigSubmissionV2InboundPeerPipelined (SigSubmissionInboundPipelined inboundSt) = run (SendMsgRequestSigsPipelined sigIds k) = YieldPipelined - (MsgRequestSigs sigIds) + (MsgRequestSigs $ Map.keys sigIds) (ReceiverAwait $ \(MsgReplySigs sigs) -> ReceiverDone (CollectSigs sigIds sigs) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs index a3f0f3f..49970ee 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Outbound.hs @@ -64,7 +64,7 @@ data OutboundStIdle sigId sig m a = OutboundStIdle { data OutboundStSigIds blocking sigId sig m a where SendMsgReplySigIds :: SingI blocking - => BlockingReplyList blocking sigId + => BlockingReplyList blocking (sigId, SizeInBytes) -> OutboundStIdle sigId sig m a -> OutboundStSigIds blocking sigId sig m a diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs index cf9976a..368f133 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Type.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -36,17 +36,22 @@ module DMQ.Protocol.SigSubmissionV2.Type ) where import Control.DeepSeq (NFData (..)) +import Data.Aeson (ToJSON (toJSON), Value (String), KeyValue ((.=)), object) import Data.Kind (Type) import Data.Monoid (Sum (..)) import Data.Singletons +import Data.Text (pack) import Data.Word (Word16) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Quiet (Quiet (..)) +import Network.TypedProtocol.Codec (AnyMessage(AnyMessageAndAgency)) import Network.TypedProtocol.Core -import DMQ.Protocol.SigSubmission.Type as SigSubmission (SigId (..), SigBody (..), SigKESSignature (..), SigOpCertificate (..), SigColdKey (..), SigRaw (..), SigRawWithSignedBytes (..), Sig (..)) +import DMQ.Protocol.SigSubmission.Type as SigSubmission (SigId (..), + SigBody (..), SigKESSignature (..), SigOpCertificate (..), + SigColdKey (..), SigRaw (..), SigRawWithSignedBytes (..), Sig (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type (BlockingReplyList (..), SingBlockingStyle (..), StBlockingStyle (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) @@ -93,6 +98,40 @@ instance ( ShowProxy sigId instance ShowProxy (StIdle :: SigSubmissionV2 sigId sig) where showProxy _ = "StIdle" +instance (Show sigId, Show sig) + => ToJSON (AnyMessage (SigSubmissionV2 sigId sig)) where + toJSON (AnyMessageAndAgency stok MsgRequestSigIds{}) = + object + [ "kind" .= String "MsgRequestSigIds" + , "agency" .= String (pack $ show stok) + ] + toJSON (AnyMessageAndAgency stok (MsgReplySigIds ids)) = + object + [ "kind" .= String "MsgReplySigIds" + , "agency" .= String (pack $ show stok) + , "ids" .= String (pack $ show ids) + ] + toJSON (AnyMessageAndAgency stok MsgReplyNoSigIds) = + object + [ "kind" .= String "MsgReplyNoSigIds" + , "agency" .= String (pack $ show stok) + ] + toJSON (AnyMessageAndAgency stok (MsgRequestSigs{})) = + object + [ "kind" .= String "MsgRequestSigs" + , "agency" .= String (pack $ show stok) + ] + toJSON (AnyMessageAndAgency stok (MsgReplySigs sigs)) = + object + [ "kind" .= String "MsgReplySigs" + , "agency" .= String (pack $ show stok) + , "sigs" .= String (pack $ show sigs) + ] + toJSON (AnyMessageAndAgency stok MsgDone) = + object + [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] type SingSigSubmissionV2 @@ -174,7 +213,7 @@ instance Protocol (SigSubmissionV2 sigId sig) where -- number of outstanding identifiers. -- -- With 'TokBlocking' this is a blocking operation but it's not guaranteed - -- taht the server will respond with signatures. The server might block for + -- that the server will respond with signatures. The server might block for -- only a limited time waiting for signaures, if it times out it will reply -- with `MsgReplyNoSigs` to let the client regain control of the protocol. -- @@ -205,13 +244,14 @@ instance Protocol (SigSubmissionV2 sigId sig) where -- -- * The non-blocking case __MUST__ be used when there are non-zero -- remaining unacknowledged signatures. - + -- MsgRequestSigIds :: forall (blocking :: StBlockingStyle) sigId sig. SingBlockingStyle blocking -> NumIdsAck -- ^ Acknowledge this number of outstanding signatures -> NumIdsReq -- ^ Request up to this number of identifiers -> Message (SigSubmissionV2 sigId sig) StIdle (StSigIds blocking) + -- | Reply with a list of object identifiers for available objects, along -- with the size of each object. -- @@ -226,9 +266,9 @@ instance Protocol (SigSubmissionV2 sigId sig) where -- The order in which these object identifiers are returned must be the -- order in which they are submitted to the mempool, to preserve dependent -- objects. - + -- MsgReplySigIds - :: BlockingReplyList blocking sigId + :: BlockingReplyList blocking (sigId, SizeInBytes) -> Message (SigSubmissionV2 sigId sig) (StSigIds blocking) StIdle -- | The blocking request `MsgRequestSigIds` can be replied with no @@ -248,6 +288,7 @@ instance Protocol (SigSubmissionV2 sigId sig) where -- -- It is an error to ask for identifiers that are not -- outstanding or that were already asked for. + -- MsgRequestSigs :: [sigId] -> Message (SigSubmissionV2 sigId sig) StIdle StSigs @@ -262,7 +303,7 @@ instance Protocol (SigSubmissionV2 sigId sig) where -- should be considered as if this peer had never announced them. (Note -- that this is no guarantee that the signature is invalid, it may still be -- valid and available from another peer). - + -- MsgReplySigs :: [sig] -> Message (SigSubmissionV2 sigId sig) StSigs StIdle From 0f772d152c8cfe82bd25d74fe17c06c984c69723 Mon Sep 17 00:00:00 2001 From: edgr Date: Wed, 14 Jan 2026 18:56:30 +0800 Subject: [PATCH 06/11] Stitching --- dmq-node/src/DMQ/Configuration.hs | 22 ++--- dmq-node/src/DMQ/Diffusion/NodeKernel.hs | 18 ++-- dmq-node/src/DMQ/NodeToNode.hs | 96 ++++++++++--------- .../src/DMQ/Protocol/SigSubmission/Codec.hs | 18 ++-- .../src/DMQ/Protocol/SigSubmissionV2/Codec.hs | 31 ++++-- 5 files changed, 101 insertions(+), 84 deletions(-) diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index 88679f7..8acd690 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -73,9 +73,9 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (LocalAddress (..), RemoteAddress) -import Ouroboros.Network.TxSubmission.Inbound.V2 (TxDecisionPolicy (..)) import DMQ.Configuration.Topology (NoExtraConfig (..), NoExtraFlags (..)) +import DMQ.SigSubmission.Inbound (SigDecisionPolicy (..)) -- | Configuration comes in two flavours paramemtrised by `f` functor: -- `PartialConfig` is using `Last` and `Configuration` is using an identity @@ -576,16 +576,16 @@ mkDiffusionConfiguration -- TODO: review this once we know what is the size of a `Sig`. -- TODO: parts of should be configurable -defaultSigDecisionPolicy :: TxDecisionPolicy -defaultSigDecisionPolicy = TxDecisionPolicy { - maxNumTxIdsToRequest = 10, - maxUnacknowledgedTxIds = 40, - txsSizeInflightPerPeer = 100_000, - maxTxsSizeInflight = 250_000, - txInflightMultiplicity = 1, - bufferedTxsMinLifetime = 0, - scoreRate = 0.1, - scoreMax = 15 * 60 +defaultSigDecisionPolicy :: SigDecisionPolicy +defaultSigDecisionPolicy = SigDecisionPolicy { + maxNumSigIdsToRequest = 10, + maxUnacknowledgedSigIds = 40, + sigsSizeInflightPerPeer = 100_000, + maxSigsSizeInflight = 250_000, + sigInflightMultiplicity = 1, + bufferedSigsMinLifetime = 0, + scoreRate = 0.1, + scoreMax = 15 * 60 } data ConfigurationError = diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index 27c7e08..a99d1b9 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -48,13 +48,13 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry, newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) -import Ouroboros.Network.TxSubmission.Inbound.V2 import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool (..), MempoolSeq (..)) import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool -import DMQ.Configuration +import DMQ.Configuration as Conf import DMQ.Protocol.SigSubmission.Type (Sig (sigExpiresAt, sigId), SigId) +import DMQ.SigSubmission.Inbound import DMQ.Tracer @@ -68,9 +68,9 @@ data NodeKernel crypto ntnAddr m = , peerSharingRegistry :: !(PeerSharingRegistry ntnAddr m) , peerSharingAPI :: !(PeerSharingAPI ntnAddr StdGen m) , mempool :: !(Mempool m SigId (Sig crypto)) - , sigChannelVar :: !(TxChannelsVar m ntnAddr SigId (Sig crypto)) - , sigMempoolSem :: !(TxMempoolSem m) - , sigSharedTxStateVar :: !(SharedTxStateVar m ntnAddr SigId (Sig crypto)) + , sigChannelVar :: !(SigChannelsVar m ntnAddr SigId (Sig crypto)) + , sigMempoolSem :: !(SigMempoolSem m) + , sigSharedTxStateVar :: !(SharedSigStateVar m ntnAddr SigId (Sig crypto)) , stakePools :: !(StakePools m) , nextEpochVar :: !(StrictTVar m (Maybe UTCTime)) } @@ -118,10 +118,10 @@ newNodeKernel rng = do peerSharingRegistry <- newPeerSharingRegistry mempool <- Mempool.empty - sigChannelVar <- newTxChannelsVar - sigMempoolSem <- newTxMempoolSem + sigChannelVar <- newSigChannelsVar + sigMempoolSem <- newSigMempoolSem let (rng', rng'') = Random.split rng - sigSharedTxStateVar <- newSharedTxStateVar rng' + sigSharedTxStateVar <- newSharedSigStateVar rng' (nextEpochVar, ocertCountersVar, stakePoolsVar, ledgerBigPeersVar, ledgerPeersVar) <- atomically $ (,,,,) <$> newTVar Nothing <*> newTVar Map.empty @@ -196,7 +196,7 @@ withNodeKernel tracer then WithEventType "SigSubmission.Logic" >$< tracer else nullTracer) nullTracer - defaultSigDecisionPolicy + Conf.defaultSigDecisionPolicy sigChannelVar sigSharedTxStateVar) $ \sigLogicThread -> diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index ffc8149..9e355ed 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -57,8 +57,13 @@ import Cardano.KESAgent.KES.Crypto (Crypto (..)) import DMQ.Configuration (Configuration, Configuration' (..), I (..)) import DMQ.Diffusion.NodeKernel (NodeKernel (..)) import DMQ.NodeToNode.Version -import DMQ.Protocol.SigSubmission.Codec -import DMQ.Protocol.SigSubmission.Type +import DMQ.Protocol.SigSubmission.Codec (codecSigSubmission) +import DMQ.Protocol.SigSubmissionV2.Codec +import DMQ.Protocol.SigSubmissionV2.Inbound (sigSubmissionV2InboundPeerPipelined) +import DMQ.Protocol.SigSubmissionV2.Outbound (sigSubmissionV2OutboundPeer) +import DMQ.Protocol.SigSubmissionV2.Type +import DMQ.SigSubmission.Inbound as SigSubmission +import DMQ.SigSubmission.Outbound import DMQ.Tracer import Ouroboros.Network.BlockFetch.ClientRegistry (bracketKeepAliveClient) @@ -84,9 +89,8 @@ import Ouroboros.Network.PeerSelection (PeerSharing (..)) import Ouroboros.Network.PeerSharing (bracketPeerSharingClient, peerSharingClient, peerSharingServer) import Ouroboros.Network.Snocket (RemoteAddress) -import Ouroboros.Network.TxSubmission.Inbound.V2 as SigSubmission +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionMempoolWriter) import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.OrphanInstances () @@ -105,9 +109,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, codecPeerSharing, timeLimitsPeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Server (peerSharingServerPeer) import Ouroboros.Network.Protocol.PeerSharing.Type qualified as Protocol -import Ouroboros.Network.Protocol.TxSubmission2.Client (txSubmissionClientPeer) -import Ouroboros.Network.Protocol.TxSubmission2.Server - (txSubmissionServerPeerPipelined) + -- TODO: if we add `versionNumber` to `ctx` we could use `RunMiniProtocolCb`. -- This makes sense, since `ctx` already contains `versionData`. @@ -170,7 +172,7 @@ ntnApps -> NodeKernel crypto addr m -> Codecs crypto addr m -> LimitsAndTimeouts crypto addr - -> TxDecisionPolicy + -> SigDecisionPolicy -> Apps addr m () () ntnApps tracer @@ -227,36 +229,11 @@ ntnApps -> ExpandedInitiatorContext addr m -> Channel m BL.ByteString -> m ((), Maybe BL.ByteString) - aSigSubmissionClient version + aSigSubmissionClient _version ExpandedInitiatorContext { eicConnectionId = connId, eicControlMessage = controlMessage } channel = - runAnnotatedPeerWithLimits - (if sigSubmissionClientProtocolTracer - then WithEventType "SigSubmission.Protocol.Client" . Mx.WithBearer connId >$< tracer - else nullTracer) - sigSubmissionCodec - sigSubmissionSizeLimits - sigSubmissionTimeLimits - channel - $ txSubmissionClientPeer - $ txSubmissionOutbound - (if sigSubmissionOutboundTracer - then WithEventType "SigSubmission.Outbound" . Mx.WithBearer connId >$< tracer - else nullTracer) - _MAX_SIGS_TO_ACK - mempoolReader - version - controlMessage - - - aSigSubmissionServer - :: NodeToNodeVersion - -> ResponderContext addr - -> Channel m BL.ByteString - -> m ((), Maybe BL.ByteString) - aSigSubmissionServer _version ResponderContext { rcConnectionId = connId } channel = SigSubmission.withPeer (if sigSubmissionLogicTracer then WithEventType "SigSubmission.Logic" . Mx.WithBearer connId >$< tracer @@ -269,7 +246,7 @@ ntnApps mempoolWriter sigSize (remoteAddress connId) - $ \(peerSigAPI :: PeerTxAPI m SigId (Sig crypto)) -> + $ \(peerSigAPI :: PeerSigAPI m SigId (Sig crypto)) -> runPipelinedAnnotatedPeerWithLimits (if sigSubmissionServerProtocolTracer then WithEventType "SigSubmission.Protocol.Server" . Mx.WithBearer connId >$< tracer @@ -278,14 +255,39 @@ ntnApps sigSubmissionSizeLimits sigSubmissionTimeLimits channel - $ txSubmissionServerPeerPipelined - $ txSubmissionInboundV2 + $ sigSubmissionV2InboundPeerPipelined + $ sigSubmissionInboundV2 (if sigSubmissionInboundTracer then WithEventType "SigSubmission.Inbound" . Mx.WithBearer connId >$< tracer else nullTracer) _SIG_SUBMISSION_INIT_DELAY mempoolWriter peerSigAPI + controlMessage + + + aSigSubmissionServer + :: NodeToNodeVersion + -> ResponderContext addr + -> Channel m BL.ByteString + -> m ((), Maybe BL.ByteString) + aSigSubmissionServer version ResponderContext { rcConnectionId = connId } channel = + runAnnotatedPeerWithLimits + (if sigSubmissionClientProtocolTracer + then WithEventType "SigSubmission.Protocol.Client" . Mx.WithBearer connId >$< tracer + else nullTracer) + sigSubmissionCodec + sigSubmissionSizeLimits + sigSubmissionTimeLimits + channel + $ sigSubmissionV2OutboundPeer + $ sigSubmissionOutbound + (if sigSubmissionOutboundTracer + then WithEventType "SigSubmission.Outbound" . Mx.WithBearer connId >$< tracer + else nullTracer) + _MAX_SIGS_TO_ACK + mempoolReader + version aKeepAliveClient @@ -532,7 +534,7 @@ initiatorAndResponderProtocols limitsAndTimeouts data Codecs crypto addr m = Codecs { - sigSubmissionCodec :: AnnotatedCodec (SigSubmission crypto) + sigSubmissionCodec :: AnnotatedCodec (SigSubmissionV2 SigId (Sig crypto)) CBOR.DeserialiseFailure m BL.ByteString , keepAliveCodec :: Codec KeepAlive CBOR.DeserialiseFailure m BL.ByteString @@ -540,8 +542,8 @@ data Codecs crypto addr m = CBOR.DeserialiseFailure m BL.ByteString } -dmqCodecs :: ( Crypto crypto - , MonadST m +dmqCodecs :: ( MonadST m + , Crypto crypto ) => (addr -> CBOR.Encoding) -> (forall s. CBOR.Decoder s addr) @@ -559,9 +561,9 @@ data LimitsAndTimeouts crypto addr = sigSubmissionLimits :: MiniProtocolLimits , sigSubmissionSizeLimits - :: ProtocolSizeLimits (SigSubmission crypto) BL.ByteString + :: ProtocolSizeLimits (SigSubmissionV2 SigId (Sig crypto)) BL.ByteString , sigSubmissionTimeLimits - :: ProtocolTimeLimits (SigSubmission crypto) + :: ProtocolTimeLimits (SigSubmissionV2 SigId (Sig crypto)) -- keep-alive , keepAliveLimits @@ -588,8 +590,8 @@ dmqLimitsAndTimeouts = -- TODO maximumIngressQueue = maxBound } - , sigSubmissionTimeLimits = timeLimitsSigSubmission - , sigSubmissionSizeLimits = byteLimitsSigSubmission size + , sigSubmissionTimeLimits = timeLimitsSigSubmissionV2 + , sigSubmissionSizeLimits = byteLimitsSigSubmissionV2 size , keepAliveLimits = MiniProtocolLimits { @@ -652,11 +654,11 @@ stdVersionDataNTN networkMagic diffusionMode peerSharing = } -- TODO: choose wisely, is a protocol parameter. -_MAX_SIGS_TO_ACK :: NumTxIdsToAck +_MAX_SIGS_TO_ACK :: NumIdsAck _MAX_SIGS_TO_ACK = 20 -_SIG_SUBMISSION_INIT_DELAY :: TxSubmissionInitDelay -_SIG_SUBMISSION_INIT_DELAY = NoTxSubmissionInitDelay +_SIG_SUBMISSION_INIT_DELAY :: SigSubmissionInitDelay +_SIG_SUBMISSION_INIT_DELAY = NoSigSubmissionInitDelay -- TODO: this is duplicated code, similar function is in diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs index aa09d11..dbe2275 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs @@ -38,11 +38,14 @@ import Cardano.Crypto.KES.Class (decodeSigKES, decodeVerKeyKES, encodeVerKeyKES) import Cardano.KESAgent.KES.Crypto (Crypto (..)) import Cardano.KESAgent.KES.OCert (OCert (..)) -import DMQ.Protocol.SigSubmission.Type import Ouroboros.Network.Protocol.Codec.Utils qualified as Utils import Ouroboros.Network.Protocol.Limits import Ouroboros.Network.Protocol.TxSubmission2.Codec qualified as TX +import DMQ.Protocol.SigSubmission.Type +import DMQ.Protocol.SigSubmissionV2.Type (SigSubmissionV2) +import DMQ.Protocol.SigSubmissionV2.Codec (codecSigSubmissionV2Id) + -- | 'SigSubmission' time limits. @@ -135,10 +138,10 @@ codecSigSubmission ) => AnnotatedCodec (SigSubmission crypto) CBOR.DeserialiseFailure m ByteString codecSigSubmission = - TX.anncodecTxSubmission2' - SigWithBytes - encodeSigId decodeSigId - encodeSig decodeSig + TX.anncodecTxSubmission2' + SigWithBytes + encodeSigId decodeSigId + encodeSig decodeSig encodeSig :: Sig crypto -> CBOR.Encoding @@ -189,5 +192,6 @@ decodeSig = do codecSigSubmissionId :: Monad m - => Codec (SigSubmission crypto) CodecFailure m (AnyMessage (SigSubmission crypto)) -codecSigSubmissionId = TX.codecTxSubmission2Id + => Codec (SigSubmissionV2 sigId sig) CodecFailure m (AnyMessage (SigSubmissionV2 sigId sig)) +codecSigSubmissionId = codecSigSubmissionV2Id + diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs index c81c9f4..b9581ce 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs @@ -15,18 +15,22 @@ module DMQ.Protocol.SigSubmissionV2.Codec , encodeSigSubmissionV2 ) where -import Codec.CBOR.Decoding qualified as CBOR -import Codec.CBOR.Encoding qualified as CBOR -import Codec.CBOR.Read qualified as CBOR import Control.Monad.Class.MonadST import Control.Monad.Class.MonadTime.SI import Data.ByteString.Lazy (ByteString) import Data.Kind (Type) import Data.List.NonEmpty qualified as NonEmpty -import DMQ.Protocol.SigSubmissionV2.Type +import Text.Printf + +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.CBOR.Read qualified as CBOR + import Network.TypedProtocol.Codec.CBOR + import Ouroboros.Network.Protocol.Limits -import Text.Printf + +import DMQ.Protocol.SigSubmissionV2.Type -- | Byte Limits. byteLimitsSigSubmissionV2 @@ -130,10 +134,13 @@ encodeSigSubmissionV2 encodeObjectId encodeObject = encode encode (MsgReplySigIds objIds) = CBOR.encodeListLen 2 - <> CBOR.encodeWord 2 + <> CBOR.encodeWord 1 -- TODO 1 or 2? <> CBOR.encodeListLenIndef - <> foldMap encodeObjectId objIds - <> CBOR.encodeBreak + <> foldr (\(sigid, SizeInBytes sz) r -> + CBOR.encodeListLen 2 + <> encodeObjectId sigid + <> CBOR.encodeWord32 sz + <> r) CBOR.encodeBreak objIds encode MsgReplyNoSigIds = CBOR.encodeListLen 1 @@ -187,13 +194,17 @@ decodeSigSubmissionV2 decodeSigId decodeSig = decode then SomeMessage $ MsgRequestSigIds SingBlocking ackNo reqNo else SomeMessage $ MsgRequestSigIds SingNonBlocking ackNo reqNo - (SingSigIds b, 2, 2) -> do + -- (SingSigIds b, 2, 2) -> do TODO 1 or 2? + (SingSigIds b, 2, 1) -> do CBOR.decodeListLenIndef sigIds <- CBOR.decodeSequenceLenIndef (flip (:)) [] reverse - decodeSigId + (do CBOR.decodeListLenOf 2 + sigid <- decodeSigId + sz <- CBOR.decodeWord32 + return (sigid, SizeInBytes sz)) case (b, sigIds) of (SingBlocking, t : ts) -> return From 8a64f6d50a5b5277918bdf9d28bec3d33fbf1485 Mon Sep 17 00:00:00 2001 From: edgr Date: Thu, 15 Jan 2026 14:09:44 +0800 Subject: [PATCH 07/11] Signature decoder --- .../src/DMQ/Protocol/SigSubmission/Codec.hs | 8 +- .../src/DMQ/Protocol/SigSubmissionV2/Codec.hs | 137 +++++++++++++++++- 2 files changed, 138 insertions(+), 7 deletions(-) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs index dbe2275..dda716f 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs @@ -40,11 +40,11 @@ import Cardano.KESAgent.KES.OCert (OCert (..)) import Ouroboros.Network.Protocol.Codec.Utils qualified as Utils import Ouroboros.Network.Protocol.Limits -import Ouroboros.Network.Protocol.TxSubmission2.Codec qualified as TX import DMQ.Protocol.SigSubmission.Type import DMQ.Protocol.SigSubmissionV2.Type (SigSubmissionV2) -import DMQ.Protocol.SigSubmissionV2.Codec (codecSigSubmissionV2Id) +import DMQ.Protocol.SigSubmissionV2.Codec (codecSigSubmissionV2Id, + anncodecSigSubmissionV2) @@ -136,9 +136,9 @@ codecSigSubmission ( Crypto crypto , MonadST m ) - => AnnotatedCodec (SigSubmission crypto) CBOR.DeserialiseFailure m ByteString + => AnnotatedCodec (SigSubmissionV2 SigId (Sig crypto)) CBOR.DeserialiseFailure m ByteString codecSigSubmission = - TX.anncodecTxSubmission2' + anncodecSigSubmissionV2 SigWithBytes encodeSigId decodeSigId encodeSig decodeSig diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs index b9581ce..7fc4700 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +14,7 @@ module DMQ.Protocol.SigSubmissionV2.Codec , byteLimitsSigSubmissionV2 , timeLimitsSigSubmissionV2 , encodeSigSubmissionV2 + , anncodecSigSubmissionV2 ) where import Control.Monad.Class.MonadST @@ -25,9 +27,11 @@ import Text.Printf import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR - + import Network.TypedProtocol.Codec.CBOR +import Ouroboros.Network.Protocol.Codec.Utils (WithByteSpan (..)) +import Ouroboros.Network.Protocol.Codec.Utils qualified as Utils import Ouroboros.Network.Protocol.Limits import DMQ.Protocol.SigSubmissionV2.Type @@ -233,12 +237,12 @@ decodeSigSubmissionV2 decodeSigId decodeSig = decode (SingSigs, 2, 5) -> do CBOR.decodeListLenIndef - sigIds <- CBOR.decodeSequenceLenIndef + sigs <- CBOR.decodeSequenceLenIndef (flip (:)) [] reverse decodeSig - return $ SomeMessage $ MsgReplySigs sigIds + return $ SomeMessage $ MsgReplySigs sigs (SingIdle, 1, 6) -> return $ SomeMessage MsgDone @@ -304,3 +308,130 @@ codecSigSubmissionV2Id = Codec {encode, decode} notActiveState stok (_, _) -> DecodeFail $ CodecFailure "codecSigSubmissionV2Id: no matching message" + + +-- | An 'AnnotatedCodec' with a custom `sigWithBytes` wrapper of `sig`, +-- e.g. `sigWithBytes ~ WithBytes sig`. +-- +anncodecSigSubmissionV2 + :: forall (sigId :: Type) (sig :: Type) (sigWithBytes :: Type) m. + MonadST m + => (ByteString -> sig -> sigWithBytes) + -- ^ `withBytes` constructor + -> (sigId -> CBOR.Encoding) + -- ^ encode 'sigid' + -> (forall s . CBOR.Decoder s sigId) + -- ^ decode 'sigid' + -> (sigWithBytes -> CBOR.Encoding) + -- ^ encode `sig` + -> (forall s . CBOR.Decoder s (ByteString -> sig)) + -- ^ decode transaction + -> AnnotatedCodec (SigSubmissionV2 sigId sigWithBytes) CBOR.DeserialiseFailure m ByteString +anncodecSigSubmissionV2 mkWithBytes encodeSigId decodeSigId + encodeSig decodeSig = + mkCodecCborLazyBS + (encodeSigSubmissionV2 encodeSigId encodeSig) + decode + where + decode :: forall (st :: SigSubmissionV2 sigId sigWithBytes). + ActiveState st + => StateToken st + -> forall s. CBOR.Decoder s (Annotator ByteString st) + decode = + decodeSigSubmissionV2' @sig + @sigWithBytes + @WithByteSpan + @ByteString + mkWithBytes' + decodeSigId + (Utils.decodeWithByteSpan decodeSig) + + mkWithBytes' :: ByteString + -> WithByteSpan (ByteString -> sig) + -> sigWithBytes + mkWithBytes' bytes (WithByteSpan (fn, start, end)) = + mkWithBytes (Utils.bytesBetweenOffsets start end bytes) -- bytes of the transaction + (fn bytes) -- note: fn expects full bytes + + +decodeSigSubmissionV2' + :: forall (sig :: Type) + (sigWithBytes :: Type) + (withByteSpan :: Type -> Type) + (bytes :: Type) + (sigId :: Type) + (st :: SigSubmissionV2 sigId sigWithBytes) + s. + ActiveState st + => (bytes -> withByteSpan (bytes -> sig) -> sigWithBytes) + -> (forall s'. CBOR.Decoder s' sigId) -- ^ decode 'sigId' + -> (forall s'. CBOR.Decoder s' (withByteSpan (bytes -> sig))) + -> StateToken st + -> CBOR.Decoder s (Annotator bytes st) +decodeSigSubmissionV2' mkWithBytes decodeSigId decodeSig sok = do + len <- CBOR.decodeListLen + key <- CBOR.decodeWord + decode sok len key + where + decode stok len key = do + case (stok, len, key) of + (SingIdle, 4, 1) -> do + blocking <- CBOR.decodeBool + ackNo <- NumIdsAck <$> CBOR.decodeWord16 + reqNo <- NumIdsReq <$> CBOR.decodeWord16 + return $! if blocking + then Annotator $ \_ -> SomeMessage $ MsgRequestSigIds SingBlocking ackNo reqNo + else Annotator $ \_ -> SomeMessage $ MsgRequestSigIds SingNonBlocking ackNo reqNo + + -- (SingSigIds b, 2, 2) -> do TODO 1 or 2? + (SingSigIds b, 2, 1) -> do + CBOR.decodeListLenIndef + sigIds <- CBOR.decodeSequenceLenIndef + (flip (:)) + [] + reverse + (do CBOR.decodeListLenOf 2 + sigid <- decodeSigId + sz <- CBOR.decodeWord32 + return (sigid, SizeInBytes sz)) + case (b, sigIds) of + (SingBlocking, t : ts) -> + return + $ Annotator $ \_ -> SomeMessage $ MsgReplySigIds (BlockingReply (t NonEmpty.:| ts)) + + (SingNonBlocking, ts) -> + return + $ Annotator $ \_ -> SomeMessage $ MsgReplySigIds (NonBlockingReply ts) + + (SingBlocking, []) -> + fail "codecSigSubmissionV2: MsgReplySigIds: empty list not permitted" + + (SingSigIds SingBlocking, 1, 3) -> + return (Annotator $ \_ -> SomeMessage MsgReplyNoSigIds) + + (SingIdle, 2, 4) -> do + CBOR.decodeListLenIndef + sigIds <- CBOR.decodeSequenceLenIndef + (flip (:)) + [] + reverse + decodeSigId + return $ Annotator $ \_ -> SomeMessage $ MsgRequestSigs sigIds + + (SingSigs, 2, 5) -> do + CBOR.decodeListLenIndef + sigs <- CBOR.decodeSequenceLenIndef + (flip (:)) + [] + reverse + decodeSig + return (Annotator $ \bytes -> SomeMessage (MsgReplySigs $ mkWithBytes bytes <$> sigs)) + + (SingIdle, 1, 6) -> + return $ Annotator $ \_ -> SomeMessage MsgDone + + (SingDone, _, _) -> notActiveState stok + + -- failures + (_, _, _) -> + fail $ printf "codecSigSubmissionV2 (%s) unexpected key %d, length %d" (show stok) key len From a2cbe5da2adf304d09a399f8adda30f22d229b1b Mon Sep 17 00:00:00 2001 From: edgr Date: Thu, 15 Jan 2026 17:14:52 +0800 Subject: [PATCH 08/11] Codec V1 and V2 fixes --- dmq-node/src/DMQ/NodeToNode.hs | 6 ++--- .../src/DMQ/Protocol/SigSubmission/Codec.hs | 24 ++++++++++++++----- .../src/DMQ/Protocol/SigSubmissionV2/Codec.hs | 2 +- .../DMQ/Protocol/LocalMsgNotification/Test.hs | 1 - .../DMQ/Protocol/SigSubmissionV2/Direct.hs | 6 +++-- .../test/DMQ/Protocol/SigSubmissionV2/Test.hs | 2 ++ 6 files changed, 28 insertions(+), 13 deletions(-) diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index 9e355ed..9f597f3 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -57,8 +57,8 @@ import Cardano.KESAgent.KES.Crypto (Crypto (..)) import DMQ.Configuration (Configuration, Configuration' (..), I (..)) import DMQ.Diffusion.NodeKernel (NodeKernel (..)) import DMQ.NodeToNode.Version -import DMQ.Protocol.SigSubmission.Codec (codecSigSubmission) -import DMQ.Protocol.SigSubmissionV2.Codec +import DMQ.Protocol.SigSubmission.Codec (codecSigSubmissionV2) +import DMQ.Protocol.SigSubmissionV2.Codec hiding (codecSigSubmissionV2) import DMQ.Protocol.SigSubmissionV2.Inbound (sigSubmissionV2InboundPeerPipelined) import DMQ.Protocol.SigSubmissionV2.Outbound (sigSubmissionV2OutboundPeer) import DMQ.Protocol.SigSubmissionV2.Type @@ -550,7 +550,7 @@ dmqCodecs :: ( MonadST m -> Codecs crypto addr m dmqCodecs encodeAddr decodeAddr = Codecs { - sigSubmissionCodec = codecSigSubmission + sigSubmissionCodec = codecSigSubmissionV2 , keepAliveCodec = codecKeepAlive_v2 , peerSharingCodec = codecPeerSharing encodeAddr decodeAddr } diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs index dda716f..7ba2134 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Codec.hs @@ -7,6 +7,7 @@ module DMQ.Protocol.SigSubmission.Codec ( codecSigSubmission + , codecSigSubmissionV2 , byteLimitsSigSubmission , timeLimitsSigSubmission , codecSigSubmissionId @@ -40,11 +41,11 @@ import Cardano.KESAgent.KES.OCert (OCert (..)) import Ouroboros.Network.Protocol.Codec.Utils qualified as Utils import Ouroboros.Network.Protocol.Limits +import Ouroboros.Network.Protocol.TxSubmission2.Codec qualified as TX import DMQ.Protocol.SigSubmission.Type import DMQ.Protocol.SigSubmissionV2.Type (SigSubmissionV2) -import DMQ.Protocol.SigSubmissionV2.Codec (codecSigSubmissionV2Id, - anncodecSigSubmissionV2) +import DMQ.Protocol.SigSubmissionV2.Codec (anncodecSigSubmissionV2) @@ -136,8 +137,20 @@ codecSigSubmission ( Crypto crypto , MonadST m ) - => AnnotatedCodec (SigSubmissionV2 SigId (Sig crypto)) CBOR.DeserialiseFailure m ByteString + => AnnotatedCodec (SigSubmission crypto) CBOR.DeserialiseFailure m ByteString codecSigSubmission = + TX.anncodecTxSubmission2' + SigWithBytes + encodeSigId decodeSigId + encodeSig decodeSig + +codecSigSubmissionV2 + :: forall crypto m. + ( Crypto crypto + , MonadST m + ) + => AnnotatedCodec (SigSubmissionV2 SigId (Sig crypto)) CBOR.DeserialiseFailure m ByteString +codecSigSubmissionV2 = anncodecSigSubmissionV2 SigWithBytes encodeSigId decodeSigId @@ -192,6 +205,5 @@ decodeSig = do codecSigSubmissionId :: Monad m - => Codec (SigSubmissionV2 sigId sig) CodecFailure m (AnyMessage (SigSubmissionV2 sigId sig)) -codecSigSubmissionId = codecSigSubmissionV2Id - + => Codec (SigSubmission crypto) CodecFailure m (AnyMessage (SigSubmission crypto)) +codecSigSubmissionId = TX.codecTxSubmission2Id diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs index 7fc4700..1db8083 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs @@ -325,7 +325,7 @@ anncodecSigSubmissionV2 -> (sigWithBytes -> CBOR.Encoding) -- ^ encode `sig` -> (forall s . CBOR.Decoder s (ByteString -> sig)) - -- ^ decode transaction + -- ^ decode signature -> AnnotatedCodec (SigSubmissionV2 sigId sigWithBytes) CBOR.DeserialiseFailure m ByteString anncodecSigSubmissionV2 mkWithBytes encodeSigId decodeSigId encodeSig decodeSig = diff --git a/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs b/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs index 7260704..b8467a7 100644 --- a/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs +++ b/dmq-node/test/DMQ/Protocol/LocalMsgNotification/Test.hs @@ -221,7 +221,6 @@ codec :: MonadST m => LocalMsgNotificationCodec m MsgWithBytes codec = codecLocalMsgNotification' Utils.runWithByteSpan encodeMsg decodeMsg - instance Arbitrary HasMore where arbitrary = elements [HasMore, DoesNotHaveMore] diff --git a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs index ffa0be6..c84ff49 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Direct.hs @@ -6,6 +6,7 @@ module DMQ.Protocol.SigSubmissionV2.Direct (directPipelined) where +import Data.Map.Strict qualified as Map import Data.List.NonEmpty qualified as NonEmpty import Network.TypedProtocol.Core @@ -24,8 +25,9 @@ directPipelined -> SigSubmissionInboundPipelined sigId sig m a -> m a directPipelined (SigSubmissionOutbound mOutbound) - (SigSubmissionInboundPipelined inbound) = do + (SigSubmissionInboundPipelined mInbound) = do outbound <- mOutbound + inbound <- mInbound directSender EmptyQ inbound outbound where directSender :: forall (n :: N). @@ -55,7 +57,7 @@ directPipelined (SigSubmissionOutbound mOutbound) directSender q (SendMsgRequestSigsPipelined sigIds inboundNext) OutboundStIdle{recvMsgRequestSigs} = do - SendMsgReplySigs sigs outbound' <- recvMsgRequestSigs sigIds + SendMsgReplySigs sigs outbound' <- recvMsgRequestSigs $ Map.keys sigIds inbound' <- inboundNext directSender (enqueue (CollectSigs sigIds sigs) q) inbound' outbound' diff --git a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs index 73138ea..75102d9 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmissionV2/Test.hs @@ -86,6 +86,8 @@ newtype SigId = SigId Any instance ShowProxy SigId where showProxy _ = "SigId" +deriving newtype instance Arbitrary SizeInBytes + deriving newtype instance Arbitrary NumIdsAck deriving newtype instance Arbitrary NumIdsReq From 4325314aaa0d41f9545e413ab31fb69a5eaef237 Mon Sep 17 00:00:00 2001 From: edgr Date: Thu, 15 Jan 2026 17:24:51 +0800 Subject: [PATCH 09/11] Codec fixes --- dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs index 1db8083..e652db8 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmissionV2/Codec.hs @@ -138,7 +138,7 @@ encodeSigSubmissionV2 encodeObjectId encodeObject = encode encode (MsgReplySigIds objIds) = CBOR.encodeListLen 2 - <> CBOR.encodeWord 1 -- TODO 1 or 2? + <> CBOR.encodeWord 2 <> CBOR.encodeListLenIndef <> foldr (\(sigid, SizeInBytes sz) r -> CBOR.encodeListLen 2 @@ -198,8 +198,7 @@ decodeSigSubmissionV2 decodeSigId decodeSig = decode then SomeMessage $ MsgRequestSigIds SingBlocking ackNo reqNo else SomeMessage $ MsgRequestSigIds SingNonBlocking ackNo reqNo - -- (SingSigIds b, 2, 2) -> do TODO 1 or 2? - (SingSigIds b, 2, 1) -> do + (SingSigIds b, 2, 2) -> do CBOR.decodeListLenIndef sigIds <- CBOR.decodeSequenceLenIndef (flip (:)) @@ -383,8 +382,7 @@ decodeSigSubmissionV2' mkWithBytes decodeSigId decodeSig sok = do then Annotator $ \_ -> SomeMessage $ MsgRequestSigIds SingBlocking ackNo reqNo else Annotator $ \_ -> SomeMessage $ MsgRequestSigIds SingNonBlocking ackNo reqNo - -- (SingSigIds b, 2, 2) -> do TODO 1 or 2? - (SingSigIds b, 2, 1) -> do + (SingSigIds b, 2, 2) -> do CBOR.decodeListLenIndef sigIds <- CBOR.decodeSequenceLenIndef (flip (:)) From 84dc0471a0b34c26d847acee1b8aa21921487591 Mon Sep 17 00:00:00 2001 From: edgr Date: Thu, 15 Jan 2026 19:32:15 +0800 Subject: [PATCH 10/11] CDDL messageTuple --- dmq-node/cddl/specs/sig-submission-v2.cddl | 3 ++- dmq-node/cddl/specs/sig.cddl | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/dmq-node/cddl/specs/sig-submission-v2.cddl b/dmq-node/cddl/specs/sig-submission-v2.cddl index b22a574..49cae7d 100644 --- a/dmq-node/cddl/specs/sig-submission-v2.cddl +++ b/dmq-node/cddl/specs/sig-submission-v2.cddl @@ -18,7 +18,7 @@ sigSubmissionV2Message msgRequestSigIds = [1, blocking, sigCount, sigCount] -msgReplySigIds = [2, [*sig.messageId] ] +msgReplySigIds = [2, [*messageTuple] ] msgReplyNoSigIds = [3] msgRequestSigs = [4, [*sig.messageId] ] msgReplySigs = [5, [*sig.message] ] @@ -26,5 +26,6 @@ msgDone = [6] blocking = false / true sigCount = sig.word16 +messageTuple = [sig.messageId, sig.messageSize] ;# import sig as sig diff --git a/dmq-node/cddl/specs/sig.cddl b/dmq-node/cddl/specs/sig.cddl index e1a41d0..a0b68b2 100644 --- a/dmq-node/cddl/specs/sig.cddl +++ b/dmq-node/cddl/specs/sig.cddl @@ -13,6 +13,7 @@ messagePayload = [ messageId = bstr messageBody = bstr +messageSize = word32 kesSignature = bstr .size 448 kesPeriod = word64 operationalCertificate = [ bstr .size 32, word64, word64, bstr .size 64 ] From 0880f8e2beb1215eb509ec70da289ff1ca272fff Mon Sep 17 00:00:00 2001 From: edgr Date: Mon, 19 Jan 2026 14:55:52 +0800 Subject: [PATCH 11/11] Node version --- dmq-node/src/DMQ/NodeToNode/Version.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/dmq-node/src/DMQ/NodeToNode/Version.hs b/dmq-node/src/DMQ/NodeToNode/Version.hs index 752c97a..adfee08 100644 --- a/dmq-node/src/DMQ/NodeToNode/Version.hs +++ b/dmq-node/src/DMQ/NodeToNode/Version.hs @@ -31,20 +31,24 @@ import Ouroboros.Network.Protocol.Handshake (Accept (..)) import Ouroboros.Network.OrphanInstances () -data NodeToNodeVersion = - NodeToNodeV_1 +data NodeToNodeVersion + = NodeToNodeV_1 + | NodeToNodeV_2 deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData) instance Aeson.ToJSON NodeToNodeVersion where toJSON NodeToNodeV_1 = Aeson.toJSON (1 :: Int) + toJSON NodeToNodeV_2 = Aeson.toJSON (2 :: Int) instance Aeson.ToJSONKey NodeToNodeVersion where nodeToNodeVersionCodec :: CodecCBORTerm (Text, Maybe Int) NodeToNodeVersion nodeToNodeVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } where encodeTerm NodeToNodeV_1 = CBOR.TInt 1 + encodeTerm NodeToNodeV_2 = CBOR.TInt 2 decodeTerm (CBOR.TInt 1) = Right NodeToNodeV_1 + decodeTerm (CBOR.TInt 2) = Right NodeToNodeV_2 decodeTerm (CBOR.TInt n) = Left ( T.pack "decode NodeToNodeVersion: unknown tag: " <> T.pack (show n) , Just n @@ -113,6 +117,7 @@ nodeToNodeCodecCBORTerm :: NodeToNodeVersion nodeToNodeCodecCBORTerm = \case NodeToNodeV_1 -> v1 + NodeToNodeV_2 -> v1 where v1 = CodecCBORTerm { encodeTerm = encodeTerm1, decodeTerm = decodeTerm1 }