From 0f1269700aa1aa50d4ae7f1e89892bac74d3d643 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Sep 2025 15:57:02 +0200 Subject: [PATCH 01/29] api: add Point to LedgerPeerSnapshot api: facilitate future removal of a few {From,To}CBOR instances Added explicit encode/decode functions such that CBOR instances can be easily removed when ntc v22 is no longer supported --- .../api/lib/Ouroboros/Network/Block.hs | 3 + .../api/lib/Ouroboros/Network/Magic.hs | 3 + .../Network/PeerSelection/LedgerPeers/Type.hs | 491 ++++++++++++------ .../PeerSelection/LedgerPeers/Utils.hs | 3 +- .../api/lib/Ouroboros/Network/Point.hs | 3 +- ouroboros-network/ouroboros-network.cabal | 1 + 6 files changed, 334 insertions(+), 170 deletions(-) diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Block.hs b/ouroboros-network/api/lib/Ouroboros/Network/Block.hs index e39f8608ff5..7bcdd080bf3 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Block.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Block.hs @@ -79,6 +79,7 @@ import Codec.CBOR.Read qualified as Read import Codec.CBOR.Write qualified as Write import Codec.Serialise (Serialise (..)) import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Base16.Lazy qualified as B16 import Data.ByteString.Lazy qualified as Lazy import Data.ByteString.Lazy.Char8 qualified as BSC @@ -216,6 +217,8 @@ deriving newtype instance StandardHash block => Ord (Point block) deriving via (Quiet (Point block)) instance StandardHash block => Show (Point block) deriving newtype instance StandardHash block => NoThunks (Point block) +deriving newtype instance ToJSON (Point.Block SlotNo (HeaderHash block)) => ToJSON (Point block) +deriving newtype instance FromJSON (Point.Block SlotNo (HeaderHash block)) => FromJSON (Point block) instance ShowProxy block => ShowProxy (Point block) where showProxy _ = "Point " ++ showProxy (Proxy :: Proxy block) diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs b/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs index 8974d95de63..d5d4dfed0f5 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs @@ -3,6 +3,7 @@ module Ouroboros.Network.Magic where +import Control.DeepSeq (NFData) import Data.Word (Word32) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -11,3 +12,5 @@ import NoThunks.Class (NoThunks) -- | NetworkMagic is used to differentiate between different networks during the initial handshake. newtype NetworkMagic = NetworkMagic { unNetworkMagic :: Word32 } deriving (Show, Eq, Generic, NoThunks) + +instance NFData NetworkMagic diff --git a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index ca92eecdff4..73b53f915dc 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -1,17 +1,18 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeFamilies #-} -- | Various types related to ledger peers. This module is re-exported from -- "Ouroboros.Network.PeerSelection.LedgerPeers". @@ -27,13 +28,23 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , UseLedgerPeers (..) , AfterSlot (..) , LedgerPeersKind (..) - , LedgerPeerSnapshot (.., LedgerPeerSnapshot) + , LedgerPeerSnapshot (..) + , SomeLedgerPeerSnapshot (..) , LedgerPeerSnapshotSRVSupport (..) , encodeLedgerPeerSnapshot + , encodeLedgerPeerSnapshot' , decodeLedgerPeerSnapshot - , getRelayAccessPointsFromLedgerPeerSnapshot + , encodeWithOrigin + , decodeWithOrigin + , encodeLedgerPeerSnapshotPoint + , decodeLedgerPeerSnapshotPoint + , encodeBigStakePools + , decodeBigStakePools + , encodeAllStakePools + , decodeAllStakePools + , getRelayAccessPointsFromBigLedgerPeersSnapshot + , getRelayAccessPointsFromAllLedgerPeersSnapshot , isLedgerPeersEnabled - , compareLedgerPeerSnapshotApproximate -- * Re-exports , SRVPrefix , RelayAccessPoint (..) @@ -41,214 +52,359 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , prefixLedgerRelayAccessPoint ) where -import GHC.Generics (Generic) --- TODO: remove `FromCBOR` and `ToCBOR` type classes -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Binary qualified as Codec -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import Control.Applicative ((<|>)) import Control.Concurrent.Class.MonadSTM import Control.DeepSeq (NFData (..)) import Control.Monad (forM) import Data.Aeson -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty +import Data.Typeable +import GHC.Generics (Generic) import NoThunks.Class +-- TODO: remove `FromCBOR` and `ToCBOR` instances when ntc V22 is no longer supported +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import Cardano.Binary qualified as Codec +import Cardano.Crypto.Hash (Blake2b_256, Hash) +import Ouroboros.Network.Block +import Ouroboros.Network.Magic import Ouroboros.Network.PeerSelection.RelayAccessPoint +import Ouroboros.Network.Point --- |The type of big ledger peers that is serialised or later --- provided by node configuration for the networking layer --- to connect to when syncing. +-- | A snapshot of ledger peers extracted from the ledger state at some point -- -data LedgerPeerSnapshot = - LedgerPeerSnapshotV2 (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) - -- ^ Internal use for version 2, use pattern synonym for public API - deriving (Eq, Show) +data LedgerPeerSnapshot (a :: LedgerPeersKind) where + LedgerPeerSnapshotV2 + :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) + -> LedgerPeerSnapshot BigLedgerPeers + LedgerBigPeerSnapshotV23 + :: !(Point (LedgerPeerSnapshot BigLedgerPeers)) + -> !NetworkMagic + -> ![(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] + -> LedgerPeerSnapshot BigLedgerPeers + LedgerAllPeerSnapshotV23 + :: !(Point (LedgerPeerSnapshot AllLedgerPeers)) + -> !NetworkMagic + -> ![(PoolStake, NonEmpty LedgerRelayAccessPoint)] + -> LedgerPeerSnapshot AllLedgerPeers + +deriving instance Eq (LedgerPeerSnapshot a) +deriving instance Show (LedgerPeerSnapshot a) +instance Typeable a => StandardHash (LedgerPeerSnapshot a) +type instance HeaderHash (LedgerPeerSnapshot a) = Hash Blake2b_256 (LedgerPeerSnapshot a) + +-- | facility for encoding the snapshot +-- +data SomeLedgerPeerSnapshot = forall k. SomeLedgerPeerSnapshot (LedgerPeerSnapshot k) +deriving instance Show SomeLedgerPeerSnapshot -getRelayAccessPointsFromLedgerPeerSnapshot +getRelayAccessPointsFromBigLedgerPeersSnapshot :: SRVPrefix - -> LedgerPeerSnapshot + -> LedgerPeerSnapshot BigLedgerPeers -> (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]) -getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix (LedgerPeerSnapshotV2 as) = +getRelayAccessPointsFromBigLedgerPeersSnapshot srvPrefix = \case + LedgerPeerSnapshotV2 as -> fmap (fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix))))) as + LedgerBigPeerSnapshotV23 pt _magic as -> + let as' = fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix)))) as + in (pointSlot pt, as') --- |Public API to access snapshot data. Currently access to only most recent version is available. --- Nonetheless, serialisation from the node into JSON is supported for older versions via internal --- api so that newer CLI can still support older node formats. --- -pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) - -> LedgerPeerSnapshot -pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where - LedgerPeerSnapshot payload = LedgerPeerSnapshotV2 payload - -{-# COMPLETE LedgerPeerSnapshot #-} - --- | Since ledger peer snapshot is serialised with all domain names --- fully qualified, and all stake values are approximate in floating --- point, comparison is necessarily approximate as well. --- The candidate argument is processed here to simulate a round trip --- by the serialisation mechanism and then compared to the baseline --- argument, which is assumed that it was actually processed this way --- when a snapshot was created earlier, and hence it is approximate as well. --- The two approximate values should be equal if they were created --- from the same 'faithful' data. --- -compareLedgerPeerSnapshotApproximate :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - -> Bool -compareLedgerPeerSnapshotApproximate baseline candidate = - case tripIt of - Success candidate' -> candidate' == baseline - Error _ -> False - where - tripIt = fmap (fmap (fmap (first unPoolStakeCoded))) - . fmap (fmap (first unAccPoolStakeCoded)) - . fromJSON - . toJSON - . fmap (fmap (first PoolStakeCoded)) - . fmap (first AccPoolStakeCoded) - $ candidate - --- | In case the format changes in the future, this function provides a migration functionality --- when possible. --- -migrateLedgerPeerSnapshot - :: LedgerPeerSnapshot - -> Maybe LedgerPeerSnapshot -migrateLedgerPeerSnapshot snapshot@LedgerPeerSnapshotV2{} = Just snapshot +getRelayAccessPointsFromAllLedgerPeersSnapshot + :: SRVPrefix + -> LedgerPeerSnapshot AllLedgerPeers + -> (WithOrigin SlotNo, [(PoolStake, NonEmpty RelayAccessPoint)]) +getRelayAccessPointsFromAllLedgerPeersSnapshot srvPrefix = \case + LedgerAllPeerSnapshotV23 pt _magic as -> + let as' = fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix))) as + in (pointSlot pt, as') + -instance ToJSON LedgerPeerSnapshot where +instance ToJSON (LedgerPeerSnapshot a) where toJSON (LedgerPeerSnapshotV2 (slot, pools)) = object [ "version" .= (2 :: Int) , "slotNo" .= slot , "bigLedgerPools" .= [ object [ "accumulatedStake" .= fromRational @Double accStake - , "relativeStake" .= fromRational @Double relStake - , "relays" .= relays] + , "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] + | (AccPoolStake accStake, (PoolStake relStake, relays)) <- pools + ]] + toJSON (LedgerAllPeerSnapshotV23 pt magic pools) = + object [ "NodeToClientVersion" .= (23 :: Int) + , "Point" .= toJSON pt + , "NetworkMagic" .= unNetworkMagic magic + , "allLedgerPools" .= [ object + [ "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] + | (PoolStake relStake, relays) <- pools + ]] + toJSON (LedgerBigPeerSnapshotV23 pt magic pools) = + object [ "NodeToClientVersion" .= (23 :: Int) + , "Point" .= toJSON pt + , "NetworkMagic" .= unNetworkMagic magic + , "bigLedgerPools" .= [ object + [ "accumulatedStake" .= fromRational @Double accStake + , "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] | (AccPoolStake accStake, (PoolStake relStake, relays)) <- pools ]] -instance FromJSON LedgerPeerSnapshot where - parseJSON = withObject "LedgerPeerSnapshot" $ \v -> do - vNum :: Int <- v .: "version" - ledgerPeerSnapshot <- - case vNum of - 1 -> do - slot <- v .: "slotNo" - bigPools <- v .: "bigLedgerPools" - bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do - let f poolV = do - AccPoolStakeCoded accStake <- poolV .: "accumulatedStake" - PoolStakeCoded reStake <- poolV .: "relativeStake" - -- decode using `LedgerRelayAccessPointV1` instance - relays <- fmap getLedgerReelayAccessPointV1 <$> poolV .: "relays" - return (accStake, (reStake, relays)) - withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) - - return $ LedgerPeerSnapshotV2 (slot, bigPools') - 2 -> do - slot <- v .: "slotNo" - bigPools <- v .: "bigLedgerPools" - bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do - let f poolV = do - AccPoolStakeCoded accStake <- poolV .: "accumulatedStake" - PoolStakeCoded reStake <- poolV .: "relativeStake" - relays <- poolV .: "relays" - return (accStake, (reStake, relays)) - withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) - - return $ LedgerPeerSnapshotV2 (slot, bigPools') - _ -> fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " <> show vNum - case migrateLedgerPeerSnapshot ledgerPeerSnapshot of - Just ledgerPeerSnapshot' -> return ledgerPeerSnapshot' - Nothing -> fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot" +instance FromJSON (LedgerPeerSnapshot AllLedgerPeers) where + parseJSON = withObject "LedgerPeerSnapshot" \v -> do + -- TODO: remove "version" key after NtC V22 support is removed + vNum :: Int <- v .: "version" <|> v .: "NodeToClientVersion" + allPools <- v .: "allLedgerPools" + case vNum of + 23 -> do + point <- v .: "Point" + magic <- v .: "NetworkMagic" + allPools' <- forM (zip [0 :: Int ..] allPools) \(idx, poolO) -> do + let f poolV = do + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (reStake, relays) + withObject ("allLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerAllPeerSnapshotV23 point (NetworkMagic magic) allPools' + _ -> + fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " + <> show vNum + +instance FromJSON (LedgerPeerSnapshot BigLedgerPeers) where + parseJSON = withObject "LedgerPeerSnapshot" \v -> do + -- TODO: remove "version" key after NtC V22 support is removed + vNum :: Int <- v .: "version" <|> v .: "NodeToClientVersion" + case vNum of + 1 -> do + slot <- v .: "slotNo" + bigPools <- v .: "bigLedgerPools" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + -- decode using `LedgerRelayAccessPointV1` instance + relays <- fmap getLedgerReelayAccessPointV1 <$> poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerPeerSnapshotV2 (slot, bigPools') + 2 -> do + slot <- v .: "slotNo" + bigPools <- v .: "bigLedgerPools" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerPeerSnapshotV2 (slot, bigPools') + 23 -> do + point <- v .: "Point" + magic <- v .: "NetworkMagic" + bigPools <- v .: "bigLedgerPools" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerBigPeerSnapshotV23 point (NetworkMagic magic) bigPools' + _ -> + fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " + <> show vNum + + +data LedgerPeerSnapshotSRVSupport + = LedgerPeerSnapshotSupportsSRV + -- ^ since `NodeToClientV_22` + | LedgerPeerSnapshotDoesntSupportSRV + deriving (Show, Eq) + + +encodeLedgerPeerSnapshot' :: LedgerPeerSnapshotSRVSupport -> SomeLedgerPeerSnapshot -> Codec.Encoding +encodeLedgerPeerSnapshot' srvSupport (SomeLedgerPeerSnapshot lps) = encodeLedgerPeerSnapshot srvSupport lps +{-# INLINE encodeLedgerPeerSnapshot' #-} + + +encodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot a -> Codec.Encoding +encodeLedgerPeerSnapshot LedgerPeerSnapshotDoesntSupportSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools' + where + pools' = + [(accPoolStake, (relStake, NonEmpty.fromList relays)) + | (accPoolStake, (relStake, relays)) <- + -- filter out SRV domains, not supported by `< NodeToClientV_22` + map + (second $ second $ NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True) + ) + pools + , not (null relays) + ] + +encodeLedgerPeerSnapshot LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools + +encodeLedgerPeerSnapshot _LedgerPeerSnapshotSupportsSRV (LedgerBigPeerSnapshotV23 pt magic pools) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 2 -- internal version + <> Codec.encodeListLen 3 + <> encodeLedgerPeerSnapshotPoint pt + <> Codec.encodeWord32 (unNetworkMagic magic) + <> encodeBigStakePools pools + +encodeLedgerPeerSnapshot _LedgerPeerSnapshotSupportsSRV (LedgerAllPeerSnapshotV23 pt magic pools) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 3 -- internal version + <> Codec.encodeListLen 3 + <> encodeLedgerPeerSnapshotPoint pt + <> Codec.encodeWord32 (unNetworkMagic magic) + <> encodeAllStakePools pools + + +decodeLedgerPeerSnapshot :: Codec.Decoder s SomeLedgerPeerSnapshot +decodeLedgerPeerSnapshot = do + Codec.decodeListLenOf 2 + version <- Codec.decodeWord8 + case version of + 1 -> Codec.decodeListLenOf 2 >> + SomeLedgerPeerSnapshot . + LedgerPeerSnapshotV2 <$> ((,) <$> decodeWithOrigin <*> fromCBOR) + 2 -> Codec.decodeListLenOf 3 >> + SomeLedgerPeerSnapshot <$> + (LedgerBigPeerSnapshotV23 <$> decodeLedgerPeerSnapshotPoint + <*> (NetworkMagic <$> Codec.decodeWord32) + <*> decodeBigStakePools) + 3 -> Codec.decodeListLenOf 3 >> + SomeLedgerPeerSnapshot <$> + (LedgerAllPeerSnapshotV23 <$> decodeLedgerPeerSnapshotPoint + <*> (NetworkMagic <$> Codec.decodeWord32) + <*> decodeAllStakePools) + _ -> fail $ "LedgerPeers.Type: no decoder could be found for version " <> show version encodeWithOrigin :: WithOrigin SlotNo -> Codec.Encoding encodeWithOrigin Origin = Codec.encodeListLen 1 <> Codec.encodeWord8 0 encodeWithOrigin (At slotNo) = Codec.encodeListLen 2 <> Codec.encodeWord8 1 <> toCBOR slotNo + decodeWithOrigin :: Codec.Decoder s (WithOrigin SlotNo) decodeWithOrigin = do listLen <- Codec.decodeListLen - tag <- Codec.decodeWord8 + tag <- Codec.decodeWord8 case (listLen, tag) of - (1, 0) -> pure $ Origin + (1, 0) -> pure Origin (1, _) -> fail "LedgerPeers.Type: Expected tag for Origin constructor" (2, 1) -> At <$> fromCBOR (2, _) -> fail "LedgerPeers.Type: Expected tag for At constructor" _ -> fail "LedgerPeers.Type: Unrecognized list length while decoding WithOrigin SlotNo" -data LedgerPeerSnapshotSRVSupport - = LedgerPeerSnapshotSupportsSRV - -- ^ since `NodeToClientV_22` - | LedgerPeerSnapshotDoesntSupportSRV - deriving (Show, Eq) - -encodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot -> Codec.Encoding -encodeLedgerPeerSnapshot LedgerPeerSnapshotDoesntSupportSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = - Codec.encodeListLen 2 - <> Codec.encodeWord8 1 -- internal version - <> Codec.encodeListLen 2 - <> encodeWithOrigin wOrigin - <> toCBOR pools' - where - pools' = - [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) - | (accPoolStake, (relStake, relays)) <- - -- filter out SRV domains, not supported by `< NodeToClientV_22` - map - (second $ second $ NonEmpty.filter - (\case - LedgerRelayAccessSRVDomain {} -> False - _ -> True) - ) - pools - , not (null relays) - ] -encodeLedgerPeerSnapshot LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = - Codec.encodeListLen 2 - <> Codec.encodeWord8 1 -- internal version - <> Codec.encodeListLen 2 - <> encodeWithOrigin wOrigin - <> toCBOR pools' - where - pools' = - [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) - | (accPoolStake, (relStake, relays)) <- pools - ] - -decodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> Codec.Decoder s LedgerPeerSnapshot -decodeLedgerPeerSnapshot _ = do - Codec.decodeListLenOf 2 - version <- Codec.decodeWord8 - case version of - 1 -> LedgerPeerSnapshotV2 <$> do - Codec.decodeListLenOf 2 - wOrigin <- decodeWithOrigin - pools <- fromCBOR - let pools' = [(accStake, (relStake, relays)) - | (AccPoolStakeCoded accStake, (PoolStakeCoded relStake, relays)) <- pools - ] - return (wOrigin, pools') - _ -> fail $ "LedgerPeers.Type: no decoder could be found for version " <> show version - --- | Which ledger peers to pick. +encodeLedgerPeerSnapshotPoint :: Typeable a => Point (LedgerPeerSnapshot a) -> Codec.Encoding +encodeLedgerPeerSnapshotPoint = \case + GenesisPoint -> Codec.encodeListLen 1 <> Codec.encodeWord8 0 + BlockPoint { atSlot, withHash } -> + Codec.encodeListLen 3 <> Codec.encodeWord8 1 + <> Codec.toCBOR atSlot <> Codec.toCBOR withHash + + +decodeLedgerPeerSnapshotPoint :: Typeable a => Codec.Decoder s (Point (LedgerPeerSnapshot a)) +decodeLedgerPeerSnapshotPoint = do + listLen <- Codec.decodeListLen + tag <- Codec.decodeWord8 + case (tag, listLen) of + (0, 1) -> pure $ Point Origin + (0, n) -> fail $ "LedgerPeers.Type: invalid listLen for Origin tag, expected 1 got " <> show n + (1, 3) -> Point . At <$> (Block <$> fromCBOR <*> fromCBOR) + (1, n) -> fail $ "LedgerPeers.Type: invalid listLen for At tag, expected 3 got " <> show n + _ -> fail "LedgerPeers.Type: Unrecognized CBOR encoding of Point for LedgerPeerSnapshot" + + +encodeBigStakePools :: [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] + -> Codec.Encoding +encodeBigStakePools pools = + Codec.encodeListLenIndef + <> foldMap (\(AccPoolStake accPoolStake, (PoolStake poolStake, relays)) -> + Codec.encodeListLen 3 + <> toCBOR accPoolStake + <> toCBOR poolStake + <> toCBOR relays + ) + pools + <> Codec.encodeBreak + + +decodeBigStakePools :: Codec.Decoder s [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] +decodeBigStakePools = do + Codec.decodeListLenIndef + Codec.decodeSequenceLenIndef + (flip (:)) [] reverse + do + Codec.decodeListLenOf 3 + accPoolStake <- AccPoolStake <$> fromCBOR + poolStake <- PoolStake <$> fromCBOR + relays <- fromCBOR + return (accPoolStake, (poolStake, relays)) + + +encodeAllStakePools :: [(PoolStake, NonEmpty LedgerRelayAccessPoint)] + -> Codec.Encoding +encodeAllStakePools pools = + Codec.encodeListLenIndef + <> foldMap (\(PoolStake poolStake, relays) -> + Codec.encodeListLen 2 + <> toCBOR poolStake + <> toCBOR relays + ) + pools + <> Codec.encodeBreak + + +decodeAllStakePools :: Codec.Decoder s [(PoolStake, NonEmpty LedgerRelayAccessPoint)] +decodeAllStakePools = do + Codec.decodeListLenIndef + Codec.decodeSequenceLenIndef + (flip (:)) [] reverse + do + Codec.decodeListLenOf 2 + poolStake <- PoolStake <$> fromCBOR + relays <- fromCBOR + return (poolStake, relays) + + +-- | Used by functions to indicate what kind of ledger peer to process -- data LedgerPeersKind = AllLedgerPeers | BigLedgerPeers - deriving Show + deriving (Eq, Show) + -- | Only use the ledger after the given slot number. +-- data UseLedgerPeers = DontUseLedgerPeers | UseLedgerPeers AfterSlot deriving (Eq, Show, Generic, NoThunks) -- | Only use the ledger after the given slot number. +-- data AfterSlot = Always | After SlotNo deriving (Eq, Show, Generic) @@ -258,25 +414,24 @@ isLedgerPeersEnabled :: UseLedgerPeers -> Bool isLedgerPeersEnabled DontUseLedgerPeers = False isLedgerPeersEnabled UseLedgerPeers {} = True + -- | The relative stake of a stakepool in relation to the total amount staked. -- A value in the [0, 1] range. -- newtype PoolStake = PoolStake { unPoolStake :: Rational } deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num, NFData) + deriving newtype (Fractional, Num, NFData, FromJSON, ToJSON, ToCBOR, FromCBOR) + -- the ToCBOR and FromCBOR instances can be removed once V22 is no longer supported -newtype PoolStakeCoded = PoolStakeCoded { unPoolStakeCoded :: PoolStake } - deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational -- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the -- relative stake of all preceding pools. A value in the range [0, 1]. -- newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational } - deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num) + deriving (Eq, Ord, Show) + deriving newtype (Fractional, Num, NFData, FromJSON, ToJSON, FromCBOR, ToCBOR) + -- the ToCBOR and FromCBOR instances can be removed once V22 is no longer supported -newtype AccPoolStakeCoded = AccPoolStakeCoded { unAccPoolStakeCoded :: AccPoolStake } - deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational -- | Identifies a peer as coming from ledger or not. data IsLedgerPeer = IsLedgerPeer diff --git a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs index 3cf28aa7f10..5d3f7894872 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs @@ -20,7 +20,8 @@ import Data.Ratio ((%)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type --- | The total accumulated stake of big ledger peers. +-- | Big ledger peers are those ledger peers, which when sorted down by their +-- relative stake, in the aggregate hold 90% of the total stake in the network. -- bigLedgerPeerQuota :: AccPoolStake bigLedgerPeerQuota = 0.9 diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Point.hs b/ouroboros-network/api/lib/Ouroboros/Network/Point.hs index 8f09b55cec1..cd49f242a8a 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Point.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Point.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.Point , withOriginFromMaybe ) where +import Data.Aeson import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -25,7 +26,7 @@ data Block slot hash = Block { blockPointSlot :: !slot , blockPointHash :: !hash } - deriving (Eq, Ord, Show, Generic, NoThunks) + deriving (Eq, Ord, Show, ToJSON, FromJSON, Generic, NoThunks) block :: slot -> hash -> WithOrigin (Block slot hash) block slot hash = at (Block slot hash) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index fa18938acb1..4ed940b7b06 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -93,6 +93,7 @@ library api base16-bytestring, bytestring >=0.10 && <0.13, cardano-binary, + cardano-crypto-class, cardano-slotting, cardano-strict-containers, cborg >=0.2.1 && <0.3, From db879c8f1e08b7defdbd604269da049807eec8dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 28 Oct 2025 07:27:29 +0100 Subject: [PATCH 02/29] o-n: remove dependence on cardano-slotting --- .../lib/Cardano/Network/PeerSelection/Governor/Monitor.hs | 1 + .../lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs | 3 +-- .../lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs | 1 + .../lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs | 3 ++- .../lib/Ouroboros/Network/PeerSelection/PeerMetric.hs | 2 +- ouroboros-network/ouroboros-network.cabal | 1 - 6 files changed, 6 insertions(+), 5 deletions(-) diff --git a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs index 18a44512f7f..5bd3a370f45 100644 --- a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs +++ b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs @@ -54,6 +54,7 @@ import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (LocalRootConfig (..)) import Ouroboros.Network.PeerSelection.Types +import Ouroboros.Network.Point (Block (..), WithOrigin (..)) -- | Used to set 'bootstrapPeersTimeout' for crashing the node in a critical diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs index 4071a5d6fe3..19566c7e6d5 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs @@ -149,10 +149,9 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison(..), ChainSelStarvation (..), FetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) - -import Cardano.Slotting.Slot (WithOrigin) import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) +import Ouroboros.Network.Point (WithOrigin) type WithDeclined peer = Writer (DList (FetchDecline, peer)) diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index 875cfef0128..ab2a8cc6d5d 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -31,6 +31,7 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import System.Random (randomR) +import Ouroboros.Network.Block (HeaderHash, SlotNo) import Ouroboros.Network.ExitPolicy (RepromoteDelay) import Ouroboros.Network.ExitPolicy qualified as ExitPolicy import Ouroboros.Network.PeerSelection.Governor.ActivePeers diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 17141285f20..834fe193a07 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -52,7 +52,6 @@ import Data.Ratio import System.Random import Text.Printf -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Data.Set (Set) @@ -60,11 +59,13 @@ import Data.Set qualified as Set import Data.Void (Void) import Data.Word (Word16, Word64) import Network.DNS qualified as DNS +import Ouroboros.Network.Block (SlotNo) import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.LedgerPeers.Utils (accumulateBigLedgerStake, bigLedgerPeerQuota, recomputeRelativeStake) import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.Point (WithOrigin (..)) -- | Ledger Peer request result -- diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs index fdafe499f4f..6eb33a5f6ca 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -50,7 +50,7 @@ import GHC.Generics import NoThunks.Class import NoThunks.Class.Orphans () -import Cardano.Slotting.Slot (SlotNo (..)) +import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.DeltaQ (SizeInBytes) import Ouroboros.Network.PeerSelection.PeerMetric.Type diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 4ed940b7b06..52f4a6f291f 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -284,7 +284,6 @@ library base >=4.14 && <4.22, bytestring >=0.10 && <0.13, cardano-prelude, - cardano-slotting, cardano-strict-containers >=0.1.4, cborg >=0.2.1 && <0.3, containers, From fb4a9613f6fab10ae1c1dde07eadc9ec81b3e867 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 28 Oct 2025 07:33:09 +0100 Subject: [PATCH 03/29] o-n tests: remove dependence on cardano-slotting --- .../Network/Diffusion/Testnet/Simulation.hs | 1 + .../lib/Test/Cardano/Network/PeerSelection.hs | 2 + .../Network/PeerSelection/MockEnvironment.hs | 1 + ouroboros-network/ouroboros-network.cabal | 3 +- .../lib/Test/Ouroboros/Network/LedgerPeers.hs | 208 +++++++++++++----- .../Network/PeerSelection/Instances.hs | 4 +- .../Network/PeerSelection/PeerMetric.hs | 2 +- 7 files changed, 165 insertions(+), 56 deletions(-) diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs index bb54b757666..33987ca51d1 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs @@ -1245,6 +1245,7 @@ diffusionSimulationM Cardano.LedgerPeersConsensusInterface { Cardano.readFetchMode = pure (PraosFetchMode FetchModeDeadline) , Cardano.getLedgerStateJudgement = pure TooOld + , Cardano.getBlockHash = const retry , Cardano.updateOutboundConnectionsState = \a -> do a' <- readTVar onlyOutboundConnectionsStateVar diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs index 246500f48da..bb73269c9d9 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs @@ -69,6 +69,7 @@ import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (LocalRootPeers (..)) import Ouroboros.Network.Point +import Ouroboros.Network.Socket () import Test.Cardano.Network.PeerSelection.MockEnvironment hiding (tests) import Test.Cardano.Network.PeerSelection.Utils @@ -4382,6 +4383,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrap lpExtraAPI = Cardano.LedgerPeersConsensusInterface { readFetchMode = pure (PraosFetchMode FetchModeDeadline), getLedgerStateJudgement = readLedgerStateJudgement, + getBlockHash = const retry, updateOutboundConnectionsState = \a -> do a' <- readTVar olocVar when (a /= a') $ diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs index dfe7d0e344b..dca9de812d9 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs @@ -485,6 +485,7 @@ mockPeerSelectionActions' tracer lpExtraAPI = Cardano.LedgerPeersConsensusInterface { readFetchMode = pure (PraosFetchMode FetchModeDeadline), getLedgerStateJudgement = readLedgerStateJudgement, + getBlockHash = const retry, updateOutboundConnectionsState = \a -> do a' <- readTVar outboundConnectionsStateVar when (a /= a') $ diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 52f4a6f291f..96f2f83481b 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -826,8 +826,9 @@ library ouroboros-network-tests-lib aeson, array, base >=4.14 && <4.22, + binary, bytestring, - cardano-slotting, + cardano-crypto-class, cardano-strict-containers, cborg, containers, diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs index 9bedaa6b23f..7ec202237e3 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs @@ -1,9 +1,12 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -26,6 +29,7 @@ import Control.Monad.IOSim hiding (SimResult) import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Aeson import Data.Aeson.Types as Aeson +import Data.Binary as Binary (encode) import Data.ByteString.Char8 qualified as BS import Data.IP qualified as IP import Data.List as List (foldl', intercalate, isPrefixOf, nub, sortOn) @@ -42,11 +46,14 @@ import System.Random import Network.DNS (Domain) -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import Cardano.Crypto.Hash.Class (hashWith) +import Ouroboros.Network.Block +import Ouroboros.Network.Magic import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.LedgerPeers.Utils (recomputeRelativeStake) import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.Point (WithOrigin (..)) import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.PeerSelection.RootPeersDNS @@ -63,7 +70,8 @@ tests = testGroup "Ouroboros.Network.LedgerPeers" , testProperty "recomputeRelativeStake" prop_recomputeRelativeStake , testProperty "getLedgerPeers invariants" prop_getLedgerPeers , testProperty "LedgerPeerSnapshot CBOR version 2" prop_ledgerPeerSnapshotCBORV2 - , testProperty "LedgerPeerSnapshot JSON version 2" prop_ledgerPeerSnapshotJSONV2 + , testProperty "LedgerPeerSnapshot CBOR version 3" prop_ledgerPeerSnapshotCBORV3 + , testProperty "LedgerPeerSnapshot JSON version 2/3" prop_ledgerPeerSnapshotJSON ] type ExtraTestInterface = () @@ -209,8 +217,10 @@ prop_ledgerPeerSnapshot_requests bigPoolRelays = fmap (snd . snd) . Map.toList $ bigPoolMap poolRelays = fmap (snd . snd) . Map.toList $ poolMap in case (ledgerWithOrigin, ledgerPeers, peerSnapshot) of - (At t, LedgerPeers ledgerPools, Just (LedgerPeerSnapshot (At t', snapshotAccStake))) - | t' >= t -> + (At t, + LedgerPeers ledgerPools, + Just (LedgerBigPeerSnapshotV23 BlockPoint { atSlot } _magic snapshotAccStake)) + | atSlot >= t -> snapshotRelays === bigPoolRelays .&&. bigPoolRelays === poolRelays | otherwise -> bigPoolRelays === ledgerBigPoolRelays @@ -228,12 +238,14 @@ prop_ledgerPeerSnapshot_requests ledgerBigPoolRelays = fmap (snd . snd) (accumulateBigLedgerStake ledgerPools) ledgerRelays = fmap (snd . snd) . Map.toList $ accPoolStake ledgerPools - (_, _, Just (LedgerPeerSnapshot (At t', snapshotAccStake))) - | After slot <- useLedgerAfter, t' >= slot -> + (_, _, Just (LedgerBigPeerSnapshotV23 BlockPoint { atSlot } _magic snapshotAccStake)) + | After slot <- useLedgerAfter, atSlot >= slot -> snapshotRelays === bigPoolRelays .&&. bigPoolRelays === poolRelays where snapshotRelays :: [NonEmpty RelayAccessPoint] - snapshotRelays = fmap (fmap (prefixLedgerRelayAccessPoint cardanoSRVPrefix) . snd . snd) snapshotAccStake + snapshotRelays = + fmap (fmap (prefixLedgerRelayAccessPoint cardanoSRVPrefix) . snd . snd) + snapshotAccStake _otherwise -> bigPoolRelays === [] .&&. poolRelays === [] @@ -511,59 +523,108 @@ prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport -> Property prop_ledgerPeerSnapshotCBORV2 srvSupport slotNo ledgerPools = - counterexample (show snapshot) $ + counterexample (show someSnapshot) $ counterexample ("Invalid CBOR encoding" <> show encoded) (validFlatTerm encoded) .&&. either ((`counterexample` False) . ("CBOR decode failed: " <>)) (counterexample . ("CBOR round trip failed: " <>) . show <*> (result ==)) decoded where - snapshot = snapshotV2 slotNo ledgerPools - encoded = toFlatTerm . encodeLedgerPeerSnapshot srvSupport $ snapshot - decoded = fromFlatTerm (decodeLedgerPeerSnapshot srvSupport) encoded - - result = case srvSupport of - LedgerPeerSnapshotSupportsSRV -> snapshot - LedgerPeerSnapshotDoesntSupportSRV -> - -- filter out SRV records - LedgerPeerSnapshotV2 - ( slotNo' - , [ (accStake, (stake, NonEmpty.fromList relays')) - | (accStake, (stake, relays)) <- peers - , let relays' = NonEmpty.filter - (\case - LedgerRelayAccessSRVDomain {} -> False - _ -> True - ) - relays - , not (null relays') - ] - ) - where - LedgerPeerSnapshotV2 (slotNo', peers) = snapshot + someSnapshot = snapshotV2 slotNo ledgerPools + encoded = toFlatTerm . encodeLedgerPeerSnapshot' srvSupport $ someSnapshot + decoded = unwrap <$> fromFlatTerm decodeLedgerPeerSnapshot encoded + unwrap :: SomeLedgerPeerSnapshot -> LedgerPeerSnapshot BigLedgerPeers + unwrap = \case + SomeLedgerPeerSnapshot lps@LedgerPeerSnapshotV2{} -> lps + _otherwise -> error "impossible" + + result = case someSnapshot of + SomeLedgerPeerSnapshot lps@(LedgerPeerSnapshotV2 (slotNo', peers)) -> + case srvSupport of + LedgerPeerSnapshotSupportsSRV -> lps + LedgerPeerSnapshotDoesntSupportSRV -> + LedgerPeerSnapshotV2 + ( slotNo' + , [ (accStake, (stake, NonEmpty.fromList relays')) + | (accStake, (stake, relays)) <- peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True + ) + relays + , not (null relays') + ] + ) + _otherwise -> error "impossible" + + +-- TODO: move to `ouroboros-network-api:test` +prop_ledgerPeerSnapshotCBORV3 :: SlotNo -> Word32 -> LedgerPools -> Bool -> Property +prop_ledgerPeerSnapshotCBORV3 slotNo magic ledgerPools big = + counterexample (show someSnapshot) $ + counterexample ("Invalid CBOR encoding" <> show encoded) + (validFlatTerm encoded) + .&&. either ((`counterexample` False) . ("CBOR decode failed: " <>)) + (counterexample . ("CBOR round trip failed: " <>) . show <*> cmp) + decoded + where + someSnapshot = snapshotV3 slotNo (NetworkMagic magic) ledgerPools big + encoded = toFlatTerm . encodeLedgerPeerSnapshot' LedgerPeerSnapshotSupportsSRV $ someSnapshot + decoded = fromFlatTerm decodeLedgerPeerSnapshot encoded + cmp decoded' = case (someSnapshot, decoded') of + (SomeLedgerPeerSnapshot someSnapshot', + SomeLedgerPeerSnapshot decoded'')-> case (someSnapshot', decoded'') of + (lps@LedgerBigPeerSnapshotV23{}, lps'@LedgerBigPeerSnapshotV23{}) -> lps == lps' + (lps@LedgerAllPeerSnapshotV23{}, lps'@LedgerAllPeerSnapshotV23{}) -> lps == lps' + _otherwise -> False + -- | Tests if LedgerPeerSnapshot JSON round trip is the identity function -- -- TODO: move to `ouroboros-network-api:test` -prop_ledgerPeerSnapshotJSONV2 :: SlotNo - -> LedgerPools - -> Property -prop_ledgerPeerSnapshotJSONV2 slotNo - ledgerPools = - counterexample (show snapshot) $ - either ((`counterexample` False) . ("JSON decode failed: " <>)) - (counterexample . ("JSON round trip failed: " <>) . show <*> nearlyEqualModuloFullyQualified snapshot) - roundTrip +prop_ledgerPeerSnapshotJSON :: SlotNo + -> (Bool, Bool) + -> Word32 + -> LedgerPools + -> Property +prop_ledgerPeerSnapshotJSON slotNo (v3, big) pureMagic ledgerPools = + counterexample (show someSnapshot) $ + either ((`counterexample` False) . renderMsg) + ( counterexample . ("JSON round trip failed: " <>) . show + <*> nearlyEqualModuloFullyQualified someSnapshot) + someRoundTrip where - snapshot = snapshotV2 slotNo ledgerPools - roundTrip = case fromJSON . toJSON $ snapshot of - Aeson.Success s -> Right s - Error str -> Left str - - nearlyEqualModuloFullyQualified snapshotOriginal snapshotRoundTripped = - let LedgerPeerSnapshotV2 (wOrigin, relaysWithAccStake) = snapshotOriginal - strippedRelaysWithAccStake = stripFQN <$> relaysWithAccStake - LedgerPeerSnapshotV2 (wOrigin', relaysWithAccStake') = snapshotRoundTripped + renderMsg msg = mconcat ["JSON decode failed: " + , show msg + , "\nNB. JSON encoding: ", show $ case someSnapshot of + SomeLedgerPeerSnapshot lps -> toJSON lps + ] + + someSnapshot = + if v3 + then snapshotV3 slotNo (NetworkMagic pureMagic) ledgerPools big + else snapshotV2 slotNo ledgerPools + + jsonResult = case someSnapshot of + SomeLedgerPeerSnapshot lps -> case lps of + lps'@LedgerBigPeerSnapshotV23{} -> + SomeLedgerPeerSnapshot <$> (fromJSON @(LedgerPeerSnapshot BigLedgerPeers) . toJSON $ lps') + lps'@LedgerAllPeerSnapshotV23{} -> + SomeLedgerPeerSnapshot <$> (fromJSON @(LedgerPeerSnapshot AllLedgerPeers) . toJSON $ lps') + lps'@LedgerPeerSnapshotV2{} -> + SomeLedgerPeerSnapshot <$> (fromJSON @(LedgerPeerSnapshot BigLedgerPeers) . toJSON $ lps') + + someRoundTrip = case jsonResult of + Aeson.Success s -> Right $ s + Error str -> Left str + + nearlyEqualModuloFullyQualified :: SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Property + nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot + (LedgerPeerSnapshotV2 (wOrigin, relaysWithAccStake))) + (SomeLedgerPeerSnapshot + (LedgerPeerSnapshotV2 (wOrigin', relaysWithAccStake'))) = + let strippedRelaysWithAccStake = stripFQN <$> relaysWithAccStake strippedRelaysWithAccStake' = stripFQN <$> relaysWithAccStake' in wOrigin === wOrigin' @@ -572,6 +633,34 @@ prop_ledgerPeerSnapshotJSONV2 slotNo .&&. counterexample "approximation error" (compareApprox relaysWithAccStake relaysWithAccStake') + nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot + (LedgerBigPeerSnapshotV23 point magic relaysWithAccStake)) + (SomeLedgerPeerSnapshot + (LedgerBigPeerSnapshotV23 point' magic' relaysWithAccStake')) = + let strippedRelaysWithAccStake = stripFQN <$> relaysWithAccStake + strippedRelaysWithAccStake' = stripFQN <$> relaysWithAccStake' + in + point === point' + .&&. magic === magic' + .&&. counterexample "fully qualified name" + (strippedRelaysWithAccStake === strippedRelaysWithAccStake') + .&&. counterexample "approximation error" + (compareApprox relaysWithAccStake relaysWithAccStake') + + nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot + (LedgerAllPeerSnapshotV23 point magic relays)) + (SomeLedgerPeerSnapshot + (LedgerAllPeerSnapshotV23 point' magic' relays')) = + let strippedRelays = stripFQN <$> zip (repeat (0 :: Int)) relays + strippedRelays' = stripFQN <$> zip (repeat (0 :: Int)) relays' + in + point === point' + .&&. magic === magic' + .&&. counterexample "fully qualified name" + (strippedRelays === strippedRelays') + + nearlyEqualModuloFullyQualified _ _ = property False + stripFQN (_, (_, relays)) = step <$> relays step it@(LedgerRelayAccessDomain domain port) = case BS.unsnoc domain of @@ -601,15 +690,32 @@ prop_ledgerPeerSnapshotJSONV2 slotNo -- snapshotV2 :: SlotNo -> LedgerPools - -> LedgerPeerSnapshot + -> SomeLedgerPeerSnapshot snapshotV2 slot - (LedgerPools pools) = LedgerPeerSnapshotV2 (originOrSlot, poolStakeWithAccumulation) + (LedgerPools pools) = + SomeLedgerPeerSnapshot $ LedgerPeerSnapshotV2 (originOrSlot, poolStakeWithAccumulation) where poolStakeWithAccumulation = Map.assocs . accPoolStake $ pools originOrSlot = if slot == 0 then Origin else At slot +snapshotV3 :: SlotNo -> NetworkMagic -> LedgerPools -> Bool -> SomeLedgerPeerSnapshot +snapshotV3 slotNo magic (LedgerPools pools) big = snapshot + where + snapshot = + if big + then let point = BlockPoint slotNo hash + bigPools = Map.assocs . accPoolStake $ pools + lps = LedgerBigPeerSnapshotV23 point magic bigPools + hash = hashWith (BS.toStrict . Binary.encode . const (unSlotNo slotNo)) lps + in SomeLedgerPeerSnapshot lps + else let point = BlockPoint slotNo hash + lps = LedgerAllPeerSnapshotV23 point magic pools + hash = hashWith (BS.toStrict . Binary.encode . const (unSlotNo slotNo)) lps + in SomeLedgerPeerSnapshot lps + + -- TODO: Belongs in iosim. data SimResult a = SimReturn a [String] | SimException SomeException [String] diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs index f1896197a3d..db60c6db3c6 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs @@ -24,11 +24,9 @@ import Data.Hashable import Data.IP qualified as IP import Data.Word (Word16, Word32, Word64) -import Cardano.Slotting.Slot (SlotNo (..)) - +import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.DiffusionMode import Ouroboros.Network.PeerSelection.Governor - import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..), UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index 297b9b02074..fa9ec6f75ef 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -33,6 +33,7 @@ import GHC.Generics import Network.Mux.Trace (TraceLabelPeer (..)) +import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.ConnectionId import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, PeerMetricsConfiguration (..), ReportPeerMetrics (..), @@ -40,7 +41,6 @@ import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, reportMetric, upstreamyness) import Ouroboros.Network.SizeInBytes -import Cardano.Slotting.Slot (SlotNo (..)) import Control.Monad.IOSim From a501cedac717ac7b5907b0532c31b4aa32783dba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 17 Sep 2025 16:00:21 +0200 Subject: [PATCH 04/29] peer-selection: verify peer snapshot with hash --- cardano-diffusion/cardano-diffusion.cabal | 1 + .../Network/LedgerPeerConsensusInterface.hs | 11 ++- .../Network/PeerSelection/Governor/Monitor.hs | 70 ++++++++++++++----- .../lib/Ouroboros/Network/Diffusion/Types.hs | 2 +- .../Network/PeerSelection/Governor/Monitor.hs | 48 ++----------- .../Network/PeerSelection/Governor/Types.hs | 17 ++--- .../Network/PeerSelection/LedgerPeers.hs | 17 ++--- 7 files changed, 88 insertions(+), 78 deletions(-) diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 7b1eb44914b..b1280402932 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -151,6 +151,7 @@ library aeson, base >=4.14 && <4.22, bytestring, + cardano-crypto-class, cardano-diffusion:{api, protocols}, containers, contra-tracer, diff --git a/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs b/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs index 615cb5a3edb..1f5d3198738 100644 --- a/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs +++ b/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} + module Cardano.Network.LedgerPeerConsensusInterface ( LedgerPeersConsensusInterface (..) -- * Re-exports @@ -8,11 +10,14 @@ module Cardano.Network.LedgerPeerConsensusInterface import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) - +import Cardano.Crypto.Hash (Blake2b_256, Hash) import Cardano.Network.LedgerStateJudgement import Cardano.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState (..)) +import Ouroboros.Network.Block (SlotNo) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) +import Ouroboros.Network.Point (Block) + -- | Cardano Node specific consensus interface actions. -- @@ -31,4 +36,6 @@ data LedgerPeersConsensusInterface m = -- it only has local peers. -- , updateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + + , getBlockHash :: forall a. SlotNo -> STM m (Block SlotNo (Hash Blake2b_256 a)) } diff --git a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs index 5bd3a370f45..658c3ae45ee 100644 --- a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs +++ b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module contains governor decisions for monitoring tasks: -- @@ -18,14 +22,18 @@ module Cardano.Network.PeerSelection.Governor.Monitor , ExtraTrace (..) ) where -import Data.Set qualified as Set - +import Control.Concurrent.JobPool (Job (..)) +import Control.Exception (assert) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Cardano.Crypto.Hash as Crypto (castHash) import Cardano.Network.ConsensusMode -import Cardano.Network.Diffusion.Configuration qualified as Cardano (srvPrefix) import Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano import Cardano.Network.LedgerStateJudgement import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..), @@ -37,24 +45,22 @@ import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Ca import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Cardano.Network.PeerSelection.PublicRootPeers qualified as Cardano.PublicRootPeers import Cardano.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers -import Control.Exception (assert) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Set (Set) +import Ouroboros.Network.Block (HeaderHash, SlotNo, atSlot, pattern BlockPoint, + withHash) import Ouroboros.Network.PeerSelection.Governor.ActivePeers (jobDemoteActivePeer) -import Ouroboros.Network.PeerSelection.Governor.Monitor (jobVerifyPeerSnapshot) import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface (..)) + (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..), + LedgerPeersKind (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (LocalRootConfig (..)) import Ouroboros.Network.PeerSelection.Types -import Ouroboros.Network.Point (Block (..), WithOrigin (..)) +import Ouroboros.Network.Point (Block (..)) -- | Used to set 'bootstrapPeersTimeout' for crashing the node in a critical @@ -496,8 +502,8 @@ monitorLedgerStateJudgement (TimedDecision m Cardano.ExtraState extraDebugState extraFlags (Cardano.ExtraPeers peeraddr) ExtraTrace peeraddr peerconn) monitorLedgerStateJudgement PeerSelectionActions{ - getLedgerStateCtx = ledgerCtx@LedgerPeersConsensusInterface { - lpExtraAPI = Cardano.LedgerPeersConsensusInterface { + getLedgerStateCtx = LedgerPeersConsensusInterface { + lpExtraAPI = lpExtraAPI@Cardano.LedgerPeersConsensusInterface { Cardano.getLedgerStateJudgement = readLedgerStateJudgement } } @@ -524,8 +530,9 @@ monitorLedgerStateJudgement PeerSelectionActions{ Decision { decisionTrace = [ExtraTrace (TraceLedgerStateJudgementChanged lsj)], decisionJobs = case (lsj, ledgerPeerSnapshot) of - (TooOld, Just ledgerPeerSnapshot') -> - [jobVerifyPeerSnapshot Cardano.srvPrefix ledgerPeerSnapshot' ledgerCtx] + (TooOld, Just (LedgerBigPeerSnapshotV23 point _magic _pools)) + | BlockPoint { atSlot, withHash } <- point -> + [jobVerifyPeerSnapshot (atSlot, withHash) lpExtraAPI] _otherwise -> [], decisionState = st { extraState = cpst { @@ -676,6 +683,35 @@ waitForSystemToQuiesce st@PeerSelectionState{ | otherwise = GuardedSkip Nothing +-- |This job, which is initiated by monitorLedgerStateJudgement job, +-- verifies whether the provided big ledger pools match up with the +-- ledger state once the node catches up to the slot at which the +-- snapshot was ostensibly taken +-- +jobVerifyPeerSnapshot :: (MonadSTM m) + => (SlotNo, HeaderHash (LedgerPeerSnapshot BigLedgerPeers)) + -> Cardano.LedgerPeersConsensusInterface m + -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn) +jobVerifyPeerSnapshot (slotNo, theHash) + Cardano.LedgerPeersConsensusInterface { getBlockHash } + = Job job (const (completion False)) () "jobVerifyPeerSnapshot" + where + completion result = return . Completion $ \st _now -> + Decision { + decisionTrace = [TraceVerifyPeerSnapshot result], + decisionState = st, + decisionJobs = [] } + + job = do + Block { blockPointHash } <- atomically $ getBlockHash slotNo + let result = theHash == Crypto.castHash blockPointHash + return . Completion $ \st _now -> + Decision { + decisionTrace = [TraceVerifyPeerSnapshot result], + decisionState = st, + decisionJobs = [] } + + -- | Extra trace points for `TracePeerSelection`. -- -- TODO: it ought to be moved to `Types`, but that introduces a circular diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs index cca8c7912dd..40ab961efc3 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs @@ -473,7 +473,7 @@ data Configuration extraFlags m ntnFd ntnAddr ntcFd ntcAddr = Configuration { -- These peers may be selected by ledgerPeersThread when requested -- by the peer selection governor when the node is syncing up. -- This is especially useful for Genesis consensus mode. - , dcReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) + , dcReadLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -- | `UseLedgerPeers` from topology file. -- diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index ab2a8cc6d5d..61b0f865bce 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,7 +12,6 @@ module Ouroboros.Network.PeerSelection.Governor.Monitor ( targetPeers , jobs - , jobVerifyPeerSnapshot , connections , localRoots , ledgerPeerSnapshotChange @@ -23,7 +23,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Set (Set) import Data.Set qualified as Set -import Control.Concurrent.JobPool (Job (..), JobPool) +import Control.Concurrent.JobPool (JobPool) import Control.Concurrent.JobPool qualified as JobPool import Control.Exception (assert) import Control.Monad.Class.MonadSTM @@ -31,7 +31,6 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import System.Random (randomR) -import Ouroboros.Network.Block (HeaderHash, SlotNo) import Ouroboros.Network.ExitPolicy (RepromoteDelay) import Ouroboros.Network.ExitPolicy qualified as ExitPolicy import Ouroboros.Network.PeerSelection.Governor.ActivePeers @@ -39,11 +38,7 @@ import Ouroboros.Network.PeerSelection.Governor.ActivePeers import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..), - SRVPrefix, compareLedgerPeerSnapshotApproximate, - getRelayAccessPointsFromLedger, - getRelayAccessPointsFromLedgerPeerSnapshot) -import Ouroboros.Network.PeerSelection.LedgerPeers.Utils + (LedgerPeerSnapshot (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers @@ -410,38 +405,6 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers | (peeraddr, peerconn) <- Map.assocs selectedToDemote' ] } --- |This job, which is initiated by monitorLedgerStateJudgement job, --- verifies whether the provided big ledger pools match up with the --- ledger state once the node catches up to the slot at which the --- snapshot was ostensibly taken --- -jobVerifyPeerSnapshot :: MonadSTM m - => SRVPrefix - -> LedgerPeerSnapshot - -> LedgerPeersConsensusInterface extraAPI m - -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn) -jobVerifyPeerSnapshot srvPrefix - ledgerPeerSnapshot - ledgerCtx@LedgerPeersConsensusInterface { lpGetLatestSlot } - = Job job (const (completion False)) () "jobVerifyPeerSnapshot" - where - (slot, snapshotPeers) = - getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot - - completion result = return . Completion $ \st _now -> - Decision { - decisionTrace = [TraceVerifyPeerSnapshot result], - decisionState = st, - decisionJobs = [] } - - job = do - ledgerPeers <- - atomically $ do - check . (>= slot) =<< lpGetLatestSlot - accumulateBigLedgerStake <$> getRelayAccessPointsFromLedger srvPrefix ledgerCtx - completion $ snapshotPeers - `compareLedgerPeerSnapshotApproximate` - ledgerPeers -- |This job monitors for any changes in the big ledger peer snapshot -- and flips ledger state judgement private state so that monitoring action @@ -464,8 +427,9 @@ ledgerPeerSnapshotChange extraStateChange ledgerPeerSnapshot' <- readLedgerPeerSnapshot case (ledgerPeerSnapshot', ledgerPeerSnapshot) of (Nothing, _) -> retry - (Just (LedgerPeerSnapshot (slot, _)), Just (LedgerPeerSnapshot (slot', _))) - | slot == slot' -> retry + (Just (LedgerBigPeerSnapshotV23 point _magic _pools), + Just (LedgerBigPeerSnapshotV23 point' _magic' _pools')) + | point == point' -> retry _otherwise -> return $ \_now -> Decision { decisionTrace = [], diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs index be3d925f5bb..4fa65dbb288 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,6 +10,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} #if __GLASGOW_HASKELL__ < 904 @@ -70,6 +72,11 @@ module Ouroboros.Network.PeerSelection.Governor.Types , DemotionTimeoutException (..) ) where +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Concurrent.JobPool (Job) +import Control.Exception (Exception (..), SomeException, assert) +import Control.Monad.Class.MonadTime.SI import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) @@ -81,12 +88,6 @@ import Data.Set qualified as Set import GHC.Stack (HasCallStack) import System.Random (StdGen) -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Concurrent.JobPool (Job) -import Control.Exception (Exception (..), SomeException, assert) -import Control.Monad.Class.MonadTime.SI - import Ouroboros.Network.DiffusionMode import Ouroboros.Network.ExitPolicy import Ouroboros.Network.PeerSelection.LedgerPeers.Type @@ -351,7 +352,7 @@ data PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounter -- | Read the current state of ledger peer snapshot -- - readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) + readLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)) } -- | Interfaces required by the peer selection governor, which do not need to @@ -646,7 +647,7 @@ data PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn = -- | Internal state of ledger peer snapshot -- - ledgerPeerSnapshot :: Maybe LedgerPeerSnapshot, + ledgerPeerSnapshot :: Maybe (LedgerPeerSnapshot BigLedgerPeers), -- | Extension point so that 3rd party users can plug their own peer -- selection state if needed diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 834fe193a07..371d98d77dc 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -36,9 +37,11 @@ module Ouroboros.Network.PeerSelection.LedgerPeers , resolveLedgerPeers ) where +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) import Data.IP qualified as IP @@ -49,16 +52,14 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (isJust) import Data.Ratio -import System.Random -import Text.Printf - -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow import Data.Set (Set) import Data.Set qualified as Set import Data.Void (Void) import Data.Word (Word16, Word64) import Network.DNS qualified as DNS +import System.Random +import Text.Printf + import Ouroboros.Network.Block (SlotNo) import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.LedgerPeers.Utils @@ -381,7 +382,7 @@ ledgerPeersThread PeerActionsDNS { data StakeMapOverSource = StakeMapOverSource { ledgerWithOrigin :: WithOrigin SlotNo, ledgerPeers :: LedgerPeers, - peerSnapshot :: Maybe LedgerPeerSnapshot, + peerSnapshot :: Maybe (LedgerPeerSnapshot BigLedgerPeers), cachedSlot :: Maybe SlotNo, peerMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), bigPeerMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), @@ -412,7 +413,7 @@ stakeMapWithSlotOverSource StakeMapOverSource { -- check if we can use the snapshot first (ledgerSlotNo, _, Just ledgerPeerSnapshot) | (At snapshotSlotNo, snapshotRelays) - <- getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot + <- getRelayAccessPointsFromBigLedgerPeersSnapshot srvPrefix ledgerPeerSnapshot , snapshotSlotNo >= ledgerSlotNo' , snapshotSlotNo >= useLedgerAfter' -> -- we cache the peers from the snapshot @@ -448,7 +449,7 @@ data WithLedgerPeersArgs extraAPI m = WithLedgerPeersArgs { -- ^ Get Ledger Peers comes from here wlpGetUseLedgerPeers :: STM m UseLedgerPeers, -- ^ Get Use Ledger After value - wlpGetLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot), + wlpGetLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)), -- ^ Get ledger peer snapshot from file read by node wlpSemaphore :: DNSSemaphore m, wlpSRVPrefix :: SRVPrefix From 98992a35caca4d065eff9c2703feffe4bf980e93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 18 Sep 2025 11:20:56 +0200 Subject: [PATCH 05/29] Bump to NodeToClientV_23 Supports block hash in cbor encoding of ledger peer snapshot --- .../Cardano/Network/NodeToClient/Version.hs | 5 + .../cddl/specs/handshake-node-to-client.cddl | 2 +- cardano-ping/src/Cardano/Network/Ping.hs | 112 ++++++++++-------- 3 files changed, 66 insertions(+), 53 deletions(-) diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs index b74593ab2de..9fb0538daf8 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs @@ -56,8 +56,13 @@ data NodeToClientVersion -- ^ new codecs for @PParams@ and @CompactGenesis@ | NodeToClientV_22 -- ^ support SRV records in @GetBigLedgerPeerSnapshot@ query + -- TODO: remove CBOR instances from LedgerPeers.Type when V22 support + -- is removed, update {To,From}JSON LedgerPeerSnapshot instances + -- and update LedgerPeerSnapshot query encoding in consensus. + -- marked with TODO's. | NodeToClientV_23 -- ^ added @QueryDRepsDelegations@, + -- LedgerPeerSnapshot CBOR encoding contains block hash and NetworkMagic deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData) -- | We set 16ths bit to distinguish `NodeToNodeVersion` and diff --git a/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl b/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl index 3d917758421..8715996714a 100644 --- a/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl +++ b/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl @@ -19,7 +19,7 @@ versionTable = { * versionNumber => nodeToClientVersionData } ; as of version 2 (which is no longer supported) we set 16th bit to 1 -; 16 / 17 / 18 / 19 / 20 / 21 / 22 / 23 +; 16 / 17 / 18 / 19 / 20 / 21 / 22 / 23 versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 / 32790 / 32791 ; As of version 15 and higher diff --git a/cardano-ping/src/Cardano/Network/Ping.hs b/cardano-ping/src/Cardano/Network/Ping.hs index ae723af712b..1b38178e4b1 100644 --- a/cardano-ping/src/Cardano/Network/Ping.hs +++ b/cardano-ping/src/Cardano/Network/Ping.hs @@ -154,6 +154,7 @@ supportedNodeToClientVersions magic = , NodeToClientVersionV20 magic , NodeToClientVersionV21 magic , NodeToClientVersionV22 magic + , NodeToClientVersionV23 magic ] data InitiatorOnly = InitiatorOnly | InitiatorAndResponder @@ -193,6 +194,7 @@ data NodeVersion | NodeToClientVersionV20 Word32 | NodeToClientVersionV21 Word32 | NodeToClientVersionV22 Word32 + | NodeToClientVersionV23 Word32 | NodeToNodeVersionV1 Word32 | NodeToNodeVersionV2 Word32 | NodeToNodeVersionV3 Word32 @@ -212,32 +214,33 @@ data NodeVersion instance ToJSON NodeVersion where toJSON nv = object $ case nv of - NodeToClientVersionV9 m -> go2 "NodeToClientVersionV9" m - NodeToClientVersionV10 m -> go2 "NodeToClientVersionV10" m - NodeToClientVersionV11 m -> go2 "NodeToClientVersionV11" m - NodeToClientVersionV12 m -> go2 "NodeToClientVersionV12" m - NodeToClientVersionV13 m -> go2 "NodeToClientVersionV13" m - NodeToClientVersionV14 m -> go2 "NodeToClientVersionV14" m - NodeToClientVersionV15 m -> go2 "NodeToClientVersionV15" m - NodeToClientVersionV16 m -> go2 "NodeToClientVersionV16" m - NodeToClientVersionV17 m -> go2 "NodeToClientVersionV17" m - NodeToClientVersionV18 m -> go2 "NodeToClientVersionV18" m - NodeToClientVersionV19 m -> go2 "NodeToClientVersionV19" m - NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m - NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m - NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m - NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m - NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m - NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m - NodeToNodeVersionV4 m i -> go3 "NodeToNodeVersionV4" m i - NodeToNodeVersionV5 m i -> go3 "NodeToNodeVersionV5" m i - NodeToNodeVersionV6 m i -> go3 "NodeToNodeVersionV6" m i - NodeToNodeVersionV7 m i -> go3 "NodeToNodeVersionV7" m i - NodeToNodeVersionV8 m i -> go3 "NodeToNodeVersionV8" m i - NodeToNodeVersionV9 m i -> go3 "NodeToNodeVersionV9" m i - NodeToNodeVersionV10 m i -> go3 "NodeToNodeVersionV10" m i - NodeToNodeVersionV11 m i -> go3 "NodeToNodeVersionV11" m i - NodeToNodeVersionV12 m i -> go3 "NodeToNodeVersionV12" m i + NodeToClientVersionV9 m -> go2 "NodeToClientVersionV9" m + NodeToClientVersionV10 m -> go2 "NodeToClientVersionV10" m + NodeToClientVersionV11 m -> go2 "NodeToClientVersionV11" m + NodeToClientVersionV12 m -> go2 "NodeToClientVersionV12" m + NodeToClientVersionV13 m -> go2 "NodeToClientVersionV13" m + NodeToClientVersionV14 m -> go2 "NodeToClientVersionV14" m + NodeToClientVersionV15 m -> go2 "NodeToClientVersionV15" m + NodeToClientVersionV16 m -> go2 "NodeToClientVersionV16" m + NodeToClientVersionV17 m -> go2 "NodeToClientVersionV17" m + NodeToClientVersionV18 m -> go2 "NodeToClientVersionV18" m + NodeToClientVersionV19 m -> go2 "NodeToClientVersionV19" m + NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m + NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m + NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m + NodeToClientVersionV23 m -> go2 "NodeToClientVersionV23" m + NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m + NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m + NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m + NodeToNodeVersionV4 m i -> go3 "NodeToNodeVersionV4" m i + NodeToNodeVersionV5 m i -> go3 "NodeToNodeVersionV5" m i + NodeToNodeVersionV6 m i -> go3 "NodeToNodeVersionV6" m i + NodeToNodeVersionV7 m i -> go3 "NodeToNodeVersionV7" m i + NodeToNodeVersionV8 m i -> go3 "NodeToNodeVersionV8" m i + NodeToNodeVersionV9 m i -> go3 "NodeToNodeVersionV9" m i + NodeToNodeVersionV10 m i -> go3 "NodeToNodeVersionV10" m i + NodeToNodeVersionV11 m i -> go3 "NodeToNodeVersionV11" m i + NodeToNodeVersionV12 m i -> go3 "NodeToNodeVersionV12" m i NodeToNodeVersionV13 m i ps -> go4 "NodeToNodeVersionV13" m i ps NodeToNodeVersionV14 m i ps -> go4 "NodeToNodeVersionV14" m i ps where @@ -377,6 +380,9 @@ handshakeReqEnc versions query = encodeVersion (NodeToClientVersionV22 magic) = CBOR.encodeWord (22 `setBit` nodeToClientVersionBit) <> nodeToClientDataWithQuery magic + encodeVersion (NodeToClientVersionV23 magic) = + CBOR.encodeWord (23 `setBit` nodeToClientVersionBit) + <> nodeToClientDataWithQuery magic -- node-to-node encodeVersion (NodeToNodeVersionV1 magic) = @@ -528,6 +534,7 @@ handshakeDec = do (20, True) -> Right . NodeToClientVersionV20 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (21, True) -> Right . NodeToClientVersionV21 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (22, True) -> Right . NodeToClientVersionV22 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) + (23, True) -> Right . NodeToClientVersionV23 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) _ -> return $ Left $ UnknownVersionInRsp version decodeWithMode :: (Word32 -> InitiatorOnly -> NodeVersion) -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) @@ -839,31 +846,32 @@ pingClient stdout stderr PingOpts{..} versions peer = bracket isSameVersionAndMagic :: NodeVersion -> NodeVersion -> Bool isSameVersionAndMagic v1 v2 = extract v1 == extract v2 where extract :: NodeVersion -> (Int, Word32) - extract (NodeToClientVersionV9 m) = (-9, m) - extract (NodeToClientVersionV10 m) = (-10, m) - extract (NodeToClientVersionV11 m) = (-11, m) - extract (NodeToClientVersionV12 m) = (-12, m) - extract (NodeToClientVersionV13 m) = (-13, m) - extract (NodeToClientVersionV14 m) = (-14, m) - extract (NodeToClientVersionV15 m) = (-15, m) - extract (NodeToClientVersionV16 m) = (-16, m) - extract (NodeToClientVersionV17 m) = (-17, m) - extract (NodeToClientVersionV18 m) = (-18, m) - extract (NodeToClientVersionV19 m) = (-19, m) - extract (NodeToClientVersionV20 m) = (-20, m) - extract (NodeToClientVersionV21 m) = (-21, m) - extract (NodeToClientVersionV22 m) = (-22, m) - extract (NodeToNodeVersionV1 m) = (1, m) - extract (NodeToNodeVersionV2 m) = (2, m) - extract (NodeToNodeVersionV3 m) = (3, m) - extract (NodeToNodeVersionV4 m _) = (4, m) - extract (NodeToNodeVersionV5 m _) = (5, m) - extract (NodeToNodeVersionV6 m _) = (6, m) - extract (NodeToNodeVersionV7 m _) = (7, m) - extract (NodeToNodeVersionV8 m _) = (8, m) - extract (NodeToNodeVersionV9 m _) = (9, m) - extract (NodeToNodeVersionV10 m _) = (10, m) - extract (NodeToNodeVersionV11 m _) = (11, m) - extract (NodeToNodeVersionV12 m _) = (12, m) + extract (NodeToClientVersionV9 m) = (-9, m) + extract (NodeToClientVersionV10 m) = (-10, m) + extract (NodeToClientVersionV11 m) = (-11, m) + extract (NodeToClientVersionV12 m) = (-12, m) + extract (NodeToClientVersionV13 m) = (-13, m) + extract (NodeToClientVersionV14 m) = (-14, m) + extract (NodeToClientVersionV15 m) = (-15, m) + extract (NodeToClientVersionV16 m) = (-16, m) + extract (NodeToClientVersionV17 m) = (-17, m) + extract (NodeToClientVersionV18 m) = (-18, m) + extract (NodeToClientVersionV19 m) = (-19, m) + extract (NodeToClientVersionV20 m) = (-20, m) + extract (NodeToClientVersionV21 m) = (-21, m) + extract (NodeToClientVersionV22 m) = (-22, m) + extract (NodeToClientVersionV23 m) = (-23, m) + extract (NodeToNodeVersionV1 m) = (1, m) + extract (NodeToNodeVersionV2 m) = (2, m) + extract (NodeToNodeVersionV3 m) = (3, m) + extract (NodeToNodeVersionV4 m _) = (4, m) + extract (NodeToNodeVersionV5 m _) = (5, m) + extract (NodeToNodeVersionV6 m _) = (6, m) + extract (NodeToNodeVersionV7 m _) = (7, m) + extract (NodeToNodeVersionV8 m _) = (8, m) + extract (NodeToNodeVersionV9 m _) = (9, m) + extract (NodeToNodeVersionV10 m _) = (10, m) + extract (NodeToNodeVersionV11 m _) = (11, m) + extract (NodeToNodeVersionV12 m _) = (12, m) extract (NodeToNodeVersionV13 m _ _) = (13, m) extract (NodeToNodeVersionV14 m _ _) = (14, m) From b10bcab81e6e305047d1bd9d8587957a4def9470 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 30 Oct 2025 16:27:38 +0100 Subject: [PATCH 06/29] dmq: integrate LedgerPeerSnapshot changes --- dmq-node/src/DMQ/Configuration.hs | 9 ++++----- dmq-node/src/DMQ/Configuration/Topology.hs | 8 +++++--- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index b524497c969..2cf7c16b093 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -69,7 +70,7 @@ import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.PeerSelection.Governor.Types (PeerSelectionTargets (..), makePublicPeerSelectionStateVar) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeerSnapshot (..)) + (LedgerPeerSnapshot (..), LedgerPeersKind (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (LocalAddress (..), RemoteAddress) @@ -577,8 +578,8 @@ mkDiffusionConfiguration updateLedgerPeerSnapshot :: HasCallStack => FilePath -> STM IO (Maybe FilePath) - -> (Maybe LedgerPeerSnapshot -> STM IO ()) - -> IO (Maybe LedgerPeerSnapshot) + -> (Maybe (LedgerPeerSnapshot BigLedgerPeers) -> STM IO ()) + -> IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) updateLedgerPeerSnapshot topologyDir readLedgerPeerPath writeVar = do mPeerSnapshotFile <- atomically readLedgerPeerPath mLedgerPeerSnapshot <- case mPeerSnapshotFile of @@ -612,5 +613,3 @@ data ConfigurationError = instance Exception ConfigurationError where displayException NoAddressInformation = "no ipv4 or ipv6 address specified, use --host-addr or --host-ipv6-addr" - - diff --git a/dmq-node/src/DMQ/Configuration/Topology.hs b/dmq-node/src/DMQ/Configuration/Topology.hs index 23f33f861d0..c5857ac0b00 100644 --- a/dmq-node/src/DMQ/Configuration/Topology.hs +++ b/dmq-node/src/DMQ/Configuration/Topology.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} @@ -16,7 +17,8 @@ import Data.Text qualified as Text import Ouroboros.Network.Diffusion.Topology (NetworkTopology (..)) import Ouroboros.Network.OrphanInstances (localRootPeersGroupsFromJSON, networkTopologyFromJSON, networkTopologyToJSON) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, + LedgerPeersKind (..)) import System.Exit (die) data NoExtraConfig = NoExtraConfig @@ -69,7 +71,7 @@ readTopologyFileOrError nc = >>= either (die . Text.unpack) pure -readPeerSnapshotFile :: FilePath -> IO (Either Text LedgerPeerSnapshot) +readPeerSnapshotFile :: FilePath -> IO (Either Text (LedgerPeerSnapshot BigLedgerPeers)) readPeerSnapshotFile psf = do eBs <- try $ BS.readFile psf case eBs of @@ -89,7 +91,7 @@ readPeerSnapshotFile psf = do , Text.pack err ] -readPeerSnapshotFileOrError :: FilePath -> IO LedgerPeerSnapshot +readPeerSnapshotFileOrError :: FilePath -> IO (LedgerPeerSnapshot BigLedgerPeers) readPeerSnapshotFileOrError psf = readPeerSnapshotFile psf >>= either (die . Text.unpack) From 5275f2688d1260b5fb317a1fefe8938e3e40bbb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 28 Oct 2025 16:29:38 +0100 Subject: [PATCH 07/29] scriv --- ...ocodile-dentist_ledgerpeersnapshot_hash.md | 16 +++++++++++++ ...ocodile-dentist_ledgerpeersnapshot_hash.md | 11 +++++++++ ...ocodile-dentist_ledgerpeersnapshot_hash.md | 17 ++++++++++++++ ...ocodile-dentist_ledgerpeersnapshot_hash.md | 23 +++++++++++++++++++ 4 files changed, 67 insertions(+) create mode 100644 cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md create mode 100644 cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md create mode 100644 dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md create mode 100644 ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md diff --git a/cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md b/cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..817fddffd6f --- /dev/null +++ b/cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,16 @@ + + +### Breaking + +cardano-diffusion: +- added `lpGetBlockInfo` to `LedgerPeersConsensusInterface` + +### Non-Breaking + +cardano-diffusion: +- moved `jobVerifyPeerSnapshot` from o-n diff --git a/cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md b/cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..d161d5d0209 --- /dev/null +++ b/cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,11 @@ + + + +### Breaking + +- Added `NodeToClientVersionV23` diff --git a/dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md b/dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..200772f8c93 --- /dev/null +++ b/dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,17 @@ + + + + +### Non-Breaking + +- update to new LedgerPeerSnapshot definition diff --git a/ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md b/ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..d064b8de6f3 --- /dev/null +++ b/ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,23 @@ + + +### Breaking + +o-n-api: +- Added tag `LedgerPeerSnapshotV3` +- removed compareLedgerPeerSnapshotApproximate + +### Non-Breaking + +o-n-api: +- Added {To,From}JSON instances to `Point` and `Block` +- added {encode,decode}LedgerPeerSnapshotPoint +- added {encode,decode}StakePools + +o-n: +- Removed cardano-slotting dependency +- moved `jobVerifyPeerSnapshot` to cardano-diffusion From 9f5e7f583a4d716381dda64fa9219f50765642e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 4 Nov 2025 15:01:20 +0100 Subject: [PATCH 08/29] nix: fix static build --- nix/ouroboros-network.nix | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix index f3a54858a59..3fe34a1063b 100644 --- a/nix/ouroboros-network.nix +++ b/nix/ouroboros-network.nix @@ -137,6 +137,19 @@ let "-L${lib.getLib static-secp256k1}/lib" "-L${lib.getLib static-libblst}/lib" ]; + packages.cardano-diffusion.ghcOptions = with pkgs; [ + "-L${lib.getLib static-gmp}/lib" + "-L${lib.getLib static-libsodium-vrf}/lib" + "-L${lib.getLib static-secp256k1}/lib" + "-L${lib.getLib static-libblst}/lib" + ]; + # for api-bench + packages.ouroboros-network.ghcOptions = with pkgs; [ + "-L${lib.getLib static-gmp}/lib" + "-L${lib.getLib static-libsodium-vrf}/lib" + "-L${lib.getLib static-secp256k1}/lib" + "-L${lib.getLib static-libblst}/lib" + ]; }) ]; }); From 69b14c743b9cbf5da5e1aa9d9ac890f788379a17 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 27 Aug 2025 11:17:20 +0200 Subject: [PATCH 09/29] quickcheck-monoids: compatibility with QuickCheck-2.16 --- cardano-diffusion/cardano-diffusion.cabal | 6 +- .../Test/Cardano/Network/Diffusion/Testnet.hs | 4 + .../lib/Test/Cardano/Network/PeerSelection.hs | 1 + nix/ouroboros-network.nix | 2 + .../Test/Ouroboros/Network/Server/Sim.hs | 6 ++ .../Network/ConnectionManager/Timeouts.hs | 6 ++ .../Network/ConnectionManager/Utils.hs | 6 ++ .../Network/InboundGovernor/Utils.hs | 6 ++ ouroboros-network/ouroboros-network.cabal | 26 ++++-- .../Network/Protocol/LocalStateQuery/Test.hs | 9 +- .../Network/PeerSelection/PeerMetric.hs | 4 + .../Ouroboros/Network/TxSubmission/AppV2.hs | 6 ++ .../Ouroboros/Network/TxSubmission/TxLogic.hs | 6 ++ quickcheck-monoids/CHANGELOG.md | 20 +++++ quickcheck-monoids/quickcheck-monoids.cabal | 57 +++++++++++++ .../src/Test/QuickCheck/Monoids.hs | 85 +++++++++++++++++++ 16 files changed, 240 insertions(+), 10 deletions(-) create mode 100644 quickcheck-monoids/CHANGELOG.md create mode 100644 quickcheck-monoids/quickcheck-monoids.cabal create mode 100644 quickcheck-monoids/src/Test/QuickCheck/Monoids.hs diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index b1280402932..8aa483b0012 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -431,10 +431,13 @@ test-suite protocols-bench library cardano-diffusion-tests-lib import: ghc-options-tests + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + visibility: public hs-source-dirs: tests/lib build-depends: - QuickCheck >=2.16, + QuickCheck, aeson, base >=4.14 && <4.22, bytestring, @@ -454,6 +457,7 @@ library cardano-diffusion-tests-lib pipes, pretty-simple, psqueues, + quickcheck-monoids, random, serialise, tasty, diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs index 3e4ac9f977b..0fb8ec0e09b 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -106,6 +107,9 @@ import Test.Ouroboros.Network.TxSubmission.Types (Tx (..), TxId) import Test.Ouroboros.Network.Utils hiding (SmallDelay, debugTracer) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty import Test.Tasty.QuickCheck (testProperty) diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs index bb73269c9d9..7dce68270b9 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs @@ -94,6 +94,7 @@ import Cardano.Network.PeerSelection.Governor.Types qualified as Cardano.ExtraSi import Cardano.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..)) import Test.QuickCheck +import Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck import Text.Pretty.Simple diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix index 3fe34a1063b..e5baae054e1 100644 --- a/nix/ouroboros-network.nix +++ b/nix/ouroboros-network.nix @@ -43,6 +43,8 @@ let # stdenv.hostPlatform.isWindows will work as expected src = ./..; name = "ouroboros-network"; + index-state = "2025-07-16T09:24:19Z"; + index-sha256 = "sha256-fmnSRF68/UIQYzzdmNs3UT0cbYhn9d5nlhb3BnVXe48="; compiler-nix-name = lib.mkDefault defaultCompiler; cabalProjectLocal = if pkgs.stdenv.hostPlatform.isWindows diff --git a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index a6bd00592ec..a8ddfbe84c4 100644 --- a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -15,6 +15,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +#if !MIN_VERSION_QuickCheck(2,16,0) +{-# LANGUAGE PackageImports #-} +#endif -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -64,6 +67,9 @@ import System.Random (StdGen, mkStdGen, split) import Text.Printf import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs index 22d07e6a33f..ec511a8ab53 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs @@ -1,5 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} + +{-# LANGUAGE CPP #-} module Test.Ouroboros.Network.ConnectionManager.Timeouts ( verifyAllTimeouts @@ -39,6 +42,9 @@ import Data.Monoid (Sum (Sum)) import Text.Printf (printf) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Core qualified as CM diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs index 573ce87ba89..ebe7f4860d8 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Utils.hs @@ -1,6 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + module Test.Ouroboros.Network.ConnectionManager.Utils where import Prelude hiding (read) @@ -10,6 +13,9 @@ import Ouroboros.Network.ConnectionManager.Core as CM import Ouroboros.Network.ConnectionManager.Types import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif verifyAbstractTransition :: AbstractTransition diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs index 171674153d2..d9ad578bf19 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/InboundGovernor/Utils.hs @@ -1,11 +1,17 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} + module Test.Ouroboros.Network.InboundGovernor.Utils where import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor (RemoteSt (..)) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 96f2f83481b..6ababba7f96 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -470,6 +470,9 @@ test-suite tests-lib-tests library framework-tests-lib import: ghc-options + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + visibility: public hs-source-dirs: framework/tests-lib exposed-modules: @@ -481,7 +484,7 @@ library framework-tests-lib Test.Ouroboros.Network.RawBearer.Utils build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -492,12 +495,16 @@ library framework-tests-lib io-sim, network-mux, ouroboros-network:{api, framework, tests-lib}, + quickcheck-monoids, random, serialise, typed-protocols:{typed-protocols, examples}, test-suite framework-sim-tests import: ghc-options + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: framework/sim-tests @@ -509,7 +516,7 @@ test-suite framework-sim-tests Test.Simulation.Network.Snocket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -523,6 +530,7 @@ test-suite framework-sim-tests pretty-simple, psqueues, quickcheck-instances, + quickcheck-monoids, quiet, random, serialise, @@ -551,7 +559,7 @@ test-suite framework-io-tests Test.Ouroboros.Network.Socket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, contra-tracer, @@ -819,10 +827,13 @@ test-suite protocols-tests -- Simulation Test Library library ouroboros-network-tests-lib import: ghc-options-tests + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + visibility: public hs-source-dirs: tests/lib build-depends: - QuickCheck >=2.16, + QuickCheck, aeson, array, base >=4.14 && <4.22, @@ -846,6 +857,7 @@ library ouroboros-network-tests-lib nothunks, ouroboros-network:{ouroboros-network, api, api-tests-lib, framework, framework-tests-lib, protocols, protocols-tests-lib, tests-lib}, pretty-simple, + quickcheck-monoids, random, serialise, splitmix, @@ -854,6 +866,7 @@ library ouroboros-network-tests-lib tasty-quickcheck, text, time >=1.9.1 && <1.14, + transformers-except, typed-protocols, exposed-modules: @@ -880,6 +893,9 @@ library ouroboros-network-tests-lib Test.Ouroboros.Network.TxSubmission.TxLogic Test.Ouroboros.Network.TxSubmission.Types + ghc-options: + -Wno-unused-packages + -- Simulation tests, and IO tests which don't require native system calls. -- (i.e. they don't require system call API provided by `Win32-network` or -- `network` dependency). test-suite sim-tests @@ -916,7 +932,7 @@ test-suite ouroboros-network-io-tests Test.Ouroboros.Network.Socket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs index 6bb7bba12a0..7d5c3f207cd 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs @@ -46,7 +46,8 @@ import Ouroboros.Network.Mock.ChainGenerators () import Ouroboros.Network.Mock.ConcreteBlock (Block) import Ouroboros.Network.Protocol.LocalStateQuery.Client -import Ouroboros.Network.Protocol.LocalStateQuery.Codec +import Ouroboros.Network.Protocol.LocalStateQuery.Codec hiding (Some (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Codec qualified as LocalStateQuery import Ouroboros.Network.Protocol.LocalStateQuery.Direct import Ouroboros.Network.Protocol.LocalStateQuery.Examples import Ouroboros.Network.Protocol.LocalStateQuery.Server @@ -54,7 +55,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type import Test.Ouroboros.Network.Protocol.Utils -import Test.QuickCheck as QC hiding (Result, Some (Some)) +import Test.QuickCheck as QC hiding (Result) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Show.Functions () @@ -386,10 +387,10 @@ codec = encodeQuery :: Query result -> CBOR.Encoding encodeQuery GetTheLedgerState = Serialise.encode () - decodeQuery :: forall s . CBOR.Decoder s (Some Query) + decodeQuery :: forall s . CBOR.Decoder s (LocalStateQuery.Some Query) decodeQuery = do () <- Serialise.decode - return $ Some GetTheLedgerState + return $ LocalStateQuery.Some GetTheLedgerState encodeResult :: Query result -> result -> CBOR.Encoding encodeResult GetTheLedgerState = Serialise.encode diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index fa9ec6f75ef..1455faf7811 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 908 @@ -49,6 +50,9 @@ import NoThunks.Class import Test.Ouroboros.Network.Data.Script import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs index c12e9ca59dd..f08ddb1d5db 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -4,11 +4,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Test.Ouroboros.Network.TxSubmission.AppV2 (tests) where @@ -63,6 +66,9 @@ import Test.Ouroboros.Network.TxSubmission.Types import Test.Ouroboros.Network.Utils hiding (debugTracer) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index f15d6b06749..4b8381f8c74 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -7,10 +7,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Test.Ouroboros.Network.TxSubmission.TxLogic @@ -60,6 +63,9 @@ import Test.QuickCheck import Test.QuickCheck.Function (apply) import Test.QuickCheck.Gen (Gen (..)) import Test.QuickCheck.Random (QCGen (..)) +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Pretty.Simple diff --git a/quickcheck-monoids/CHANGELOG.md b/quickcheck-monoids/CHANGELOG.md new file mode 100644 index 00000000000..faa779ee3aa --- /dev/null +++ b/quickcheck-monoids/CHANGELOG.md @@ -0,0 +1,20 @@ +# Revision history for quickcheck-monoids + +## 0.1.0.3 -- 2025-08-27 + +* Somewhat compatible with `QuickCheck-2.16`: `QuickCheck` is also defining + `Test.QuickCheck.Monoids` module. + +## 0.1.0.2 -- 2025-06-28 + +* Package is deprecated, use `QuickCheck >= 2.16` which provides `Every` and + `Some` monoids. + +## 0.1.0.1 -- 2024-08-07 + +* Make it build with ghc-9.10 + * fix base upper bound + +## 0.1.0.0 -- 2024-06-07 + +* First version. Released on an unsuspecting world. diff --git a/quickcheck-monoids/quickcheck-monoids.cabal b/quickcheck-monoids/quickcheck-monoids.cabal new file mode 100644 index 00000000000..d0e4f45495d --- /dev/null +++ b/quickcheck-monoids/quickcheck-monoids.cabal @@ -0,0 +1,57 @@ +cabal-version: 3.0 +name: quickcheck-monoids +version: 0.1.0.3 +synopsis: QuickCheck monoids +description: All and Any monoids for `Testable` instances based on `.&&.` and `.||.`. +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +author: Marcin Szamotulski +maintainer: coot@coot.me +category: Testing +copyright: 2024 Input Output Global Inc (IOG) +build-type: Simple +extra-doc-files: CHANGELOG.md +extra-source-files: README.md + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Test.QuickCheck.Monoids + build-depends: + QuickCheck, + base <4.22, + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wunused-packages + +test-suite quickcheck-monoids-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + QuickCheck, + base, + quickcheck-monoids, + tasty, + tasty-quickcheck, + + ghc-options: + -Wall + -rtsopts diff --git a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs new file mode 100644 index 00000000000..fb6abf8b467 --- /dev/null +++ b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Monoids using `.&&.` and `.||.`. +-- +-- They satisfy monoid laws with respect to the `isSuccess` unless one is using +-- `checkCoverage` (see test for a counterexample). +-- +module Test.QuickCheck.Monoids +#if !MIN_VERSION_QuickCheck(2,16,0) + ( type Every + , All(Every, getEvery, ..) + , type Some + , Any(Some, getSome, ..) +#else + ( All (..) + , Any (..) + , Every (..) + , Some (..) +#endif + ) where + +import Data.List.NonEmpty as NonEmpty +import Data.Semigroup (Semigroup (..)) +import Test.QuickCheck + +-- | Conjunction monoid build with `.&&.`. +-- +-- Use `property @All` as an accessor which doesn't leak +-- existential variables. +-- +data All = forall p. Testable p => All { getAll :: p } + +#if !MIN_VERSION_QuickCheck(2,16,0) +type Every = All + +pattern Every :: () + => Testable p + => p + -> All +pattern Every { getEvery } = All getEvery +#endif + +instance Testable All where + property (All p) = property p + +instance Semigroup All where + All p <> All p' = All (p .&&. p') + sconcat = All . conjoin . NonEmpty.toList + +instance Monoid All where + mempty = All True + mconcat = All . conjoin + + +-- | Disjunction monoid build with `.||.`. +-- +-- Use `property @Any` as an accessor which doesn't leak +-- existential variables. +-- +data Any = forall p. Testable p => Any { getAny :: p } + +#if !MIN_VERSION_QuickCheck(2,16,0) +type Some = Any + +pattern Some :: () + => Testable p + => p + -> Any +pattern Some { getSome } = Any getSome +#endif + +instance Testable Any where + property (Any p) = property p + +instance Semigroup Any where + Any p <> Any p' = Any (p .||. p') + sconcat = Any . disjoin . NonEmpty.toList + +instance Monoid Any where + mempty = Any False + mconcat = Any . disjoin From 7abeb5a0ffec9b8e915f14f35b527c7b8cb66f63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 25 Aug 2025 11:05:24 +0200 Subject: [PATCH 10/29] Revert "Ensure that compared fragments always intersect" This reverts commit a5b5ba28ea58af9dd3dc695317c7562c25b2d4fb. --- .../Network/BlockFetch/ConsensusInterface.hs | 2 - .../Ouroboros/Network/BlockFetch/Decision.hs | 60 +++++-------------- .../Network/BlockFetch/Decision/Genesis.hs | 5 +- 3 files changed, 17 insertions(+), 50 deletions(-) diff --git a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 5b84eff0366..8c79dff3fa1 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -179,8 +179,6 @@ data ChainComparison header = -- This is used as part of selecting which chains to prioritise for -- downloading block bodies. -- - -- PRECONDITION: The two fragments must intersect. - -- compareCandidateChains :: HasCallStack => AnchoredFragment header -> AnchoredFragment header diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs index 67e7cbac1c3..c242c6313f2 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs @@ -33,7 +33,7 @@ import Data.Set qualified as Set import Data.Function (on) import Data.Hashable import Data.List as List (foldl', groupBy, sortBy, transpose) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Set (Set) import Control.Exception (assert) @@ -473,19 +473,8 @@ empty fetch range, but this is ok since we never request empty ranges. -- -- A 'ChainSuffix' must be non-empty, as an empty suffix, i.e. the candidate -- chain is equal to the current chain, would not be a plausible candidate. --- --- Additionally, we store the full candidate (with the same anchor as our --- current chain), as this is needed for comparing different candidates via --- 'compareCandidateChains'. -data ChainSuffix header = ChainSuffix { - -- | The suffix of the candidate after the intersection with the current - -- chain. - getChainSuffix :: !(AnchoredFragment header), - -- | The full candidate, characterized by having the same tip as - -- 'getChainSuffix' and the same anchor as our current chain. In particular, - -- 'getChainSuffix' is a suffix of 'getFullCandidate'. - getFullCandidate :: !(AnchoredFragment header) - } +newtype ChainSuffix header = + ChainSuffix { getChainSuffix :: AnchoredFragment header } {- We define the /chain suffix/ as the suffix of the candidate chain up until (but @@ -522,31 +511,25 @@ interested in this candidate at all. -- current chain. -- chainForkSuffix - :: HasHeader header - => AnchoredFragment header - -> AnchoredFragment header + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -- ^ Current chain. + -> AnchoredFragment header -- ^ Candidate chain -> Maybe (ChainSuffix header) chainForkSuffix current candidate = case AF.intersect current candidate of Nothing -> Nothing - Just (currentChainPrefix, _, _, candidateSuffix) -> + Just (_, _, _, candidateSuffix) -> -- If the suffix is empty, it means the candidate chain was equal to -- the current chain and didn't fork off. Such a candidate chain is -- not a plausible candidate, so it must have been filtered out. assert (not (AF.null candidateSuffix)) $ - Just ChainSuffix { - getChainSuffix = candidateSuffix, - getFullCandidate = fullCandidate - } - where - fullCandidate = - fromMaybe (error "invariant violation of AF.intersect") $ - AF.join currentChainPrefix candidateSuffix - + Just (ChainSuffix candidateSuffix) selectForkSuffixes - :: HasHeader header - => AnchoredFragment header + :: (HasHeader header, HasHeader block, + HeaderHash header ~ HeaderHash block) + => AnchoredFragment block -> [(FetchDecision (AnchoredFragment header), peerinfo)] -> [(FetchDecision (ChainSuffix header), peerinfo)] selectForkSuffixes current chains = @@ -760,11 +743,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz (equatingPair -- compare on probability band first, then preferred chain (==) - -- Precondition of 'compareCandidateChains' (used by - -- 'equateCandidateChains') is fulfilled as all - -- 'getFullCandidate's intersect pairwise (due to having the - -- same anchor as our current chain). - (equateCandidateChains `on` getFullCandidate) + (equateCandidateChains `on` getChainSuffix) `on` (\(band, chain, _fragments) -> (band, chain))))) . sortBy (descendingOrder @@ -773,10 +752,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz (comparingPair -- compare on probability band first, then preferred chain compare - -- Precondition of 'compareCandidateChains' is fulfilled as - -- all 'getFullCandidate's intersect pairwise (due to - -- having the same anchor as our current chain). - (compareCandidateChains `on` getFullCandidate) + (compareCandidateChains `on` getChainSuffix) `on` (\(band, chain, _fragments) -> (band, chain)))))) . map annotateProbabilityBand @@ -800,7 +776,7 @@ prioritisePeerChains FetchModeDeadline salt compareCandidateChains blockFetchSiz | EQ <- compareCandidateChains chain1 chain2 = True | otherwise = False - chainHeadPoint (_,ChainSuffix {getChainSuffix = c},_) = AF.headPoint c + chainHeadPoint (_,ChainSuffix c,_) = AF.headPoint c prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSize = map (\(decision, peer) -> @@ -809,11 +785,7 @@ prioritisePeerChains FetchModeBulkSync salt compareCandidateChains blockFetchSiz (comparingRight (comparingPair -- compare on preferred chain first, then duration - -- - -- Precondition of 'compareCandidateChains' is fulfilled as - -- all 'getFullCandidate's intersect pairwise (due to having - -- the same anchor as our current chain). - (compareCandidateChains `on` getFullCandidate) + (compareCandidateChains `on` getChainSuffix) compare `on` (\(duration, chain, _fragments) -> (chain, duration))))) diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs index 19566c7e6d5..98557641238 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs @@ -461,16 +461,13 @@ selectTheCandidate case inRace of [] -> pure Nothing _ : _ -> do - -- Precondition of 'compareCandidateChains' is fulfilled as all - -- 'getFullCandidate's intersect pairwise (due to having the same - -- anchor as our current chain). let maxChainOn f c0 c1 = case compareCandidateChains (f c0) (f c1) of LT -> c1 _ -> c0 -- maximumBy yields the last element in case of a tie while we -- prefer the first one chainSfx = fst $ - List.foldl1' (maxChainOn (getFullCandidate . fst)) inRace + List.foldl1' (maxChainOn (getChainSuffix . fst)) inRace pure $ Just (chainSfx, inRace) -- | Given _the_ candidate fragment to sync from, and a list of peers (with From 0d76f9cd88fe13e030b754109edfc28ece80c7a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 25 Aug 2025 11:07:57 +0200 Subject: [PATCH 11/29] Revert "Support dynamic chain comparisons" This reverts commit 6b688c0926feed0065fcd4d5593f8ea75ce12590. --- cardano-diffusion/demo/chain-sync.hs | 9 +- ouroboros-network/CHANGELOG.md | 2 +- .../Network/BlockFetch/ConsensusInterface.hs | 91 +++++-------------- .../lib/Ouroboros/Network/BlockFetch.hs | 8 +- .../Ouroboros/Network/BlockFetch/Decision.hs | 35 ++++--- .../Network/BlockFetch/Decision/Genesis.hs | 15 +-- .../lib/Ouroboros/Network/BlockFetch/State.hs | 34 +++---- .../Ouroboros/Network/BlockFetch/Examples.hs | 7 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 9 +- 9 files changed, 72 insertions(+), 138 deletions(-) diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index dcc375eded0..7f51509153c 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -75,8 +75,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Type qualified as BlockFetch import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientRegistry (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..), - initialWithFingerprint) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) import Ouroboros.Network.DeltaQ (defaultGSV) import Ouroboros.Network.Server.Simple qualified as Server.Simple @@ -436,10 +435,8 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do pure $ \p b -> addTestFetchedBlock blockHeap (castPoint p) (blockHeader b), - readChainComparison = pure $ initialWithFingerprint ChainComparison { - plausibleCandidateChain, - compareCandidateChains - }, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize = \_ -> 1000, blockMatchesHeader = \_ _ -> True, diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index e46798f9359..9f00f0e5180 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -12,7 +12,7 @@ * Adapt to simplified type of `headerForgeUTCTime` in `BlockFetchConsensusInterface`. * Type of `defaultSyncTargets` changed. * Type of `defaultPeerSharing` changed. -* Adapted to changes of `BlockFetchConsensusInterface`. +* (REVERTED temporarily) Adapted to changes of `BlockFetchConsensusInterface`. * `Ouroboros.Network.TxSubmission.Inbound` moved to `Ouroboros.Network.TxSubmission.Inbound.V1` * `Ouroboros.Network.TxSubmission.Inbound.V1.txSubmissionInbound` takes extra argument: `TxSubmissionInitDelay` (previously configurable through `cabal` flags). * Removed the `txsubmission-delay` cabal flag. diff --git a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 8c79dff3fa1..41290e54627 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -1,20 +1,13 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} module Ouroboros.Network.BlockFetch.ConsensusInterface ( PraosFetchMode (..) , FetchMode (..) , BlockFetchConsensusInterface (..) , ChainSelStarvation (..) - , ChainComparison (..) - -- * Utilities - , WithFingerprint (..) - , Fingerprint (..) - , initialWithFingerprint ) where import Control.Monad.Class.MonadSTM @@ -22,7 +15,6 @@ import Control.Monad.Class.MonadTime (UTCTime) import Control.Monad.Class.MonadTime.SI (Time) import Data.Map.Strict (Map) -import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks) @@ -115,9 +107,24 @@ data BlockFetchConsensusInterface peer header block m = -- have been downloaded anyway. readFetchedMaxSlotNo :: STM m MaxSlotNo, - -- | Compare chain fragments. This might involve further state, such as - -- Peras certificates (which give certain blocks additional weight). - readChainComparison :: STM m (WithFingerprint (ChainComparison header)), + -- | Given the current chain, is the given chain plausible as a + -- candidate chain. Classically for Ouroboros this would simply + -- check if the candidate is strictly longer, but for Ouroboros + -- with operational key certificates there are also cases where + -- we would consider a chain of equal length to the current chain. + -- + plausibleCandidateChain :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header -> Bool, + + -- | Compare two candidate chains and return a preference ordering. + -- This is used as part of selecting which chains to prioritise for + -- downloading block bodies. + -- + compareCandidateChains :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header + -> Ordering, -- | Much of the logic for deciding which blocks to download from which -- peer depends on making estimates based on recent performance metrics. @@ -155,57 +162,3 @@ data ChainSelStarvation = ChainSelStarvationOngoing | ChainSelStarvationEndedAt Time deriving (Eq, Show, NoThunks, Generic) - - -data ChainComparison header = - ChainComparison { - -- | Given the current chain, is the given chain plausible as a candidate - -- chain. Classically for Ouroboros this would simply check if the - -- candidate is strictly longer, but it can also involve further - -- criteria: - -- - -- * Tiebreakers (e.g. based on the opcert numbers and VRFs) for chains - -- of equal length. - -- - -- * Weight in the context of Ouroboros Peras, due to a boost from a - -- Peras certificate. - -- - plausibleCandidateChain :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header - -> Bool, - - -- | Compare two candidate chains and return a preference ordering. - -- This is used as part of selecting which chains to prioritise for - -- downloading block bodies. - -- - compareCandidateChains :: HasCallStack - => AnchoredFragment header - -> AnchoredFragment header - -> Ordering - } - -{------------------------------------------------------------------------------- - Utilities --------------------------------------------------------------------------------} - --- | Simple type that can be used to indicate some value (without/only with an --- expensive 'Eq' instance) changed. -newtype Fingerprint = Fingerprint Word64 - deriving stock (Show, Eq, Generic) - deriving newtype (Enum) - deriving anyclass (NoThunks) - --- | Store a value together with its 'Fingerprint'. -data WithFingerprint a = WithFingerprint - { forgetFingerprint :: !a - , getFingerprint :: !Fingerprint - } - deriving stock (Show, Functor, Generic) - deriving anyclass (NoThunks) - --- | Attach @'Fingerprint' 0@ to the given value. When the underlying @a@ is --- changed, the 'Fingerprint' must be updated to a new unique value (e.g. via --- 'succ'). -initialWithFingerprint :: a -> WithFingerprint a -initialWithFingerprint a = WithFingerprint a (Fingerprint 0) diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs index adfd52df187..8cd0d79bf49 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs @@ -99,7 +99,6 @@ module Ouroboros.Network.BlockFetch -- * Re-export types used by 'BlockFetchConsensusInterface' , PraosFetchMode (..) , FetchMode (..) - , ChainComparison (..) , SizeInBytes ) where @@ -122,7 +121,7 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientPolicy (..), readFetchClientsStateVars, readFetchClientsStatus, readPeerGSVs, setFetchClientContext) import Ouroboros.Network.BlockFetch.ConsensusInterface - (BlockFetchConsensusInterface (..), ChainComparison (..)) + (BlockFetchConsensusInterface (..)) import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) import Ouroboros.Network.BlockFetch.State @@ -222,6 +221,8 @@ blockFetchLogic decisionTracer clientStateTracer peerSalt = bfcSalt, bulkSyncGracePeriod = gbfcGracePeriod bfcGenesisBFConfig, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize } @@ -230,8 +231,7 @@ blockFetchLogic decisionTracer clientStateTracer FetchTriggerVariables { readStateCurrentChain = readCurrentChain, readStateCandidateChains = readCandidateChains, - readStatePeerStatus = readFetchClientsStatus registry, - readStateChainComparison = readChainComparison + readStatePeerStatus = readFetchClientsStatus registry } fetchNonTriggerVariables :: FetchNonTriggerVariables addr header block m diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs index c242c6313f2..5f086f097f6 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision.hs @@ -35,6 +35,7 @@ import Data.Hashable import Data.List as List (foldl', groupBy, sortBy, transpose) import Data.Maybe (mapMaybe) import Data.Set (Set) +import GHC.Stack (HasCallStack) import Control.Exception (assert) import Control.Monad (guard) @@ -47,8 +48,8 @@ import Ouroboros.Network.Point (withOriginToMaybe) import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison (..), - FetchMode (..), PraosFetchMode (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..), + PraosFetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), PeerGSV (..), SizeInBytes, calculatePeerFetchInFlightLimits, comparePeerGSV, comparePeerGSV', estimateExpectedResponseDuration, @@ -56,16 +57,25 @@ import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), data FetchDecisionPolicy header = FetchDecisionPolicy { - maxInFlightReqsPerPeer :: Word, -- A protocol constant. + maxInFlightReqsPerPeer :: Word, -- A protocol constant. - maxConcurrencyBulkSync :: Word, - maxConcurrencyDeadline :: Word, + maxConcurrencyBulkSync :: Word, + maxConcurrencyDeadline :: Word, decisionLoopIntervalGenesis :: DiffTime, - decisionLoopIntervalPraos :: DiffTime, - peerSalt :: Int, - bulkSyncGracePeriod :: DiffTime, + decisionLoopIntervalPraos :: DiffTime, + peerSalt :: Int, + bulkSyncGracePeriod :: DiffTime, - blockFetchSize :: header -> SizeInBytes + plausibleCandidateChain :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header -> Bool, + + compareCandidateChains :: HasCallStack + => AnchoredFragment header + -> AnchoredFragment header + -> Ordering, + + blockFetchSize :: header -> SizeInBytes } @@ -254,7 +264,6 @@ fetchDecisions HasHeader header, HeaderHash header ~ HeaderHash block) => FetchDecisionPolicy header - -> ChainComparison header -> PraosFetchMode -> AnchoredFragment header -> (Point block -> Bool) @@ -262,13 +271,11 @@ fetchDecisions -> [(AnchoredFragment header, PeerInfo header peer extra)] -> [(FetchDecision (FetchRequest header), PeerInfo header peer extra)] fetchDecisions fetchDecisionPolicy@FetchDecisionPolicy { + plausibleCandidateChain, + compareCandidateChains, blockFetchSize, peerSalt } - ChainComparison { - plausibleCandidateChain, - compareCandidateChains - } fetchMode currentChain fetchedBlocks diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs index 98557641238..978a4a4a944 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs @@ -146,8 +146,8 @@ import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), PeerFetchInFlight (..), PeersOrder (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison(..), - ChainSelStarvation (..), FetchMode (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..), + FetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) @@ -166,7 +166,6 @@ fetchDecisionsGenesisM HeaderHash header ~ HeaderHash block, MonadMonotonicTime m) => Tracer m (TraceDecisionEvent peer header) -> FetchDecisionPolicy header - -> ChainComparison header -> AnchoredFragment header -> (Point block -> Bool) -- ^ Whether the block has been fetched (only if recent, i.e. within @k@). @@ -181,7 +180,6 @@ fetchDecisionsGenesisM fetchDecisionsGenesisM tracer fetchDecisionPolicy@FetchDecisionPolicy {bulkSyncGracePeriod} - chainComparison currentChain fetchedBlocks fetchedMaxSlotNo @@ -204,7 +202,6 @@ fetchDecisionsGenesisM let (theDecision, declines) = fetchDecisionsGenesis fetchDecisionPolicy - chainComparison currentChain fetchedBlocks fetchedMaxSlotNo @@ -318,7 +315,6 @@ fetchDecisionsGenesis , HeaderHash header ~ HeaderHash block ) => FetchDecisionPolicy header - -> ChainComparison header -> AnchoredFragment header -- ^ The current chain, anchored at the immutable tip. -> (Point block -> Bool) @@ -337,7 +333,6 @@ fetchDecisionsGenesis -- one @'FetchRequest' header@. fetchDecisionsGenesis fetchDecisionPolicy - chainComparison currentChain fetchedBlocks fetchedMaxSlotNo @@ -350,7 +345,7 @@ fetchDecisionsGenesis ) <- MaybeT $ selectTheCandidate - chainComparison + fetchDecisionPolicy currentChain candidatesAndPeers @@ -427,7 +422,7 @@ dropAlreadyFetched alreadyDownloaded fetchedMaxSlotNo candidate = selectTheCandidate :: forall header peerInfo. HasHeader header - => ChainComparison header + => FetchDecisionPolicy header -> AnchoredFragment header -- ^ The current chain. -> [(AnchoredFragment header, peerInfo)] @@ -440,7 +435,7 @@ selectTheCandidate -- selected candidate that we choose to sync from and a list of peers that -- are still in the race to serve that candidate. selectTheCandidate - ChainComparison {compareCandidateChains, plausibleCandidateChain} + FetchDecisionPolicy {compareCandidateChains, plausibleCandidateChain} currentChain = separateDeclinedAndStillInRace -- Select the suffix up to the intersection with the current chain. This can diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs index 62d0f4a3010..1ee5718b6e5 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/State.hs @@ -43,9 +43,8 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchClientStateVars (..), FetchRequest (..), PeerFetchInFlight (..), PeerFetchStatus (..), PeersOrder (..), TraceFetchClientState (..), TraceLabelPeer (..), addNewFetchRequest, readFetchClientState) -import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison (..), - ChainSelStarvation, FetchMode (..), Fingerprint (..), - WithFingerprint (..)) +import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation, + FetchMode (..)) import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecisionPolicy (..), FetchDecline (..), PeerInfo, PraosFetchMode (..), fetchDecisions) @@ -228,8 +227,7 @@ fetchDecisionsForStateSnapshot fetchStateFetchedBlocks, fetchStateFetchedMaxSlotNo, fetchStateFetchMode, - fetchStateChainSelStarvation, - fetchStateChainComparison + fetchStateChainSelStarvation } peersOrderHandlers = assert ( Map.keysSet fetchStatePeerChains @@ -242,7 +240,6 @@ fetchDecisionsForStateSnapshot PraosFetchMode fetchMode -> pure $ fetchDecisions fetchDecisionPolicy - fetchStateChainComparison fetchMode fetchStateCurrentChain fetchStateFetchedBlocks @@ -252,7 +249,6 @@ fetchDecisionsForStateSnapshot fetchDecisionsGenesisM tracer fetchDecisionPolicy - fetchStateChainComparison fetchStateCurrentChain fetchStateFetchedBlocks fetchStateFetchedMaxSlotNo @@ -306,8 +302,7 @@ fetchLogicIterationAct clientStateTracer FetchDecisionPolicy{blockFetchSize} data FetchTriggerVariables peer header m = FetchTriggerVariables { readStateCurrentChain :: STM m (AnchoredFragment header), readStateCandidateChains :: STM m (Map peer (AnchoredFragment header)), - readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header)), - readStateChainComparison :: STM m (WithFingerprint (ChainComparison header)) + readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header)) } -- | STM actions to read various state variables that the fetch logic uses. @@ -329,7 +324,6 @@ data FetchStateFingerprint peer header block = !(Maybe (Point block)) !(Map peer (Point header)) !(Map peer (PeerFetchStatus header)) - !Fingerprint -- ^ From 'ChainComparison' deriving Eq initialFetchStateFingerprint :: FetchStateFingerprint peer header block @@ -338,19 +332,17 @@ initialFetchStateFingerprint = Nothing Map.empty Map.empty - (Fingerprint 0) updateFetchStateFingerprintPeerStatus :: Ord peer => [(peer, PeerFetchStatus header)] -> FetchStateFingerprint peer header block -> FetchStateFingerprint peer header block updateFetchStateFingerprintPeerStatus statuses' - (FetchStateFingerprint current candidates statuses fpChainComp) = + (FetchStateFingerprint current candidates statuses) = FetchStateFingerprint current candidates (Map.union (Map.fromList statuses') statuses) -- left overrides right - fpChainComp -- | -- @@ -367,8 +359,7 @@ data FetchStateSnapshot peer header block m = FetchStateSnapshot { fetchStateFetchedBlocks :: Point block -> Bool, fetchStateFetchMode :: FetchMode, fetchStateFetchedMaxSlotNo :: MaxSlotNo, - fetchStateChainSelStarvation :: ChainSelStarvation, - fetchStateChainComparison :: ChainComparison header + fetchStateChainSelStarvation :: ChainSelStarvation } readStateVariables :: (MonadSTM m, Eq peer, @@ -387,11 +378,10 @@ readStateVariables FetchTriggerVariables{..} fetchStateFingerprint = do -- Read all the trigger state variables - fetchStateCurrentChain <- readStateCurrentChain - fetchStatePeerChains <- readStateCandidateChains - fetchStatePeerStatus <- readStatePeerStatus - chainComparison <- readStateChainComparison - gracePeriodExpired <- LazySTM.readTVar gracePeriodTVar + fetchStateCurrentChain <- readStateCurrentChain + fetchStatePeerChains <- readStateCandidateChains + fetchStatePeerStatus <- readStatePeerStatus + gracePeriodExpired <- LazySTM.readTVar gracePeriodTVar -- Construct the change detection fingerprint let !fetchStateFingerprint' = @@ -399,7 +389,6 @@ readStateVariables FetchTriggerVariables{..} (Just (castPoint (AF.headPoint fetchStateCurrentChain))) (Map.map AF.headPoint fetchStatePeerChains) fetchStatePeerStatus - (getFingerprint chainComparison) -- Check the fingerprint changed, or block and wait until it does check (gracePeriodExpired || fetchStateFingerprint' /= fetchStateFingerprint) @@ -423,8 +412,7 @@ readStateVariables FetchTriggerVariables{..} fetchStateFetchedBlocks, fetchStateFetchMode, fetchStateFetchedMaxSlotNo, - fetchStateChainSelStarvation, - fetchStateChainComparison = forgetFingerprint chainComparison + fetchStateChainSelStarvation } return (fetchStateSnapshot, gracePeriodExpired, fetchStateFingerprint') diff --git a/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs index 30a9cfde718..1072a78a354 100644 --- a/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -52,7 +52,6 @@ import Ouroboros.Network.Protocol.BlockFetch.Server import Ouroboros.Network.Protocol.BlockFetch.Type import Ouroboros.Network.Util.ShowProxy -import Ouroboros.Network.BlockFetch.ConsensusInterface (initialWithFingerprint) import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) import Ouroboros.Network.Mock.ConcreteBlock @@ -298,10 +297,8 @@ sampleBlockFetchPolicy1 fetchMode headerFieldsForgeUTCTime blockHeap currentChai getTestFetchedBlocks blockHeap, mkAddFetchedBlock = pure $ addTestFetchedBlock blockHeap, - readChainComparison = pure $ initialWithFingerprint ChainComparison { - plausibleCandidateChain, - compareCandidateChains - }, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize = \_ -> 2000, blockMatchesHeader = \_ _ -> True, diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index a8f7ad26fc7..d7334cb289e 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -75,8 +75,7 @@ import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin, pointSlot) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.ConsensusInterface - (ChainSelStarvation (ChainSelStarvationEndedAt), - initialWithFingerprint) + (ChainSelStarvation (ChainSelStarvationEndedAt)) import Ouroboros.Network.ConnectionManager.State (ConnStateIdSupply) import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import Ouroboros.Network.Diffusion qualified as Diffusion @@ -405,10 +404,8 @@ run blockGeneratorArgs ni na pure $ \_p b -> atomically (addBlock b (nkChainDB nodeKernel)), - readChainComparison = pure $ initialWithFingerprint ChainComparison { - plausibleCandidateChain, - compareCandidateChains - }, + plausibleCandidateChain, + compareCandidateChains, blockFetchSize = \_ -> 1000, blockMatchesHeader = \_ _ -> True, From 8e05c22739d633a7379c6ea71f6a3ee0bbcccfd5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 25 Aug 2025 11:08:48 +0200 Subject: [PATCH 12/29] Revert "`BlockFetchConsensusInterface`: simplify `headerForgeUTCTime`" This reverts commit 2312d2bbb518795c4e7036e00add8e0590f57e13. --- cardano-diffusion/demo/chain-sync.hs | 5 +-- ouroboros-network/CHANGELOG.md | 2 +- .../Network/BlockFetch/ConsensusInterface.hs | 34 ++++++++++++++++++- .../lib/Ouroboros/Network/BlockFetch.hs | 3 +- .../Ouroboros/Network/BlockFetch/Client.hs | 9 ++--- .../Network/BlockFetch/ClientState.hs | 4 ++- .../Ouroboros/Network/BlockFetch/Examples.hs | 10 +++--- .../lib/Test/Ouroboros/Network/BlockFetch.hs | 2 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 5 +-- 9 files changed, 56 insertions(+), 18 deletions(-) diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index 7f51509153c..314e760c95e 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -450,8 +450,9 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do plausibleCandidateChain cur candidate = AF.headBlockNo candidate > AF.headBlockNo cur - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus hdr) = + pure $ + convertSlotToTimeForTestsAssumingNoHardFork (headerSlot hdr) compareCandidateChains c1 c2 = AF.headBlockNo c1 `compare` AF.headBlockNo c2 diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 9f00f0e5180..8c4c1369bdb 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -9,7 +9,7 @@ * `Ouroboros.Network.NodeTo{Client,Node}` modules moved to `ouroboros-network:cardano-diffusion` (as `Cardano.Network.NodeTo{Node,Client}`) -* Adapt to simplified type of `headerForgeUTCTime` in `BlockFetchConsensusInterface`. +* (REVERTED temporarily) Adapt to simplified type of `headerForgeUTCTime` in `BlockFetchConsensusInterface`. * Type of `defaultSyncTargets` changed. * Type of `defaultPeerSharing` changed. * (REVERTED temporarily) Adapted to changes of `BlockFetchConsensusInterface`. diff --git a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs index 41290e54627..08f9dd8aafd 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/BlockFetch/ConsensusInterface.hs @@ -7,6 +7,7 @@ module Ouroboros.Network.BlockFetch.ConsensusInterface ( PraosFetchMode (..) , FetchMode (..) , BlockFetchConsensusInterface (..) + , FromConsensus (..) , ChainSelStarvation (..) ) where @@ -139,7 +140,19 @@ data BlockFetchConsensusInterface peer header block m = blockMatchesHeader :: header -> block -> Bool, -- | Calculate when a header's block was forged. - headerForgeUTCTime :: header -> UTCTime, + -- + -- PRECONDITION: This function will succeed and give a _correct_ result + -- when applied to headers obtained via this interface (ie via + -- Consensus, ie via 'readCurrentChain' or 'readCandidateChains'). + -- + -- WARNING: This function may fail or, worse, __give an incorrect result + -- (!!)__ if applied to headers obtained from sources outside of this + -- interface. The 'FromConsensus' newtype wrapper is intended to make it + -- difficult to make that mistake, so please pay that syntactic price + -- and consider its meaning at each call to this function. Relatedly, + -- preserve that argument wrapper as much as possible when deriving + -- ancillary functions\/interfaces from this function. + headerForgeUTCTime :: FromConsensus header -> STM m UTCTime, -- | Information on the ChainSel starvation status; whether it is ongoing -- or has ended recently. Needed by the bulk sync decision logic. @@ -162,3 +175,22 @@ data ChainSelStarvation = ChainSelStarvationOngoing | ChainSelStarvationEndedAt Time deriving (Eq, Show, NoThunks, Generic) + +{------------------------------------------------------------------------------- + Syntactic indicator of key precondition about Consensus time conversions +-------------------------------------------------------------------------------} + +-- | A new type used to emphasize the precondition of +-- 'Ouroboros.Network.BlockFetch.ConsensusInterface.headerForgeUTCTime' at each +-- call site. +-- +-- At time of writing, the @a@ is either a header or a block. The headers are +-- literally from Consensus (ie provided by ChainSync). Blocks, on the other +-- hand, are indirectly from Consensus: they were fetched only because we +-- favored the corresponding header that Consensus provided. +newtype FromConsensus a = FromConsensus {unFromConsensus :: a} + deriving (Functor) + +instance Applicative FromConsensus where + pure = FromConsensus + FromConsensus f <*> FromConsensus a = FromConsensus (f a) diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs index 8cd0d79bf49..9b5087b72db 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch.hs @@ -99,6 +99,7 @@ module Ouroboros.Network.BlockFetch -- * Re-export types used by 'BlockFetchConsensusInterface' , PraosFetchMode (..) , FetchMode (..) + , FromConsensus (..) , SizeInBytes ) where @@ -121,7 +122,7 @@ import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientPolicy (..), readFetchClientsStateVars, readFetchClientsStatus, readPeerGSVs, setFetchClientContext) import Ouroboros.Network.BlockFetch.ConsensusInterface - (BlockFetchConsensusInterface (..)) + (BlockFetchConsensusInterface (..), FromConsensus (..)) import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent) import Ouroboros.Network.BlockFetch.State diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs index 81f5612875f..ec6253cf643 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Client.hs @@ -41,9 +41,9 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.BlockFetch.ClientState (FetchClientContext (..), FetchClientPolicy (..), FetchClientStateVars (..), FetchRequest (..), - TraceFetchClientState (..), acknowledgeFetchRequest, - completeBlockDownload, completeFetchBatch, fetchClientCtxStateVars, - rejectedFetchBatch, startedFetchBatch) + FromConsensus (..), TraceFetchClientState (..), + acknowledgeFetchRequest, completeBlockDownload, completeFetchBatch, + fetchClientCtxStateVars, rejectedFetchBatch, startedFetchBatch) import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), PeerGSV (..)) import Ouroboros.Network.PeerSelection.PeerMetric.Type (FetchedMetricsTracer) @@ -267,7 +267,8 @@ blockFetchClient _version controlMessageSTM reportFetched -- Add the block to the chain DB, notifying of any new chains. addFetchedBlock (castPoint (blockPoint header)) block - let blockDelay = diffUTCTime now (headerForgeUTCTime header) + forgeTime <- atomically $ headerForgeUTCTime $ FromConsensus header + let blockDelay = diffUTCTime now forgeTime let hf = getHeaderFields header slotNo = headerFieldSlot hf diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs index 74958ad58b0..3a386d2a184 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/ClientState.hs @@ -33,6 +33,7 @@ module Ouroboros.Network.BlockFetch.ClientState , TraceLabelPeer (..) , ChainRange (..) -- * Ancillary + , FromConsensus (..) , PeersOrder (..) ) where @@ -56,6 +57,7 @@ import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block (HasHeader, HeaderHash, MaxSlotNo (..), Point, blockPoint, castPoint) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FromConsensus (..)) import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..), PeerGSV, SizeInBytes, calculatePeerFetchInFlightLimits) import Ouroboros.Network.ControlMessage (ControlMessageSTM, @@ -82,7 +84,7 @@ data FetchClientPolicy header block m = blockFetchSize :: header -> SizeInBytes, blockMatchesHeader :: header -> block -> Bool, addFetchedBlock :: Point block -> block -> m (), - headerForgeUTCTime :: header -> UTCTime + headerForgeUTCTime :: FromConsensus header -> STM m UTCTime } -- | A set of variables shared between the block fetch logic thread and each diff --git a/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs index 1072a78a354..9b74d0b544b 100644 --- a/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/tests/lib/Ouroboros/Network/BlockFetch/Examples.hs @@ -150,8 +150,8 @@ blockFetchExample0 fetchMode decisionTracer clientStateTracer clientMsgTracer }) >> return () - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus x) = + pure $ convertSlotToTimeForTestsAssumingNoHardFork (blockSlot x) driver :: TestFetchedBlockHeap m Block -> m () driver blockHeap = do @@ -264,8 +264,8 @@ blockFetchExample1 fetchMode decisionTracer clientStateTracer clientMsgTracer }) >> return () - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus x) = + pure $ convertSlotToTimeForTestsAssumingNoHardFork (blockSlot x) -- | Terminates after 1 second per block in the candidate chains. downloadTimer :: m () @@ -279,7 +279,7 @@ blockFetchExample1 fetchMode decisionTracer clientStateTracer clientMsgTracer sampleBlockFetchPolicy1 :: (MonadSTM m, HasHeader header, HasHeader block) => FetchMode - -> (header -> UTCTime) + -> (forall x. HasHeader x => FromConsensus x -> STM m UTCTime) -> TestFetchedBlockHeap m block -> AnchoredFragment header -> Map peer (AnchoredFragment header) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs index ae548e88ecc..1e59f1b1c38 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/BlockFetch.hs @@ -789,7 +789,7 @@ unit_bracketSyncWithFetchClient step = do dummyPolicy :: forall b h m. (MonadSTM m) => STM m (FetchClientPolicy h b m) dummyPolicy = let addFetchedBlock _ _ = return () - forgeTime _ = read "2000-01-01 00:00:00 UTC" + forgeTime _ = return (read "2000-01-01 00:00:00 UTC") bfSize _ = 1024 matchesHeader _ _ = True in pure $ FetchClientPolicy diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index d7334cb289e..f7348b4fb25 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -419,8 +419,9 @@ run blockGeneratorArgs ni na plausibleCandidateChain cur candidate = AF.headBlockNo candidate > AF.headBlockNo cur - headerForgeUTCTime = - convertSlotToTimeForTestsAssumingNoHardFork . headerSlot + headerForgeUTCTime (FromConsensus hdr) = + pure $ + convertSlotToTimeForTestsAssumingNoHardFork (headerSlot hdr) compareCandidateChains c1 c2 = AF.headBlockNo c1 `compare` AF.headBlockNo c2 From 268aa966906ac2b39a897fa155395946d88ed7b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 30 Oct 2025 16:30:56 +0100 Subject: [PATCH 13/29] bootstrap consensus --- cabal.project | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index d89ffe33196..ab85558d8aa 100644 --- a/cabal.project +++ b/cabal.project @@ -55,10 +55,23 @@ package acts allow-newer: quickcheck-instances:QuickCheck +constraints: + QuickCheck <2.16 + +-- temp +source-repository-package + type: git + location: https://github.com/input-output-hk/typed-protocols + tag: e29a21541c4af44a3d586ef0b2a61f8d87cc6bdd + --sha256: + subdir: typed-protocols + -- kes-agent is not yet in CHaP, so we pull it from its GitHub repo source-repository-package type: git - location: https://github.com/input-output-hk/kes-agent - tag: 6d0f51fba415d3c641a8a8da37130e7adfc3ea01 - --sha256: sha256-qM8RgmKOGBMlizPtXw2YOboYIzM6T3kvG9/Rp1F+bYQ= - subdir: kes-agent-crypto + location: https://github.com/crocodile-dentist/kes-agent + tag: c0ef04dde5582a28415ff7c8c1bb197adeec6fc8 + --sha256: + subdir: + kes-agent + kes-agent-crypto From ff55b637c5eea538ee43c8cb5953642271767bab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 25 Aug 2025 12:41:03 +0200 Subject: [PATCH 14/29] diffusion: export withiomanager --- ouroboros-network/lib/Ouroboros/Network/Diffusion.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 1175259bacd..a59a4557cb0 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.Diffusion , runM , mkInterfaces , socketAddressType + , withIOManager , module Ouroboros.Network.Diffusion.Types ) where From 0b9eee59ee61d13803bbbee48be0d2cd31b4ba78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 25 Aug 2025 12:42:53 +0200 Subject: [PATCH 15/29] dmq: node kernel to hold pool ids --- dmq-node/src/DMQ/Diffusion/NodeKernel.hs | 42 ++++++++++++++++++++++-- 1 file changed, 39 insertions(+), 3 deletions(-) diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index 3a50905ce54..a35daf81dbb 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} module DMQ.Diffusion.NodeKernel ( NodeKernel (..) , withNodeKernel + , PoolValidationCtx (..) + , StakePools (..) ) where import Control.Concurrent.Class.MonadMVar @@ -19,6 +20,8 @@ import Data.Aeson qualified as Aeson import Data.Function (on) import Data.Functor.Contravariant ((>$<)) import Data.Hashable +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Set (Set) @@ -29,8 +32,10 @@ import Data.Void (Void) import System.Random (StdGen) import System.Random qualified as Random +import Cardano.Ledger.Shelley.API hiding (I) import Cardano.KESAgent.KES.Crypto (Crypto (..)) import Cardano.KESAgent.KES.Evolution qualified as KES +import Ouroboros.Consensus.Shelley.Ledger.Query import Ouroboros.Network.BlockFetch (FetchClientRegistry, newFetchClientRegistry) @@ -64,10 +69,30 @@ data NodeKernel crypto ntnAddr m = , sigChannelVar :: !(TxChannelsVar m ntnAddr SigId (Sig crypto)) , sigMempoolSem :: !(TxMempoolSem m) , sigSharedTxStateVar :: !(SharedTxStateVar m ntnAddr SigId (Sig crypto)) + , stakePools :: !(StakePools m) + , nextEpochVar :: !(StrictTVar m (Maybe UTCTime)) } +-- | Cardano pool id's are hashes of the cold verification key +-- +type PoolId = KeyHash StakePool + +data StakePools m = StakePools { + -- | contains map of cardano pool stake snapshot obtained + -- via local state query client + stakePoolsVar :: StrictTVar m (Map PoolId StakeSnapshot) + -- | acquires validation context for signature validation + , poolValidationCtx :: m PoolValidationCtx + } + +data PoolValidationCtx = + DMQPoolValidationCtx !UTCTime -- ^ time of context acquisition + !(Maybe UTCTime) -- ^ UTC time of next epoch boundary + !(Map PoolId StakeSnapshot) -- ^ for signature validation + newNodeKernel :: ( MonadLabelledSTM m , MonadMVar m + , MonadTime m , Ord ntnAddr ) => KES.EvolutionConfig @@ -84,6 +109,15 @@ newNodeKernel evolutionConfig rng = do sigMempoolSem <- newTxMempoolSem let (rng', rng'') = Random.split rng sigSharedTxStateVar <- newSharedTxStateVar rng' + nextEpochVar <- newTVarIO Nothing + stakePoolsVar <- newTVarIO Map.empty + let poolValidationCtx = do + (nextEpochBoundary, stakePools) <- + atomically $ (,) <$> readTVar nextEpochVar <*> readTVar stakePoolsVar + now <- getCurrentTime + return $ DMQPoolValidationCtx now nextEpochBoundary stakePools + + stakePools = StakePools { stakePoolsVar, poolValidationCtx } peerSharingAPI <- newPeerSharingAPI @@ -100,6 +134,8 @@ newNodeKernel evolutionConfig rng = do , sigChannelVar , sigMempoolSem , sigSharedTxStateVar + , nextEpochVar + , stakePools } From d812243e43fa4f1162c09d0affcf793bedf8768d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 3 Sep 2025 14:15:08 +0200 Subject: [PATCH 16/29] dmq: add cardano-node socket path to configuration & cli options --- dmq-node/app/Main.hs | 1 + dmq-node/src/DMQ/Configuration.hs | 4 +++ dmq-node/src/DMQ/Configuration/CLIOptions.hs | 27 ++++++++++++-------- 3 files changed, 22 insertions(+), 10 deletions(-) diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 5cb0e4b6ca4..18b001248d5 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -73,6 +73,7 @@ runDMQ commandLineConfig = do dmqcShelleyGenesisFile = I genesisFile, dmqcHandshakeTracer = I handshakeTracer, dmqcLocalHandshakeTracer = I localHandshakeTracer, + dmqcCardanoNodeSocket = I snocketPath, dmqcVersion = I version } = config' <> commandLineConfig `act` diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index 2cf7c16b093..5e293dd2fd3 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -108,6 +108,7 @@ data Configuration' f = dmqcChurnInterval :: f DiffTime, dmqcPeerSharing :: f PeerSharing, dmqcNetworkMagic :: f NetworkMagic, + dmqcCardanoNodeSocket :: f FilePath, dmqcPrettyLog :: f Bool, dmqcMuxTracer :: f Bool, @@ -218,6 +219,7 @@ defaultConfiguration = Configuration { dmqcShelleyGenesisFile = I "mainnet-shelley-genesis.json", dmqcAcceptedConnectionsLimit = I defaultAcceptedConnectionsLimit, dmqcDiffusionMode = I InitiatorAndResponderDiffusionMode, + dmqcCardanoNodeSocket = I "cardano-node.socket", dmqcTargetOfRootPeers = I targetNumberOfRootPeers, dmqcTargetOfKnownPeers = I targetNumberOfKnownPeers, dmqcTargetOfEstablishedPeers = I targetNumberOfEstablishedPeers, @@ -305,6 +307,7 @@ instance FromJSON PartialConfig where dmqcNetworkMagic <- Last . fmap NetworkMagic <$> v .:? "NetworkMagic" dmqcDiffusionMode <- Last <$> v .:? "DiffusionMode" dmqcPeerSharing <- Last <$> v .:? "PeerSharing" + dmqcCardanoNodeSocket <- Last <$> v .:? "CardanoNodeSocket" dmqcShelleyGenesisFile <- Last <$> v .:? "ShelleyGenesisFile" @@ -383,6 +386,7 @@ instance ToJSON Configuration where , "PortNumber" .= unI dmqcPortNumber , "LocalAddress" .= unI dmqcLocalAddress , "ConfigFile" .= unI dmqcConfigFile + , "CardanoNodeSocket" .= unI dmqcCardanoNodeSocket , "TopologyFile" .= unI dmqcTopologyFile , "ShelleyGenesisFile" .= unI dmqcShelleyGenesisFile , "AcceptedConnectionsLimit" .= unI dmqcAcceptedConnectionsLimit diff --git a/dmq-node/src/DMQ/Configuration/CLIOptions.hs b/dmq-node/src/DMQ/Configuration/CLIOptions.hs index e59a62ef278..decc8fed134 100644 --- a/dmq-node/src/DMQ/Configuration/CLIOptions.hs +++ b/dmq-node/src/DMQ/Configuration/CLIOptions.hs @@ -53,6 +53,13 @@ parseCLIOptions = <> help "Topology file for DMQ Node" ) ) + <*> optional ( + strOption + ( long "cardano-node-socket" + <> metavar "Cardano node socket path" + <> help "Used for local connections to Cardano node" + ) + ) <*> optional ( switch ( long "version" @@ -61,14 +68,14 @@ parseCLIOptions = ) ) where - mkConfiguration ipv4 ipv6 portNumber localAddress configFile topologyFile version = - mempty { dmqcIPv4 = Last (Just <$> ipv4), - dmqcIPv6 = Last (Just <$> ipv6), - dmqcLocalAddress = Last (LocalAddress <$> localAddress), - dmqcPortNumber = Last portNumber, - dmqcConfigFile = Last configFile, - dmqcTopologyFile = Last topologyFile, - dmqcVersion = Last version + mkConfiguration ipv4 ipv6 portNumber localAddress + configFile topologyFile cardanoNodeSocket version = + mempty { dmqcIPv4 = Last (Just <$> ipv4), + dmqcIPv6 = Last (Just <$> ipv6), + dmqcLocalAddress = Last (LocalAddress <$> localAddress), + dmqcPortNumber = Last portNumber, + dmqcConfigFile = Last configFile, + dmqcTopologyFile = Last topologyFile, + dmqcCardanoNodeSocket = Last cardanoNodeSocket, + dmqcVersion = Last version } - - From 73ae20a00ba58a6095e1cc94e233485775f95503 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 26 Aug 2025 14:55:59 +0200 Subject: [PATCH 17/29] dmq: local state query client for cardano-node interop * cabal.project: --- dmq-node/app/Main.hs | 118 +++++++------ dmq-node/dmq-node.cabal | 12 +- dmq-node/src/DMQ/Diffusion/NodeKernel.hs | 18 +- .../DMQ/NodeToClient/LocalStateQueryClient.hs | 158 ++++++++++++++++++ 4 files changed, 246 insertions(+), 60 deletions(-) create mode 100644 dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 18b001248d5..2520f9d63de 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Main where import Control.Exception (throwIO) import Control.Monad (void, when) +import Control.Monad.Class.MonadAsync import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Act @@ -41,9 +44,11 @@ import DMQ.Protocol.SigSubmission.Type (Sig (..)) import DMQ.Tracer import DMQ.Diffusion.PeerSelection (policy) +import DMQ.NodeToClient.LocalStateQueryClient import Ouroboros.Network.Diffusion qualified as Diffusion import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, encodeRemoteAddress) +import Ouroboros.Network.Snocket import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool import Paths_dmq_node qualified as Meta @@ -112,50 +117,59 @@ runDMQ commandLineConfig = do stdGen <- newStdGen let (psRng, policyRng) = split stdGen - withNodeKernel @StandardCrypto - tracer - dmqConfig - evolutionConfig - psRng $ \nodeKernel -> do - dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt - - let dmqNtNApps = - ntnApps tracer - dmqConfig - nodeKernel - (dmqCodecs - (encodeRemoteAddress (maxBound @NodeToNodeVersion)) - (decodeRemoteAddress (maxBound @NodeToNodeVersion))) - dmqLimitsAndTimeouts - defaultSigDecisionPolicy - dmqNtCApps = - let sigSize _ = 0 -- TODO - maxMsgs = 1000 -- TODO: make this dynamic? - mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel) - mempoolWriter = Mempool.getWriter sigId (pure ()) - (\_ _ -> Right () :: Either Void ()) - (\_ -> True) - (mempool nodeKernel) - in NtC.ntcApps tracer dmqConfig - mempoolReader mempoolWriter maxMsgs - (NtC.dmqCodecs encodeReject decodeReject) - dmqDiffusionArguments = - diffusionArguments (if handshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - (if localHandshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - dmqDiffusionApplications = - diffusionApplications nodeKernel - dmqConfig - dmqDiffusionConfiguration - dmqLimitsAndTimeouts - dmqNtNApps - dmqNtCApps - (policy policyRng) - - Diffusion.run dmqDiffusionArguments - (dmqDiffusionTracers dmqConfig tracer) - dmqDiffusionConfiguration - dmqDiffusionApplications + Diffusion.withIOManager \iocp -> do + let localSnocket' = localSnocket iocp + + withNodeKernel @StandardCrypto + tracer + dmqConfig + evolutionConfig + psRng $ \nodeKernel -> do + dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt + + let stakePoolMonitor = connectToCardanoNode tracer localSnocket' snocketPath nodeKernel + + withAsync stakePoolMonitor \aid -> do + link aid + let dmqNtNApps = + ntnApps tracer + dmqConfig + nodeKernel + (dmqCodecs + -- TODO: `maxBound :: Cardano.Network.NodeToNode.NodeToNodeVersion` + -- is unsafe here! + (encodeRemoteAddress (maxBound @NodeToNodeVersion)) + (decodeRemoteAddress (maxBound @NodeToNodeVersion))) + dmqLimitsAndTimeouts + defaultSigDecisionPolicy + dmqNtCApps = + let sigSize _ = 0 -- TODO + maxMsgs = 1000 -- TODO: make this negotiated in the handshake? + mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel) + mempoolWriter = Mempool.getWriter sigId (pure ()) + (\_ _ -> Right () :: Either Void ()) + (\_ _ -> pure True) + (mempool nodeKernel) + in NtC.ntcApps tracer dmqConfig + mempoolReader mempoolWriter maxMsgs + (NtC.dmqCodecs encodeReject decodeReject) + dmqDiffusionArguments = + diffusionArguments (if handshakeTracer + then WithEventType "Handshake" >$< tracer + else nullTracer) + (if localHandshakeTracer + then WithEventType "Handshake" >$< tracer + else nullTracer) + dmqDiffusionApplications = + diffusionApplications nodeKernel + dmqConfig + dmqDiffusionConfiguration + dmqLimitsAndTimeouts + dmqNtNApps + dmqNtCApps + (policy policyRng) + + Diffusion.run dmqDiffusionArguments + (dmqDiffusionTracers dmqConfig tracer) + dmqDiffusionConfiguration + dmqDiffusionApplications diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index a4f3352dcc4..e69262a3976 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -68,6 +68,7 @@ library DMQ.NodeToClient DMQ.NodeToClient.LocalMsgNotification DMQ.NodeToClient.LocalMsgSubmission + DMQ.NodeToClient.LocalStateQueryClient DMQ.NodeToClient.Version DMQ.NodeToNode DMQ.NodeToNode.Version @@ -93,6 +94,10 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto-class, + cardano-crypto-wrapper, + cardano-ledger-byron, + cardano-ledger-shelley, + cardano-slotting, cborg >=0.2.1 && <0.3, containers >=0.5 && <0.8, contra-tracer >=0.1 && <0.3, @@ -108,11 +113,15 @@ library network ^>=3.2.7, network-mux ^>=0.9.1, optparse-applicative ^>=0.18, + ouroboros-consensus, + ouroboros-consensus-cardano, + ouroboros-consensus-diffusion, ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.23, random ^>=1.2, singletons, text >=1.2.4 && <2.2, time ^>=1.12, + transformers, typed-protocols:{typed-protocols, cborg} ^>=1.1, hs-source-dirs: src @@ -137,9 +146,10 @@ executable dmq-node cardano-git-rev, contra-tracer >=0.1 && <0.3, dmq-node, + io-classes, kes-agent-crypto, optparse-applicative, - ouroboros-network:{ouroboros-network, api}, + ouroboros-network:{ouroboros-network, api, framework}, random, text, diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index a35daf81dbb..8567ec211c1 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -112,10 +112,10 @@ newNodeKernel evolutionConfig rng = do nextEpochVar <- newTVarIO Nothing stakePoolsVar <- newTVarIO Map.empty let poolValidationCtx = do - (nextEpochBoundary, stakePools) <- + (nextEpochBoundary, stakePools') <- atomically $ (,) <$> readTVar nextEpochVar <*> readTVar stakePoolsVar now <- getCurrentTime - return $ DMQPoolValidationCtx now nextEpochBoundary stakePools + return $ DMQPoolValidationCtx now nextEpochBoundary stakePools' stakePools = StakePools { stakePoolsVar, poolValidationCtx } @@ -156,6 +156,7 @@ withNodeKernel :: forall crypto ntnAddr m a. -> Configuration -> KES.EvolutionConfig -> StdGen + -> (NodeKernel crypto ntnAddr m -> m (Either SomeException Void)) -> (NodeKernel crypto ntnAddr m -> m a) -- ^ as soon as the callback exits the `mempoolWorker` and all -- decision logic threads will be killed @@ -165,7 +166,8 @@ withNodeKernel tracer dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer } evolutionConfig - rng k = do + rng + mkStakePoolMonitor k = do nodeKernel@NodeKernel { mempool, sigChannelVar, sigSharedTxStateVar @@ -181,10 +183,12 @@ withNodeKernel tracer defaultSigDecisionPolicy sigChannelVar sigSharedTxStateVar) - $ \sigLogicThread - -> link mempoolThread - >> link sigLogicThread - >> k nodeKernel + $ \sigLogicThread -> + withAsync (mkStakePoolMonitor nodeKernel) \spmAid -> do + link mempoolThread + link sigLogicThread + link spmAid + k nodeKernel mempoolWorker :: forall crypto m. diff --git a/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs new file mode 100644 index 00000000000..e58088e0c62 --- /dev/null +++ b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +module DMQ.NodeToClient.LocalStateQueryClient + ( cardanoClient + , connectToCardanoNode + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.Trans.Except +import Control.Tracer (Tracer (..), nullTracer) +import Data.Functor.Contravariant ((>$<)) +import Data.Map.Strict qualified as Map +import Data.Proxy +import Data.Void + +import Cardano.Chain.Genesis +import Cardano.Chain.Slotting +import Cardano.Crypto.ProtocolMagic +import Cardano.Network.NodeToClient +import Cardano.Slotting.EpochInfo.API +import Cardano.Slotting.Time +import DMQ.Diffusion.NodeKernel +import DMQ.Tracer +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query +import Ouroboros.Consensus.HardFork.History.EpochInfo +import Ouroboros.Consensus.Ledger.Query +import Ouroboros.Consensus.Network.NodeToClient +import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Shelley.Ledger.Query +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +import Ouroboros.Network.Block +import Ouroboros.Network.Magic +import Ouroboros.Network.Mux qualified as Mx +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Type + +-- TODO generalize to handle ledger eras other than Conway +-- | connects the dmq node to cardano node via local state query +-- and updates the node kernel with stake pool data necessary to perform message +-- validation +cardanoClient + :: forall block query point crypto m. (MonadDelay m, MonadSTM m, MonadThrow m, MonadTime m) + => (block ~ CardanoBlock crypto, query ~ Query block, point ~ Point block) + => Tracer m String -- TODO: replace string with a proper type + -> StakePools m + -> StrictTVar m (Maybe UTCTime) -- ^ from node kernel + -> LocalStateQueryClient (CardanoBlock crypto) (Point block) (Query block) m Void +cardanoClient _tracer StakePools { stakePoolsVar } nextEpochVar = LocalStateQueryClient (idle Nothing) + where + idle mSystemStart = pure $ SendMsgAcquire ImmutableTip acquire + where + acquire :: ClientStAcquiring block point query m Void + acquire = ClientStAcquiring { + recvMsgAcquired = + let epochQry systemStart = pure $ + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetEpochNo) + $ wrappingMismatch (handleEpoch systemStart) + in case mSystemStart of + Just systemStart -> epochQry systemStart + Nothing -> pure $ + SendMsgQuery GetSystemStart $ ClientStQuerying epochQry + + , recvMsgFailure = \failure -> + throwIO . userError $ "recvMsgFailure: " <> show failure + } + + wrappingMismatch k = ClientStQuerying $ + either (const . throwIO . userError $ "mismatch era info") k + + handleEpoch systemStart epoch = pure + . SendMsgQuery (BlockQuery . QueryHardFork $ GetInterpreter) + $ getInterpreter systemStart epoch + + getInterpreter systemStart epoch = ClientStQuerying \interpreter -> do + let ei = interpreterToEpochInfo interpreter + res = + runExcept do + lastSlot <- snd <$> epochInfoRange ei epoch + lastSlotTime <- epochInfoSlotToRelativeTime ei lastSlot + lastSlotLength <- epochInfoSlotLength ei lastSlot + pure $ addRelativeTime (getSlotLength lastSlotLength) lastSlotTime + + case res of + Left _err -> pure $ SendMsgRelease do + threadDelay 86400 -- TODO fuzz this? + idle $ Just systemStart + Right relativeTime -> do + now <- getCurrentTime + let nextEpoch = fromRelativeTime systemStart relativeTime + toNextEpoch = diffUTCTime nextEpoch now + pure $ + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetStakeSnapshots Nothing) + $ wrappingMismatch (handleStakeSnapshots systemStart nextEpoch toNextEpoch) + + handleStakeSnapshots systemStart nextEpoch toNextEpoch StakeSnapshots { ssStakeSnapshots } = do + atomically do + writeTVar stakePoolsVar ssStakeSnapshots + writeTVar nextEpochVar $ Just nextEpoch + pure $ SendMsgRelease do + threadDelay $ min (realToFrac toNextEpoch) 86400 -- TODO fuzz this? + idle $ Just systemStart + +connectToCardanoNode :: Tracer IO (WithEventType String) + -> LocalSnocket + -> FilePath + -> NodeKernel crypto ntnAddr IO + -> IO (Either SomeException Void) +connectToCardanoNode tracer localSnocket' snocketPath nodeKernel = + connectTo + localSnocket' + nullNetworkConnectTracers --debuggingNetworkConnectTracers + (combineVersions + [ simpleSingletonVersions + version + NodeToClientVersionData { + networkMagic = + NetworkMagic -- 2 {- preview net -} + . unProtocolMagicId + $ mainnetProtocolMagicId + , query = False + } + \_version -> + Mx.OuroborosApplication + [ Mx.MiniProtocol + { miniProtocolNum = Mx.MiniProtocolNum 7 + , miniProtocolStart = Mx.StartEagerly + , miniProtocolLimits = + Mx.MiniProtocolLimits + { maximumIngressQueue = 0xffffffff + } + , miniProtocolRun = + Mx.InitiatorProtocolOnly + . Mx.mkMiniProtocolCbFromPeerSt + . const + $ ( nullTracer + , cStateQueryCodec + , StateIdle + , localStateQueryClientPeer + $ cardanoClient (WithEventType "LocalStateQuery" >$< tracer) + (stakePools nodeKernel) + (nextEpochVar nodeKernel) + ) + } + ] + | version <- [minBound..maxBound] + , let supportedVersionMap = supportedNodeToClientVersions (Proxy :: Proxy (CardanoBlock StandardCrypto)) + blk = supportedVersionMap Map.! version + Codecs {cStateQueryCodec} = + clientCodecs (pClientInfoCodecConfig . protocolClientInfoCardano $ EpochSlots 21600) blk version + ]) + snocketPath From 0de3477551ca5f448e2f41fa3915431bb4f78026 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Fri, 12 Sep 2025 15:12:38 +0200 Subject: [PATCH 18/29] sig validation --- dmq-node/dmq-node.cabal | 3 + .../src/DMQ/Protocol/SigSubmission/Type.hs | 74 +------ .../DMQ/Protocol/SigSubmission/Validate.hs | 207 ++++++++++++++++++ 3 files changed, 211 insertions(+), 73 deletions(-) create mode 100644 dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index e69262a3976..aa5799257a9 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -82,6 +82,7 @@ library DMQ.Protocol.LocalMsgSubmission.Type DMQ.Protocol.SigSubmission.Codec DMQ.Protocol.SigSubmission.Type + DMQ.Protocol.SigSubmission.Validate DMQ.Tracer build-depends: @@ -96,6 +97,7 @@ library cardano-crypto-class, cardano-crypto-wrapper, cardano-ledger-byron, + cardano-ledger-core, cardano-ledger-shelley, cardano-slotting, cborg >=0.2.1 && <0.3, @@ -122,6 +124,7 @@ library text >=1.2.4 && <2.2, time ^>=1.12, transformers, + transformers-except, typed-protocols:{typed-protocols, cborg} ^>=1.1, hs-source-dirs: src diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs index feb9e028b27..4f42afaae50 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs @@ -6,6 +6,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,7 +21,6 @@ module DMQ.Protocol.SigSubmission.Type , SigRaw (..) , SigRawWithSignedBytes (..) , Sig (Sig, SigWithBytes, sigRawWithSignedBytes, sigRawBytes, sigId, sigBody, sigExpiresAt, sigOpCertificate, sigKESPeriod, sigKESSignature, sigColdKey, sigSignedBytes, sigBytes) - , validateSig -- * `TxSubmission` mini-protocol , SigSubmission , module SigSubmission @@ -41,7 +41,6 @@ import Data.ByteString.Lazy.Char8 qualified as LBS.Char8 import Data.Text.Encoding qualified as Text import Data.Time.Clock.POSIX (POSIXTime) import Data.Typeable -import Data.Word (Word64) import Cardano.Crypto.DSIGN.Class (ContextDSIGN, DSIGNAlgorithm, VerKeyDSIGN) import Cardano.Crypto.DSIGN.Class qualified as DSIGN @@ -274,61 +273,6 @@ pattern instance Typeable crypto => ShowProxy (Sig crypto) where -data SigValidationError = - InvalidKESSignature KESPeriod KESPeriod String - | InvalidSignatureOCERT - !Word64 -- OCert counter - !KESPeriod -- OCert KES period - !String -- DSIGN error message - | KESBeforeStartOCERT KESPeriod KESPeriod - | KESAfterEndOCERT KESPeriod KESPeriod - deriving Show - -validateSig :: forall crypto. - ( Crypto crypto - , ContextDSIGN (KES.DSIGN crypto) ~ () - , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) - , ContextKES (KES crypto) ~ () - , Signable (KES crypto) ByteString - ) - => KES.EvolutionConfig - -> Sig crypto - -> Either SigValidationError () -validateSig _ec - Sig { sigSignedBytes = signedBytes, - sigKESPeriod, - sigOpCertificate = SigOpCertificate ocert@OCert { - ocertKESPeriod, - ocertVkHot, - ocertN - }, - sigColdKey = SigColdKey coldKey, - sigKESSignature = SigKESSignature kesSig - } - = do - sigKESPeriod < endKESPeriod - ?! KESAfterEndOCERT endKESPeriod sigKESPeriod - sigKESPeriod >= startKESPeriod - ?! KESBeforeStartOCERT startKESPeriod sigKESPeriod - - -- validate OCert, which includes verifying its signature - validateOCert coldKey ocertVkHot ocert - ?!: InvalidSignatureOCERT ocertN sigKESPeriod - -- validate KES signature of the payload - verifyKES () ocertVkHot - (unKESPeriod sigKESPeriod - unKESPeriod startKESPeriod) - (LBS.toStrict signedBytes) - kesSig - ?!: InvalidKESSignature ocertKESPeriod sigKESPeriod - where - startKESPeriod, endKESPeriod :: KESPeriod - - startKESPeriod = ocertKESPeriod - -- TODO: is `totalPeriodsKES` the same as `praosMaxKESEvo` - -- or `sgMaxKESEvolution` in the genesis file? - endKESPeriod = KESPeriod $ unKESPeriod startKESPeriod - + totalPeriodsKES (Proxy :: Proxy (KES crypto)) - type SigSubmission crypto = TxSubmission2.TxSubmission2 SigId (Sig crypto) @@ -343,19 +287,3 @@ newtype CBORBytes = CBORBytes { getCBORBytes :: LBS.ByteString } instance Show CBORBytes where show = LBS.Char8.unpack . LBS.Base16.encode . getCBORBytes - - --- --- Utility functions --- - -(?!:) :: Either e1 a -> (e1 -> e2) -> Either e2 a -(?!:) = flip first - -infix 1 ?!: - -(?!) :: Bool -> e -> Either e () -(?!) True _ = Right () -(?!) False e = Left e - -infix 1 ?! diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs new file mode 100644 index 00000000000..7707d39ba9e --- /dev/null +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Encapsulates signature validation utilities leveraged by the mempool writer +-- +module DMQ.Protocol.SigSubmission.Validate where + +import Control.Exception +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Trans.Except +import Control.Monad.Trans.Except.Extra +import Data.Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, isNothing) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Typeable +import Data.Word +import Text.Printf + +import Cardano.Crypto.DSIGN.Class (ContextDSIGN) +import Cardano.Crypto.DSIGN.Class qualified as DSIGN +import Cardano.Crypto.KES.Class (KESAlgorithm (..)) +import Cardano.KESAgent.KES.Crypto as KES +import Cardano.KESAgent.KES.OCert (OCert (..), OCertSignable, validateOCert) +import Cardano.Ledger.BaseTypes.NonZero +import Cardano.Ledger.Hashes + +import DMQ.Diffusion.NodeKernel (PoolValidationCtx (..)) +import DMQ.Protocol.SigSubmission.Type +import Ouroboros.Consensus.Shelley.Ledger.Query +import Ouroboros.Network.TxSubmission.Mempool.Simple +import Ouroboros.Network.Util.ShowProxy + + +-- | The type of non-fatal failures reported by the mempool writer +-- for invalid messages +-- +data instance MempoolAddFail (Sig crypto) = + SigInvalid Text + | SigDuplicate + | SigExpired + | SigResultOther Text + deriving (Eq, Show) + +instance (Typeable crypto) => ShowProxy (MempoolAddFail (Sig crypto)) + +instance ToJSON (MempoolAddFail (Sig crypto)) where + toJSON SigDuplicate = String "duplicate" + toJSON SigExpired = String "expired" + toJSON (SigInvalid txt) = object + [ "type" .= String "invalid" + , "reason" .= txt + ] + toJSON (SigResultOther txt) = object + [ "type" .= String "other" + , "reason" .= txt + ] + +-- | The type of exception raised by the mempool writer for invalid messages +-- as determined by the validation procedure and policy +-- +newtype instance InvalidTxsError SigValidationError = InvalidTxsError SigValidationError + +deriving instance Show (InvalidTxsError SigValidationError) +instance Exception (InvalidTxsError SigValidationError) + +-- | The policy which is realized by the mempool writer when encountering +-- an invalid message. +-- +data ValidationPolicy = + FailDefault | FailSoft + +data SigValidationError = + InvalidKESSignature KESPeriod KESPeriod String + | InvalidSignatureOCERT + !Word64 -- OCert counter + !KESPeriod -- OCert KES period + !String -- DSIGN error message + | KESBeforeStartOCERT KESPeriod KESPeriod + | KESAfterEndOCERT KESPeriod KESPeriod + | UnrecognizedPool + | ExpiredPool + | NotInitialized + | ClockSkew + deriving Show + +-- TODO fine tune policy +sigValidationPolicy + :: SigValidationError + -> Either (MempoolAddFail (Sig crypto)) (MempoolAddFail (Sig crypto)) +sigValidationPolicy sve = case sve of + InvalidKESSignature {} -> Left . SigInvalid . Text.pack . show $ sve + InvalidSignatureOCERT {} -> Left . SigInvalid . Text.pack . show $ sve + KESAfterEndOCERT {} -> Left SigExpired + KESBeforeStartOCERT start sig -> + Left . SigResultOther . Text.pack + $ printf "KESBeforeStartOCERT %s %s" (show start) (show sig) + UnrecognizedPool -> Left . SigInvalid $ Text.pack "unrecognized pool id" + ClockSkew -> Left . SigInvalid $ Text.pack "clock skew out of range" + ExpiredPool -> Left . SigInvalid $ Text.pack "expired pool" + NotInitialized -> Right . SigResultOther $ Text.pack "not initialized yet" + +-- TODO: +-- We don't validate ocert numbers, since we might not have necessary +-- information to do so, but we can validate that they are growing. +validateSig :: forall crypto. + ( Crypto crypto + , ContextDSIGN (KES.DSIGN crypto) ~ () + , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) + , ContextKES (KES crypto) ~ () + , Signable (KES crypto) ByteString + ) + => ValidationPolicy + -> (DSIGN.VerKeyDSIGN (DSIGN crypto) -> KeyHash StakePool) + -> [Sig crypto] + -> PoolValidationCtx + -- ^ cardano pool id verification + -> Except (InvalidTxsError SigValidationError) [Either (MempoolAddFail (Sig crypto)) ()] +validateSig policy verKeyHashingFn sigs ctx = firstExceptT InvalidTxsError $ traverse process sigs + where + DMQPoolValidationCtx now mNextEpoch pools = ctx + + process Sig { sigSignedBytes = signedBytes, + sigKESPeriod, + sigOpCertificate = SigOpCertificate ocert@OCert { + ocertKESPeriod, + ocertVkHot, + ocertN + }, + sigColdKey = SigColdKey coldKey, + sigKESSignature = SigKESSignature kesSig + } = do + e1 <- sigKESPeriod < endKESPeriod + ?! KESAfterEndOCERT endKESPeriod sigKESPeriod + e2 <- sigKESPeriod >= startKESPeriod + ?! KESBeforeStartOCERT startKESPeriod sigKESPeriod + e3 <- case Map.lookup (verKeyHashingFn coldKey) pools of + Nothing | isNothing mNextEpoch -> classifyError NotInitialized + | otherwise -> classifyError UnrecognizedPool + -- TODO make 5 a constant + Just ss | not (isZero (ssSetPool ss)) + -- we bound the time we're willing to approve a message + -- in case smth happened to localstatequery and it's taking + -- too long to update our state + , now <= addUTCTime 5 nextEpoch -> right $ Right () + | not (isZero (ssMarkPool ss)) + -- we take abs time in case we're late with our own + -- localstatequery update, and/or the other side's clock + -- is ahead, and we're just about or have just crossed the epoch + -- and the pool is expected to move into the set mark + , abs (diffUTCTime nextEpoch now) <= 5 -> right $ Right () + -- pool is deregistered and ineligible to mint blocks + | isZero (ssMarkPool ss) && isZero (ssSetPool ss) -> + classifyError ExpiredPool + | otherwise -> classifyError ClockSkew + where + -- mNextEpoch and pools are initialized in one STM transaction + -- and fromJust will not fail here + nextEpoch = fromJust mNextEpoch + + -- validate OCert, which includes verifying its signature + e4 <- validateOCert coldKey ocertVkHot ocert + ?!: InvalidSignatureOCERT ocertN sigKESPeriod + -- validate KES signature of the payload + e5 <- verifyKES () ocertVkHot + (unKESPeriod sigKESPeriod - unKESPeriod startKESPeriod) + (LBS.toStrict signedBytes) + kesSig + ?!: InvalidKESSignature ocertKESPeriod sigKESPeriod + -- for eg. remember to run all results with possibly non-fatal errors + right $ e1 >> e2 >> e3 >> e4 >> e5 + where + startKESPeriod, endKESPeriod :: KESPeriod + + startKESPeriod = ocertKESPeriod + -- TODO: is `totalPeriodsKES` the same as `praosMaxKESEvo` + -- or `sgMaxKESEvolution` in the genesis file? + endKESPeriod = KESPeriod $ unKESPeriod startKESPeriod + + totalPeriodsKES (Proxy :: Proxy (KES crypto)) + + classifyError sigValidationError = case policy of + FailSoft -> + let mempoolAddFail = either id id (sigValidationPolicy sigValidationError) + in right . Left $ mempoolAddFail + FailDefault -> + either (const $ throwE sigValidationError) (right . Left) + (sigValidationPolicy sigValidationError) + + (?!:) :: Either e1 () + -> (e1 -> SigValidationError) + -> Except SigValidationError (Either (MempoolAddFail (Sig crypto)) ()) + (?!:) = (handleE classifyError .) . flip firstExceptT . hoistEither . fmap Right + + (?!) :: Bool + -> SigValidationError + -> Except SigValidationError (Either (MempoolAddFail (Sig crypto)) ()) + (?!) flag sve = if flag then right $ Right () else classifyError sve + + infix 1 ?! + infix 1 ?!: From 0242634b9a546263f79fd6171d44fec97d315f54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 11 Sep 2025 16:14:44 +0200 Subject: [PATCH 19/29] mempool: adapt for generalized validation --- .../DMQ/Protocol/LocalMsgSubmission/Client.hs | 3 +- .../DMQ/Protocol/LocalMsgSubmission/Server.hs | 3 +- .../DMQ/Protocol/LocalMsgSubmission/Type.hs | 29 +-- .../Network/TxSubmission/Mempool/Simple.hs | 170 +++++++++++------- 4 files changed, 110 insertions(+), 95 deletions(-) diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs index 01429e66b8b..dc23363faef 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs @@ -17,10 +17,11 @@ module DMQ.Protocol.LocalMsgSubmission.Client import DMQ.Protocol.LocalMsgSubmission.Type import Network.TypedProtocol.Peer.Client import Ouroboros.Network.Protocol.LocalTxSubmission.Client +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Type aliases for the high level client API -- -type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig SigMempoolFail +type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig (MempoolAddFail sig) type LocalMsgClientStIdle = LocalTxClientStIdle diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs index 9a44d2b0060..7936fd78945 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs @@ -18,10 +18,11 @@ module DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type import Network.TypedProtocol.Peer.Server import Ouroboros.Network.Protocol.LocalTxSubmission.Server as LocalTxSubmission +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Type aliases for the high level client API -- -type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig SigMempoolFail +type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig (MempoolAddFail sig) -- | A non-pipelined 'Peer' representing the 'LocalMsgSubmissionServer'. diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs index 2ef26424b9f..114249c8f31 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs @@ -13,35 +13,10 @@ module DMQ.Protocol.LocalMsgSubmission.Type , module Ouroboros ) where -import Data.Aeson -import Data.Text (Text) import Network.TypedProtocol.Core as Core import Ouroboros.Network.Protocol.LocalTxSubmission.Type as Ouroboros -import Ouroboros.Network.Util.ShowProxy +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | The LocalMsgSubmission protocol is an alias for the LocalTxSubmission -- -type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig SigMempoolFail - --- | The type of failures when adding to the mempool --- -data SigMempoolFail = - SigInvalid Text - | SigDuplicate - | SigExpired - | SigResultOther Text - deriving (Eq, Show) - -instance ShowProxy SigMempoolFail where - -instance ToJSON SigMempoolFail where - toJSON SigDuplicate = String "duplicate" - toJSON SigExpired = String "expired" - toJSON (SigInvalid txt) = object - [ "type" .= String "invalid" - , "reason" .= txt - ] - toJSON (SigResultOther txt) = object - [ "type" .= String "other" - , "reason" .= txt - ] +type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig (MempoolAddFail sig) diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs index 75e49ace3e2..f627ca7c989 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs @@ -1,40 +1,49 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | The module should be imported qualified. -- module Ouroboros.Network.TxSubmission.Mempool.Simple - ( Mempool (..) + ( InvalidTxsError + , MempoolAddFail + , Mempool (..) , MempoolSeq (..) + , MempoolWriter (..) , empty , new , read , getReader , getWriter + , writerAdapter ) where import Prelude hiding (read, seq) import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (when) +import Control.DeepSeq +import Control.Exception (assert) import Control.Monad.Class.MonadThrow - +import Control.Monad.Trans.Except import Data.Bifunctor (bimap) -import Data.Either (partitionEithers) +import Data.Either import Data.Foldable (toList) import Data.Foldable qualified as Foldable -import Data.Function (on) -import Data.List (find, nubBy) +import Data.List (find) import Data.Maybe (isJust) import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Set (Set) import Data.Set qualified as Set -import Data.Typeable (Typeable) +import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) import Ouroboros.Network.SizeInBytes import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Ouroboros.Network.TxSubmission.Mempool.Reader @@ -105,69 +114,98 @@ getReader getTxId getTxSize (Mempool mempool) = f :: Int -> tx -> (txid, Int, SizeInBytes) f idx tx = (getTxId tx, idx, getTxSize tx) +-- | type of mempool validation errors which are thrown as exceptions +-- +data family InvalidTxsError failure -data InvalidTxsError where - InvalidTxsError :: forall txid failure. - ( Typeable txid - , Typeable failure - , Show txid - , Show failure - ) - => [(txid, failure)] - -> InvalidTxsError - -deriving instance Show InvalidTxsError -instance Exception InvalidTxsError - +-- | type of mempool validation errors which are non-fatal +-- +data family MempoolAddFail tx --- | A simple mempool writer. +-- | A mempool writer which generalizes the tx submission mempool writer +-- TODO: We could replace TxSubmissionMempoolWriter with this at some point +-- +data MempoolWriter txid tx failure idx m = + MempoolWriter { + + -- | Compute the transaction id from a transaction. + -- + -- This is used in the protocol handler to verify a full transaction + -- matches a previously given transaction id. + -- + txId :: tx -> txid, + + -- | Supply a batch of transactions to the mempool. They are either + -- accepted or rejected individually, but in the order supplied. + -- + -- The 'txid's of all transactions that were added successfully are + -- returned. + mempoolAddTxs :: [tx] -> m [(txid, SubmitResult (MempoolAddFail tx))] + } + + +-- | A mempool writer with validation harness +-- PRECONDITION: no duplicates given to mempoolAddTxs -- getWriter :: forall tx txid ctx failure m. ( MonadSTM m + , Exception (InvalidTxsError failure) , MonadThrow m + -- TODO: + -- , NFData txid + -- , NFData tx + -- , NFData (MempoolAddFail tx) , Ord txid - , Typeable txid - , Typeable failure - , Show txid - , Show failure ) => (tx -> txid) -- ^ get txid of a tx -> m ctx - -- ^ monadic validation ctx - -> (ctx -> tx -> Either failure ()) - -- ^ validate a tx, any failing `tx` throws an exception. - -> (failure -> Bool) - -- ^ return `True` when a failure should throw an exception + -- ^ acquire validation context + -> ([tx] -> ctx -> Except (InvalidTxsError failure) [(Either (MempoolAddFail tx) ())]) + -- ^ validation function which should evaluate its result to normal form + -- esp. if it is 'expensive' + -> MempoolAddFail tx + -- ^ replace duplicates -> Mempool m txid tx - -> TxSubmissionMempoolWriter txid tx Int m -getWriter getTxId getValidationCtx validateTx failureFilterFn (Mempool mempool) = - TxSubmissionMempoolWriter { - txId = getTxId, - - mempoolAddTxs = \txs -> do - ctx <- getValidationCtx - (invalidTxIds, validTxs) <- atomically $ do - MempoolSeq { mempoolSet, mempoolSeq } <- readTVar mempool - let (invalidTxIds, validTxs) = - bimap (filter (failureFilterFn . snd)) - (nubBy (on (==) getTxId)) - . partitionEithers - . map (\tx -> case validateTx ctx tx of - Left e -> Left (getTxId tx, e) - Right _ -> Right tx - ) - . filter (\tx -> getTxId tx `Set.notMember` mempoolSet) - $ txs - mempoolTxs' = MempoolSeq { - mempoolSet = Foldable.foldl' (\s tx -> getTxId tx `Set.insert` s) - mempoolSet - validTxs, - mempoolSeq = Foldable.foldl' (Seq.|>) mempoolSeq validTxs - } - writeTVar mempool mempoolTxs' - return (invalidTxIds, map getTxId validTxs) - when (not (null invalidTxIds)) $ - throwIO (InvalidTxsError invalidTxIds) - return validTxs - } + -> MempoolWriter txid tx failure Int m +getWriter getTxId acquireCtx validateTxs duplicateFail (Mempool mempool) = + MempoolWriter { + txId = getTxId, + + mempoolAddTxs = \txs -> assert (not . null $ txs) $ do + ctx <- acquireCtx + !vTxs <- case runExcept (validateTxs txs ctx) of + Left e -> throwIO e + Right r -> pure {-. force-} $ zipWith3 ((,,) . getTxId) txs txs r + + atomically $ do + MempoolSeq { mempoolSet, mempoolSeq } <- readTVar mempool + let result = + [if duplicate then + Left . (txid,) $ SubmitFail duplicateFail + else + bimap ((txid,) . SubmitFail) (const (txid, tx)) eErrTx + | (txid, tx, eErrTx) <- vTxs + , let duplicate = txid `Set.member` mempoolSet + ] + (validIds, validTxs) = unzip . rights $ result + mempoolTxs' = MempoolSeq { + mempoolSet = Set.union mempoolSet (Set.fromList validIds), + mempoolSeq = Foldable.foldl' (Seq.|>) mempoolSeq validTxs + } + writeTVar mempool mempoolTxs' + return $ either id ((,SubmitSuccess) . fst) <$> result + } + + +-- | Takes the general mempool writer defined here +-- and adapts it to the API of the tx submission mempool writer +-- to avoid more breaking changes for now. +-- +writerAdapter :: (Functor m) + => MempoolWriter txid tx failure idx m + -> TxSubmissionMempoolWriter txid tx idx m +writerAdapter MempoolWriter { txId, mempoolAddTxs } = + TxSubmissionMempoolWriter { txId, mempoolAddTxs = adapter } + where + adapter = fmap (fmap fst) . mempoolAddTxs From 026e4868e823d62ec2b1f1a43992af94bdd1bf41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Sun, 14 Sep 2025 09:49:51 +0200 Subject: [PATCH 20/29] localmsgsubmission: codec and server changes --- .../DMQ/NodeToClient/LocalMsgSubmission.hs | 65 ++++++++++--------- .../DMQ/Protocol/LocalMsgSubmission/Codec.hs | 9 +-- 2 files changed, 39 insertions(+), 35 deletions(-) diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs index 152ed979c1b..40d7a3896d0 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} module DMQ.NodeToClient.LocalMsgSubmission where @@ -6,62 +8,63 @@ import Control.Concurrent.Class.MonadSTM import Control.Tracer import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson qualified as Aeson -import Data.Maybe - -import Ouroboros.Network.TxSubmission.Inbound.V2 import DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type +import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Local transaction submission server, for adding txs to the 'Mempool' -- localMsgSubmissionServer :: MonadSTM m - => (msg -> msgid) + => (sig -> sigid) -- ^ get message id - -> Tracer m (TraceLocalMsgSubmission msgid) - -> TxSubmissionMempoolWriter msgid msg idx m - -> m (LocalMsgSubmissionServer msg m ()) -localMsgSubmissionServer getMsgId tracer TxSubmissionMempoolWriter { mempoolAddTxs } = + -> Tracer m (TraceLocalMsgSubmission sig sigid) + -> MempoolWriter sigid sig failure idx m + -- ^ duplicate error tag in case the mempool returns the empty list on failure + -> m (LocalMsgSubmissionServer sig m ()) +localMsgSubmissionServer getMsgId tracer MempoolWriter { mempoolAddTxs } = pure server where - failure = - -- TODO remove dummy hardcode when mempool returns reason - (SubmitFail SigExpired, server) <$ traceWith tracer (TraceSubmitFailure SigExpired) - success msgid = - (SubmitSuccess, server) <$ traceWith tracer (TraceSubmitAccept msgid) + process (sigid, e@(SubmitFail reason)) = + (e, server) <$ traceWith tracer (TraceSubmitFailure sigid reason) + process (sigid, success) = + (success, server) <$ traceWith tracer (TraceSubmitAccept sigid) server = LocalTxSubmissionServer { - recvMsgSubmitTx = \msg -> do - traceWith tracer $ TraceReceivedMsg (getMsgId msg) - -- TODO mempool should return 'SubmitResult' - maybe failure success . listToMaybe =<< mempoolAddTxs [msg] + recvMsgSubmitTx = \sig -> do + traceWith tracer $ TraceReceivedMsg (getMsgId sig) + process . head =<< mempoolAddTxs [sig] , recvMsgDone = () } -data TraceLocalMsgSubmission msgid = - TraceReceivedMsg msgid - -- ^ A transaction was received. - | TraceSubmitFailure SigMempoolFail - | TraceSubmitAccept msgid - deriving Show +data TraceLocalMsgSubmission sig sigid = + TraceReceivedMsg sigid + -- ^ A signature was received. + | TraceSubmitFailure sigid (MempoolAddFail sig) + | TraceSubmitAccept sigid + +deriving instance + (Show sig, Show sigid, Show (MempoolAddFail sig)) + => Show (TraceLocalMsgSubmission sig sigid) -instance ToJSON msgid - => ToJSON (TraceLocalMsgSubmission msgid) where - toJSON (TraceReceivedMsg msgid) = +instance (ToJSON sigid, ToJSON (MempoolAddFail sig)) + => ToJSON (TraceLocalMsgSubmission sig sigid) where + toJSON (TraceReceivedMsg sigid) = -- TODO: once we have verbosity levels, we could include the full tx, for -- now one can use `TraceSendRecv` tracer for the mini-protocol to see full -- msgs. object [ "kind" .= Aeson.String "TraceReceivedMsg" - , "sigId" .= msgid + , "sigId" .= sigid ] - toJSON (TraceSubmitFailure reject) = + toJSON (TraceSubmitFailure sigid reject) = object [ "kind" .= Aeson.String "TraceSubmitFailure" + , "sigId" .= sigid , "reason" .= reject ] - toJSON (TraceSubmitAccept msgid) = + toJSON (TraceSubmitAccept sigid) = object [ "kind" .= Aeson.String "TraceSubmitAccept" - , "sigId" .= msgid + , "sigId" .= sigid ] diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs index 8a010bff407..51724951915 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs @@ -17,6 +17,7 @@ import Cardano.KESAgent.KES.Crypto (Crypto (..)) import DMQ.Protocol.LocalMsgSubmission.Type import DMQ.Protocol.SigSubmission.Codec qualified as SigSubmission import DMQ.Protocol.SigSubmission.Type (Sig (..)) +import DMQ.Protocol.SigSubmission.Validate import Network.TypedProtocol.Codec.CBOR import Ouroboros.Network.Protocol.LocalTxSubmission.Codec qualified as LTX @@ -26,13 +27,13 @@ codecLocalMsgSubmission ( MonadST m , Crypto crypto ) - => (SigMempoolFail -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s SigMempoolFail) + => (MempoolAddFail (Sig crypto) -> CBOR.Encoding) + -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto))) -> AnnotatedCodec (LocalMsgSubmission (Sig crypto)) CBOR.DeserialiseFailure m ByteString codecLocalMsgSubmission = LTX.anncodecLocalTxSubmission' SigWithBytes SigSubmission.encodeSig SigSubmission.decodeSig -encodeReject :: SigMempoolFail -> CBOR.Encoding +encodeReject :: MempoolAddFail (Sig crypto) -> CBOR.Encoding encodeReject = \case SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encodeString reason SigDuplicate -> CBOR.encodeListLen 1 <> CBOR.encodeWord 1 @@ -40,7 +41,7 @@ encodeReject = \case SigResultOther reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> CBOR.encodeString reason -decodeReject :: CBOR.Decoder s SigMempoolFail +decodeReject :: CBOR.Decoder s (MempoolAddFail (Sig crypto)) decodeReject = do len <- CBOR.decodeListLen tag <- CBOR.decodeWord From 3d4650f2010cc45f42669ecb4f0f1982653ee629 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 11 Sep 2025 16:14:51 +0200 Subject: [PATCH 21/29] app: integration --- dmq-node/app/Main.hs | 105 +++++++++++++++++-------------- dmq-node/dmq-node.cabal | 2 +- dmq-node/src/DMQ/NodeToClient.hs | 18 +++--- dmq-node/src/DMQ/NodeToNode.hs | 33 ++++------ 4 files changed, 83 insertions(+), 75 deletions(-) diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 2520f9d63de..7f67d7d9fea 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -10,7 +10,6 @@ module Main where import Control.Exception (throwIO) import Control.Monad (void, when) -import Control.Monad.Class.MonadAsync import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Act @@ -28,13 +27,15 @@ import System.Random (newStdGen, split) import Cardano.Git.Rev (gitRev) import Cardano.KESAgent.KES.Evolution qualified as KES import Cardano.KESAgent.Protocols.StandardCrypto (StandardCrypto) +import Cardano.Ledger.Keys (VKey (..)) +import Cardano.Ledger.Hashes (hashKey) import DMQ.Configuration import DMQ.Configuration.CLIOptions (parseCLIOptions) import DMQ.Configuration.Topology (readTopologyFileOrError) import DMQ.Diffusion.Applications (diffusionApplications) import DMQ.Diffusion.Arguments -import DMQ.Diffusion.NodeKernel (mempool, withNodeKernel) +import DMQ.Diffusion.NodeKernel import DMQ.Handlers.TopLevel (toplevelExceptionHandler) import DMQ.NodeToClient qualified as NtC import DMQ.NodeToNode (NodeToNodeVersion, dmqCodecs, dmqLimitsAndTimeouts, @@ -45,9 +46,11 @@ import DMQ.Tracer import DMQ.Diffusion.PeerSelection (policy) import DMQ.NodeToClient.LocalStateQueryClient +import DMQ.Protocol.SigSubmission.Validate import Ouroboros.Network.Diffusion qualified as Diffusion import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, encodeRemoteAddress) +import Ouroboros.Network.SizeInBytes import Ouroboros.Network.Snocket import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool @@ -118,58 +121,68 @@ runDMQ commandLineConfig = do let (psRng, policyRng) = split stdGen Diffusion.withIOManager \iocp -> do - let localSnocket' = localSnocket iocp + let localSnocket' = localSnocket iocp + mkStakePoolMonitor = connectToCardanoNode tracer localSnocket' snocketPath withNodeKernel @StandardCrypto tracer dmqConfig evolutionConfig - psRng $ \nodeKernel -> do + psRng + mkStakePoolMonitor $ \nodeKernel -> do dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt - let stakePoolMonitor = connectToCardanoNode tracer localSnocket' snocketPath nodeKernel - - withAsync stakePoolMonitor \aid -> do - link aid - let dmqNtNApps = - ntnApps tracer - dmqConfig - nodeKernel - (dmqCodecs + let sigSize :: Sig StandardCrypto -> SizeInBytes + sigSize _ = 0 -- TODO + mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel) + dmqNtNApps = + let ntnMempoolWriter = Mempool.writerAdapter $ + Mempool.getWriter sigId + (poolValidationCtx $ stakePools nodeKernel) + (validateSig evolutionConfig (hashKey . VKey)) + SigDuplicate + (mempool nodeKernel) + in ntnApps tracer + dmqConfig + mempoolReader + ntnMempoolWriter + sigSize + nodeKernel + (dmqCodecs -- TODO: `maxBound :: Cardano.Network.NodeToNode.NodeToNodeVersion` -- is unsafe here! (encodeRemoteAddress (maxBound @NodeToNodeVersion)) (decodeRemoteAddress (maxBound @NodeToNodeVersion))) - dmqLimitsAndTimeouts - defaultSigDecisionPolicy - dmqNtCApps = - let sigSize _ = 0 -- TODO - maxMsgs = 1000 -- TODO: make this negotiated in the handshake? - mempoolReader = Mempool.getReader sigId sigSize (mempool nodeKernel) - mempoolWriter = Mempool.getWriter sigId (pure ()) - (\_ _ -> Right () :: Either Void ()) - (\_ _ -> pure True) - (mempool nodeKernel) - in NtC.ntcApps tracer dmqConfig - mempoolReader mempoolWriter maxMsgs - (NtC.dmqCodecs encodeReject decodeReject) - dmqDiffusionArguments = - diffusionArguments (if handshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - (if localHandshakeTracer - then WithEventType "Handshake" >$< tracer - else nullTracer) - dmqDiffusionApplications = - diffusionApplications nodeKernel - dmqConfig - dmqDiffusionConfiguration - dmqLimitsAndTimeouts - dmqNtNApps - dmqNtCApps - (policy policyRng) - - Diffusion.run dmqDiffusionArguments - (dmqDiffusionTracers dmqConfig tracer) - dmqDiffusionConfiguration - dmqDiffusionApplications + dmqLimitsAndTimeouts + defaultSigDecisionPolicy + dmqNtCApps = + let maxMsgs = 1000 -- TODO: make this negotiated in the handshake? + ntcMempoolWriter = + Mempool.getWriter sigId + (poolValidationCtx $ stakePools nodeKernel) + (validateSig (hashKey . VKey)) + SigDuplicate + (mempool nodeKernel) + in NtC.ntcApps tracer dmqConfig + mempoolReader ntcMempoolWriter maxMsgs + (NtC.dmqCodecs encodeReject decodeReject) + dmqDiffusionArguments = + diffusionArguments (if handshakeTracer + then WithEventType "Handshake" >$< tracer + else nullTracer) + (if localHandshakeTracer + then WithEventType "Handshake" >$< tracer + else nullTracer) + dmqDiffusionApplications = + diffusionApplications nodeKernel + dmqConfig + dmqDiffusionConfiguration + dmqLimitsAndTimeouts + dmqNtNApps + dmqNtCApps + (policy policyRng) + + Diffusion.run dmqDiffusionArguments + (dmqDiffusionTracers dmqConfig tracer) + dmqDiffusionConfiguration + dmqDiffusionApplications diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index aa5799257a9..a7bd9e081f4 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -147,9 +147,9 @@ executable dmq-node aeson, base, cardano-git-rev, + cardano-ledger-core, contra-tracer >=0.1 && <0.3, dmq-node, - io-classes, kes-agent-crypto, optparse-applicative, ouroboros-network:{ouroboros-network, api, framework}, diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index a6684db27d5..eeffeeb1311 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -16,7 +16,6 @@ module DMQ.NodeToClient import Data.Aeson qualified as Aeson import Data.ByteString.Lazy (ByteString) import Data.Functor.Contravariant ((>$<)) -import Data.Typeable (Typeable) import Data.Void import Data.Word @@ -47,6 +46,7 @@ import DMQ.Protocol.LocalMsgSubmission.Codec import DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type import DMQ.Protocol.SigSubmission.Type (Sig, SigId, sigId) +import DMQ.Protocol.SigSubmission.Validate import DMQ.Tracer import Ouroboros.Network.Context @@ -58,9 +58,9 @@ import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.Protocol.Handshake (Handshake, HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, codecHandshake, noTimeLimitsHandshake) -import Ouroboros.Network.TxSubmission.Inbound.V2.Types - (TxSubmissionMempoolWriter) import Ouroboros.Network.TxSubmission.Mempool.Reader +import Ouroboros.Network.TxSubmission.Mempool.Simple +import Ouroboros.Network.Util.ShowProxy type HandshakeTr ntcAddr = Mx.WithBearer (ConnectionId ntcAddr) (TraceSendRecv (Handshake NodeToClientVersion CBOR.Term)) @@ -100,8 +100,8 @@ data Codecs crypto m = dmqCodecs :: ( MonadST m , Crypto crypto ) - => (SigMempoolFail -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s SigMempoolFail) + => (MempoolAddFail (Sig crypto) -> CBOR.Encoding) + -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto))) -> Codecs crypto m dmqCodecs encodeReject' decodeReject' = Codecs { @@ -132,18 +132,20 @@ data Apps ntcAddr m a = -- | Construct applications for the node-to-client protocols -- ntcApps - :: forall crypto idx ntcAddr m. + :: forall crypto idx ntcAddr failure m. ( MonadThrow m , MonadThread m , MonadSTM m , Crypto crypto - , Typeable crypto , Aeson.ToJSON ntcAddr + , Aeson.ToJSON (MempoolAddFail (Sig crypto)) + , ShowProxy (MempoolAddFail (Sig crypto)) + , ShowProxy (Sig crypto) ) => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration -> TxSubmissionMempoolReader SigId (Sig crypto) idx m - -> TxSubmissionMempoolWriter SigId (Sig crypto) idx m + -> MempoolWriter SigId (Sig crypto) failure idx m -> Word16 -> Codecs crypto m -> Apps ntcAddr m () diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index 71322107797..982e5255027 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -90,7 +90,7 @@ import Ouroboros.Network.PeerSharing (bracketPeerSharingClient, peerSharingClient, peerSharingServer) import Ouroboros.Network.Snocket (RemoteAddress) import Ouroboros.Network.TxSubmission.Inbound.V2 as SigSubmission -import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool +import Ouroboros.Network.TxSubmission.Mempool.Reader import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.OrphanInstances () @@ -150,12 +150,12 @@ data Apps addr m a b = } ntnApps - :: forall crypto m addr . + :: forall crypto m addr idx. ( Crypto crypto - , DSIGN.ContextDSIGN (DSIGN crypto) ~ () - , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) - , KES.ContextKES (KES crypto) ~ () - , KES.Signable (KES crypto) BS.ByteString + -- , DSIGN.ContextDSIGN (DSIGN crypto) ~ () + -- , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) + -- , KES.ContextKES (KES crypto) ~ () + -- , KES.Signable (KES crypto) BS.ByteString , Typeable crypto , Alternative (STM m) , MonadAsync m @@ -166,12 +166,16 @@ ntnApps , MonadThrow (STM m) , MonadTimer m , Ord addr + , Ord idx , Show addr , Hashable addr , Aeson.ToJSON addr ) => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration + -> TxSubmissionMempoolReader SigId (Sig crypto) idx m + -> TxSubmissionMempoolWriter SigId (Sig crypto) idx m + -> (Sig crypto -> SizeInBytes) -> NodeKernel crypto addr m -> Codecs crypto addr m -> LimitsAndTimeouts crypto addr @@ -191,6 +195,9 @@ ntnApps , dmqcSigSubmissionInboundTracer = I sigSubmissionInboundTracer , dmqcSigSubmissionLogicTracer = I sigSubmissionLogicTracer } + mempoolReader + mempoolWriter + sigSize NodeKernel { fetchClientRegistry , peerSharingRegistry @@ -225,20 +232,6 @@ ntnApps , aPeerSharingServer } where - sigSize :: Sig crypto -> SizeInBytes - sigSize _ = 0 -- TODO - - mempoolReader = Mempool.getReader sigId sigSize mempool - -- TODO: invalid signatures are just omitted from the mempool. For DMQ - -- we need to validate signatures when we received them, and shutdown - -- connection if we receive one, rather than validate them in the - -- mempool. - mempoolWriter = Mempool.getWriter sigId - (pure ()) -- TODO not needed - (\_ -> validateSig evolutionConfig) - (\_ -> True) - mempool - aSigSubmissionClient :: NodeToNodeVersion -> ExpandedInitiatorContext addr m From 65cd90372b067d3d1cf9adeb48a28b7e1bf6e8bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 15 Oct 2025 09:13:28 +0200 Subject: [PATCH 22/29] make it build --- cabal.project | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index ab85558d8aa..b489a8c7257 100644 --- a/cabal.project +++ b/cabal.project @@ -18,7 +18,7 @@ index-state: , hackage.haskell.org 2025-08-05T15:28:56Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-03-18T17:41:11Z + , cardano-haskell-packages 2025-09-10T02:05:10Z packages: ./cardano-ping ./monoidal-synchronisation @@ -63,7 +63,7 @@ source-repository-package type: git location: https://github.com/input-output-hk/typed-protocols tag: e29a21541c4af44a3d586ef0b2a61f8d87cc6bdd - --sha256: + --sha256: sha256-Kww2GEqi+GbjmKVIhMADazpUddOBuXqQCiR58WkMj10= subdir: typed-protocols -- kes-agent is not yet in CHaP, so we pull it from its GitHub repo @@ -71,7 +71,19 @@ source-repository-package type: git location: https://github.com/crocodile-dentist/kes-agent tag: c0ef04dde5582a28415ff7c8c1bb197adeec6fc8 - --sha256: + --sha256: sha256-slF7zuBy2DKWKlQfhBPW5FDRhueWrFcJkrHW4jEEELs= subdir: kes-agent kes-agent-crypto + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: 97137fb0484454f0cd208c55bfee278f7561e9ed + --sha256: sha256-T56Axhx/dk7D9s+LOi+NhY+Tb5n7H99OfUjUE5hPxtQ= + subdir: + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + sop-extras + ouroboros-consensus-protocol + ouroboros-consensus From 04a982a632963cc6be756525f2345e13ae93ea2b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 23 Oct 2025 20:39:55 +0200 Subject: [PATCH 23/29] move some things to a private library to remove deps on cardano-diffusion in the main library --- dmq-node/dmq-node.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index a7bd9e081f4..33c1bd03773 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -118,6 +118,7 @@ library ouroboros-consensus, ouroboros-consensus-cardano, ouroboros-consensus-diffusion, + cardano-diffusion, ouroboros-network:{ouroboros-network, api, framework, orphan-instances, protocols} ^>=0.23, random ^>=1.2, singletons, From e7b69fbda668f2570d337ccc2a0c8926f0b85f1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 27 Oct 2025 10:01:40 +0100 Subject: [PATCH 24/29] Expose big ledger peers to dmq node and add ocert counter --- dmq-node/app/Main.hs | 14 ++++- dmq-node/dmq-node.cabal | 3 +- dmq-node/src/DMQ/Configuration.hs | 42 +++------------ dmq-node/src/DMQ/Configuration/Topology.hs | 28 ---------- dmq-node/src/DMQ/Diffusion/Arguments.hs | 9 ++-- dmq-node/src/DMQ/Diffusion/NodeKernel.hs | 44 +++++++++++----- .../DMQ/NodeToClient/LocalStateQueryClient.hs | 52 +++++++++++++++++-- 7 files changed, 107 insertions(+), 85 deletions(-) diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 7f67d7d9fea..9ea66aceb46 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -8,6 +10,7 @@ module Main where +import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (throwIO) import Control.Monad (void, when) import Control.Tracer (Tracer (..), nullTracer, traceWith) @@ -15,6 +18,7 @@ import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Act import Data.Aeson (ToJSON) import Data.Functor.Contravariant ((>$<)) +import Data.List.NonEmpty (NonEmpty) import Data.Maybe (maybeToList) import Data.Text qualified as Text import Data.Text.IO qualified as Text @@ -48,6 +52,7 @@ import DMQ.Diffusion.PeerSelection (policy) import DMQ.NodeToClient.LocalStateQueryClient import DMQ.Protocol.SigSubmission.Validate import Ouroboros.Network.Diffusion qualified as Diffusion +import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, encodeRemoteAddress) import Ouroboros.Network.SizeInBytes @@ -130,7 +135,8 @@ runDMQ commandLineConfig = do evolutionConfig psRng mkStakePoolMonitor $ \nodeKernel -> do - dmqDiffusionConfiguration <- mkDiffusionConfiguration dmqConfig nt + dmqDiffusionConfiguration <- + mkDiffusionConfiguration dmqConfig nt (nodeKernel.stakePools.ledgerBigPeersVar) let sigSize :: Sig StandardCrypto -> SizeInBytes sigSize _ = 0 -- TODO @@ -173,6 +179,12 @@ runDMQ commandLineConfig = do (if localHandshakeTracer then WithEventType "Handshake" >$< tracer else nullTracer) + $ maybe [] out <$> (tryReadTMVar $ nodeKernel.stakePools.ledgerPeersVar) + where + out :: LedgerPeerSnapshot AllLedgerPeers + -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)] + out (LedgerAllPeerSnapshotV23 _pt _magic relays) = relays + dmqDiffusionApplications = diffusionApplications nodeKernel dmqConfig diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index 33c1bd03773..4834ff0a27d 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -104,9 +104,7 @@ library containers >=0.5 && <0.8, contra-tracer >=0.1 && <0.3, deepseq >=1.0 && <1.6, - directory, dns >=1.0 && <4.3, - filepath, generic-data, hashable >=1.0 && <1.6, io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1, @@ -151,6 +149,7 @@ executable dmq-node cardano-ledger-core, contra-tracer >=0.1 && <0.3, dmq-node, + io-classes:{strict-stm}, kes-agent-crypto, optparse-applicative, ouroboros-network:{ouroboros-network, api, framework}, diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index 5e293dd2fd3..305cf94a585 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -32,7 +32,7 @@ module DMQ.Configuration , LocalAddress (..) ) where -import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI (DiffTime) import Data.Act @@ -49,11 +49,8 @@ import Data.Text (Text) import Data.Text qualified as Text import Generic.Data (gmappend, gmempty) import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) import Network.Socket (AddrInfo (..), AddrInfoFlag (..), PortNumber, SocketType (..), defaultHints, getAddrInfo) -import System.Directory qualified as Directory -import System.FilePath qualified as FilePath import System.IO.Error (isDoesNotExistError) import Text.Read (readMaybe) @@ -76,8 +73,7 @@ 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 (..), - readPeerSnapshotFileOrError) +import DMQ.Configuration.Topology (NoExtraConfig (..), NoExtraFlags (..)) -- | Configuration comes in two flavours paramemtrised by `f` functor: -- `PartialConfig` is using `Last` and `Configuration` is using an identity @@ -480,16 +476,15 @@ readConfigurationFileOrError nc = pure mkDiffusionConfiguration - :: HasCallStack - => Configuration + :: Configuration -> NetworkTopology NoExtraConfig NoExtraFlags + -> StrictTVar IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -> IO (Diffusion.Configuration NoExtraFlags IO ntnFd RemoteAddress ntcFd LocalAddress) mkDiffusionConfiguration Configuration { dmqcIPv4 = I ipv4 , dmqcIPv6 = I ipv6 , dmqcLocalAddress = I localAddress - , dmqcTopologyFile = I topologyFile , dmqcPortNumber = I portNumber , dmqcDiffusionMode = I diffusionMode , dmqcAcceptedConnectionsLimit = I acceptedConnectionsLimit @@ -506,8 +501,8 @@ mkDiffusionConfiguration } nt@NetworkTopology { useLedgerPeers - , peerSnapshotPath - } = do + } + ledgerBigPeersVar = do case (ipv4, ipv6) of (Nothing, Nothing) -> throwIO NoAddressInformation @@ -535,12 +530,6 @@ mkDiffusionConfiguration localRootsVar <- newTVarIO localRoots publicRootsVar <- newTVarIO publicRoots useLedgerVar <- newTVarIO useLedgerPeers - ledgerPeerSnapshotPathVar <- newTVarIO peerSnapshotPath - topologyDir <- FilePath.takeDirectory <$> Directory.makeAbsolute topologyFile - ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot - topologyDir - (readTVar ledgerPeerSnapshotPathVar) - (const . pure $ ()) return $ Diffusion.Configuration { @@ -562,7 +551,7 @@ mkDiffusionConfiguration } , Diffusion.dcReadLocalRootPeers = readTVar localRootsVar , Diffusion.dcReadPublicRootPeers = readTVar publicRootsVar - , Diffusion.dcReadLedgerPeerSnapshot = readTVar ledgerPeerSnapshotVar + , Diffusion.dcReadLedgerPeerSnapshot = readTVar ledgerBigPeersVar , Diffusion.dcPeerSharing = peerSharing , Diffusion.dcReadUseLedgerPeers = readTVar useLedgerVar , Diffusion.dcProtocolIdleTimeout = protocolIdleTimeout @@ -579,23 +568,6 @@ mkDiffusionConfiguration , addrSocketType = Stream } - updateLedgerPeerSnapshot :: HasCallStack - => FilePath - -> STM IO (Maybe FilePath) - -> (Maybe (LedgerPeerSnapshot BigLedgerPeers) -> STM IO ()) - -> IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) - updateLedgerPeerSnapshot topologyDir readLedgerPeerPath writeVar = do - mPeerSnapshotFile <- atomically readLedgerPeerPath - mLedgerPeerSnapshot <- case mPeerSnapshotFile of - Nothing -> pure Nothing - Just peerSnapshotFile | FilePath.isRelative peerSnapshotFile -> do - peerSnapshotFile' <- Directory.makeAbsolute $ topologyDir FilePath. peerSnapshotFile - Just <$> readPeerSnapshotFileOrError peerSnapshotFile' - Just peerSnapshotFile -> - Just <$> readPeerSnapshotFileOrError peerSnapshotFile - atomically . writeVar $ mLedgerPeerSnapshot - pure mLedgerPeerSnapshot - -- TODO: review this once we know what is the size of a `Sig`. -- TODO: parts of should be configurable diff --git a/dmq-node/src/DMQ/Configuration/Topology.hs b/dmq-node/src/DMQ/Configuration/Topology.hs index c5857ac0b00..845650afd8c 100644 --- a/dmq-node/src/DMQ/Configuration/Topology.hs +++ b/dmq-node/src/DMQ/Configuration/Topology.hs @@ -17,8 +17,6 @@ import Data.Text qualified as Text import Ouroboros.Network.Diffusion.Topology (NetworkTopology (..)) import Ouroboros.Network.OrphanInstances (localRootPeersGroupsFromJSON, networkTopologyFromJSON, networkTopologyToJSON) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, - LedgerPeersKind (..)) import System.Exit (die) data NoExtraConfig = NoExtraConfig @@ -70,29 +68,3 @@ readTopologyFileOrError nc = readTopologyFile nc >>= either (die . Text.unpack) pure - -readPeerSnapshotFile :: FilePath -> IO (Either Text (LedgerPeerSnapshot BigLedgerPeers)) -readPeerSnapshotFile psf = do - eBs <- try $ BS.readFile psf - case eBs of - Left e -> return . Left $ handler e - Right bs -> - let bs' = LBS.fromStrict bs in - case eitherDecode bs' of - Left err -> return $ Left (handlerJSON err) - Right t -> return $ Right t - where - handler :: IOException -> Text - handler e = Text.pack $ "DMQ.Topology.readLedgerPeerSnapshotFile: " - ++ displayException e - handlerJSON :: String -> Text - handlerJSON err = Text.unlines - [ "snapshot file parging error:" - , Text.pack err - ] - -readPeerSnapshotFileOrError :: FilePath -> IO (LedgerPeerSnapshot BigLedgerPeers) -readPeerSnapshotFileOrError psf = - readPeerSnapshotFile psf - >>= either (die . Text.unpack) - pure diff --git a/dmq-node/src/DMQ/Diffusion/Arguments.hs b/dmq-node/src/DMQ/Diffusion/Arguments.hs index 20c882c45b3..a00ea723a8b 100644 --- a/dmq-node/src/DMQ/Diffusion/Arguments.hs +++ b/dmq-node/src/DMQ/Diffusion/Arguments.hs @@ -22,6 +22,7 @@ import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadCatch) import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer) import Control.Tracer (Tracer) +import Data.List.NonEmpty (NonEmpty) import Network.DNS (Resolver) import Network.Socket (Socket) @@ -35,7 +36,7 @@ import Ouroboros.Network.PeerSelection.Churn (peerChurnGovernor) import Ouroboros.Network.PeerSelection.Governor.Types (ExtraGuardedDecisions (..), PeerSelectionGovernorArgs (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface (..)) + (LedgerPeersConsensusInterface (..), PoolStake, LedgerRelayAccessPoint) import Ouroboros.Network.PeerSelection.RelayAccessPoint (SRVPrefix) import Ouroboros.Network.PeerSelection.Types (nullPublicExtraPeersAPI) @@ -49,6 +50,7 @@ diffusionArguments ) => Tracer m (NtN.HandshakeTr ntnAddr) -> Tracer m (NtC.HandshakeTr ntcAddr) + -> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)] -> Diffusion.Arguments NoExtraState NoExtraDebugState NoExtraFlags NoExtraPeers NoExtraAPI NoExtraChurnArgs NoExtraCounters NoExtraTracer @@ -63,7 +65,8 @@ diffusionArguments NodeToClientVersion NodeToClientVersionData diffusionArguments handshakeNtNTracer - handshakeNtCTracer = + handshakeNtCTracer + lpGetLedgerPeers = Diffusion.Arguments { Diffusion.daNtnDataFlow = DMQ.ntnDataFlow , Diffusion.daNtnPeerSharing = peerSharing @@ -74,7 +77,7 @@ diffusionArguments handshakeNtNTracer , Diffusion.daLedgerPeersCtx = LedgerPeersConsensusInterface { lpGetLatestSlot = return minBound - , lpGetLedgerPeers = return [] + , lpGetLedgerPeers , lpExtraAPI = NoExtraAPI } , Diffusion.daEmptyExtraState = NoExtraState diff --git a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs index 8567ec211c1..ed5be24b269 100644 --- a/dmq-node/src/DMQ/Diffusion/NodeKernel.hs +++ b/dmq-node/src/DMQ/Diffusion/NodeKernel.hs @@ -29,6 +29,7 @@ import Data.Set qualified as Set import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX qualified as Time import Data.Void (Void) +import Data.Word import System.Random (StdGen) import System.Random qualified as Random @@ -42,6 +43,8 @@ import Ouroboros.Network.BlockFetch (FetchClientRegistry, import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.PeerSelection.Governor.Types (makePublicPeerSelectionStateVar) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, + LedgerPeersKind (..)) import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry, newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) @@ -65,7 +68,7 @@ data NodeKernel crypto ntnAddr m = , peerSharingRegistry :: !(PeerSharingRegistry ntnAddr m) , peerSharingAPI :: !(PeerSharingAPI ntnAddr StdGen m) , mempool :: !(Mempool m SigId (Sig crypto)) - , evolutionConfig :: !(KES.EvolutionConfig) + , evolutionConfig :: !KES.EvolutionConfig , sigChannelVar :: !(TxChannelsVar m ntnAddr SigId (Sig crypto)) , sigMempoolSem :: !(TxMempoolSem m) , sigSharedTxStateVar :: !(SharedTxStateVar m ntnAddr SigId (Sig crypto)) @@ -80,15 +83,27 @@ type PoolId = KeyHash StakePool data StakePools m = StakePools { -- | contains map of cardano pool stake snapshot obtained -- via local state query client - stakePoolsVar :: StrictTVar m (Map PoolId StakeSnapshot) + stakePoolsVar :: !(StrictTVar m (Map PoolId StakeSnapshot)) -- | acquires validation context for signature validation - , poolValidationCtx :: m PoolValidationCtx + , poolValidationCtx :: !(m (PoolValidationCtx m)) + -- | provides only those big peers which provide SRV endpoints + -- as otherwise those are cardano-nodes + , ledgerBigPeersVar + :: !(StrictTVar m (Maybe (LedgerPeerSnapshot BigLedgerPeers))) + -- | all ledger peers, restricted to srv endpoints + , ledgerPeersVar + :: !(StrictTMVar m (LedgerPeerSnapshot AllLedgerPeers)) } -data PoolValidationCtx = - DMQPoolValidationCtx !UTCTime -- ^ time of context acquisition - !(Maybe UTCTime) -- ^ UTC time of next epoch boundary - !(Map PoolId StakeSnapshot) -- ^ for signature validation +data PoolValidationCtx m = + DMQPoolValidationCtx !UTCTime + -- ^ time of context acquisition + !(Maybe UTCTime) + -- ^ UTC time of next epoch boundary for handling clock skey + !(Map PoolId StakeSnapshot) + -- ^ for signature validation + !(StrictTVar m (Map PoolId Word64)) + -- ^ ocert counter to validate only monotonically increasing values newNodeKernel :: ( MonadLabelledSTM m , MonadMVar m @@ -109,15 +124,20 @@ newNodeKernel evolutionConfig rng = do sigMempoolSem <- newTxMempoolSem let (rng', rng'') = Random.split rng sigSharedTxStateVar <- newSharedTxStateVar rng' - nextEpochVar <- newTVarIO Nothing - stakePoolsVar <- newTVarIO Map.empty + (nextEpochVar, ocertCountersVar, stakePoolsVar, ledgerBigPeersVar, ledgerPeersVar) <- atomically $ + (,,,,) <$> newTVar Nothing + <*> newTVar Map.empty + <*> newTVar Map.empty + <*> newTVar Nothing + <*> newEmptyTMVar let poolValidationCtx = do (nextEpochBoundary, stakePools') <- - atomically $ (,) <$> readTVar nextEpochVar <*> readTVar stakePoolsVar + atomically $ + (,) <$> readTVar nextEpochVar <*> readTVar stakePoolsVar now <- getCurrentTime - return $ DMQPoolValidationCtx now nextEpochBoundary stakePools' + return $ DMQPoolValidationCtx now nextEpochBoundary stakePools' ocertCountersVar - stakePools = StakePools { stakePoolsVar, poolValidationCtx } + stakePools = StakePools { stakePoolsVar, poolValidationCtx, ledgerBigPeersVar, ledgerPeersVar } peerSharingAPI <- newPeerSharingAPI diff --git a/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs index e58088e0c62..1cf09c747db 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalStateQueryClient.hs @@ -7,18 +7,22 @@ module DMQ.NodeToClient.LocalStateQueryClient ) where import Control.Concurrent.Class.MonadSTM.Strict +import Control.DeepSeq import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.Trans.Except import Control.Tracer (Tracer (..), nullTracer) +import Data.Functor ((<&>)) import Data.Functor.Contravariant ((>$<)) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Proxy import Data.Void import Cardano.Chain.Genesis import Cardano.Chain.Slotting +import Cardano.Crypto.Hash qualified as Crypto import Cardano.Crypto.ProtocolMagic import Cardano.Network.NodeToClient import Cardano.Slotting.EpochInfo.API @@ -38,6 +42,9 @@ import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Network.Block import Ouroboros.Network.Magic import Ouroboros.Network.Mux qualified as Mx +import Ouroboros.Network.PeerSelection.LedgerPeers.Type +import Ouroboros.Network.PeerSelection.LedgerPeers.Utils +import Ouroboros.Network.Point import Ouroboros.Network.Protocol.LocalStateQuery.Client import Ouroboros.Network.Protocol.LocalStateQuery.Type @@ -52,7 +59,8 @@ cardanoClient -> StakePools m -> StrictTVar m (Maybe UTCTime) -- ^ from node kernel -> LocalStateQueryClient (CardanoBlock crypto) (Point block) (Query block) m Void -cardanoClient _tracer StakePools { stakePoolsVar } nextEpochVar = LocalStateQueryClient (idle Nothing) +cardanoClient _tracer StakePools { stakePoolsVar, ledgerPeersVar, ledgerBigPeersVar } nextEpochVar = + LocalStateQueryClient (idle Nothing) where idle mSystemStart = pure $ SendMsgAcquire ImmutableTip acquire where @@ -103,9 +111,45 @@ cardanoClient _tracer StakePools { stakePoolsVar } nextEpochVar = LocalStateQuer atomically do writeTVar stakePoolsVar ssStakeSnapshots writeTVar nextEpochVar $ Just nextEpoch - pure $ SendMsgRelease do - threadDelay $ min (realToFrac toNextEpoch) 86400 -- TODO fuzz this? - idle $ Just systemStart + pure $ + SendMsgQuery (BlockQuery . QueryIfCurrentConway $ GetLedgerPeerSnapshot AllLedgerPeers) + $ wrappingMismatch handleLedgerPeers + where + handleLedgerPeers (SomeLedgerPeerSnapshot (LedgerAllPeerSnapshotV23 pt magic peers)) = do + let bigSrvRelays = force + [(accStake, (stake, NonEmpty.fromList relays')) + | (accStake, (stake, relays)) <- accumulateBigLedgerStake peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> True + _ -> False + ) + relays + , not (null relays') + ] + pt' = Point $ getPoint pt <&> + \blk -> blk { blockPointSlot = maxBound, + blockPointHash = Crypto.castHash (blockPointHash blk)} + srvRelays = force + [ (stake, NonEmpty.fromList relays') + | (stake, relays) <- peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> True + _ -> False + ) + relays + , not (null relays') + ] + atomically do + writeTMVar ledgerPeersVar $ LedgerAllPeerSnapshotV23 pt magic srvRelays + writeTVar ledgerBigPeersVar . Just $! LedgerBigPeerSnapshotV23 pt' magic bigSrvRelays + pure $ SendMsgRelease do + threadDelay $ min (realToFrac toNextEpoch) 86400 -- TODO fuzz this? + idle $ Just systemStart + + handleLedgerPeers _ = error "handleLedgerPeers: impossible!" + connectToCardanoNode :: Tracer IO (WithEventType String) -> LocalSnocket From 0c49fd279e302ac4468d98807fc0eb776286b9d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 16 Oct 2025 10:14:26 +0200 Subject: [PATCH 25/29] Validate ocert counter, change encoding of validation failures --- dmq-node/src/DMQ/NodeToClient.hs | 7 +- .../DMQ/NodeToClient/LocalMsgSubmission.hs | 85 +++++---- dmq-node/src/DMQ/NodeToNode.hs | 8 +- .../DMQ/Protocol/LocalMsgSubmission/Codec.hs | 50 +++++- .../DMQ/Protocol/SigSubmission/Validate.hs | 164 +++++++++--------- .../Network/TxSubmission/Mempool/Simple.hs | 78 ++++----- 6 files changed, 225 insertions(+), 167 deletions(-) diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index eeffeeb1311..5a129c33388 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -16,6 +16,7 @@ module DMQ.NodeToClient import Data.Aeson qualified as Aeson import Data.ByteString.Lazy (ByteString) import Data.Functor.Contravariant ((>$<)) +import Data.Typeable import Data.Void import Data.Word @@ -132,20 +133,22 @@ data Apps ntcAddr m a = -- | Construct applications for the node-to-client protocols -- ntcApps - :: forall crypto idx ntcAddr failure m. + :: forall crypto idx ntcAddr m. ( MonadThrow m , MonadThread m , MonadSTM m , Crypto crypto , Aeson.ToJSON ntcAddr , Aeson.ToJSON (MempoolAddFail (Sig crypto)) + , Show (MempoolAddFail (Sig crypto)) , ShowProxy (MempoolAddFail (Sig crypto)) , ShowProxy (Sig crypto) + , Typeable crypto ) => (forall ev. Aeson.ToJSON ev => Tracer m (WithEventType ev)) -> Configuration -> TxSubmissionMempoolReader SigId (Sig crypto) idx m - -> MempoolWriter SigId (Sig crypto) failure idx m + -> MempoolWriter SigId (Sig crypto) idx m -> Word16 -> Codecs crypto m -> Apps ntcAddr m () diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs index 40d7a3896d0..36a7eb418df 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module DMQ.NodeToClient.LocalMsgSubmission where import Control.Concurrent.Class.MonadSTM +import Control.Monad.Class.MonadThrow import Control.Tracer import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson qualified as Aeson +import Data.Typeable import DMQ.Protocol.LocalMsgSubmission.Server import DMQ.Protocol.LocalMsgSubmission.Type @@ -16,55 +20,78 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Local transaction submission server, for adding txs to the 'Mempool' -- localMsgSubmissionServer :: - MonadSTM m - => (sig -> sigid) + forall msgid msg idx m. + ( MonadSTM m + , MonadThrow m + , Typeable msgid + , Typeable msg + , Show msgid + , Show (MempoolAddFail msg)) + => (msg -> msgid) -- ^ get message id - -> Tracer m (TraceLocalMsgSubmission sig sigid) - -> MempoolWriter sigid sig failure idx m + -> Tracer m (TraceLocalMsgSubmission msg msgid) + -> MempoolWriter msgid msg idx m -- ^ duplicate error tag in case the mempool returns the empty list on failure - -> m (LocalMsgSubmissionServer sig m ()) + -> m (LocalMsgSubmissionServer msg m ()) localMsgSubmissionServer getMsgId tracer MempoolWriter { mempoolAddTxs } = pure server where - process (sigid, e@(SubmitFail reason)) = - (e, server) <$ traceWith tracer (TraceSubmitFailure sigid reason) - process (sigid, success) = - (success, server) <$ traceWith tracer (TraceSubmitAccept sigid) + process (Left (msgid, reason)) = do + traceWith tracer (TraceSubmitFailure msgid reason) + throwIO $ MsgValidationException msgid reason + process (Right [(msgid, e@(SubmitFail reason))]) = + (e, server) <$ traceWith tracer (TraceSubmitFailure msgid reason) + process (Right [(msgid, SubmitSuccess)]) = + (SubmitSuccess, server) <$ traceWith tracer (TraceSubmitAccept msgid) + process _ = throwIO (TooManyMessages @msgid @msg) server = LocalTxSubmissionServer { - recvMsgSubmitTx = \sig -> do - traceWith tracer $ TraceReceivedMsg (getMsgId sig) - process . head =<< mempoolAddTxs [sig] + recvMsgSubmitTx = \msg -> do + traceWith tracer $ TraceReceivedMsg (getMsgId msg) + process =<< mempoolAddTxs [msg] , recvMsgDone = () } -data TraceLocalMsgSubmission sig sigid = - TraceReceivedMsg sigid +data TraceLocalMsgSubmission msg msgid = + TraceReceivedMsg msgid -- ^ A signature was received. - | TraceSubmitFailure sigid (MempoolAddFail sig) - | TraceSubmitAccept sigid + | TraceSubmitFailure msgid (MempoolAddFail msg) + | TraceSubmitAccept msgid deriving instance - (Show sig, Show sigid, Show (MempoolAddFail sig)) - => Show (TraceLocalMsgSubmission sig sigid) + (Show msg, Show msgid, Show (MempoolAddFail msg)) + => Show (TraceLocalMsgSubmission msg msgid) -instance (ToJSON sigid, ToJSON (MempoolAddFail sig)) - => ToJSON (TraceLocalMsgSubmission sig sigid) where - toJSON (TraceReceivedMsg sigid) = + + +data MsgSubmissionServerException msgid msg = + MsgValidationException msgid (MempoolAddFail msg) + | TooManyMessages + +deriving instance (Show (MempoolAddFail msg), Show msgid) + => Show (MsgSubmissionServerException msgid msg) + +instance (Typeable msgid, Typeable msg, Show (MempoolAddFail msg), Show msgid) + => Exception (MsgSubmissionServerException msgid msg) where + + +instance (ToJSON msgid, ToJSON (MempoolAddFail msg)) + => ToJSON (TraceLocalMsgSubmission msg msgid) where + toJSON (TraceReceivedMsg msgid) = -- TODO: once we have verbosity levels, we could include the full tx, for -- now one can use `TraceSendRecv` tracer for the mini-protocol to see full -- msgs. object [ "kind" .= Aeson.String "TraceReceivedMsg" - , "sigId" .= sigid + , "sigId" .= msgid ] - toJSON (TraceSubmitFailure sigid reject) = + toJSON (TraceSubmitFailure msgid reject) = object [ "kind" .= Aeson.String "TraceSubmitFailure" - , "sigId" .= sigid + , "sigId" .= msgid , "reason" .= reject ] - toJSON (TraceSubmitAccept sigid) = + toJSON (TraceSubmitAccept msgid) = object [ "kind" .= Aeson.String "TraceSubmitAccept" - , "sigId" .= sigid + , "sigId" .= msgid ] diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index 982e5255027..da2c7beda9e 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -41,7 +41,6 @@ import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR import Data.Aeson qualified as Aeson -import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.Functor.Contravariant ((>$<)) import Data.Hashable (Hashable) @@ -54,10 +53,7 @@ import Network.Mux.Types (Mode (..)) import Network.Mux.Types qualified as Mx import Network.TypedProtocol.Codec (AnnotatedCodec, Codec) -import Cardano.Crypto.DSIGN.Class qualified as DSIGN -import Cardano.Crypto.KES.Class qualified as KES import Cardano.KESAgent.KES.Crypto (Crypto (..)) -import Cardano.KESAgent.KES.OCert (OCertSignable) import DMQ.Configuration (Configuration, Configuration' (..), I (..)) import DMQ.Diffusion.NodeKernel (NodeKernel (..)) @@ -202,8 +198,8 @@ ntnApps fetchClientRegistry , peerSharingRegistry , peerSharingAPI - , mempool - , evolutionConfig + -- , mempool + -- , evolutionConfig , sigChannelVar , sigMempoolSem , sigSharedTxStateVar diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs index 51724951915..bbb869dd785 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs @@ -10,8 +10,11 @@ import Codec.CBOR.Encoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR import Control.Monad.Class.MonadST import Data.ByteString.Lazy (ByteString) +import Data.Text qualified as T +import Data.Tuple (swap) import Text.Printf +import Cardano.Binary import Cardano.KESAgent.KES.Crypto (Crypto (..)) import DMQ.Protocol.LocalMsgSubmission.Type @@ -35,18 +38,53 @@ codecLocalMsgSubmission = encodeReject :: MempoolAddFail (Sig crypto) -> CBOR.Encoding encodeReject = \case - SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> CBOR.encodeString reason - SigDuplicate -> CBOR.encodeListLen 1 <> CBOR.encodeWord 1 - SigExpired -> CBOR.encodeListLen 1 <> CBOR.encodeWord 2 + SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 0 <> e + where + e = case reason of + InvalidKESSignature ocertKESPeriod sigKESPeriod err -> mconcat [ + CBOR.encodeListLen 4, CBOR.encodeWord8 0, toCBOR ocertKESPeriod, toCBOR sigKESPeriod, CBOR.encodeString (T.pack err) + ] + InvalidSignatureOCERT ocertN sigKESPeriod err -> mconcat [ + CBOR.encodeListLen 4, CBOR.encodeWord8 1, CBOR.encodeWord64 ocertN, toCBOR sigKESPeriod, CBOR.encodeString (T.pack err) + ] + KESBeforeStartOCERT startKESPeriod sigKESPeriod -> mconcat [ + CBOR.encodeListLen 3, CBOR.encodeWord8 2, toCBOR startKESPeriod, toCBOR sigKESPeriod + ] + KESAfterEndOCERT endKESPeriod sigKESPeriod -> mconcat [ + CBOR.encodeListLen 3, CBOR.encodeWord8 3, toCBOR endKESPeriod, toCBOR sigKESPeriod + ] + UnrecognizedPool -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 4 + NotInitialized -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 5 + ClockSkew -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 6 + InvalidOCertCounter seen received + -> mconcat + [CBOR.encodeListLen 3, CBOR.encodeWord8 7, CBOR.encodeWord64 seen, CBOR.encodeWord64 received] + SigDuplicate -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 1 + SigExpired -> CBOR.encodeListLen 1 <> CBOR.encodeWord8 2 SigResultOther reason - -> CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> CBOR.encodeString reason + -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 3 <> CBOR.encodeString reason decodeReject :: CBOR.Decoder s (MempoolAddFail (Sig crypto)) decodeReject = do len <- CBOR.decodeListLen - tag <- CBOR.decodeWord + tag <- CBOR.decodeWord8 case (tag, len) of - (0, 2) -> SigInvalid <$> CBOR.decodeString + (0, 2) -> SigInvalid <$> decSigValidError + where + decSigValidError :: CBOR.Decoder s SigValidationError + decSigValidError = do + lenTag <- (,) <$> CBOR.decodeListLen <*> CBOR.decodeWord8 + case swap lenTag of + (0, 4) -> InvalidKESSignature <$> fromCBOR <*> fromCBOR <*> (T.unpack <$> CBOR.decodeString) + (1, 4) -> InvalidSignatureOCERT <$> CBOR.decodeWord64 <*> fromCBOR <*> (T.unpack <$> CBOR.decodeString) + (2, 3) -> KESBeforeStartOCERT <$> fromCBOR <*> fromCBOR + (3, 4) -> KESAfterEndOCERT <$> fromCBOR <*> fromCBOR + (4, 1) -> pure UnrecognizedPool + (5, 1) -> pure NotInitialized + (6, 1) -> pure ClockSkew + (7, 3) -> InvalidOCertCounter <$> fromCBOR <*> fromCBOR + _otherwise -> fail $ printf "unrecognized (tag,len) = (%d, %d) when decoding SigInvalid tag" tag len + (1, 1) -> pure SigDuplicate (2, 1) -> pure SigExpired (3, 2) -> SigResultOther <$> CBOR.decodeString diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs index 7707d39ba9e..87eb2fbd2a5 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -9,8 +11,10 @@ -- module DMQ.Protocol.SigSubmission.Validate where -import Control.Exception +import Control.Monad +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadTime.SI +import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Except.Extra import Data.Aeson @@ -22,12 +26,12 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Typeable import Data.Word -import Text.Printf import Cardano.Crypto.DSIGN.Class (ContextDSIGN) import Cardano.Crypto.DSIGN.Class qualified as DSIGN import Cardano.Crypto.KES.Class (KESAlgorithm (..)) import Cardano.KESAgent.KES.Crypto as KES +import Cardano.KESAgent.KES.Evolution as KES import Cardano.KESAgent.KES.OCert (OCert (..), OCertSignable, validateOCert) import Cardano.Ledger.BaseTypes.NonZero import Cardano.Ledger.Hashes @@ -43,7 +47,7 @@ import Ouroboros.Network.Util.ShowProxy -- for invalid messages -- data instance MempoolAddFail (Sig crypto) = - SigInvalid Text + SigInvalid SigValidationError | SigDuplicate | SigExpired | SigResultOther Text @@ -54,28 +58,15 @@ instance (Typeable crypto) => ShowProxy (MempoolAddFail (Sig crypto)) instance ToJSON (MempoolAddFail (Sig crypto)) where toJSON SigDuplicate = String "duplicate" toJSON SigExpired = String "expired" - toJSON (SigInvalid txt) = object + toJSON (SigInvalid e) = object [ "type" .= String "invalid" - , "reason" .= txt + , "reason" .= show e ] toJSON (SigResultOther txt) = object [ "type" .= String "other" , "reason" .= txt ] --- | The type of exception raised by the mempool writer for invalid messages --- as determined by the validation procedure and policy --- -newtype instance InvalidTxsError SigValidationError = InvalidTxsError SigValidationError - -deriving instance Show (InvalidTxsError SigValidationError) -instance Exception (InvalidTxsError SigValidationError) - --- | The policy which is realized by the mempool writer when encountering --- an invalid message. --- -data ValidationPolicy = - FailDefault | FailSoft data SigValidationError = InvalidKESSignature KESPeriod KESPeriod String @@ -83,100 +74,111 @@ data SigValidationError = !Word64 -- OCert counter !KESPeriod -- OCert KES period !String -- DSIGN error message + | InvalidOCertCounter + Word64 -- last seen + Word64 -- received | KESBeforeStartOCERT KESPeriod KESPeriod | KESAfterEndOCERT KESPeriod KESPeriod | UnrecognizedPool - | ExpiredPool | NotInitialized | ClockSkew - deriving Show - --- TODO fine tune policy -sigValidationPolicy - :: SigValidationError - -> Either (MempoolAddFail (Sig crypto)) (MempoolAddFail (Sig crypto)) -sigValidationPolicy sve = case sve of - InvalidKESSignature {} -> Left . SigInvalid . Text.pack . show $ sve - InvalidSignatureOCERT {} -> Left . SigInvalid . Text.pack . show $ sve - KESAfterEndOCERT {} -> Left SigExpired - KESBeforeStartOCERT start sig -> - Left . SigResultOther . Text.pack - $ printf "KESBeforeStartOCERT %s %s" (show start) (show sig) - UnrecognizedPool -> Left . SigInvalid $ Text.pack "unrecognized pool id" - ClockSkew -> Left . SigInvalid $ Text.pack "clock skew out of range" - ExpiredPool -> Left . SigInvalid $ Text.pack "expired pool" - NotInitialized -> Right . SigResultOther $ Text.pack "not initialized yet" + deriving (Eq, Show) + -- TODO: -- We don't validate ocert numbers, since we might not have necessary -- information to do so, but we can validate that they are growing. -validateSig :: forall crypto. +validateSig :: forall crypto m. ( Crypto crypto , ContextDSIGN (KES.DSIGN crypto) ~ () , DSIGN.Signable (DSIGN crypto) (OCertSignable crypto) , ContextKES (KES crypto) ~ () , Signable (KES crypto) ByteString + , MonadSTM m ) - => ValidationPolicy + => KES.EvolutionConfig -> (DSIGN.VerKeyDSIGN (DSIGN crypto) -> KeyHash StakePool) -> [Sig crypto] - -> PoolValidationCtx + -> PoolValidationCtx m -- ^ cardano pool id verification - -> Except (InvalidTxsError SigValidationError) [Either (MempoolAddFail (Sig crypto)) ()] -validateSig policy verKeyHashingFn sigs ctx = firstExceptT InvalidTxsError $ traverse process sigs + -> ExceptT (Sig crypto, MempoolAddFail (Sig crypto)) m + [(Sig crypto, Either (MempoolAddFail (Sig crypto)) ())] +validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs where - DMQPoolValidationCtx now mNextEpoch pools = ctx + DMQPoolValidationCtx now mNextEpoch pools ocertCountersVar = ctx + + process' sig = bimapExceptT (sig,) (sig,) $ process sig process Sig { sigSignedBytes = signedBytes, sigKESPeriod, sigOpCertificate = SigOpCertificate ocert@OCert { - ocertKESPeriod, - ocertVkHot, - ocertN - }, + ocertKESPeriod, + ocertVkHot, + ocertN + }, sigColdKey = SigColdKey coldKey, sigKESSignature = SigKESSignature kesSig } = do - e1 <- sigKESPeriod < endKESPeriod + sigKESPeriod < endKESPeriod ?! KESAfterEndOCERT endKESPeriod sigKESPeriod - e2 <- sigKESPeriod >= startKESPeriod + sigKESPeriod >= startKESPeriod ?! KESBeforeStartOCERT startKESPeriod sigKESPeriod - e3 <- case Map.lookup (verKeyHashingFn coldKey) pools of - Nothing | isNothing mNextEpoch -> classifyError NotInitialized - | otherwise -> classifyError UnrecognizedPool + e <- case Map.lookup (verKeyHashingFn coldKey) pools of + Nothing | isNothing mNextEpoch + -> invalid SigResultOther $ Text.pack "not initialized yet" + | otherwise + -> left $ SigInvalid UnrecognizedPool -- TODO make 5 a constant - Just ss | not (isZero (ssSetPool ss)) - -- we bound the time we're willing to approve a message - -- in case smth happened to localstatequery and it's taking - -- too long to update our state - , now <= addUTCTime 5 nextEpoch -> right $ Right () - | not (isZero (ssMarkPool ss)) - -- we take abs time in case we're late with our own - -- localstatequery update, and/or the other side's clock - -- is ahead, and we're just about or have just crossed the epoch - -- and the pool is expected to move into the set mark - , abs (diffUTCTime nextEpoch now) <= 5 -> right $ Right () - -- pool is deregistered and ineligible to mint blocks - | isZero (ssMarkPool ss) && isZero (ssSetPool ss) -> - classifyError ExpiredPool - | otherwise -> classifyError ClockSkew + Just ss | not (isZero (ssSetPool ss)) -> + if | now < nextEpoch -> success + -- localstatequery is late, but the pool is about to expire + | isZero (ssMarkPool ss) + , now > addUTCTime 5 nextEpoch -> left SigExpired + -- we bound the time we're willing to approve a message + -- in case smth happened to localstatequery and it's taking + -- too long to update our state + | now <= addUTCTime 5 nextEpoch -> success + | otherwise -> left $ SigInvalid ClockSkew + | not (isZero (ssMarkPool ss)) -> + -- we take abs time in case we're late with our own + -- localstatequery update, and/or the other side's clock + -- is ahead, and we're just about or have just crossed the epoch + -- and the pool is expected to move into the set mark + if | abs (diffUTCTime nextEpoch now) <= 5 -> success + | diffUTCTime nextEpoch now > 5 -> + left . SigResultOther $ Text.pack "pool not eligible yet" + | otherwise -> right . Left $ SigInvalid ClockSkew + -- pool is deregistered and ineligible to mint blocks + | isZero (ssSetPool ss) -> + left SigExpired + | otherwise -> error "validateSig: impossible pool validation error" where -- mNextEpoch and pools are initialized in one STM transaction -- and fromJust will not fail here nextEpoch = fromJust mNextEpoch - -- validate OCert, which includes verifying its signature - e4 <- validateOCert coldKey ocertVkHot ocert + validateOCert coldKey ocertVkHot ocert ?!: InvalidSignatureOCERT ocertN sigKESPeriod -- validate KES signature of the payload - e5 <- verifyKES () ocertVkHot - (unKESPeriod sigKESPeriod - unKESPeriod startKESPeriod) - (LBS.toStrict signedBytes) - kesSig + verifyKES () ocertVkHot + (unKESPeriod sigKESPeriod - unKESPeriod startKESPeriod) + (LBS.toStrict signedBytes) + kesSig ?!: InvalidKESSignature ocertKESPeriod sigKESPeriod + join . lift . atomically $ stateTVar ocertCountersVar \ocertCounters -> + let f = \case + Nothing -> Right $ Just ocertN + Just n | n <= ocertN -> Right $ Just ocertN + | otherwise -> Left . throwE . SigInvalid $ InvalidOCertCounter n ocertN + in case Map.alterF f (verKeyHashingFn coldKey) ocertCounters of + Right ocertCounters' -> (void success, ocertCounters') + Left err -> (err, ocertCounters) -- for eg. remember to run all results with possibly non-fatal errors - right $ e1 >> e2 >> e3 >> e4 >> e5 + right e where + success = right $ Right () + invalid tag = right . Left . tag + startKESPeriod, endKESPeriod :: KESPeriod startKESPeriod = ocertKESPeriod @@ -185,23 +187,15 @@ validateSig policy verKeyHashingFn sigs ctx = firstExceptT InvalidTxsError $ tra endKESPeriod = KESPeriod $ unKESPeriod startKESPeriod + totalPeriodsKES (Proxy :: Proxy (KES crypto)) - classifyError sigValidationError = case policy of - FailSoft -> - let mempoolAddFail = either id id (sigValidationPolicy sigValidationError) - in right . Left $ mempoolAddFail - FailDefault -> - either (const $ throwE sigValidationError) (right . Left) - (sigValidationPolicy sigValidationError) - (?!:) :: Either e1 () -> (e1 -> SigValidationError) - -> Except SigValidationError (Either (MempoolAddFail (Sig crypto)) ()) - (?!:) = (handleE classifyError .) . flip firstExceptT . hoistEither . fmap Right + -> ExceptT (MempoolAddFail (Sig crypto)) m () + (?!:) result f = firstExceptT (SigInvalid . f) . hoistEither $ result (?!) :: Bool -> SigValidationError - -> Except SigValidationError (Either (MempoolAddFail (Sig crypto)) ()) - (?!) flag sve = if flag then right $ Right () else classifyError sve + -> ExceptT (MempoolAddFail (Sig crypto)) m () + (?!) flag sve = if flag then void success else left (SigInvalid sve) infix 1 ?! infix 1 ?!: diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs index f627ca7c989..3e2e871582d 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -12,8 +13,7 @@ -- | The module should be imported qualified. -- module Ouroboros.Network.TxSubmission.Mempool.Simple - ( InvalidTxsError - , MempoolAddFail + ( MempoolAddFail , Mempool (..) , MempoolSeq (..) , MempoolWriter (..) @@ -30,9 +30,8 @@ import Prelude hiding (read, seq) import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq import Control.Exception (assert) -import Control.Monad.Class.MonadThrow import Control.Monad.Trans.Except -import Data.Bifunctor (bimap) +import Data.Bifunctor (bimap, first, second) import Data.Either import Data.Foldable (toList) import Data.Foldable qualified as Foldable @@ -114,9 +113,6 @@ getReader getTxId getTxSize (Mempool mempool) = f :: Int -> tx -> (txid, Int, SizeInBytes) f idx tx = (getTxId tx, idx, getTxSize tx) --- | type of mempool validation errors which are thrown as exceptions --- -data family InvalidTxsError failure -- | type of mempool validation errors which are non-fatal -- @@ -125,7 +121,7 @@ data family MempoolAddFail tx -- | A mempool writer which generalizes the tx submission mempool writer -- TODO: We could replace TxSubmissionMempoolWriter with this at some point -- -data MempoolWriter txid tx failure idx m = +data MempoolWriter txid tx idx m = MempoolWriter { -- | Compute the transaction id from a transaction. @@ -140,17 +136,17 @@ data MempoolWriter txid tx failure idx m = -- -- The 'txid's of all transactions that were added successfully are -- returned. - mempoolAddTxs :: [tx] -> m [(txid, SubmitResult (MempoolAddFail tx))] + mempoolAddTxs + :: [tx] + -> m (Either (txid, MempoolAddFail tx) [(txid, SubmitResult (MempoolAddFail tx))]) } -- | A mempool writer with validation harness -- PRECONDITION: no duplicates given to mempoolAddTxs -- -getWriter :: forall tx txid ctx failure m. +getWriter :: forall tx txid ctx m. ( MonadSTM m - , Exception (InvalidTxsError failure) - , MonadThrow m -- TODO: -- , NFData txid -- , NFData tx @@ -161,40 +157,44 @@ getWriter :: forall tx txid ctx failure m. -- ^ get txid of a tx -> m ctx -- ^ acquire validation context - -> ([tx] -> ctx -> Except (InvalidTxsError failure) [(Either (MempoolAddFail tx) ())]) + -> ( [tx] + -> ctx + -> ExceptT (tx, MempoolAddFail tx) m + [(tx, Either (MempoolAddFail tx) ())]) -- ^ validation function which should evaluate its result to normal form -- esp. if it is 'expensive' -> MempoolAddFail tx -- ^ replace duplicates -> Mempool m txid tx - -> MempoolWriter txid tx failure Int m + -> MempoolWriter txid tx Int m getWriter getTxId acquireCtx validateTxs duplicateFail (Mempool mempool) = MempoolWriter { txId = getTxId, mempoolAddTxs = \txs -> assert (not . null $ txs) $ do - ctx <- acquireCtx - !vTxs <- case runExcept (validateTxs txs ctx) of - Left e -> throwIO e - Right r -> pure {-. force-} $ zipWith3 ((,,) . getTxId) txs txs r - - atomically $ do - MempoolSeq { mempoolSet, mempoolSeq } <- readTVar mempool - let result = - [if duplicate then - Left . (txid,) $ SubmitFail duplicateFail - else - bimap ((txid,) . SubmitFail) (const (txid, tx)) eErrTx - | (txid, tx, eErrTx) <- vTxs - , let duplicate = txid `Set.member` mempoolSet - ] - (validIds, validTxs) = unzip . rights $ result - mempoolTxs' = MempoolSeq { - mempoolSet = Set.union mempoolSet (Set.fromList validIds), - mempoolSeq = Foldable.foldl' (Seq.|>) mempoolSeq validTxs - } - writeTVar mempool mempoolTxs' - return $ either id ((,SubmitSuccess) . fst) <$> result + ctx <- acquireCtx + first (first getTxId) + <$> runExceptT do + -- todo probably should force the results before entering the atomically block + !vTxs <- zipWith ((,) . getTxId) txs <$> validateTxs txs ctx + + ExceptT . atomically $ do + MempoolSeq { mempoolSet, mempoolSeq } <- readTVar mempool + let result = + [if duplicate then + Left (txid, duplicateFail) + else + bimap ((txid,)) (const (txid, tx)) eResult + | (txid, (tx, eResult)) <- vTxs + , let duplicate = txid `Set.member` mempoolSet + ] + (validIds, validTxs) = unzip . rights $ result + mempoolTxs' = MempoolSeq { + mempoolSet = Set.union mempoolSet (Set.fromList validIds), + mempoolSeq = Foldable.foldl' (Seq.|>) mempoolSeq validTxs + } + writeTVar mempool mempoolTxs' + return . Right $ either (second SubmitFail) (second (const SubmitSuccess)) <$> result } @@ -203,9 +203,9 @@ getWriter getTxId acquireCtx validateTxs duplicateFail (Mempool mempool) = -- to avoid more breaking changes for now. -- writerAdapter :: (Functor m) - => MempoolWriter txid tx failure idx m + => MempoolWriter txid tx idx m -> TxSubmissionMempoolWriter txid tx idx m -writerAdapter MempoolWriter { txId, mempoolAddTxs } = +writerAdapter MempoolWriter { txId, mempoolAddTxs } = undefined TxSubmissionMempoolWriter { txId, mempoolAddTxs = adapter } where - adapter = fmap (fmap fst) . mempoolAddTxs + adapter = fmap (either (const []) (fmap fst)) . mempoolAddTxs From 289411c44a65b7c9a8dff37d30a243e2a643aaa4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 27 Oct 2025 12:35:07 +0100 Subject: [PATCH 26/29] tx-sub tests: integrate getMempoolWriter --- .../Ouroboros/Network/TxSubmission/Types.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs index ca765c2aa56..7d819780cce 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Test.Ouroboros.Network.TxSubmission.Types ( Tx (..) @@ -42,6 +43,7 @@ import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim hiding (SimResult) +import Control.Monad.Trans.Except.Extra import Control.Tracer (Tracer (..), showTracing, traceWith) import Codec.CBOR.Decoding qualified as CBOR @@ -58,7 +60,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Type import Ouroboros.Network.TxSubmission.Inbound.V1 import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool) +import Ouroboros.Network.TxSubmission.Mempool.Simple (Mempool, TxValidationFail) import Ouroboros.Network.TxSubmission.Mempool.Simple qualified as Mempool import Ouroboros.Network.Util.ShowProxy @@ -77,6 +79,8 @@ data Tx txid = Tx { } deriving (Eq, Ord, Show, Generic, NFData) +data instance TxValidationFail (Tx txid) = TxFail + instance NoThunks txid => NoThunks (Tx txid) instance ShowProxy txid => ShowProxy (Tx txid) where showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) @@ -133,13 +137,16 @@ getMempoolWriter :: forall txid m. ) => Mempool m txid (Tx txid) -> TxSubmissionMempoolWriter txid (Tx txid) Int m -getMempoolWriter = Mempool.getWriter getTxId +getMempoolWriter = Mempool.writerAdapter + . Mempool.getWriter getTxId (pure ()) - (\_ tx -> if getTxValid tx - then Right () - else Left () + (\txs _ctx -> + case txs of + [tx] | getTxValid tx -> right [(tx, Right ())] + | otherwise -> left (tx, TxFail) + _otherwise -> error "getMempoolWriter: impossible" ) - (\_ -> False) + TxFail txSubmissionCodec2 :: MonadST m From 7969b50636dab3d8f63c767f1916daae0a8a5355 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 4 Nov 2025 09:44:11 +0100 Subject: [PATCH 27/29] mempool: rename `MempoolAddFail` to `TxValidationFail` --- dmq-node/src/DMQ/NodeToClient.hs | 9 +++---- .../DMQ/NodeToClient/LocalMsgSubmission.hs | 14 +++++----- .../DMQ/Protocol/LocalMsgSubmission/Client.hs | 2 +- .../DMQ/Protocol/LocalMsgSubmission/Codec.hs | 8 +++--- .../DMQ/Protocol/LocalMsgSubmission/Server.hs | 2 +- .../DMQ/Protocol/LocalMsgSubmission/Type.hs | 3 +-- .../DMQ/Protocol/SigSubmission/Validate.hs | 26 +++++++++---------- .../Network/TxSubmission/Mempool/Simple.hs | 19 ++++++-------- 8 files changed, 39 insertions(+), 44 deletions(-) diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index 5a129c33388..cd6360ab46b 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -101,8 +101,8 @@ data Codecs crypto m = dmqCodecs :: ( MonadST m , Crypto crypto ) - => (MempoolAddFail (Sig crypto) -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto))) + => (TxValidationFail (Sig crypto) -> CBOR.Encoding) + -> (forall s. CBOR.Decoder s (TxValidationFail (Sig crypto))) -> Codecs crypto m dmqCodecs encodeReject' decodeReject' = Codecs { @@ -139,9 +139,8 @@ ntcApps , MonadSTM m , Crypto crypto , Aeson.ToJSON ntcAddr - , Aeson.ToJSON (MempoolAddFail (Sig crypto)) - , Show (MempoolAddFail (Sig crypto)) - , ShowProxy (MempoolAddFail (Sig crypto)) + , Aeson.ToJSON (TxValidationFail (Sig crypto)) + , ShowProxy (TxValidationFail (Sig crypto)) , ShowProxy (Sig crypto) , Typeable crypto ) diff --git a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs index 36a7eb418df..2d302891a02 100644 --- a/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs +++ b/dmq-node/src/DMQ/NodeToClient/LocalMsgSubmission.hs @@ -26,7 +26,7 @@ localMsgSubmissionServer :: , Typeable msgid , Typeable msg , Show msgid - , Show (MempoolAddFail msg)) + , Show (TxValidationFail msg)) => (msg -> msgid) -- ^ get message id -> Tracer m (TraceLocalMsgSubmission msg msgid) @@ -57,27 +57,27 @@ localMsgSubmissionServer getMsgId tracer MempoolWriter { mempoolAddTxs } = data TraceLocalMsgSubmission msg msgid = TraceReceivedMsg msgid -- ^ A signature was received. - | TraceSubmitFailure msgid (MempoolAddFail msg) + | TraceSubmitFailure msgid (TxValidationFail msg) | TraceSubmitAccept msgid deriving instance - (Show msg, Show msgid, Show (MempoolAddFail msg)) + (Show msg, Show msgid, Show (TxValidationFail msg)) => Show (TraceLocalMsgSubmission msg msgid) data MsgSubmissionServerException msgid msg = - MsgValidationException msgid (MempoolAddFail msg) + MsgValidationException msgid (TxValidationFail msg) | TooManyMessages -deriving instance (Show (MempoolAddFail msg), Show msgid) +deriving instance (Show (TxValidationFail msg), Show msgid) => Show (MsgSubmissionServerException msgid msg) -instance (Typeable msgid, Typeable msg, Show (MempoolAddFail msg), Show msgid) +instance (Typeable msgid, Typeable msg, Show (TxValidationFail msg), Show msgid) => Exception (MsgSubmissionServerException msgid msg) where -instance (ToJSON msgid, ToJSON (MempoolAddFail msg)) +instance (ToJSON msgid, ToJSON (TxValidationFail msg)) => ToJSON (TraceLocalMsgSubmission msg msgid) where toJSON (TraceReceivedMsg msgid) = -- TODO: once we have verbosity levels, we could include the full tx, for diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs index dc23363faef..1fd8b3b0071 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Client.hs @@ -21,7 +21,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Type aliases for the high level client API -- -type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig (MempoolAddFail sig) +type LocalMsgSubmissionClient sig = LocalTxSubmissionClient sig (TxValidationFail sig) type LocalMsgClientStIdle = LocalTxClientStIdle diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs index bbb869dd785..a98d27cc5f0 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Codec.hs @@ -30,13 +30,13 @@ codecLocalMsgSubmission ( MonadST m , Crypto crypto ) - => (MempoolAddFail (Sig crypto) -> CBOR.Encoding) - -> (forall s. CBOR.Decoder s (MempoolAddFail (Sig crypto))) + => (TxValidationFail (Sig crypto) -> CBOR.Encoding) + -> (forall s. CBOR.Decoder s (TxValidationFail (Sig crypto))) -> AnnotatedCodec (LocalMsgSubmission (Sig crypto)) CBOR.DeserialiseFailure m ByteString codecLocalMsgSubmission = LTX.anncodecLocalTxSubmission' SigWithBytes SigSubmission.encodeSig SigSubmission.decodeSig -encodeReject :: MempoolAddFail (Sig crypto) -> CBOR.Encoding +encodeReject :: TxValidationFail (Sig crypto) -> CBOR.Encoding encodeReject = \case SigInvalid reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 0 <> e where @@ -64,7 +64,7 @@ encodeReject = \case SigResultOther reason -> CBOR.encodeListLen 2 <> CBOR.encodeWord8 3 <> CBOR.encodeString reason -decodeReject :: CBOR.Decoder s (MempoolAddFail (Sig crypto)) +decodeReject :: CBOR.Decoder s (TxValidationFail (Sig crypto)) decodeReject = do len <- CBOR.decodeListLen tag <- CBOR.decodeWord8 diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs index 7936fd78945..2cb07af6f1e 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Server.hs @@ -22,7 +22,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple -- | Type aliases for the high level client API -- -type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig (MempoolAddFail sig) +type LocalMsgSubmissionServer sig = LocalTxSubmissionServer sig (TxValidationFail sig) -- | A non-pipelined 'Peer' representing the 'LocalMsgSubmissionServer'. diff --git a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs index 114249c8f31..b4613442990 100644 --- a/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/LocalMsgSubmission/Type.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -19,4 +18,4 @@ import Ouroboros.Network.TxSubmission.Mempool.Simple -- | The LocalMsgSubmission protocol is an alias for the LocalTxSubmission -- -type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig (MempoolAddFail sig) +type LocalMsgSubmission sig = Ouroboros.LocalTxSubmission sig (TxValidationFail sig) diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs index 87eb2fbd2a5..55ef6786b5b 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Validate.hs @@ -2,11 +2,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Encapsulates signature validation utilities leveraged by the mempool writer -- module DMQ.Protocol.SigSubmission.Validate where @@ -46,16 +47,16 @@ import Ouroboros.Network.Util.ShowProxy -- | The type of non-fatal failures reported by the mempool writer -- for invalid messages -- -data instance MempoolAddFail (Sig crypto) = +data instance TxValidationFail (Sig crypto) = SigInvalid SigValidationError | SigDuplicate | SigExpired | SigResultOther Text deriving (Eq, Show) -instance (Typeable crypto) => ShowProxy (MempoolAddFail (Sig crypto)) +instance (Typeable crypto) => ShowProxy (TxValidationFail (Sig crypto)) -instance ToJSON (MempoolAddFail (Sig crypto)) where +instance ToJSON (TxValidationFail (Sig crypto)) where toJSON SigDuplicate = String "duplicate" toJSON SigExpired = String "expired" toJSON (SigInvalid e) = object @@ -101,8 +102,8 @@ validateSig :: forall crypto m. -> [Sig crypto] -> PoolValidationCtx m -- ^ cardano pool id verification - -> ExceptT (Sig crypto, MempoolAddFail (Sig crypto)) m - [(Sig crypto, Either (MempoolAddFail (Sig crypto)) ())] + -> ExceptT (Sig crypto, TxValidationFail (Sig crypto)) m + [(Sig crypto, Either (TxValidationFail (Sig crypto)) ())] validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs where DMQPoolValidationCtx now mNextEpoch pools ocertCountersVar = ctx @@ -125,7 +126,7 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs ?! KESBeforeStartOCERT startKESPeriod sigKESPeriod e <- case Map.lookup (verKeyHashingFn coldKey) pools of Nothing | isNothing mNextEpoch - -> invalid SigResultOther $ Text.pack "not initialized yet" + -> right . Left . SigResultOther $ Text.pack "not initialized yet" | otherwise -> left $ SigInvalid UnrecognizedPool -- TODO make 5 a constant @@ -138,7 +139,7 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs -- in case smth happened to localstatequery and it's taking -- too long to update our state | now <= addUTCTime 5 nextEpoch -> success - | otherwise -> left $ SigInvalid ClockSkew + | otherwise -> right . Left $ SigInvalid ClockSkew | not (isZero (ssMarkPool ss)) -> -- we take abs time in case we're late with our own -- localstatequery update, and/or the other side's clock @@ -169,15 +170,14 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs let f = \case Nothing -> Right $ Just ocertN Just n | n <= ocertN -> Right $ Just ocertN - | otherwise -> Left . throwE . SigInvalid $ InvalidOCertCounter n ocertN + | otherwise -> Left $ InvalidOCertCounter n ocertN in case Map.alterF f (verKeyHashingFn coldKey) ocertCounters of Right ocertCounters' -> (void success, ocertCounters') - Left err -> (err, ocertCounters) + Left err -> (throwE (SigInvalid err), ocertCounters) -- for eg. remember to run all results with possibly non-fatal errors right e where success = right $ Right () - invalid tag = right . Left . tag startKESPeriod, endKESPeriod :: KESPeriod @@ -189,12 +189,12 @@ validateSig _ec verKeyHashingFn sigs ctx = traverse process' sigs (?!:) :: Either e1 () -> (e1 -> SigValidationError) - -> ExceptT (MempoolAddFail (Sig crypto)) m () + -> ExceptT (TxValidationFail (Sig crypto)) m () (?!:) result f = firstExceptT (SigInvalid . f) . hoistEither $ result (?!) :: Bool -> SigValidationError - -> ExceptT (MempoolAddFail (Sig crypto)) m () + -> ExceptT (TxValidationFail (Sig crypto)) m () (?!) flag sve = if flag then void success else left (SigInvalid sve) infix 1 ?! diff --git a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs index 3e2e871582d..1af15542456 100644 --- a/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs +++ b/ouroboros-network/lib/Ouroboros/Network/TxSubmission/Mempool/Simple.hs @@ -6,14 +6,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | The module should be imported qualified. -- module Ouroboros.Network.TxSubmission.Mempool.Simple - ( MempoolAddFail + ( TxValidationFail , Mempool (..) , MempoolSeq (..) , MempoolWriter (..) @@ -28,7 +27,6 @@ module Ouroboros.Network.TxSubmission.Mempool.Simple import Prelude hiding (read, seq) import Control.Concurrent.Class.MonadSTM.Strict -import Control.DeepSeq import Control.Exception (assert) import Control.Monad.Trans.Except import Data.Bifunctor (bimap, first, second) @@ -116,7 +114,7 @@ getReader getTxId getTxSize (Mempool mempool) = -- | type of mempool validation errors which are non-fatal -- -data family MempoolAddFail tx +data family TxValidationFail tx -- | A mempool writer which generalizes the tx submission mempool writer -- TODO: We could replace TxSubmissionMempoolWriter with this at some point @@ -138,7 +136,7 @@ data MempoolWriter txid tx idx m = -- returned. mempoolAddTxs :: [tx] - -> m (Either (txid, MempoolAddFail tx) [(txid, SubmitResult (MempoolAddFail tx))]) + -> m (Either (txid, TxValidationFail tx) [(txid, SubmitResult (TxValidationFail tx))]) } @@ -147,10 +145,9 @@ data MempoolWriter txid tx idx m = -- getWriter :: forall tx txid ctx m. ( MonadSTM m - -- TODO: -- , NFData txid -- , NFData tx - -- , NFData (MempoolAddFail tx) + -- , NFData (TxValidationFail tx) , Ord txid ) => (tx -> txid) @@ -159,11 +156,11 @@ getWriter :: forall tx txid ctx m. -- ^ acquire validation context -> ( [tx] -> ctx - -> ExceptT (tx, MempoolAddFail tx) m - [(tx, Either (MempoolAddFail tx) ())]) + -> ExceptT (tx, TxValidationFail tx) m + [(tx, Either (TxValidationFail tx) ())]) -- ^ validation function which should evaluate its result to normal form -- esp. if it is 'expensive' - -> MempoolAddFail tx + -> TxValidationFail tx -- ^ replace duplicates -> Mempool m txid tx -> MempoolWriter txid tx Int m @@ -184,7 +181,7 @@ getWriter getTxId acquireCtx validateTxs duplicateFail (Mempool mempool) = [if duplicate then Left (txid, duplicateFail) else - bimap ((txid,)) (const (txid, tx)) eResult + bimap (txid,) (const (txid, tx)) eResult | (txid, (tx, eResult)) <- vTxs , let duplicate = txid `Set.member` mempoolSet ] From 345ad32c521ea9771b05cb26b8a4b68ba761a61f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 4 Nov 2025 09:45:02 +0100 Subject: [PATCH 28/29] cleanup --- dmq-node/app/Main.hs | 6 +++--- dmq-node/src/DMQ/NodeToNode.hs | 1 - dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs | 11 +++-------- 3 files changed, 6 insertions(+), 12 deletions(-) diff --git a/dmq-node/app/Main.hs b/dmq-node/app/Main.hs index 9ea66aceb46..0694511c100 100644 --- a/dmq-node/app/Main.hs +++ b/dmq-node/app/Main.hs @@ -115,7 +115,7 @@ runDMQ commandLineConfig = do res <- KES.evolutionConfigFromGenesisFile genesisFile evolutionConfig <- case res of Left err -> traceWith tracer (WithEventType "ShelleyGenesisFile" err) - >> throwIO (userError $ err) + >> throwIO (userError err) Right ev -> return ev traceWith tracer (WithEventType "Configuration" dmqConfig) @@ -136,7 +136,7 @@ runDMQ commandLineConfig = do psRng mkStakePoolMonitor $ \nodeKernel -> do dmqDiffusionConfiguration <- - mkDiffusionConfiguration dmqConfig nt (nodeKernel.stakePools.ledgerBigPeersVar) + mkDiffusionConfiguration dmqConfig nt nodeKernel.stakePools.ledgerBigPeersVar let sigSize :: Sig StandardCrypto -> SizeInBytes sigSize _ = 0 -- TODO @@ -179,7 +179,7 @@ runDMQ commandLineConfig = do (if localHandshakeTracer then WithEventType "Handshake" >$< tracer else nullTracer) - $ maybe [] out <$> (tryReadTMVar $ nodeKernel.stakePools.ledgerPeersVar) + $ maybe [] out <$> tryReadTMVar nodeKernel.stakePools.ledgerPeersVar where out :: LedgerPeerSnapshot AllLedgerPeers -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)] diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index da2c7beda9e..2f367385705 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} module DMQ.NodeToNode ( RemoteAddress diff --git a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs index 4f42afaae50..6c925c99dfe 100644 --- a/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs +++ b/dmq-node/src/DMQ/Protocol/SigSubmission/Type.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module DMQ.Protocol.SigSubmission.Type @@ -32,7 +31,6 @@ module DMQ.Protocol.SigSubmission.Type ) where import Data.Aeson -import Data.Bifunctor (first) import Data.ByteString (ByteString) import Data.ByteString.Base16 as BS.Base16 import Data.ByteString.Base16.Lazy as LBS.Base16 @@ -42,13 +40,10 @@ import Data.Text.Encoding qualified as Text import Data.Time.Clock.POSIX (POSIXTime) import Data.Typeable -import Cardano.Crypto.DSIGN.Class (ContextDSIGN, DSIGNAlgorithm, VerKeyDSIGN) -import Cardano.Crypto.DSIGN.Class qualified as DSIGN -import Cardano.Crypto.KES.Class (KESAlgorithm (..), Signable) +import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm, VerKeyDSIGN) +import Cardano.Crypto.KES.Class (KESAlgorithm (..)) import Cardano.KESAgent.KES.Crypto as KES -import Cardano.KESAgent.KES.Evolution qualified as KES -import Cardano.KESAgent.KES.OCert (KESPeriod (..), OCert (..), OCertSignable, - validateOCert) +import Cardano.KESAgent.KES.OCert (KESPeriod (..), OCert (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type as SigSubmission hiding (TxSubmission2) From 86412d4e40780227b54816f28b87f179932695ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 5 Nov 2025 13:27:40 +0100 Subject: [PATCH 29/29] sig-submission test: integrate validateSig --- dmq-node/dmq-node.cabal | 7 ++++++- .../test/DMQ/Protocol/SigSubmission/Test.hs | 21 ++++++++++++++++--- 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/dmq-node/dmq-node.cabal b/dmq-node/dmq-node.cabal index 4834ff0a27d..2a7517d851b 100644 --- a/dmq-node/dmq-node.cabal +++ b/dmq-node/dmq-node.cabal @@ -179,13 +179,16 @@ test-suite dmq-tests build-depends: QuickCheck, base >=4.14 && <4.22, + binary, bytestring, cardano-crypto-class, cardano-crypto-tests, + cardano-ledger-core, cborg, + containers, contra-tracer, dmq-node, - io-classes, + io-classes:{io-classes, strict-stm}, io-sim, kes-agent-crypto, ouroboros-network:{api, framework, protocols, protocols-tests-lib, tests-lib}, @@ -193,6 +196,8 @@ test-suite dmq-tests serialise, tasty, tasty-quickcheck, + time, + transformers, typed-protocols:{typed-protocols, codec-properties}, with-utf8, diff --git a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs index d4b6898c5e6..b15b25c8d56 100644 --- a/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs +++ b/dmq-node/test/DMQ/Protocol/SigSubmission/Test.hs @@ -26,12 +26,18 @@ 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 Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (zipWithM, (>=>)) import Control.Monad.ST (runST) +import Control.Monad.Trans.Except import Data.Bifunctor (second) +import Data.Binary qualified as Binary import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.List.NonEmpty qualified as NonEmpty +import Data.Map qualified as Map +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Typeable import Data.Word (Word32) import GHC.TypeNats (KnownNat) @@ -46,7 +52,9 @@ import Cardano.Crypto.DSIGN.Class qualified as DSIGN import Cardano.Crypto.KES.Class (KESAlgorithm (..), VerKeyKES, encodeSigKES) import Cardano.Crypto.KES.Class qualified as KES import Cardano.Crypto.PinnedSizedBytes (PinnedSizedBytes, psbToByteString) +import Cardano.Crypto.Hash (castHash, hashWith) import Cardano.Crypto.Seed (mkSeedFromBytes) +import Cardano.Ledger.Hashes (KeyHash (..)) import Cardano.KESAgent.KES.Crypto (Crypto (..)) import Cardano.KESAgent.KES.Evolution qualified as KES import Cardano.KESAgent.KES.OCert (OCert (..)) @@ -54,8 +62,10 @@ import Cardano.KESAgent.KES.OCert qualified as KES import Cardano.KESAgent.Protocols.StandardCrypto (MockCrypto, StandardCrypto) import Test.Crypto.Instances +import DMQ.Diffusion.NodeKernel (PoolValidationCtx(..)) import DMQ.Protocol.SigSubmission.Codec import DMQ.Protocol.SigSubmission.Type +import DMQ.Protocol.SigSubmission.Validate import Ouroboros.Network.Protocol.TxSubmission2.Test (labelMsg) @@ -830,15 +840,20 @@ prop_validateSig ) => WithConstrKES size kesCrypt (Sig crypto) -> Property -prop_validateSig constr = ioProperty $ do +prop_validateSig constr = ioProperty do sig <- runWithConstr constr - return $ case validateSig KES.defEvolutionConfig sig of + countersVar <- newTVarIO Map.empty + let validationCtx = + DMQPoolValidationCtx (posixSecondsToUTCTime 0) Nothing Map.empty countersVar + dummyHash = KeyHash . castHash . hashWith (BS.toStrict . Binary.encode . const (0 :: Int)) + result <- runExceptT $ validateSig KES.defEvolutionConfig dummyHash [sig] validationCtx + return case result of Left err -> counterexample ("KES seed: " ++ show (ctx constr)) . counterexample ("KES vk key: " ++ show (ocertVkHot . getSigOpCertificate . sigOpCertificate $ sig)) . counterexample (show sig) . counterexample (show err) $ False - Right () -> property True + Right {} -> property True prop_validateSig_mockcrypto :: Blind (WithConstrKES (SeedSizeKES (KES MockCrypto)) (KES MockCrypto) (Sig MockCrypto))