diff --git a/.github/workflows/actionlint.yml b/.github/workflows/actionlint.yml index 1970fb42d6a..d9026e86d66 100644 --- a/.github/workflows/actionlint.yml +++ b/.github/workflows/actionlint.yml @@ -23,6 +23,8 @@ jobs: extra-substituters = https://cache.iog.io/ # Make the Nix environment available to next steps - uses: rrbutani/use-nix-shell-action@f97339023a09121113e5a58ad88fe0e9fde3406b # v1 + with: + flakes: nixpkgs#shellcheck,nixpkgs#actionlint - name: actionlint run: | diff --git a/.github/workflows/check-changelog.yml b/.github/workflows/check-changelog.yml index c2b31c444ca..d30b20536c5 100644 --- a/.github/workflows/check-changelog.yml +++ b/.github/workflows/check-changelog.yml @@ -42,9 +42,11 @@ jobs: extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= extra-substituters = https://cache.iog.io/ - - name: Check scriv fragments are correct + - uses: rrbutani/use-nix-shell-action@v1 if: steps.filter.outputs.cardano == 'true' - uses: rrbutani/use-nix-shell-action@f97339023a09121113e5a58ad88fe0e9fde3406b # v1 with: - script: cd cardano-testnet && scriv collect --version "CI-CHECK" --keep + flakes: nixpkgs#scriv + - name: Check scriv fragments are correct + if: steps.filter.outputs.cardano == 'true' + run: cd cardano-testnet && scriv collect --version "CI-CHECK" --keep diff --git a/.github/workflows/shellcheck.yml b/.github/workflows/shellcheck.yml index bdac554824b..911e274412c 100644 --- a/.github/workflows/shellcheck.yml +++ b/.github/workflows/shellcheck.yml @@ -25,6 +25,8 @@ jobs: extra-substituters = https://cache.iog.io/ # Make the Nix environment available to next steps - uses: rrbutani/use-nix-shell-action@f97339023a09121113e5a58ad88fe0e9fde3406b # v1 + with: + flakes: nixpkgs#shellcheck - name: shellcheck run: | for file in $(git ls-files "*.sh") diff --git a/.gitignore b/.gitignore index fa56a0bd882..617e5c62f91 100644 --- a/.gitignore +++ b/.gitignore @@ -77,3 +77,5 @@ cardano-tracer/cardano-tracer-test .idea/ .codex + +.serena/ diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index b0812288828..1333026f4af 100644 --- a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal +++ b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal @@ -82,10 +82,10 @@ library -- IOG dependencies -------------------------- build-depends: - , cardano-api ^>=11.0 - , plutus-ledger-api ^>=1.63 - , plutus-tx ^>=1.63 - , plutus-tx-plugin ^>=1.63 + , cardano-api ^>=11.3 + , plutus-ledger-api ^>=1.65 + , plutus-tx ^>=1.65 + , plutus-tx-plugin ^>=1.65 ------------------------ -- Non-IOG dependencies diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs index f2030e39ae6..492f6c47f5c 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -40,6 +40,7 @@ import Ouroboros.Network.Mux (MiniProtocolCb (..), OuroborosApplicatio import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, encodeRemoteAddress) +import Ouroboros.Network.PerasSupport (PerasSupport (..)) import Ouroboros.Network.Protocol.BlockFetch.Client (BlockFetchClient (..), blockFetchClientPeer) import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions) @@ -112,7 +113,7 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec supportedVers = supportedNodeToNodeVersions (Proxy @blk) myCodecs :: Codecs blk NtN.RemoteAddress DeserialiseFailure IO ByteString ByteString ByteString ByteString ByteString ByteString - ByteString + ByteString ByteString ByteString myCodecs = defaultCodecs codecConfig blkN2nVer encodeRemoteAddress decodeRemoteAddress n2nVer peerMultiplex :: NtN.Versions NodeToNodeVersion NtN.NodeToNodeVersionData @@ -129,10 +130,11 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec , NtN.diffusionMode = NtN.InitiatorOnlyDiffusionMode , NtN.peerSharing = ownPeerSharing , NtN.query = False + , NtN.perasSupport = PerasUnsupported }) $ \n2nData -> mkApp $ - NtN.nodeToNodeProtocols NtN.defaultMiniProtocolParameters + NtN.nodeToNodeProtocols mempty NtN.defaultMiniProtocolParameters NtN.NodeToNodeProtocols { NtN.chainSyncProtocol = InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx channel -> runPeer @@ -160,6 +162,11 @@ benchmarkConnectTxSubmit EnvConsts { .. } handshakeTracer submissionTracer codec (cPeerSharingCodec myCodecs) channel (peerSharingClientPeer peerSharingClientNull) + -- TODO Peras is not supported here + , NtN.perasCertDiffusionProtocol = InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx _channel -> + error "tx-generator: Peras cert diffusion is unsupported" + , NtN.perasVoteDiffusionProtocol = InitiatorProtocolOnly $ MiniProtocolCb $ \_ctx _channel -> + error "tx-generator: Peras vote diffusion is unsupported" } n2nVer n2nData diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs index 768081fcaf0..eb6610306b4 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs @@ -3,11 +3,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + module Cardano.Benchmarking.GeneratorTx.SizedMetadata where import Cardano.Api +import Cardano.Ledger.BaseTypes (maybeToStrictMaybe) +import qualified Cardano.Ledger.Core as L import Cardano.TxGenerator.Utils import Prelude @@ -16,6 +19,7 @@ import qualified Data.ByteString as BS import Data.Function ((&)) import qualified Data.Map.Strict as Map import Data.Word (Word64) +import Lens.Micro ((.~), (^.)) maxMapSize :: Int @@ -53,7 +57,7 @@ prop_mapCostsMary = measureMapCosts AsMaryEra == assumeMapCosts AsMaryE prop_mapCostsAlonzo = measureMapCosts AsAlonzoEra == assumeMapCosts AsAlonzoEra prop_mapCostsBabbage = measureMapCosts AsBabbageEra == assumeMapCosts AsBabbageEra prop_mapCostsConway = measureMapCosts AsConwayEra == assumeMapCosts AsConwayEra -prop_mapCostsDijkstra = measureMapCosts AsDijkstraEra == assumeMapCosts AsDijkstraEra +prop_mapCostsDijkstra = measureMapCosts AsDijkstraEra == assumeMapCosts AsDijkstraEra assumeMapCosts :: forall era . IsShelleyBasedEra era => AsType era -> [Int] assumeMapCosts _proxy = stepFunction [ @@ -113,21 +117,25 @@ measureBSCosts era = map (metadataSize era . Just . bsMetadata) [0..maxBSSize] metadataSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int metadataSize p m = dummyTxSize p m - dummyTxSize p Nothing -dummyTxSizeInEra :: IsShelleyBasedEra era => TxMetadataInEra era -> Int -dummyTxSizeInEra metadata = case createTransactionBody shelleyBasedEra dummyTx of - Right b -> BS.length $ serialiseToCBOR b - Left err -> error $ "metaDataSize " ++ show err +dummyTxSizeInEra :: forall era. IsShelleyBasedEra era => TxMetadataInEra era -> Int +dummyTxSizeInEra metadata = + BS.length $ serialiseToCBOR dummyTx where - dummyTx = defaultTxBodyContent shelleyBasedEra - & setTxIns - [ ( mkTxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0" - , BuildTxWith $ KeyWitness KeyWitnessForSpending - ) - ] - & setTxFee (mkTxFee 0) - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (mkTxValidityUpperBound 0) - & setTxMetadata metadata + sbe = shelleyBasedEra @era + txInputs = + [ ( mkTxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810#0" + , BuildTxWith $ KeyWitness KeyWitnessForSpending + ) + ] + txAuxData = toAuxiliaryData sbe metadata TxAuxScriptsNone + ledgerTxBody = + mkCommonTxBody sbe txInputs [] (mkTxFee 0) TxWithdrawalsNone txAuxData + & invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (mkTxValidityUpperBound 0) + dummyTx :: Tx era + dummyTx = shelleyBasedEraConstraints sbe $ + ShelleyTx sbe $ + L.mkBasicTx (ledgerTxBody ^. txBodyL) + & L.auxDataTxL .~ maybeToStrictMaybe txAuxData dummyTxSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int dummyTxSize _p m = (dummyTxSizeInEra @era) $ metadataInEra m diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index 312466573ad..824e648eb20 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -101,7 +101,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fail (T.unpack err) let (stillUnacked, acked) = L.splitAtEnd ack unAcked let newStats = stats { stsAcked = stsAcked stats + Ack ack } - traceWith bmtr $ SubmissionClientDiscardAcknowledged (getTxId . getTxBody <$> acked) + traceWith bmtr $ SubmissionClientDiscardAcknowledged (txIdFromTx <$> acked) return (txSource, UnAcked stillUnacked, newStats) queueNewTxs :: [Tx era] -> LocalState era -> LocalState era @@ -130,8 +130,8 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = let stateC@(_, UnAcked outs , stats) = queueNewTxs newTxs stateB traceWith tr $ idListTrace (ToAnnce newTxs) blocking - traceWith bmtr $ SubmissionClientReplyTxIds (getTxId . getTxBody <$> newTxs) - traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> outs) + traceWith bmtr $ SubmissionClientReplyTxIds (txIdFromTx <$> newTxs) + traceWith bmtr $ SubmissionClientUnAcked (txIdFromTx <$> outs) case blocking of SingBlocking -> case NE.nonEmpty newTxs of @@ -155,12 +155,12 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = reqTxIds = fmap fromGenTxId txIds traceWith tr $ ReqTxs (length reqTxIds) let UnAcked ua = unAcked - uaIds = getTxId . getTxBody <$> ua - (toSend, _retained) = L.partition ((`L.elem` reqTxIds) . getTxId . getTxBody) ua + uaIds = txIdFromTx <$> ua + (toSend, _retained) = L.partition ((`L.elem` reqTxIds) . txIdFromTx) ua missIds = reqTxIds L.\\ uaIds traceWith tr $ TxList (length toSend) - traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> ua) + traceWith bmtr $ SubmissionClientUnAcked (txIdFromTx <$> ua) traceWith bmtr $ TraceBenchTxSubServReq reqTxIds unless (L.null missIds) $ traceWith bmtr $ TraceBenchTxSubServUnav missIds @@ -190,6 +190,10 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fromGenTxId (Block.GenTxIdConway (Mempool.ShelleyTxId i)) = fromShelleyTxId i fromGenTxId _ = error "TODO: fix incomplete match" + txIdFromTx :: Tx era -> TxId + txIdFromTx (ShelleyTx sbe tx) = + shelleyBasedEraConstraints sbe $ fromShelleyTxId $ Ledger.txIdTxBody (tx ^. Ledger.bodyTxL) + tokIsBlocking :: SingBlockingStyle a -> Bool tokIsBlocking = \case SingBlocking -> True diff --git a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs index abd5a10c54f..77d54cad06b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs @@ -38,21 +38,19 @@ import Prelude type CardanoBlock = Consensus.CardanoBlock StandardCrypto -toProtocolInfo :: SomeConsensusProtocol -> ProtocolInfo CardanoBlock -toProtocolInfo (SomeConsensusProtocol CardanoBlockType info) = fst $ protocolInfo @IO info +toProtocolInfo :: SomeConsensusProtocol -> IO (ProtocolInfo CardanoBlock) +toProtocolInfo (SomeConsensusProtocol CardanoBlockType info) = fst <$> protocolInfo @IO info toProtocolInfo _ = error "toProtocolInfo unknown protocol" -protocolToTopLevelConfig :: SomeConsensusProtocol -> TopLevelConfig CardanoBlock -protocolToTopLevelConfig ptcl = pInfoConfig - where - ProtocolInfo {pInfoConfig} = toProtocolInfo ptcl +protocolToTopLevelConfig :: SomeConsensusProtocol -> IO (TopLevelConfig CardanoBlock) +protocolToTopLevelConfig ptcl = pInfoConfig <$> toProtocolInfo ptcl -protocolToCodecConfig :: SomeConsensusProtocol -> CodecConfig CardanoBlock -protocolToCodecConfig = configCodec . protocolToTopLevelConfig +protocolToCodecConfig :: SomeConsensusProtocol -> IO (CodecConfig CardanoBlock) +protocolToCodecConfig = fmap configCodec . protocolToTopLevelConfig -protocolToNetworkId :: SomeConsensusProtocol -> NetworkId +protocolToNetworkId :: SomeConsensusProtocol -> IO NetworkId protocolToNetworkId ptcl - = Testnet $ getNetworkMagic $ configBlock $ protocolToTopLevelConfig ptcl + = Testnet . getNetworkMagic . configBlock <$> protocolToTopLevelConfig ptcl makeLocalConnectInfo :: NetworkId -> SocketPath -> LocalNodeConnectInfo makeLocalConnectInfo networkId socketPath diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs index 3435fbddeb9..0c992938ee0 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs @@ -69,8 +69,8 @@ startProtocol configFile tracerSocket = do setEnvGenesis $ getGenesis protocol iomgr <- askIOManager + networkId <- liftIO $ protocolToNetworkId protocol let - networkId = protocolToNetworkId protocol tracerSocket' = (,,) iomgr networkId `fmap` tracerSocket setEnvNetworkId networkId diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 1b345952511..b26d5964203 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -38,6 +38,7 @@ import Cardano.Benchmarking.Version as Version import Cardano.Benchmarking.Wallet as Wallet import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Tools (estimateMinFeeTx) import Cardano.Logging hiding (LocalSocket) import Cardano.TxGenerator.Fund as Fund import qualified Cardano.TxGenerator.FundQueue as FundQueue @@ -56,7 +57,7 @@ import Prelude import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.Trans.RWS.Strict (ask) -import "contra-tracer" Control.Tracer (Tracer (..)) +import "contra-tracer" Control.Tracer (mkTracer) import Data.ByteString.Lazy.Char8 as BSL (writeFile) import Data.Ratio ((%)) import qualified Data.Text as Text (unpack) @@ -136,11 +137,12 @@ getConnectClient = do protocol <- getEnvProtocol void $ return $ btSubmission2_ tracers envConsts <- lift ask + codecConfig <- liftIO $ protocolToCodecConfig protocol return $ benchmarkConnectTxSubmit envConsts - (Tracer $ traceWith (btConnect_ tracers)) + (mkTracer $ traceWith (btConnect_ tracers)) mempty -- (btSubmission2_ tracers) - (protocolToCodecConfig protocol) + codecConfig networkMagic waitBenchmark :: ActionM () waitBenchmark = do @@ -353,10 +355,12 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do Right tx -> do let txSize = txSizeInBytes tx - txFeeEstimate = case toLedgerPParams shelleyBasedEra protocolParameters of - Left{} -> Nothing - Right ledgerPParams -> Just $ - evaluateTransactionFee shelleyBasedEra ledgerPParams (getTxBody tx) (fromIntegral $ inputs + 1) 0 0 -- 1 key witness per tx input + 1 collateral + txFeeEstimate = case tx of + ShelleyTx sbe ledgerTx -> shelleyBasedEraConstraints sbe $ + case toLedgerPParams sbe protocolParameters of + Left{} -> Nothing + Right ledgerPParams -> Just $ + estimateMinFeeTx ledgerPParams ledgerTx (inputs + 1) 0 0 -- 1 key witness per tx input + 1 collateral traceDebug $ "Projected Tx size in bytes: " ++ show txSize traceDebug $ "Projected Tx fee in Coin: " ++ show txFeeEstimate -- TODO: possibly emit a warning when (Just txFeeEstimate) is lower than specified by config in TxGenTxParams.txFee diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs index 6ab5e091806..c35bac56c7d 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} + {- HLINT ignore "Use map with tuple-section" -} -- | This module provides means to secure funds that are given in genesis. @@ -21,16 +22,20 @@ where import Cardano.Api hiding (ShelleyGenesis) import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Keys.WitVKey (WitVKey (WitVKey)) import Cardano.Ledger.Shelley.API (Addr (..)) import Cardano.TxGenerator.Fund import Cardano.TxGenerator.Types import Cardano.TxGenerator.Utils import Ouroboros.Consensus.Shelley.Node (validateGenesis) -import Data.Bifunctor (bimap, second) +import Data.Bifunctor (second) import Data.Function ((&)) import Data.List (find) import qualified Data.ListMap as ListMap (toList) +import qualified Data.Set as Set +import Lens.Micro ((.~), (^.)) genesisValidate :: ShelleyGenesis -> Either String () @@ -105,12 +110,16 @@ genesisExpenditure networkId inputKey addr value fee ttl outputKey pseudoTxIn = genesisTxInput networkId inputKey fund tx = FundInEra { - _fundTxIn = TxIn (getTxId $ getTxBody tx) (TxIx 0) + _fundTxIn = TxIn (txIdFromTx tx) (TxIx 0) , _fundWitness = KeyWitness KeyWitnessForSpending , _fundVal = value , _fundSigningKey = Just outputKey } + txIdFromTx :: Tx era -> TxId + txIdFromTx (ShelleyTx sbe' tx') = + shelleyBasedEraConstraints sbe' $ fromShelleyTxId $ Ledger.txIdTxBody (tx' ^. Ledger.bodyTxL) + mkGenesisTransaction :: forall era . IsShelleyBasedEra era => SigningKey GenesisUTxOKey @@ -119,18 +128,24 @@ mkGenesisTransaction :: forall era . -> [TxIn] -> [TxOut CtxTx era] -> Either TxGenError (Tx era) -mkGenesisTransaction key ttl fee txins txouts - = bimap - ApiError - (\b -> signShelleyTransaction (shelleyBasedEra @era) b [WitnessGenesisUTxOKey key]) - (createTransactionBody (shelleyBasedEra @era) txBodyContent) +mkGenesisTransaction key ttl fee txins txouts = + shelleyBasedEraConstraints sbe $ + let txInputs = zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending + ledgerTxBody = + mkCommonTxBody sbe txInputs txouts (mkTxFee fee) TxWithdrawalsNone Nothing + & invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (mkTxValidityUpperBound ttl) + rawBody = ledgerTxBody ^. txBodyL + unsignedLedgerTx = Ledger.mkBasicTx rawBody + txHash = Ledger.extractHash $ Ledger.hashAnnotated rawBody + shelleySigningKey = toShelleySigningKey (WitnessGenesisUTxOKey key) + witVKey = WitVKey + (getShelleyKeyWitnessVerificationKey shelleySigningKey) + (makeShelleySignature txHash shelleySigningKey) + signedLedgerTx = unsignedLedgerTx + & Ledger.witsTxL .~ (Ledger.mkBasicTxWits & Ledger.addrTxWitsL .~ Set.singleton witVKey) + in Right $ ShelleyTx sbe signedLedgerTx where - txBodyContent = defaultTxBodyContent shelleyBasedEra - & setTxIns (zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending) - & setTxOuts txouts - & setTxFee (mkTxFee fee) - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (mkTxValidityUpperBound ttl) + sbe = shelleyBasedEra @era castKey :: SigningKey PaymentKey -> SigningKey GenesisUTxOKey castKey (PaymentSigningKey skey) = GenesisUTxOSigningKey skey diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs index 8b83528f49a..2e1c48c2852 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NixService.hs @@ -27,7 +27,7 @@ import Cardano.Api (AnyCardanoEra, mapFile) import Cardano.CLI.Type.Common (FileDirection (..), SigningKeyFile) import qualified Cardano.Ledger.Coin as L import Cardano.Node.Configuration.NodeAddress (NodeAddress' (..), - NodeHostIPv4Address (..), NodeIPv4Address) + NodeIPv4Address) import Cardano.Node.Types (AdjustFilePaths (..)) import Cardano.TxGenerator.Internal.Orphans () import Cardano.TxGenerator.Types @@ -74,22 +74,20 @@ data NodeDescription = instance FromJSON NodeDescription where parseJSON = withObject "NodeDescription" \v -> do - unNodeHostIPv4Address + naHostAddress <- v .: "addr" Key "addr" naPort <- fmap toEnum $ v .: "port" Key "port" - let naHostAddress = NodeHostIPv4Address {..} - ndAddr = NodeAddress {..} + let ndAddr = NodeAddress {..} ndName <- v .:? "name" Key "name" .!= show ndAddr pure $ NodeDescription {..} instance ToJSON NodeDescription where toJSON NodeDescription {ndAddr, ndName} = object [ "name" .= ndName - , "addr" .= unNodeHostIPv4Address + , "addr" .= naHostAddress , "port" .= fromEnum naPort ] where _addr@NodeAddress {naHostAddress, naPort} = ndAddr - _hostAddr@NodeHostIPv4Address {unNodeHostIPv4Address} = naHostAddress -- Long GC pauses on target nodes can trigger spurious MVar deadlock diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs index fab37d0fe8b..0f42f441265 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs @@ -11,20 +11,18 @@ module Cardano.TxGenerator.Setup.NodeConfig import Cardano.Api (BlockType (..), ProtocolInfoArgs (..)) import qualified Cardano.Ledger.Api.Transition as Ledger (tcShelleyGenesisL) +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromFile) import Cardano.Node.Configuration.POM -import Cardano.Node.Handlers.Shutdown (ShutdownConfig (..)) import Cardano.Node.Protocol.Cardano import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) -import Cardano.Node.Types (ConfigYamlFilePath (..), GenesisFile, KESSource (..), - NodeProtocolConfiguration (..), NodeShelleyProtocolConfiguration (..), - ProtocolFilepaths (..)) +import Cardano.Node.Types (GenesisFile, NodeProtocolConfiguration (..), + NodeShelleyProtocolConfiguration (..)) import Cardano.TxGenerator.Types import qualified Ouroboros.Consensus.Cardano.Node as Consensus import Control.Applicative (Const (Const), getConst) import Control.Monad.Trans.Except (runExceptT) import Data.Bifunctor (first) -import Data.Monoid -- | extract genesis from a Cardano protocol @@ -34,7 +32,7 @@ getGenesis :: SomeConsensusProtocol -> ShelleyGenesis getGenesis (SomeConsensusProtocol CardanoBlockType proto) = getConst $ Ledger.tcShelleyGenesisL Const transCfg where - ProtocolInfoArgsCardano Consensus.CardanoProtocolParams + ProtocolInfoArgsCardano _ Consensus.CardanoProtocolParams { Consensus.cardanoLedgerTransitionConfig = transCfg } = proto @@ -53,29 +51,11 @@ mkConsensusProtocol nodeConfig = <$> runExceptT (mkSomeConsensusProtocolCardano byronConfig shelleyConfig alonzoConfig conwayConfig dijkstraConfig hardforkConfig checkpointsConfig Nothing) -- | Creates a NodeConfiguration from a config file; --- the result is devoid of any keys/credentials +-- the result is devoid of any keys/credentials. +-- +-- The configuration is parsed and resolved through the @cardano-config@ package +-- (via "Cardano.Node.Configuration.Adapter"), applying no CLI overrides, so the +-- credential and socket paths are left unset. mkNodeConfig :: FilePath -> IO (Either TxGenError NodeConfiguration) -mkNodeConfig configFp_ - = do - configYamlPc <- parseNodeConfigurationFP . Just $ configFp - return - $ first (TxGenError . ("mkNodeConfig: " ++)) - $! makeNodeConfiguration (configYamlPc <> filesPc) - where - configFp = ConfigYamlFilePath configFp_ - - filesPc :: PartialNodeConfiguration - filesPc = defaultPartialNodeConfiguration - { pncProtocolFiles = Last . Just $ - ProtocolFilepaths - { byronCertFile = Just "" - , byronKeyFile = Just "" - , shelleyKESSource = Just (KESKeyFilePath "") - , shelleyVRFFile = Just "" - , shelleyCertFile = Just "" - , shelleyBulkCredsFile = Just "" - } - , pncValidateDB = Last $ Just False - , pncShutdownConfig = Last $ Just $ ShutdownConfig Nothing Nothing - , pncConfigFile = Last $ Just configFp - } +mkNodeConfig configFp = + first (TxGenError . ("mkNodeConfig: " ++)) <$> nodeConfigurationFromFile configFp diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs index d1431f4ae9d..86eda440cf8 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} + module Cardano.TxGenerator.Tx (module Cardano.TxGenerator.Tx) @@ -9,15 +9,20 @@ module Cardano.TxGenerator.Tx import Cardano.Api hiding (txId) +import Cardano.Ledger.BaseTypes (maybeToStrictMaybe) import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Keys.WitVKey (WitVKey (WitVKey)) import Cardano.TxGenerator.Fund import Cardano.TxGenerator.Types import Cardano.TxGenerator.UTxO (ToUTxOList) -import Data.Bifunctor (bimap, second) +import Data.Bifunctor (second) import qualified Data.ByteString as BS (length) import Data.Function ((&)) import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Lens.Micro ((.~), (^.)) -- | 'CreateAndStore' is meant to represent building a transaction @@ -165,22 +170,33 @@ genTx :: forall era. () -> TxFee era -> TxMetadataInEra era -> TxGenerator era -genTx sbe ledgerParameters (collateral, collFunds) fee metadata inFunds outputs - = bimap - ApiError - (\b -> (signShelleyTransaction (shelleyBasedEra @era) b $ map WitnessPaymentKey allKeys, getTxId b)) - (createTransactionBody (shelleyBasedEra @era) txBodyContent) - where - allKeys = mapMaybe getFundKey $ inFunds ++ collFunds - txBodyContent = defaultTxBodyContent sbe - & setTxIns (map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds) - & setTxInsCollateral collateral - & setTxOuts outputs - & setTxFee fee - & setTxValidityLowerBound TxValidityNoLowerBound - & setTxValidityUpperBound (defaultTxValidityUpperBound sbe) - & setTxMetadata metadata - & setTxProtocolParams (BuildTxWith (Just ledgerParameters)) +genTx sbe _ledgerParameters (collateral, collFunds) fee metadata inFunds outputs = + shelleyBasedEraConstraints sbe $ do + let allKeys = mapMaybe getFundKey $ inFunds ++ collFunds + setCollateral = case collateral of + TxInsCollateralNone -> id + TxInsCollateral eon _ -> collateralInputsTxBodyL eon .~ convCollateralTxIns collateral + txInputs = map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds + txAuxData = toAuxiliaryData sbe metadata TxAuxScriptsNone + ledgerTxBody = + mkCommonTxBody sbe txInputs outputs fee TxWithdrawalsNone txAuxData + & invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (defaultTxValidityUpperBound sbe) + & setCollateral + rawBody = ledgerTxBody ^. txBodyL + unsignedLedgerTx = Ledger.mkBasicTx rawBody + txHash = Ledger.extractHash $ Ledger.hashAnnotated rawBody + witVKeys = Set.fromList + [ WitVKey + (getShelleyKeyWitnessVerificationKey sk) + (makeShelleySignature txHash sk) + | sk <- map (toShelleySigningKey . WitnessPaymentKey) allKeys + ] + signedLedgerTx = unsignedLedgerTx + & Ledger.witsTxL .~ (Ledger.mkBasicTxWits & Ledger.addrTxWitsL .~ witVKeys) + & Ledger.auxDataTxL .~ maybeToStrictMaybe txAuxData + tx = ShelleyTx sbe signedLedgerTx + txId = fromShelleyTxId $ Ledger.txIdTxBody rawBody + Right (tx, txId) txSizeInBytes :: forall era. IsShelleyBasedEra era => diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index ef230e3e003..acabbb3d6d7 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -109,32 +109,24 @@ library , attoparsec-aeson , base16-bytestring , bytestring - , cardano-api ^>= 11.0 + , cardano-api ^>= 11.3 , cardano-binary - , cardano-cli ^>= 11.0 + , cardano-cli ^>= 11.1 , cardano-crypto-class - , cardano-crypto-wrapper , cardano-data , cardano-diffusion ^>= 1.0 , cardano-git-rev ^>= 0.2.2 - , cardano-ledger-alonzo , cardano-ledger-api - , cardano-ledger-byron , cardano-ledger-core , cardano-node , cardano-prelude - , cardano-strict-containers >=0.1 , contra-tracer , cborg >= 0.2.2 && < 0.3 , containers - , constraints-extras , directory , dlist , extra , filepath - , formatting - , generic-monoid - , ghc-prim , io-classes:{io-classes, strict-stm} , microlens , mtl @@ -142,7 +134,7 @@ library , network-mux , optparse-applicative , ouroboros-consensus:{ouroboros-consensus, cardano, diffusion} >= 3.0.1 - , ouroboros-network:{api, framework, framework-tracing, ouroboros-network, protocols} >= 1.1 + , ouroboros-network:{api, framework, tracing, ouroboros-network, protocols} >= 1.1 , plutus-ledger-api , plutus-tx , random @@ -158,7 +150,6 @@ library , trace-forward , transformers , transformers-except - , unordered-containers , yaml -- Needed by "Cardano.Api.Internal.ProtocolParameters" port. , either @@ -195,12 +186,12 @@ executable calibrate-script , aeson , aeson-pretty , bytestring + , cardano-api , containers , directory , extra , filepath , optparse-applicative - , cardano-api , text , transformers , transformers-except diff --git a/cabal.project b/cabal.project index c818a53ab0c..5abcd01df7a 100644 --- a/cabal.project +++ b/cabal.project @@ -13,12 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2026-04-17T09:20:55Z - , cardano-haskell-packages 2026-05-02T16:21:41Z - -active-repositories: - , :rest - , cardano-haskell-packages:override + , hackage.haskell.org 2026-06-10T14:43:25Z + , cardano-haskell-packages 2026-06-10T14:16:00Z constraints: -- haskell.nix patch does not work for 1.6.8 @@ -86,3 +82,111 @@ allow-newer: -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api.git + tag: bb64ad40f904040a9b4d99306cf13eef4650a6c9 + --sha256: sha256-302P+qj+UkY/uSWHt8YMT4VzNhRS9tWMz0G6rjr4eVk= + subdir: + cardano-api + cardano-rpc + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-cli.git + tag: 9678a844fd2b53bc3777906d61b53fe0ff93e8ed + --sha256: sha256-0Eo3txVuqkmvZdsyalKbS+bnmFzevG4O99CavSjo7SM= + subdir: + cardano-cli + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger.git + tag: 8dc1c431e06db2c8b5d44fb4b3cca6419197d763 + --sha256: sha256-xKtgNFxjbJE6UWGvTioGX81NgvlKH3mHEaYMWDm8/UA= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/babbage/impl + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley-ma/test-suite + eras/shelley/impl + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/vector-map + +source-repository-package + type: git + location: https://github.com/f-f/kes-agent.git + tag: 32c1ed675d22a30735d9f22f7afa436a3ef3e64a + --sha256: sha256-o7hFX1JnraS6Xq0WoXQwd9Z8GsPPv0Ls2DWvZ08o0ZU= + subdir: + kes-agent + kes-agent-crypto + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus.git + tag: e6fad063078894cefece2a535a2e2b4d9a092e73 + --sha256: sha256-SPtbQ1+zN4uYiVx3rej2kMasbpfhSAyjRD5bdrnK3Rs= + subdir: + . + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 8b4dcb898b64615f574a7fbdcf119f77c7fbc598 + --sha256: sha256-t1tGV5uZwyKnSSCbaJJAteMYKnQYeO39hUUycMRuC2M= + subdir: + ./cardano-diffusion + ./monoidal-synchronisation + ./network-mux + ./ouroboros-network + +source-repository-package + type: git + location: https://github.com/f-f/dmq-node.git + tag: b7d59834e52d46229bb3ff6e5595509eede730dd + --sha256: sha256-8GKAaNPRZkKsk10Emokrlnc0sQOx1aHUnggqlMdY0nw= + subdir: + dmq-node + +source-repository-package + type: git + location: https://github.com/IntersectMBO/plutus.git + tag: b1db04cc425fab303ac3b79d7140dc2a17f29e6d + --sha256: sha256-XtYzjNVx4+IGWpgm+p/YTf56DrJtK0I98umZCTE3U80= + subdir: + plutus-core + plutus-ledger-api + plutus-tx + plutus-tx-plugin + plutus-metatheory + +source-repository-package + type: git + location: https://github.com/f-f/ekg-forward + tag: b24b3aba2806ce223c62f8ce3e267ec92dcc52e2 + --sha256: sha256-s5Hxxm04HmFVmdBjAnFEsJEhTqr5Z/uiB4K1s2VaVwE= + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-base + tag: 8761e5c7ad09935376ec440cf33919b7544b5975 + --sha256: sha256-uMExJzjeRB3DZi27zBgfdXArxiNen4e9poavE58atuI= + subdir: + cardano-config diff --git a/cardano-node-capi/cardano-node-capi.cabal b/cardano-node-capi/cardano-node-capi.cabal index d50d59e6e1e..2be5a5f3c38 100644 --- a/cardano-node-capi/cardano-node-capi.cabal +++ b/cardano-node-capi/cardano-node-capi.cabal @@ -21,8 +21,7 @@ library import: project-config exposed-modules: Node build-depends: base >= 4.14 && < 5 - , aeson - , bytestring + , cardano-config , cardano-node , optparse-applicative hs-source-dirs: src diff --git a/cardano-node-capi/src/Node.hs b/cardano-node-capi/src/Node.hs index 2db6b7730b7..d9277084c57 100644 --- a/cardano-node-capi/src/Node.hs +++ b/cardano-node-capi/src/Node.hs @@ -1,11 +1,8 @@ module Node where -import Cardano.Node.Parsers (nodeCLIParser, parserHelpHeader, parserHelpOptions, - renderHelpDoc) +import qualified Cardano.Configuration as CC import Cardano.Node.Run (runNode) -import Data.Aeson (eitherDecodeStrict) -import Data.ByteString.Char8 (pack) import Options.Applicative import Foreign.C (CString, peekCString) @@ -19,10 +16,13 @@ foreign export ccall "runNode" crunNode :: Int -> Ptr CString -> IO () crunNode :: Int -> Ptr CString -> IO () crunNode argc argv = peekArray argc argv >>= mapM peekCString >>= \args -> case execParserPure pref opts args of - Success pnc -> runNode pnc + Success cli -> runNode cli Failure f -> print f CompletionInvoked _ -> putStrLn "Completion Invoked?" where pref = prefs showHelpOnEmpty - opts = info nodeCLIParser + opts = info (nodeRunParser <**> helper) ( fullDesc <> progDesc "Start node of the Cardano blockchain." ) + nodeRunParser = + subparser $ + command "run" (info (CC.parseCliArgs <**> helper) (progDesc "Run the node.")) diff --git a/cardano-node-chairman/app/Cardano/Chairman.hs b/cardano-node-chairman/app/Cardano/Chairman.hs index b43842cf160..0d5e7453ca5 100644 --- a/cardano-node-chairman/app/Cardano/Chairman.hs +++ b/cardano-node-chairman/app/Cardano/Chairman.hs @@ -272,7 +272,7 @@ runChairman tracer networkId runningTime socketPaths cModeParams secParam = do , localNodeSocketPath = socketPath } chairmanChainSyncClient = LocalChainSyncClient $ - chainSyncClient (showTracing tracer) socketPath chainsVar secParam + chainSyncClient (show >$< tracer) socketPath chainsVar secParam protocolsInMode = LocalNodeClientProtocols { localChainSyncClient = chairmanChainSyncClient , localTxSubmissionClient = Nothing diff --git a/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs b/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs index 66b645adf46..747f69c6f6d 100644 --- a/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs +++ b/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs @@ -13,8 +13,8 @@ import qualified Cardano.Api as Api import Cardano.Chairman (chairmanTest) import Cardano.Ledger.BaseTypes (unNonZero) -import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..), - parseNodeConfigurationFP) +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromFile) +import Cardano.Node.Configuration.POM (NodeConfiguration (..)) import Cardano.Node.Protocol import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) @@ -24,8 +24,7 @@ import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.Node.ProtocolInfo import Control.Monad.Class.MonadTime.SI (DiffTime) -import Control.Tracer (Tracer (..), stdoutTracer) -import Data.Monoid (Last (..)) +import Control.Tracer (Tracer, mkTracer, stdoutTracer, traceWith) import qualified Data.Time.Clock as DTC import Options.Applicative import qualified Options.Applicative as Opt @@ -98,13 +97,13 @@ run RunOpts , caConfigYaml } = do - configYamlPc <- liftIO . parseNodeConfigurationFP $ Just caConfigYaml + nodeConfig <- liftIO (nodeConfigurationFromFile (unConfigPath caConfigYaml)) + >>= either + (\err -> error $ "Error in creating the NodeConfiguration from " + <> unConfigPath caConfigYaml <> ": " <> err) + return - ptclConfig <- case getProtocolConfiguration configYamlPc of - Nothing -> - error $ "Node protocol configuration was not specified "<> - "in Config yaml filepath: " <> unConfigPath caConfigYaml - Just ptclConfig -> return ptclConfig + let ptclConfig = ncProtocolConfig nodeConfig eitherSomeProtocol <- runExceptT $ mkConsensusProtocol ptclConfig Nothing @@ -113,14 +112,14 @@ run RunOpts Left err -> putStrLn (docToString $ prettyError err) >> exitFailure Right p -> pure p - let (k , nId) = case p of - SomeConsensusProtocol _ runP -> - let ProtocolInfo { pInfoConfig } = fst $ Api.protocolInfo @IO runP - in ( Consensus.configSecurityParam pInfoConfig - , fromNetworkMagic . getNetworkMagic $ Consensus.configBlock pInfoConfig - ) + (k , nId) <- case p of + SomeConsensusProtocol _ runP -> do + ProtocolInfo { pInfoConfig } <- fst <$> Api.protocolInfo @IO runP + pure ( Consensus.configSecurityParam pInfoConfig + , fromNetworkMagic . getNetworkMagic $ Consensus.configBlock pInfoConfig + ) - consensusModeParams = getConsensusMode k ptclConfig + let consensusModeParams = getConsensusMode k ptclConfig chairmanTest (timed stdoutTracer) @@ -134,22 +133,16 @@ run RunOpts return () where getConsensusMode :: SecurityParam -> NodeProtocolConfiguration -> ConsensusModeParams - getConsensusMode (SecurityParam k) ncProtocolConfig = - case ncProtocolConfig of + getConsensusMode (SecurityParam k) ncProtocolConfig' = + case ncProtocolConfig' of NodeProtocolConfigurationCardano{} -> CardanoModeParams $ EpochSlots $ unNonZero k - getProtocolConfiguration - :: PartialNodeConfiguration - -> Maybe NodeProtocolConfiguration - getProtocolConfiguration PartialNodeConfiguration{pncProtocolConfig} = - getLast pncProtocolConfig - timed :: Tracer IO a -> Tracer IO a -timed (Tracer runTracer) = Tracer $ \a -> do +timed tr = mkTracer $ \a -> do ts <- DTC.getCurrentTime IO.putStr ("[" <> show ts <> "] ") - runTracer a + traceWith tr a cmdRun :: Mod CommandFields (IO ()) cmdRun = command "run" $ flip info idm $ run <$> parseRunOpts diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 09db99a60e3..501e44cab1e 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -67,7 +67,7 @@ test-suite chairman-tests build-depends: , cardano-api , cardano-testnet - , cardano-crypto-class ^>=2.3 + , cardano-crypto-class ^>=2.5 , data-default-class , filepath , hedgehog @@ -86,5 +86,5 @@ test-suite chairman-tests ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" build-tool-depends: cardano-node:cardano-node - , cardano-cli:cardano-cli ^>= 11.0 + , cardano-cli:cardano-cli ^>= 11.1 , cardano-node-chairman:cardano-node-chairman diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index 563193bd652..12779ace684 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -4,23 +4,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +import qualified Cardano.Configuration as CC import qualified Cardano.Crypto.Init as Crypto import Cardano.Git.Rev (gitRev) -import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..)) import Cardano.Node.Handlers.TopLevel -import Cardano.Node.Parsers (nodeCLIParser) import Cardano.Node.Run (runNode) import Cardano.Node.Tracing.Documentation (TraceDocumentationCmd (..), parseTraceDocumentationCmd, runTraceDocumentationCmd) -import Data.Monoid (Last (getLast)) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Version (showVersion) import Options.Applicative import qualified Options.Applicative as Opt import System.Info (arch, compilerName, compilerVersion, os) -import System.IO (hPutStrLn, stderr) import Paths_cardano_node (version) @@ -32,28 +29,16 @@ main = do cmd <- Opt.customExecParser p opts case cmd of - RunCmd args -> do - warnIfSet args pncMaybeMempoolCapacityOverride "mempool-capacity-override" "MempoolCapacityBytesOverride" - runNode args + RunCmd args -> runNode args TraceDocumentation tdc -> runTraceDocumentationCmd tdc VersionCmd -> runVersionCommand where p = Opt.prefs Opt.showHelpOnEmpty - warnIfSet :: PartialNodeConfiguration -> (PartialNodeConfiguration -> Last a) -> String -> String -> IO () - warnIfSet args f name key = - maybe - (pure ()) - (\_ -> hPutStrLn stderr $ "WARNING: Option --" ++ name ++ " was set via CLI flags.\ - \ This CLI flag will be removed in upcoming node releases.\ - \ Please, set this configuration option in the configuration file instead with key " ++ key ++ ".") - $ getLast - $ f args - opts :: Opt.ParserInfo Command opts = - Opt.info (fmap RunCmd nodeCLIParser + Opt.info (fmap RunCmd nodeRunParser <|> fmap TraceDocumentation parseTraceDocumentationCmd <|> parseVersionCmd <**> helper) @@ -62,8 +47,11 @@ main = do Opt.progDesc "Start node of the Cardano blockchain." ) +-- | The node's CLI, parsed by @cardano-config@, under the @run@ subcommand. +nodeRunParser :: Parser CC.CliArgs +nodeRunParser = Opt.subparser $ command' "run" "Run the node." CC.parseCliArgs -data Command = RunCmd PartialNodeConfiguration +data Command = RunCmd CC.CliArgs | TraceDocumentation TraceDocumentationCmd | VersionCmd diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 2614d7d7884..07224a1adcb 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -59,7 +59,8 @@ library hs-source-dirs: src - exposed-modules: Cardano.Node.Configuration.NodeAddress + exposed-modules: Cardano.Node.Configuration.Adapter + Cardano.Node.Configuration.NodeAddress Cardano.Node.Configuration.POM Cardano.Node.Configuration.LedgerDB Cardano.Node.Configuration.Socket @@ -67,7 +68,6 @@ library Cardano.Node.Handlers.Shutdown Cardano.Node.Handlers.TopLevel Cardano.Node.Orphans - Cardano.Node.Parsers Cardano.Node.Pretty Cardano.Node.Protocol Cardano.Node.Protocol.Alonzo @@ -123,9 +123,10 @@ library , async , base16-bytestring , bytestring - , cardano-api ^>= 11.0 + , cardano-api ^>= 11.3 + , cardano-config , cardano-data - , cardano-crypto-class ^>=2.3 + , cardano-crypto-class ^>=2.5 , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 , cardano-ledger-alonzo @@ -141,21 +142,22 @@ library , cardano-prelude , cardano-protocol-tpraos >= 1.4 , cardano-slotting >= 0.2 - , cardano-rpc ^>= 10.2 + , cardano-rpc ^>= 11.0 , cborg ^>= 0.2.4 , containers - , contra-tracer + , contra-tracer >= 0.2.1 , data-default-class , deepseq , directory , dns , ekg-core , filepath + , fs-api , generic-data , hashable , hostname , io-classes:{io-classes,strict-stm,si-timers} ^>= 1.8 - , kes-agent ^>=1.2 + , kes-agent ^>=1.3 , microlens , mmap , network-mux @@ -164,8 +166,8 @@ library , network-mux >= 0.8 , nothunks , optparse-applicative - , ouroboros-consensus:{ouroboros-consensus, lmdb, lsm, cardano, diffusion, protocol} ^>= 3.0.1 - , ouroboros-network:{api, ouroboros-network, orphan-instances, framework, protocols, framework-tracing, tracing} ^>= 1.1 + , ouroboros-consensus:{ouroboros-consensus, lsm, cardano, diffusion, protocol} ^>= 3.0.1 + , ouroboros-network:{api, ouroboros-network, orphan-instances, framework, protocols, tracing} ^>= 1.1 , cardano-diffusion:{api, cardano-diffusion, tracing, orphan-instances} ^>=1.0 , prettyprinter , prettyprinter-ansi-terminal @@ -187,7 +189,6 @@ library , transformers , transformers-except , typed-protocols:{typed-protocols, stateful} >= 1.2 - , yaml executable cardano-node import: project-config @@ -205,6 +206,7 @@ executable cardano-node autogen-modules: Paths_cardano_node build-depends: base + , cardano-config , cardano-crypto-class , cardano-git-rev , cardano-node @@ -231,6 +233,7 @@ test-suite cardano-node-test , contra-tracer , directory , filepath + , fs-api , hedgehog , hedgehog-corpus , hedgehog-extras ^>= 0.10 @@ -239,7 +242,6 @@ test-suite cardano-node-test , ouroboros-consensus:{ouroboros-consensus, diffusion} , ouroboros-network:{api, framework, ouroboros-network} , text - , trace-dispatcher , transformers , vector , yaml diff --git a/cardano-node/src/Cardano/Node/Configuration/Adapter.hs b/cardano-node/src/Cardano/Node/Configuration/Adapter.hs new file mode 100644 index 00000000000..d8473f1049f --- /dev/null +++ b/cardano-node/src/Cardano/Node/Configuration/Adapter.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Adapter from the @cardano-config@ package's resolved configuration +-- ('CC.NodeConfiguration') to the node's existing 'PartialNodeConfiguration'. +-- +-- The intent is that the node's entrypoint becomes: +-- +-- @ +-- file <- CC.parseConfigurationFiles (CC.configFilePath cli) +-- let ccnc = CC.resolveConfiguration cli file +-- cfgDir = takeDirectory (CC.configFilePath cli) +-- makeNodeConfiguration (defaultPartialNodeConfiguration <> fromCardanoConfig cfgDir ccnc) +-- @ +-- +-- We deliberately target 'PartialNodeConfiguration' (not the fully-resolved +-- 'NodeConfiguration') so that all of the node's defaulting and validation +-- logic in 'makeNodeConfiguration' is reused verbatim. Whenever +-- @cardano-config@ has no value for a field we leave it as 'mempty' / @Last +-- Nothing@ so the node default applies. +-- +-- NOTE on file paths: genesis and checkpoint files are always sourced from the +-- configuration file and, as in the legacy parser, are resolved relative to the +-- configuration file's directory (the @configDir@ argument). Credential, +-- database and socket paths come (mostly) from the CLI and are left as given, +-- i.e. relative to the current working directory — again matching the legacy +-- 'parseNodeConfigurationFP' / 'AdjustFilePaths' behaviour. +module Cardano.Node.Configuration.Adapter + ( fromCardanoConfig + , nodeConfigurationFromCli + , nodeConfigurationFromFile + , cliArgsFromConfigFile + ) where + +import qualified Cardano.Configuration as CC +import qualified Cardano.Configuration.CliArgs as CCCli +import qualified Cardano.Configuration.File.Consensus as CCCon +import qualified Cardano.Configuration.File.Network as CCNet +import qualified Cardano.Configuration.File.Storage as CCSto + +import Cardano.Api (File (..)) + +import Cardano.Crypto (RequiresNetworkMagic (..)) +import Cardano.Network.ConsensusMode (ConsensusMode (..)) +import Cardano.Network.PeerSelection (NumberOfBigLedgerPeers (..)) +import Cardano.Node.Configuration.LedgerDB (LedgerDbConfiguration (..), + LedgerDbSelectorFlag (..), noDeprecatedOptions) +import Cardano.Node.Configuration.NodeAddress (NodeHostIPv4Address (..), + NodeHostIPv6Address (..)) +import Cardano.Node.Configuration.POM (NodeConfiguration, + PartialNodeConfiguration (..), ResponderCoreAffinityPolicy (..), + defaultPartialNodeConfiguration, makeNodeConfiguration) +import Cardano.Node.Configuration.Socket (SocketConfig (..)) +import Cardano.Node.Handlers.Shutdown (ShutdownConfig (..), ShutdownOn (..)) +import Cardano.Node.Types +import Cardano.Rpc.Server.Config (RpcConfigF (..)) + +import Cardano.Slotting.Block (BlockNo (..)) +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) + +import qualified Cardano.Logging.Types as Net + +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..)) +import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) +import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) +import qualified Ouroboros.Consensus.Node.Genesis as Genesis +import Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), + SnapshotFrequency (..), SnapshotFrequencyArgs (..), + SnapshotPolicyArgs (..), defaultSnapshotPolicyArgs) +import Ouroboros.Consensus.Util.Args (OverrideOrDefault (..)) +-- These three are re-exported (unqualified) from +-- @Ouroboros.Network.Diffusion.Configuration@, exactly as +-- 'Cardano.Node.Configuration.POM' imports them. +import Ouroboros.Network.Diffusion.Configuration (AcceptedConnectionsLimit (..), + DiffusionMode (..), PeerSharing (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionInitDelay (..), + TxSubmissionLogicVersion (..)) + +import Cardano.Ledger.BaseTypes.NonZero (nonZero) + +import Control.Exception (displayException) +import Data.Bifunctor (first) +import Data.Functor.Identity (runIdentity) +import Data.Maybe (fromMaybe) +import Data.Monoid (Last (..)) +import Data.Time.Clock (secondsToDiffTime) +import GHC.Stack (HasCallStack) +import System.FilePath (takeDirectory, ()) + +-- | Parse the configuration file(s) referenced by the CLI arguments, resolve +-- them through @cardano-config@, and build the node's 'NodeConfiguration' +-- (applying the node's own defaults and validation via 'makeNodeConfiguration'). +-- +-- Returns 'Left' with a human-readable message on a resolution or validation +-- error; an I/O error while reading the configuration file is thrown. +nodeConfigurationFromCli :: HasCallStack => CC.CliArgs -> IO (Either String NodeConfiguration) +nodeConfigurationFromCli cli = do + file <- CC.parseConfigurationFiles (CCCli.configFilePath cli) + pure $ do + ccnc <- first displayException (CC.resolveConfiguration cli file) + let cfgDir = takeDirectory (CCCli.configFilePath cli) + makeNodeConfiguration (defaultPartialNodeConfiguration <> fromCardanoConfig cfgDir ccnc) + +-- | Build the node's 'NodeConfiguration' from just a configuration file path, +-- applying no CLI overrides. For tools (e.g. the chairman, tx-generator) that +-- only need the configuration file's contents. +nodeConfigurationFromFile :: HasCallStack => FilePath -> IO (Either String NodeConfiguration) +nodeConfigurationFromFile = nodeConfigurationFromCli . cliArgsFromConfigFile + +-- | The default topology path used by @cardano-config@'s CLI parser, applied +-- when a tool constructs 'CC.CliArgs' without parsing a @--topology@ flag. +defaultTopologyFile :: FilePath +defaultTopologyFile = "configuration/cardano/mainnet-topology.json" + +-- | Build a 'CC.CliArgs' that supplies only the configuration file path, +-- leaving every other option unset. For tools that only need the configuration +-- file's contents, with no CLI overrides. +cliArgsFromConfigFile :: FilePath -> CC.CliArgs +cliArgsFromConfigFile fp = + CCCli.CliArgs + { CCCli.configFilePath = fp + , CCCli.topologyFile = defaultTopologyFile + , CCCli.databasePathCLI = Nothing + , CCCli.validateDatabase = False + , CCCli.socketPath = Nothing + , CCCli.credentials = CCCli.Credentials Nothing Nothing Nothing Nothing Nothing Nothing + , CCCli.startAsNonProducingNode = Nothing + , CCCli.hostAddr = Nothing + , CCCli.hostIPv6Addr = Nothing + , CCCli.port = Nothing + , CCCli.tracerSocket = Nothing + , CCCli.shutdownIPC = Nothing + , CCCli.shutdownOnTarget = Nothing + , CCCli.enableRpcCLI = Nothing + , CCCli.rpcSocketPathCLI = Nothing + } + +-- | Map a resolved @cardano-config@ configuration onto a +-- 'PartialNodeConfiguration'. Combine with +-- @defaultPartialNodeConfiguration <> _@ and feed to @makeNodeConfiguration@. +fromCardanoConfig :: FilePath -> CC.NodeConfiguration -> PartialNodeConfiguration +fromCardanoConfig configDir ccnc = + PartialNodeConfiguration + { pncConfigFile = Last . Just . ConfigYamlFilePath $ CC.configFilePath ccnc + , pncTopologyFile = Last . Just . TopologyFile $ CC.topologyFile ccnc + , pncDatabaseFile = Last . Just . fromDbPaths . runIdentity $ CC.databasePath storage + , pncValidateDB = Last . Just $ CC.validateDatabase ccnc + , pncProtocolFiles = Last . Just $ fromCredentials (CC.credentials ccnc) + , pncShutdownConfig = Last . Just $ ShutdownConfig (CC.shutdownIPC ccnc) (fromShutdownOn <$> CC.shutdownOnTarget ccnc) + , pncSocketConfig = Last . Just $ socketConfig + , pncStartAsNonProducingNode = Last . Just . runIdentity $ CC.startAsNonProducingNode protocol + + -- Protocol-specific parameters + , pncProtocolConfig = Last . Just $ protocolConfig + + -- Modes + , pncDiffusionMode = Last . Just . fromDiffusionMode . runIdentity $ CCNet.diffusionMode net + , pncExperimentalProtocolsEnabled = Last . Just . runIdentity $ CCNet.experimentalProtocolsEnabled net + + -- BlockFetch + , pncMaxConcurrencyBulkSync = Last . Just . MaxConcurrencyBulkSync . runIdentity $ CCNet.maxConcurrencyBulkSync net + , pncMaxConcurrencyDeadline = Last . Just . MaxConcurrencyDeadline . runIdentity $ CCNet.maxConcurrencyDeadline net + + -- Tracing forwarder socket (CLI only) + , pncTraceForwardSocket = Last $ fromTracerConnection <$> CC.tracerSocket ccnc + + -- Mempool + , pncMaybeMempoolCapacityOverride = + Last $ (MempoolCapacityBytesOverride . ByteSize32 . fromIntegral) + <$> CC.mempoolCapacityOverride mempool + , pncMempoolTimeoutSoft = Last $ CC.mempoolTimeoutSoft mempool + , pncMempoolTimeoutHard = Last $ CC.mempoolTimeoutHard mempool + , pncMempoolTimeoutCapacity = Last $ CC.mempoolTimeoutCapacity mempool + + -- LedgerDB + , pncLedgerDbConfig = Last . Just . fromLedgerDb . runIdentity $ CC.ledgerDbConfiguration storage + + -- Network timeouts + , pncProtocolIdleTimeout = Last . Just . runIdentity $ CCNet.protocolIdleTimeout net + , pncTimeWaitTimeout = Last . Just . runIdentity $ CCNet.timeWaitTimeout net + , pncEgressPollInterval = Last . Just . runIdentity $ CCNet.egressPollInterval net + , pncChainSyncIdleTimeout = Last . Just . runIdentity $ CCNet.chainSyncIdleTimeout net + + -- AcceptedConnectionsLimit + , pncAcceptedConnectionsLimit = Last . Just . fromAcceptedConnectionsLimit . runIdentity $ CCNet.acceptedConnectionsLimit net + + -- P2P governor targets (deadline) + , pncDeadlineTargetOfRootPeers = Last $ CCNet.deadlineTargetOfRootPeers net + , pncDeadlineTargetOfKnownPeers = Last $ CCNet.deadlineTargetOfKnownPeers net + , pncDeadlineTargetOfEstablishedPeers = Last $ CCNet.deadlineTargetOfEstablishedPeers net + , pncDeadlineTargetOfActivePeers = Last $ CCNet.deadlineTargetOfActivePeers net + , pncDeadlineTargetOfKnownBigLedgerPeers = Last $ CCNet.deadlineTargetOfKnownBigLedgerPeers net + , pncDeadlineTargetOfEstablishedBigLedgerPeers = Last $ CCNet.deadlineTargetOfEstablishedBigLedgerPeers net + , pncDeadlineTargetOfActiveBigLedgerPeers = Last $ CCNet.deadlineTargetOfActiveBigLedgerPeers net + + -- P2P governor targets (sync) + , pncSyncTargetOfRootPeers = Last . Just . runIdentity $ CCNet.syncTargetOfRootPeers net + , pncSyncTargetOfKnownPeers = Last . Just . runIdentity $ CCNet.syncTargetOfKnownPeers net + , pncSyncTargetOfEstablishedPeers = Last . Just . runIdentity $ CCNet.syncTargetOfEstablishedPeers net + , pncSyncTargetOfActivePeers = Last . Just . runIdentity $ CCNet.syncTargetOfActivePeers net + , pncSyncTargetOfKnownBigLedgerPeers = Last . Just . runIdentity $ CCNet.syncTargetOfKnownBigLedgerPeers net + , pncSyncTargetOfEstablishedBigLedgerPeers = Last . Just . runIdentity $ CCNet.syncTargetOfEstablishedBigLedgerPeers net + , pncSyncTargetOfActiveBigLedgerPeers = Last . Just . runIdentity $ CCNet.syncTargetOfActiveBigLedgerPeers net + + , pncMinBigLedgerPeersForTrustedState = + Last . Just . NumberOfBigLedgerPeers . runIdentity $ CCNet.minBigLedgerPeersForTrustedState net + + -- Consensus mode / Genesis + , pncConsensusMode = Last . Just $ consensusMode + , pncGenesisConfigFlags = Last genesisConfigFlags + + -- Peer sharing + , pncPeerSharing = Last $ fromPeerSharing <$> CCNet.peerSharing net + + , pncResponderCoreAffinityPolicy = + Last . Just . fromResponderCoreAffinity . runIdentity $ CCNet.responderCoreAffinityPolicy net + + , pncTxSubmissionLogicVersion = Last $ fromTxSubmissionLogicVersion (runIdentity (CCNet.txSubmissionLogicVersion net)) + , pncTxSubmissionInitDelay = Last . Just . TxSubmissionInitDelay . runIdentity $ CCNet.txSubmissionInitDelay net + + -- gRPC + , pncRpcConfig = rpcConfig + } + where + storage = CC.storageConfiguration ccnc + consensus = CC.consensusConfiguration ccnc + protocol = CC.protocolConfiguration ccnc + net = CC.networkConfiguration ccnc + testing = CC.testingConfiguration ccnc + mempool = CC.mempoolConfiguration ccnc + lcc = CC.localConnectionsConfig ccnc + + socketConfig = + SocketConfig + (Last $ NodeHostIPv4Address <$> CC.hostAddr ccnc) + (Last $ NodeHostIPv6Address <$> CC.hostIPv6Addr ccnc) + (Last $ CC.port ccnc) + (Last $ File <$> CCNet.socketPath lcc) + + rpcConfig = + RpcConfig + (Last . Just . runIdentity $ CCNet.enableRpc lcc) + (Last $ File <$> CCNet.rpcSocketPath lcc) + mempty + + -- The resolved consensus mode also drives whether the (separate) genesis + -- config flags field is populated. Mirrors the node's split: ConsensusMode + -- (Praos|Genesis) lives in one field, the low-level flags in another. + (consensusMode, genesisConfigFlags) = + case runIdentity (CC.getConsensusConfiguration consensus) of + CCCon.PraosMode -> (PraosMode, Nothing) + CCCon.GenesisMode flags -> (GenesisMode, Just (fromGenesisConfigFlags flags)) + + -- Genesis files always come from the configuration file and are resolved + -- relative to its directory (matching the legacy parser). + genesisFile = toGenesisFile configDir + + protocolConfig = + NodeProtocolConfigurationCardano + (fromByron configDir (CC.byronGenesis protocol)) + (NodeShelleyProtocolConfiguration (genesisFile (CC.shelleyGenesis protocol)) (toGenesisHash (CC.shelleyGenesis protocol))) + (NodeAlonzoProtocolConfiguration (genesisFile (CC.alonzoGenesis protocol)) (toGenesisHash (CC.alonzoGenesis protocol))) + (NodeConwayProtocolConfiguration (genesisFile (CC.conwayGenesis protocol)) (toGenesisHash (CC.conwayGenesis protocol))) + dijkstra + hardFork + checkpoints + + -- Dijkstra is only wired in when the experimental eras are enabled, and its + -- genesis file lives under the Testing component in cardano-config. + dijkstra + | runIdentity (CC.experimentalHardForksEnabled testing) + , Just h <- CC.experimentalGenesis testing + = Just $ NodeDijkstraProtocolConfiguration (genesisFile h) (toGenesisHash h) + | otherwise = Nothing + + hardFork = + NodeHardForkProtocolConfiguration + { npcExperimentalHardForksEnabled = runIdentity (CC.experimentalHardForksEnabled testing) + , npcTestShelleyHardForkAtEpoch = EpochNo <$> CC.testShelleyHardForkAtEpoch testing + , npcTestShelleyHardForkAtVersion = CC.testShelleyHardForkAtVersion testing + , npcTestAllegraHardForkAtEpoch = EpochNo <$> CC.testAllegraHardForkAtEpoch testing + , npcTestAllegraHardForkAtVersion = CC.testAllegraHardForkAtVersion testing + , npcTestMaryHardForkAtEpoch = EpochNo <$> CC.testMaryHardForkAtEpoch testing + , npcTestMaryHardForkAtVersion = CC.testMaryHardForkAtVersion testing + , npcTestAlonzoHardForkAtEpoch = EpochNo <$> CC.testAlonzoHardForkAtEpoch testing + , npcTestAlonzoHardForkAtVersion = CC.testAlonzoHardForkAtVersion testing + , npcTestBabbageHardForkAtEpoch = EpochNo <$> CC.testBabbageHardForkAtEpoch testing + , npcTestBabbageHardForkAtVersion = CC.testBabbageHardForkAtVersion testing + , npcTestConwayHardForkAtEpoch = EpochNo <$> CC.testConwayHardForkAtEpoch testing + , npcTestConwayHardForkAtVersion = CC.testConwayHardForkAtVersion testing + , npcTestDijkstraHardForkAtEpoch = EpochNo <$> CC.testDijkstraHardForkAtEpoch testing + , npcTestDijkstraHardForkAtVersion = CC.testDijkstraHardForkAtVersion testing + } + + checkpoints = + NodeCheckpointsConfiguration + (CheckpointsFile . (configDir ) . CC.hashed <$> CC.checkpointsFile protocol) + (toHash =<< CC.checkpointsFile protocol) + where + toHash h = CheckpointsHash <$> CC.hash h + +-------------------------------------------------------------------------------- +-- Component conversions +-------------------------------------------------------------------------------- + +-- Field order is (immutable, volatile) for both: cardano-config's +-- @SplitDB ImmutablePath VolatilePath@ and the node's +-- @MultipleDbPaths immutable volatile@ (see Cardano.Node.Run). +fromDbPaths :: CC.NodeDatabasePaths -> NodeDatabasePaths +fromDbPaths = \case + CC.SingleDB fp -> OnePathForAllDbs fp + CC.SplitDB im vol -> MultipleDbPaths im vol + +fromCredentials :: CC.Credentials -> ProtocolFilepaths +fromCredentials creds = + ProtocolFilepaths + { byronCertFile = CCCli.byronDelegationCertificate creds + , byronKeyFile = CCCli.byronSigningKey creds + , shelleyKESSource = fromKESSource <$> CCCli.shelleyKES creds + , shelleyVRFFile = CCCli.shelleyVRFKey creds + , shelleyCertFile = CCCli.shelleyOperationalCertificate creds + , shelleyBulkCredsFile = CCCli.bulkCredentialsFile creds + } + +fromKESSource :: CCCli.KESSource -> KESSource +fromKESSource = \case + CCCli.KESKeyFilePath fp -> KESKeyFilePath fp + CCCli.KESAgentSocketPath s -> KESAgentSocketPath s + +fromShutdownOn :: CCCli.ShutdownOn -> ShutdownOn +fromShutdownOn = \case + CCCli.ShutdownAtSlot w -> ASlot (SlotNo w) + CCCli.ShutdownAtBlock w -> ABlock (BlockNo w) + +fromDiffusionMode :: CCNet.DiffusionMode -> DiffusionMode +fromDiffusionMode = \case + CCNet.InitiatorOnly -> InitiatorOnlyDiffusionMode + CCNet.InitiatorAndResponder -> InitiatorAndResponderDiffusionMode + +fromPeerSharing :: Bool -> PeerSharing +fromPeerSharing True = PeerSharingEnabled +fromPeerSharing False = PeerSharingDisabled + +fromResponderCoreAffinity :: String -> ResponderCoreAffinityPolicy +fromResponderCoreAffinity = \case + "ResponderCoreAffinity" -> ResponderCoreAffinity + _ -> NoResponderCoreAffinity + +-- Spellings match the node's orphan @FromJSON TxSubmissionLogicVersion@ +-- (Ouroboros.Network.OrphanInstances). Falls back to the node default +-- (Last Nothing) on an unrecognised value. +fromTxSubmissionLogicVersion :: String -> Maybe TxSubmissionLogicVersion +fromTxSubmissionLogicVersion = \case + "TxSubmissionLogicV1" -> Just TxSubmissionLogicV1 + "TxSubmissionLogicV2" -> Just TxSubmissionLogicV2 + _ -> Nothing + +-- cardano-config: AcceptedConnectionsLimit . +-- ouroboros: AcceptedConnectionsLimit { hard, soft, delay }. +fromAcceptedConnectionsLimit :: CCNet.AcceptedConnectionsLimit -> AcceptedConnectionsLimit +fromAcceptedConnectionsLimit (CCNet.AcceptedConnectionsLimit hard soft delay) = + AcceptedConnectionsLimit hard soft delay + +fromTracerConnection :: CCCli.TracerConnection -> (Net.HowToConnect, Net.ForwarderMode) +fromTracerConnection (CCCli.TracerConnection tag method) = + (howToConnect, forwarderMode tag) + where + howToConnect = case method of + CCCli.TracerConnectViaPipe fp -> Net.LocalPipe fp + CCCli.TracerConnectViaRemote host pn -> Net.RemoteSocket host (fromIntegral pn) + -- "Accept" => we accept an incoming connection (Responder); + -- "Connect" => we connect out (Initiator). The tag comes from + -- cardano-config's TracerConnection (Cardano.Configuration.CliArgs). + forwarderMode "Connect" = Net.Initiator + forwarderMode _ = Net.Responder + +fromGenesisConfigFlags :: CCCon.GenesisConfigFlags -> Genesis.GenesisConfigFlags +fromGenesisConfigFlags f = + Genesis.GenesisConfigFlags + { Genesis.gcfEnableCSJ = CCCon.gcfEnableCSJ f + , Genesis.gcfEnableLoEAndGDD = CCCon.gcfEnableLoEAndGDD f + , Genesis.gcfEnableLoP = CCCon.gcfEnableLoP f + , Genesis.gcfBlockFetchGracePeriod = CCCon.gcfBlockFetchGracePeriod f + , Genesis.gcfBucketCapacity = CCCon.gcfBucketCapacity f + , Genesis.gcfBucketRate = CCCon.gcfBucketRate f + , Genesis.gcfCSJJumpSize = SlotNo <$> CCCon.gcfCSJJumpSize f + , Genesis.gcfGDDRateLimit = CCCon.gcfGDDRateLimit f + } + +fromByron :: FilePath -> CC.ByronGenesisConfiguration -> NodeByronProtocolConfiguration +fromByron configDir b = + NodeByronProtocolConfiguration + { npcByronGenesisFile = toGenesisFile configDir (CC.byronGenesisFile b) + , npcByronGenesisFileHash = toGenesisHash (CC.byronGenesisFile b) + , npcByronReqNetworkMagic = fromReqNetworkMagic (CC.byronReqNetworkMagic b) + , npcByronPbftSignatureThresh = CC.byronPbftSignatureThresh b + , npcByronSupportedProtocolVersionMajor = CC.byronSupportedProtocolVersionMajor b + , npcByronSupportedProtocolVersionMinor = CC.byronSupportedProtocolVersionMinor b + , npcByronSupportedProtocolVersionAlt = fromMaybe 0 (CC.byronSupportedProtocolVersionAlt b) + } + +-- cardano-config uses its own 'RequiresNetworkMagic' enum (absent => default +-- 'RequiresNoMagic'); the node uses the cardano-crypto enum. +fromReqNetworkMagic :: Maybe CC.RequiresNetworkMagic -> RequiresNetworkMagic +fromReqNetworkMagic = \case + Just CC.RequiresMagic -> RequiresMagic + Just CC.RequiresNoMagic -> RequiresNoMagic + Nothing -> RequiresNoMagic + +-- | Resolve a genesis file path relative to the configuration file's directory. +-- @System.FilePath.()@ leaves absolute paths untouched. +toGenesisFile :: FilePath -> CC.Hashed FilePath -> GenesisFile +toGenesisFile configDir = GenesisFile . (configDir ) . CC.hashed + +toGenesisHash :: CC.Hashed FilePath -> Maybe GenesisHash +toGenesisHash = fmap GenesisHash . CC.hash + +-- TODO(adapter): cardano-config's Mithril snapshot policy and the LSM export +-- path have no representation in the node's LedgerDbConfiguration; the Mithril +-- policy falls back to the default and the export path is dropped. The node also +-- does not consume MinDelay/MaxDelay (sfaDelaySnapshotRange is always UseDefault +-- here, mirroring the legacy parser). An absent backend selector defaults to +-- 'V2InMemory'. +fromLedgerDb :: CC.LedgerDbConfiguration -> LedgerDbConfiguration +fromLedgerDb ldb = + LedgerDbConfiguration + snapshotPolicyArgs + queryBatchSize + selector + noDeprecatedOptions + where + snapshotPolicyArgs = + case CC.snapshots ldb of + Nothing -> defaultSnapshotPolicyArgs + Just CCSto.MithrilSnapshotPolicy -> defaultSnapshotPolicyArgs -- TODO(adapter) + Just (CCSto.CustomSnapshotPolicy opts) -> + SnapshotPolicyArgs + (SnapshotFrequency SnapshotFrequencyArgs + { sfaInterval = maybe UseDefault Override (CCSto.snapshotInterval opts >>= nonZero) + , sfaOffset = maybe UseDefault (Override . SlotNo) (CCSto.slotOffset opts) + , sfaRateLimit = maybe UseDefault (Override . secondsToDiffTime . fromIntegral) (CCSto.snapshotRateLimit opts) + , sfaDelaySnapshotRange = UseDefault + }) + (maybe UseDefault (Override . NumOfDiskSnapshots . fromIntegral) (CCSto.numOfDiskSnapshots opts)) + + queryBatchSize = maybe DefaultQueryBatchSize RequestedQueryBatchSize (CC.queryBatchSize ldb) + + selector = case CC.backendSelector ldb of + Nothing -> V2InMemory + Just CCSto.V2InMemory -> V2InMemory + Just (CCSto.V2LSM dbPath _export) -> V2LSM dbPath diff --git a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs index 2c60b7e9d87..276c27aadaa 100644 --- a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Cardano.Node.Configuration.LedgerDB ( DeprecatedOptions (..), @@ -20,8 +21,6 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM @@ -31,6 +30,8 @@ import Data.Proxy import System.FilePath import System.Random (StdGen) +import Ouroboros.Consensus.Ledger.Basics (LedgerState) + -- | Choose the LedgerDB Backend -- -- As of UTxO-HD, the LedgerDB now uses either an in-memory backend or LMDB to @@ -43,18 +44,7 @@ import System.Random (StdGen) -- -- - 'V2LSM': Uses the LSM backend. data LedgerDbSelectorFlag = - V1LMDB - V1.FlushFrequency - -- ^ The frequency at which changes are flushed to the disk. - (Maybe FilePath) - -- ^ Path for the live tables. If not provided the default will be used - -- (@/lmdb@). - (Maybe Gigabytes) - -- ^ A map size can be specified, this is the maximum disk space the LMDB - -- database can fill. If not provided, the default of 16GB will be used. - (Maybe Int) - -- ^ An override to the max number of readers. - | V2InMemory + V2InMemory | V2LSM (Maybe FilePath) -- ^ Maybe a custom path to the LSM database. If not provided the default @@ -73,8 +63,7 @@ noDeprecatedOptions = DeprecatedOptions [] data LedgerDbConfiguration = LedgerDbConfiguration - NumOfDiskSnapshots - SnapshotInterval + SnapshotPolicyArgs QueryBatchSize LedgerDbSelectorFlag DeprecatedOptions @@ -89,63 +78,14 @@ newtype Gigabytes = Gigabytes Int toBytes :: Gigabytes -> Int toBytes (Gigabytes x) = x * 1024 * 1024 * 1024 --- | Recommended settings for the LMDB backing store. --- --- === @'lmdbMapSize'@ --- The default @'LMDBLimits'@ uses an @'lmdbMapSize'@ of @1024 * 1024 * 1024 * 16@ --- bytes, or 16 Gigabytes. @'lmdbMapSize'@ sets the size of the memory map --- that is used internally by the LMDB backing store, and is also the --- maximum size of the on-disk database. 16 GB should be sufficient for the --- medium term, i.e., it is sufficient until a more performant alternative to --- the LMDB backing store is implemented, which will probably replace the LMDB --- backing store altogether. --- --- Note(jdral): It is recommended not to set the @'lmdbMapSize'@ to a value --- that is much smaller than 16 GB through manual configuration: the node will --- die with a fatal error as soon as the database size exceeds the --- @'lmdbMapSize'@. If this fatal error were to occur, we would expect that --- the node can continue normal operation if it is restarted with a higher --- @'lmdbMapSize'@ configured. Nonetheless, this situation should be avoided. --- --- === @'lmdbMaxDatabases'@ --- The @'lmdbMaxDatabases'@ is set to 10, which means that the LMDB backing --- store will allow up @<= 10@ internal databases. We say /internal/ --- databases, since they are not exposed outside the backing store interface, --- such that from the outside view there is just one /logical/ database. --- Two of these internal databases are reserved for normal operation of the --- backing store, while the remaining databases will be used to store ledger --- tables. At the moment, there is at most one ledger table that will be --- stored in an internal database: the UTxO. Nonetheless, we set --- @'lmdbMaxDatabases'@ to @10@ in order to future-proof these limits. --- --- === @'lmdbMaxReaders'@ --- The @'lmdbMaxReaders'@ limit sets the maximum number of threads that can --- read from the LMDB database. Currently, there should only be a single reader --- active. Again, we set @'lmdbMaxReaders'@ to @16@ in order to future-proof --- these limits. --- --- === References --- For more information about LMDB limits, one should inspect: --- * The @lmdb-simple@ and @haskell-lmdb@ forked repositories. --- * The official LMDB API documentation at --- . -defaultLMDBLimits :: LMDB.LMDBLimits -defaultLMDBLimits = LMDB.LMDBLimits { - LMDB.lmdbMapSize = 16 * 1024 * 1024 * 1024 - , LMDB.lmdbMaxDatabases = 10 - , LMDB.lmdbMaxReaders = 16 - } - defaultLMDBPath :: FilePath -> FilePath defaultLMDBPath = ( "lmdb") -selectorToArgs :: forall blk. (LedgerSupportsProtocol blk, LedgerSupportsLedgerDB blk) => LedgerDbSelectorFlag -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen) +selectorToArgs :: + forall blk. + ( LedgerSupportsProtocol blk + , LedgerDbSerialiseConstraints blk + , CanUpgradeLedgerTables LedgerState blk + ) => LedgerDbSelectorFlag -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen) selectorToArgs V2InMemory _ = InMemory.mkInMemoryArgs -selectorToArgs (V1LMDB ff fp l mxReaders) fastStoragePath = - LMDB.mkLMDBArgs - ff - (fromMaybe (defaultLMDBPath fastStoragePath) fp) - ( maybe id (\overrideMaxReaders lim -> lim{LMDB.lmdbMaxReaders = overrideMaxReaders}) mxReaders $ - maybe id (\ll lim -> lim{LMDB.lmdbMapSize = toBytes ll}) l defaultLMDBLimits - ) -selectorToArgs (V2LSM fp) fastStoragePath = LSM.mkLSMArgsIO (Proxy @blk) (fromMaybe "lsm" fp) fastStoragePath +selectorToArgs (V2LSM fp) fastStoragePath = LSM.mkLSMArgsIO (Proxy @blk) (fromMaybe "lsm" fp) Nothing fastStoragePath diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 72a7fc94ff3..f222bab5f36 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -20,14 +20,12 @@ module Cardano.Node.Configuration.POM , defaultPartialNodeConfiguration , lastOption , makeNodeConfiguration - , parseNodeConfigurationFP , pncProtocol , ncProtocol , getForkPolicy ) where -import Cardano.Crypto (RequiresNetworkMagic (..)) import Cardano.Logging.Types import Cardano.Network.ConsensusMode (ConsensusMode (..), defaultConsensusMode) import qualified Cardano.Network.Diffusion.Configuration as Cardano @@ -39,15 +37,12 @@ import Cardano.Node.Protocol.Types (Protocol (..)) import Cardano.Node.Types import Cardano.Rpc.Server.Config (PartialRpcConfig, RpcConfig, RpcConfigF (..), makeRpcConfig) -import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags, defaultGenesisConfigFlags, mkGenesisConfig) import Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), - SnapshotInterval (..)) -import Ouroboros.Consensus.Storage.LedgerDB.V1.Args (FlushFrequency (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultSnapshotPolicyArgs) import Ouroboros.Network.Diffusion.Configuration as Configuration import qualified Ouroboros.Network.Diffusion.Configuration as Ouroboros import qualified Ouroboros.Network.Mux as Mux @@ -57,18 +52,15 @@ import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionIn TxSubmissionLogicVersion (..), defaultTxSubmissionInitDelay) import Control.Concurrent (getNumCapabilities) -import Control.Monad (unless, void, when) +import Control.Monad (unless) import Data.Aeson -import qualified Data.Aeson.Types as Aeson import Data.Hashable (Hashable) import Data.Maybe import Data.Monoid (Last (..)) import Data.Text (Text) -import Data.Time.Clock (DiffTime, secondsToDiffTime) -import Data.Yaml (decodeFileThrow) +import Data.Time.Clock (DiffTime) import GHC.Generics (Generic) import Options.Applicative -import System.FilePath (takeDirectory, ()) import System.Random (randomIO) import Generic.Data (gmappend) @@ -307,360 +299,9 @@ data PartialNodeConfiguration , pncRpcConfig :: !PartialRpcConfig } deriving (Eq, Generic, Show) -instance AdjustFilePaths PartialNodeConfiguration where - adjustFilePaths f x = - x { pncProtocolConfig = adjustFilePaths f (pncProtocolConfig x) - , pncSocketConfig = adjustFilePaths f (pncSocketConfig x) - } - instance Semigroup PartialNodeConfiguration where (<>) = gmappend -instance FromJSON PartialNodeConfiguration where - parseJSON = - withObject "PartialNodeConfiguration" $ \v -> do - pncStartAsNonProducingNode <- Last <$> v .:? "StartAsNonProducingNode" - - -- Node parameters, not protocol-specific - pncSocketPath <- Last <$> v .:? "SocketPath" - pncDatabaseFile <- Last <$> v .:? "DatabasePath" - pncDiffusionMode - <- Last . fmap getDiffusionMode <$> v .:? "DiffusionMode" - pncExperimentalProtocolsEnabled <- fmap Last $ do - mValue <- v .:? "ExperimentalProtocolsEnabled" - - mOldValue <- v .:? "TestEnableDevelopmentNetworkProtocols" - - when (isJust mOldValue) $ do - when (mOldValue /= mValue) $ - fail "TestEnableDevelopmentNetworkProtocols has been renamed to ExperimentalProtocolsEnabled in the configuration file" - - pure mValue - - -- Blockfetch parameters - pncMaxConcurrencyBulkSync <- Last <$> v .:? "MaxConcurrencyBulkSync" - pncMaxConcurrencyDeadline <- Last <$> v .:? "MaxConcurrencyDeadline" - - -- Protocol parameters - protocol <- v .:? "Protocol" .!= CardanoProtocol - pncProtocolConfig <- - case protocol of - CardanoProtocol -> do - hfp <- parseHardForkProtocol v - fmap (Last . Just) $ - NodeProtocolConfigurationCardano - <$> parseByronProtocol v - <*> parseShelleyProtocol v - <*> parseAlonzoProtocol v - <*> parseConwayProtocol v - <*> (if npcExperimentalHardForksEnabled hfp then Just <$> parseDijkstraProtocol v else pure Nothing) - <*> pure hfp - <*> parseCheckpoints v - pncMaybeMempoolCapacityOverride <- Last <$> parseMempoolCapacityBytesOverride v - - -- LedgerDB configuration - pncLedgerDbConfig <- Last <$> parseLedgerDbConfig v - - -- Network timeouts - pncProtocolIdleTimeout <- Last <$> v .:? "ProtocolIdleTimeout" - pncTimeWaitTimeout <- Last <$> v .:? "TimeWaitTimeout" - pncEgressPollInterval <- Last <$> v .:? "EgressPollInterval" - - - -- AcceptedConnectionsLimit - pncAcceptedConnectionsLimit - <- Last <$> v .:? "AcceptedConnectionsLimit" - - -- P2P Governor parameters, with conservative defaults. - pncDeadlineTargetOfRootPeers <- Last <$> v .:? "TargetNumberOfRootPeers" - pncDeadlineTargetOfKnownPeers <- Last <$> v .:? "TargetNumberOfKnownPeers" - pncDeadlineTargetOfEstablishedPeers <- Last <$> v .:? "TargetNumberOfEstablishedPeers" - pncDeadlineTargetOfActivePeers <- Last <$> v .:? "TargetNumberOfActivePeers" - pncDeadlineTargetOfKnownBigLedgerPeers <- Last <$> v .:? "TargetNumberOfKnownBigLedgerPeers" - pncDeadlineTargetOfEstablishedBigLedgerPeers <- Last <$> v .:? "TargetNumberOfEstablishedBigLedgerPeers" - pncDeadlineTargetOfActiveBigLedgerPeers <- Last <$> v .:? "TargetNumberOfActiveBigLedgerPeers" - pncSyncTargetOfRootPeers <- Last <$> v .:? "SyncTargetNumberOfRootPeers" - pncSyncTargetOfKnownPeers <- Last <$> v .:? "SyncTargetNumberOfKnownPeers" - pncSyncTargetOfEstablishedPeers <- Last <$> v .:? "SyncTargetNumberOfEstablishedPeers" - pncSyncTargetOfActivePeers <- Last <$> v .:? "SyncTargetNumberOfActivePeers" - pncSyncTargetOfKnownBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfKnownBigLedgerPeers" - pncSyncTargetOfEstablishedBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfEstablishedBigLedgerPeers" - pncSyncTargetOfActiveBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfActiveBigLedgerPeers" - -- Minimum number of active big ledger peers we must be connected to - -- in Genesis mode - pncMinBigLedgerPeersForTrustedState <- Last <$> v .:? "MinBigLedgerPeersForTrustedState" - - pncConsensusMode <- Last <$> v .:? "ConsensusMode" - - pncChainSyncIdleTimeout <- Last <$> v .:? "ChainSyncIdleTimeout" - - pncMempoolTimeoutSoft <- Last <$> v .:? "MempoolTimeoutSoft" - pncMempoolTimeoutHard <- Last <$> v .:? "MempoolTimeoutHard" - pncMempoolTimeoutCapacity <- Last <$> v .:? "MempoolTimeoutCapacity" - - -- Peer Sharing - pncPeerSharing <- Last <$> v .:? "PeerSharing" - - -- pncConsensusMode determines whether Genesis is enabled in the first place. - pncGenesisConfigFlags <- Last <$> v .:? "LowLevelGenesisOptions" - - pncResponderCoreAffinityPolicy <- - (\a b -> Last a <> Last b) - <$> v .:? "ResponderCoreAffinityPolicy" - <*> v .:? "ForkPolicy" -- deprecated - - pncRpcConfig <- - RpcConfig - <$> (Last <$> v .:? "EnableRpc") - <*> (Last <$> v .:? "RpcSocketPath") - <*> pure mempty - - txSubmissionLogicVersion <- Last <$> v .:? "TxSubmissionLogicVersion" - let parseInitDelay = - maybe (pncTxSubmissionInitDelay defaultPartialNodeConfiguration) (fmap TxSubmissionInitDelay) - <$> v .:? "TxSubmissionInitDelay" - pncTxSubmissionInitDelay <- parseInitDelay - pure PartialNodeConfiguration { - pncProtocolConfig - , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath - , pncDiffusionMode - , pncExperimentalProtocolsEnabled - , pncMaxConcurrencyBulkSync - , pncMaxConcurrencyDeadline - , pncTraceForwardSocket = mempty - , pncConfigFile = mempty - , pncTopologyFile = mempty - , pncDatabaseFile - , pncProtocolFiles = mempty - , pncValidateDB = mempty - , pncShutdownConfig = mempty - , pncStartAsNonProducingNode - , pncMaybeMempoolCapacityOverride - , pncLedgerDbConfig - , pncProtocolIdleTimeout - , pncTimeWaitTimeout - , pncChainSyncIdleTimeout - , pncMempoolTimeoutSoft - , pncMempoolTimeoutHard - , pncMempoolTimeoutCapacity - , pncEgressPollInterval - , pncAcceptedConnectionsLimit - , pncDeadlineTargetOfRootPeers - , pncDeadlineTargetOfKnownPeers - , pncDeadlineTargetOfEstablishedPeers - , pncDeadlineTargetOfActivePeers - , pncDeadlineTargetOfKnownBigLedgerPeers - , pncDeadlineTargetOfEstablishedBigLedgerPeers - , pncDeadlineTargetOfActiveBigLedgerPeers - , pncSyncTargetOfRootPeers - , pncSyncTargetOfKnownPeers - , pncSyncTargetOfEstablishedPeers - , pncSyncTargetOfActivePeers - , pncSyncTargetOfKnownBigLedgerPeers - , pncSyncTargetOfEstablishedBigLedgerPeers - , pncSyncTargetOfActiveBigLedgerPeers - , pncMinBigLedgerPeersForTrustedState - , pncConsensusMode - , pncPeerSharing - , pncGenesisConfigFlags - , pncResponderCoreAffinityPolicy - , pncRpcConfig - , pncTxSubmissionLogicVersion = txSubmissionLogicVersion - , pncTxSubmissionInitDelay - } - where - parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride - where - parseNoOverride = fmap (MempoolCapacityBytesOverride . ByteSize32) <$> v .:? "MempoolCapacityBytesOverride" - parseOverride = do - maybeString :: Maybe String <- v .:? "MempoolCapacityBytesOverride" - case maybeString of - Just "NoOverride" -> return (Just NoMempoolCapacityBytesOverride) - Just invalid -> fmap Just . Aeson.parseFail $ mconcat - [ "Invalid value for 'MempoolCapacityBytesOverride'. " - , "Expecting byte count or NoOverride. Value was: " - , show invalid - ] - Nothing -> return Nothing - - parseLedgerDbConfig v = do - let snapInterval x = fmap (RequestedSnapshotInterval . secondsToDiffTime) <$> x .:? "SnapshotInterval" - snapNum x = fmap RequestedNumOfDiskSnapshots <$> x .:? "NumOfDiskSnapshots" - - mTopLevelSnapInterval <- snapInterval v - mTopLevelSnapNum <- snapNum v - - let topLevelOptionsSet = - zip [ void mTopLevelSnapInterval - , void mTopLevelSnapNum] - ["SnapshotInterval", "NumOfDiskSnapshots"] - deprecatedOpts = DeprecatedOptions [ y | (x, y) <- topLevelOptionsSet, isJust x ] - - mLedgerDB <- v .:? "LedgerDB" - case mLedgerDB of - Nothing -> do - let si = fromMaybe DefaultSnapshotInterval mTopLevelSnapInterval - sn = fromMaybe DefaultNumOfDiskSnapshots mTopLevelSnapNum - return $ Just $ LedgerDbConfiguration sn si DefaultQueryBatchSize V2InMemory deprecatedOpts - Just ledgerDB -> flip (withObject "LedgerDB") ledgerDB $ \o -> do - ldbSnapInterval <- (getLast . (Last mTopLevelSnapInterval <>) . Last <$> snapInterval o) .!= DefaultSnapshotInterval - ldbSnapNum <- (getLast . (Last mTopLevelSnapNum <>) . Last <$> snapNum o) .!= DefaultNumOfDiskSnapshots - qsize <- (fmap RequestedQueryBatchSize <$> o .:? "QueryBatchSize") .!= DefaultQueryBatchSize - backend <- o .:? "Backend" .!= "V2InMemory" - selector <- case backend of - "V1LMDB" -> do - flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency - mapSize :: Maybe Gigabytes <- o .:? "MapSize" - lmdbPath :: Maybe FilePath <- o .:? "LiveTablesPath" - mxReaders :: Maybe Int <- o .:? "MaxReaders" - return $ V1LMDB flush lmdbPath mapSize mxReaders - "V2InMemory" -> return V2InMemory - "V2LSM" -> do - lsmPath :: Maybe FilePath <- o .:? "LSMDatabasePath" - pure $ V2LSM lsmPath - _ -> fail $ "Malformed LedgerDB Backend: " <> backend - pure $ Just $ LedgerDbConfiguration ldbSnapNum ldbSnapInterval qsize selector deprecatedOpts - - parseByronProtocol v = do - primary <- v .:? "ByronGenesisFile" - secondary <- v .:? "GenesisFile" - npcByronGenesisFile <- - case (primary, secondary) of - (Just g, Nothing) -> return g - (Nothing, Just g) -> return g - (Nothing, Nothing) -> fail $ "Missing required field, either " - ++ "ByronGenesisFile or GenesisFile" - (Just _, Just _) -> fail $ "Specify either ByronGenesisFile" - ++ "or GenesisFile, but not both" - npcByronGenesisFileHash <- v .:? "ByronGenesisHash" - - npcByronReqNetworkMagic <- v .:? "RequiresNetworkMagic" - .!= RequiresNoMagic - npcByronPbftSignatureThresh <- v .:? "PBftSignatureThreshold" - protVerMajor <- v .: "LastKnownBlockVersion-Major" - protVerMinor <- v .: "LastKnownBlockVersion-Minor" - protVerAlt <- v .: "LastKnownBlockVersion-Alt" .!= 0 - - pure NodeByronProtocolConfiguration { - npcByronGenesisFile - , npcByronGenesisFileHash - , npcByronReqNetworkMagic - , npcByronPbftSignatureThresh - , npcByronSupportedProtocolVersionMajor = protVerMajor - , npcByronSupportedProtocolVersionMinor = protVerMinor - , npcByronSupportedProtocolVersionAlt = protVerAlt - } - - parseShelleyProtocol v = do - primary <- v .:? "ShelleyGenesisFile" - secondary <- v .:? "GenesisFile" - npcShelleyGenesisFile <- - case (primary, secondary) of - (Just g, Nothing) -> return g - (Nothing, Just g) -> return g - (Nothing, Nothing) -> fail $ "Missing required field, either " - ++ "ShelleyGenesisFile or GenesisFile" - (Just _, Just _) -> fail $ "Specify either ShelleyGenesisFile" - ++ "or GenesisFile, but not both" - npcShelleyGenesisFileHash <- v .:? "ShelleyGenesisHash" - - pure NodeShelleyProtocolConfiguration { - npcShelleyGenesisFile - , npcShelleyGenesisFileHash - } - - parseAlonzoProtocol v = do - npcAlonzoGenesisFile <- v .: "AlonzoGenesisFile" - npcAlonzoGenesisFileHash <- v .:? "AlonzoGenesisHash" - pure NodeAlonzoProtocolConfiguration { - npcAlonzoGenesisFile - , npcAlonzoGenesisFileHash - } - - parseConwayProtocol v = do - npcConwayGenesisFile <- v .: "ConwayGenesisFile" - npcConwayGenesisFileHash <- v .:? "ConwayGenesisHash" - pure NodeConwayProtocolConfiguration { - npcConwayGenesisFile - , npcConwayGenesisFileHash - } - - parseDijkstraProtocol v = do - npcDijkstraGenesisFile <- v .: "DijkstraGenesisFile" - npcDijkstraGenesisFileHash <- v .:? "DijkstraGenesisHash" - pure NodeDijkstraProtocolConfiguration { - npcDijkstraGenesisFile - , npcDijkstraGenesisFileHash - } - - parseHardForkProtocol v = do - - npcExperimentalHardForksEnabled <- do - mValue <- v .:? "ExperimentalHardForksEnabled" - - mOldValue <- v .:? "TestEnableDevelopmentHardForkEras" - - when (isJust mOldValue) $ do - when (mOldValue /= mValue) $ - fail "TestEnableDevelopmentHardForkEras has been renamed to ExperimentalHardForksEnabled in the configuration file" - - pure (fromMaybe False mValue) - - npcTestShelleyHardForkAtEpoch <- v .:? "TestShelleyHardForkAtEpoch" - npcTestShelleyHardForkAtVersion <- v .:? "TestShelleyHardForkAtVersion" - - npcTestAllegraHardForkAtEpoch <- v .:? "TestAllegraHardForkAtEpoch" - npcTestAllegraHardForkAtVersion <- v .:? "TestAllegraHardForkAtVersion" - - npcTestMaryHardForkAtEpoch <- v .:? "TestMaryHardForkAtEpoch" - npcTestMaryHardForkAtVersion <- v .:? "TestMaryHardForkAtVersion" - - npcTestAlonzoHardForkAtEpoch <- v .:? "TestAlonzoHardForkAtEpoch" - npcTestAlonzoHardForkAtVersion <- v .:? "TestAlonzoHardForkAtVersion" - - npcTestBabbageHardForkAtEpoch <- v .:? "TestBabbageHardForkAtEpoch" - npcTestBabbageHardForkAtVersion <- v .:? "TestBabbageHardForkAtVersion" - - npcTestConwayHardForkAtEpoch <- v .:? "TestConwayHardForkAtEpoch" - npcTestConwayHardForkAtVersion <- v .:? "TestConwayHardForkAtVersion" - - (npcTestDijkstraHardForkAtEpoch, npcTestDijkstraHardForkAtVersion) <- if npcExperimentalHardForksEnabled - then (,) <$> v .:? "TestDijkstraHardForkAtEpoch" <*> v .:? "TestDijkstraHardForkAtVersion" - else pure (Nothing, Nothing) - - pure NodeHardForkProtocolConfiguration - { npcExperimentalHardForksEnabled - - , npcTestShelleyHardForkAtEpoch - , npcTestShelleyHardForkAtVersion - - , npcTestAllegraHardForkAtEpoch - , npcTestAllegraHardForkAtVersion - - , npcTestMaryHardForkAtEpoch - , npcTestMaryHardForkAtVersion - - , npcTestAlonzoHardForkAtEpoch - , npcTestAlonzoHardForkAtVersion - - , npcTestBabbageHardForkAtEpoch - , npcTestBabbageHardForkAtVersion - - , npcTestConwayHardForkAtEpoch - , npcTestConwayHardForkAtVersion - - , npcTestDijkstraHardForkAtEpoch - , npcTestDijkstraHardForkAtVersion - } - - parseCheckpoints v = do - npcCheckpointsFile <- v .:? "CheckpointsFile" - npcCheckpointsFileHash <- v .:? "CheckpointsFileHash" - pure NodeCheckpointsConfiguration - { npcCheckpointsFile - , npcCheckpointsFileHash - } - -- | Default configuration is mainnet defaultPartialNodeConfiguration :: PartialNodeConfiguration defaultPartialNodeConfiguration = @@ -683,8 +324,7 @@ defaultPartialNodeConfiguration = , pncLedgerDbConfig = Last $ Just $ LedgerDbConfiguration - DefaultNumOfDiskSnapshots - DefaultSnapshotInterval + defaultSnapshotPolicyArgs DefaultQueryBatchSize V2InMemory noDeprecatedOptions @@ -950,10 +590,3 @@ pncProtocol pnc = case pncProtocolConfig pnc of Last Nothing -> Left "Node protocol configuration not found" Last (Just NodeProtocolConfigurationCardano{}) -> Right CardanoProtocol - -parseNodeConfigurationFP :: Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration -parseNodeConfigurationFP Nothing = parseNodeConfigurationFP . getLast $ pncConfigFile defaultPartialNodeConfiguration -parseNodeConfigurationFP (Just (ConfigYamlFilePath fp)) = do - nc <- decodeFileThrow fp - -- Make all the files be relative to the location of the config file. - pure $ adjustFilePaths (takeDirectory fp ) nc diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs deleted file mode 100644 index 0b42c77dc62..00000000000 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Node.Parsers - ( nodeCLIParser - , parseConfigFile - , parserHelpHeader - , parserHelpOptions - , renderHelpDoc - , parseHostPort - ) where - -import Cardano.Logging.Types -import qualified Cardano.Logging.Types as Net -import Cardano.Node.Configuration.NodeAddress (File (..), - NodeHostIPv4Address (NodeHostIPv4Address), - NodeHostIPv6Address (NodeHostIPv6Address), PortNumber, SocketPath) -import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..), lastOption) -import Cardano.Node.Configuration.Socket -import Cardano.Node.Handlers.Shutdown -import Cardano.Node.Types -import Cardano.Prelude (ConvertText (..)) -import Cardano.Rpc.Server.Config (PartialRpcConfig, RpcConfigF (..)) -import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Node - -import Data.Char (isDigit) -import Data.Foldable -import Data.Maybe (fromMaybe) -import Data.Monoid (Last (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word16, Word32) -import Options.Applicative hiding (str, switch) -import qualified Options.Applicative as Opt -import qualified Options.Applicative.Help as OptI -import qualified Prettyprinter.Internal as PP -import System.Posix.Types (Fd (..)) -import Text.Read (readMaybe) - -nodeCLIParser :: Parser PartialNodeConfiguration -nodeCLIParser = subparser - ( commandGroup "Run the node" - <> metavar "run" - <> command "run" - (info (nodeRunParser <**> helper) - (progDesc "Run the node." )) - ) - -nodeRunParser :: Parser PartialNodeConfiguration -nodeRunParser = do - -- Filepaths - topFp <- lastOption parseTopologyFile - dbFp <- lastOption parseNodeDatabasePaths - validate <- lastOption parseValidateDB - socketFp <- lastOption $ parseSocketPath "socket-path" "Path to a cardano-node socket" - traceForwardSocket <- lastOption parseTracerSocketMode - nodeConfigFp <- lastOption parseConfigFile - - -- Protocol files - byronCertFile <- optional parseByronDelegationCert - byronKeyFile <- optional parseByronSigningKey - shelleyKESSource <- optional parseKesSourceFilePath - shelleyVRFFile <- optional parseVrfKeyFilePath - shelleyCertFile <- optional parseOperationalCertFilePath - shelleyBulkCredsFile <- optional parseBulkCredsFilePath - startAsNonProducingNode <- (\depr new -> Last depr <> Last new) - <$> parseStartAsNonProducingNodeDeprecated - <*> parseStartAsNonProducingNode - - -- Node Address - nIPv4Address <- lastOption parseHostIPv4Addr - nIPv6Address <- lastOption parseHostIPv6Addr - nPortNumber <- lastOption parsePort - - -- Shutdown - shutdownIPC <- lastOption parseShutdownIPC - shutdownOnLimit <- lastOption parseShutdownOn - - -- Hidden options (to be removed eventually) - maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride - - -- gRPC - pncRpcConfig <- parseRpcConfig - - pure $ PartialNodeConfiguration - { pncSocketConfig = - Last . Just $ SocketConfig - nIPv4Address - nIPv6Address - nPortNumber - socketFp - , pncConfigFile = ConfigYamlFilePath <$> nodeConfigFp - , pncTopologyFile = TopologyFile <$> topFp - , pncDatabaseFile = dbFp - , pncDiffusionMode = mempty - , pncExperimentalProtocolsEnabled = mempty - , pncProtocolFiles = Last $ Just ProtocolFilepaths - { byronCertFile - , byronKeyFile - , shelleyKESSource - , shelleyVRFFile - , shelleyCertFile - , shelleyBulkCredsFile - } - , pncValidateDB = validate - , pncShutdownConfig = - Last . Just $ ShutdownConfig (getLast shutdownIPC) (getLast shutdownOnLimit) - , pncStartAsNonProducingNode = startAsNonProducingNode - , pncProtocolConfig = mempty - , pncMaxConcurrencyBulkSync = mempty - , pncMaxConcurrencyDeadline = mempty - , pncTraceForwardSocket = traceForwardSocket - , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride - , pncLedgerDbConfig = mempty - , pncProtocolIdleTimeout = mempty - , pncTimeWaitTimeout = mempty - , pncEgressPollInterval = mempty - , pncChainSyncIdleTimeout = mempty - , pncMempoolTimeoutSoft = mempty - , pncMempoolTimeoutHard = mempty - , pncMempoolTimeoutCapacity = mempty - , pncAcceptedConnectionsLimit = mempty - , pncDeadlineTargetOfRootPeers = mempty - , pncDeadlineTargetOfKnownPeers = mempty - , pncDeadlineTargetOfEstablishedPeers = mempty - , pncDeadlineTargetOfActivePeers = mempty - , pncDeadlineTargetOfKnownBigLedgerPeers = mempty - , pncDeadlineTargetOfEstablishedBigLedgerPeers = mempty - , pncDeadlineTargetOfActiveBigLedgerPeers = mempty - , pncSyncTargetOfRootPeers = mempty - , pncSyncTargetOfKnownPeers = mempty - , pncSyncTargetOfEstablishedPeers = mempty - , pncSyncTargetOfActivePeers = mempty - , pncSyncTargetOfKnownBigLedgerPeers = mempty - , pncSyncTargetOfEstablishedBigLedgerPeers = mempty - , pncSyncTargetOfActiveBigLedgerPeers = mempty - , pncMinBigLedgerPeersForTrustedState = mempty - , pncConsensusMode = mempty - , pncPeerSharing = mempty - , pncGenesisConfigFlags = mempty - , pncResponderCoreAffinityPolicy = mempty - , pncRpcConfig - , pncTxSubmissionLogicVersion = mempty - , pncTxSubmissionInitDelay = mempty - } - -parseSocketPath :: Text -- ^ option name - -> Text -- ^ help text - -> Parser SocketPath -parseSocketPath optionName helpMessage = - fmap File $ strOption $ mconcat - [ long (toS optionName) - , help (toS helpMessage) - , completer (bashCompleter "file") - , metavar "FILEPATH" - ] - - --- leave hostname untouched, non-empty --- 0 <= port <= 65535 -parseNodeAddress :: Opt.ReadM Net.HowToConnect -parseNodeAddress = Opt.eitherReader parseHostPort - -parseHostPort :: String -> Either String Net.HowToConnect -parseHostPort str - | (portRev, ':' : hostRev) <- break (== ':') (reverse str) - = if - | null hostRev -> Left "parseHostPort: Empty host." - | null portRev -> Left "parseHostPort: Empty port." - | all isDigit portRev - , Just port <- readMaybe @Word16 (reverse portRev) -> if - | 0 <= port, port <= 65535 -> Right (Net.RemoteSocket (Text.pack (reverse hostRev)) port) - | otherwise -> Left ("parseHostPort: Numeric port '" ++ show port ++ "' out of range: 0 - 65535)") - | otherwise -> Left "parseHostPort: Non-numeric port." - | otherwise - = Left "parseHostPort: No colon found." - -parseTracerSocketMode :: Parser (Net.HowToConnect, ForwarderMode) -parseTracerSocketMode = - asum - [ fmap (, Responder) $ option parseNodeAddress $ mconcat - [ long "tracer-socket-network-accept" - , help "Accept incoming cardano-tracer connection on HOST:PORT" - , metavar "HOST:PORT" - ] - , fmap (, Initiator) $ option parseNodeAddress $ mconcat - [ long "tracer-socket-network-connect" - , help "Connect to cardano-tracer listening on HOST:PORT" - , metavar "HOST:PORT" - ] - , fmap (\host -> (Net.LocalPipe host, Responder)) $ strOption $ mconcat - [ long "tracer-socket-path-accept" - , help "Accept incoming cardano-tracer connection at local socket" - , completer (bashCompleter "file") - , metavar "FILEPATH" - ] - , fmap (\host -> (Net.LocalPipe host, Initiator)) $ strOption $ mconcat - [ long "tracer-socket-path-connect" - , help "Connect to cardano-tracer listening on a local socket" - , completer (bashCompleter "file") - , metavar "FILEPATH" - ] - ] - -parseHostIPv4Addr :: Parser NodeHostIPv4Address -parseHostIPv4Addr = - Opt.option (eitherReader parseNodeHostIPv4Address) ( - long "host-addr" - <> metavar "IPV4" - <> help "An optional IPv4 address" - ) - -parseHostIPv6Addr :: Parser NodeHostIPv6Address -parseHostIPv6Addr = - Opt.option (eitherReader parseNodeHostIPv6Address) ( - long "host-ipv6-addr" - <> metavar "IPV6" - <> help "An optional IPv6 address" - ) - -parseNodeHostIPv4Address :: String -> Either String NodeHostIPv4Address -parseNodeHostIPv4Address str = - maybe - (Left $ - "Failed to parse IPv4 address: " ++ str ++ - ". If you want to specify an IPv6 address, use --host-ipv6-addr option.") - (Right . NodeHostIPv4Address) - (readMaybe str) - -parseNodeHostIPv6Address :: String -> Either String NodeHostIPv6Address -parseNodeHostIPv6Address str = - maybe - (Left $ - "Failed to parse IPv6 address: " ++ str ++ - ". If you want to specify an IPv4 address, use --host-addr option.") - (Right . NodeHostIPv6Address) - (readMaybe str) - -parsePort :: Parser PortNumber -parsePort = - Opt.option ((fromIntegral :: Int -> PortNumber) <$> auto) ( - long "port" - <> metavar "PORT" - <> help "The port number" - <> value 0 -- Use an ephemeral port - ) - -parseConfigFile :: Parser FilePath -parseConfigFile = - strOption - ( long "config" - <> metavar "NODE-CONFIGURATION" - <> help "Configuration file for the cardano-node" - <> completer (bashCompleter "file") - ) - -parseMempoolCapacityOverride :: Parser MempoolCapacityBytesOverride -parseMempoolCapacityOverride = parseOverride <|> parseNoOverride - where - parseOverride :: Parser MempoolCapacityBytesOverride - parseOverride = - MempoolCapacityBytesOverride . ByteSize32 <$> - Opt.option (auto @Word32) - ( long "mempool-capacity-override" - <> metavar "BYTES" - <> help "[DEPRECATED: Set it in config file with key MempoolCapacityBytesOverride] The number of bytes" - ) - parseNoOverride :: Parser MempoolCapacityBytesOverride - parseNoOverride = - flag' NoMempoolCapacityBytesOverride - ( long "no-mempool-capacity-override" - <> help "[DEPRECATED: Set it in config file] Don't override mempool capacity" - ) - -parseNodeDatabasePaths :: Parser NodeDatabasePaths -parseNodeDatabasePaths = parseDbPath <|> parseMultipleDbPaths - -parseDbPath :: Parser NodeDatabasePaths -parseDbPath = - fmap OnePathForAllDbs $ - strOption $ - mconcat - [ long "database-path" - , metavar "FILEPATH" - , help "Directory where the state is stored." - , completer (bashCompleter "file") - ] - -parseMultipleDbPaths :: Parser NodeDatabasePaths -parseMultipleDbPaths = MultipleDbPaths <$> parseImmutableDbPath <*> parseVolatileDbPath - -parseVolatileDbPath :: Parser FilePath -parseVolatileDbPath = strOption $ - mconcat - [ long "volatile-database-path" - , metavar "FILEPATH" - , help "Directory where the state is stored." - , completer (bashCompleter "file") - ] - -parseImmutableDbPath :: Parser FilePath -parseImmutableDbPath = strOption $ - mconcat - [ long "immutable-database-path" - , metavar "FILEPATH" - , help "Directory where the state is stored." - , completer (bashCompleter "file") - ] - - --- | This parser will always override configuration option, even if the --- `--validate-db` is not present. This is fine for `--validate-db` switch, --- but might not be for something else. See `parseStartAsNonProducingNode` for --- an alternative solution. -parseValidateDB :: Parser Bool -parseValidateDB = - Opt.switch ( - long "validate-db" - <> help "Validate all on-disk database files" - ) - -parseShutdownIPC :: Parser Fd -parseShutdownIPC = - Opt.option (Fd <$> auto) ( - long "shutdown-ipc" - <> metavar "FD" - <> help "Shut down the process when this inherited FD reaches EOF" - <> hidden - ) - -parseTopologyFile :: Parser FilePath -parseTopologyFile = - strOption ( - long "topology" - <> metavar "FILEPATH" - <> help "The path to a file describing the topology." - <> completer (bashCompleter "file") - ) - -parseByronDelegationCert :: Parser FilePath -parseByronDelegationCert = - strOption ( long "byron-delegation-certificate" - <> metavar "FILEPATH" - <> help "Path to the delegation certificate." - <> completer (bashCompleter "file") - ) - <|> - strOption - ( long "delegation-certificate" - <> Opt.internal - ) - -parseByronSigningKey :: Parser FilePath -parseByronSigningKey = - strOption ( long "byron-signing-key" - <> metavar "FILEPATH" - <> help "Path to the Byron signing key." - <> completer (bashCompleter "file") - ) - <|> - strOption ( long "signing-key" - <> Opt.internal - ) - -parseOperationalCertFilePath :: Parser FilePath -parseOperationalCertFilePath = - strOption - ( long "shelley-operational-certificate" - <> metavar "FILEPATH" - <> help "Path to the delegation certificate." - <> completer (bashCompleter "file") - ) - -parseBulkCredsFilePath :: Parser FilePath -parseBulkCredsFilePath = - strOption - ( long "bulk-credentials-file" - <> metavar "FILEPATH" - <> help "Path to the bulk pool credentials file." - <> completer (bashCompleter "file") - ) - -parseKesSourceFilePath :: Parser KESSource -parseKesSourceFilePath = asum - [ KESKeyFilePath <$> - strOption - ( long "shelley-kes-key" - <> metavar "FILEPATH" - <> help "Path to the KES signing key." - <> completer (bashCompleter "file") - ) - , KESAgentSocketPath <$> - strOption - ( long "shelley-kes-agent-socket" - <> metavar "SOCKET_FILEPATH" - <> help "Path to the KES Agent socket" - <> completer (bashCompleter "file") - ) - ] - -parseVrfKeyFilePath :: Parser FilePath -parseVrfKeyFilePath = - strOption - ( long "shelley-vrf-key" - <> metavar "FILEPATH" - <> help "Path to the VRF signing key." - <> completer (bashCompleter "file") - ) - -parseStartAsNonProducingNodeDeprecated :: Parser (Maybe Bool) -parseStartAsNonProducingNodeDeprecated = - flag Nothing (Just True) $ mconcat - [ long "non-producing-node" - , help $ mconcat - [ "DEPRECATED, use --start-as-non-producing-node instead. " - , "This option will be removed in one of the future versions of cardano-node." - ] - , hidden - ] - --- | A parser which returns `Nothing` or `Just True`; the default value is set --- in `defaultPartialNodeConfiguration`. This allows to set this option either --- in the configuration file or as command line flag. -parseStartAsNonProducingNode :: Parser (Maybe Bool) -parseStartAsNonProducingNode = - flag Nothing (Just True) $ mconcat - [ long "start-as-non-producing-node" - , help $ mconcat - [ "Start the node as a non block producing node even if " - , "credentials are specified." - ] - ] - -parseRpcConfig :: Parser PartialRpcConfig -parseRpcConfig = do - isEnabled <- lastOption parseRpcToggle - socketPath <- lastOption parseRpcSocketPath - pure $ RpcConfig isEnabled socketPath mempty - where - parseRpcToggle :: Parser Bool - parseRpcToggle = - Opt.flag' True $ mconcat - [ long "grpc-enable" - , help "[EXPERIMENTAL] Enable node gRPC endpoint." - ] - parseRpcSocketPath :: Parser SocketPath - parseRpcSocketPath = - parseSocketPath - "grpc-socket-path" - "[EXPERIMENTAL] gRPC socket path. Defaults to rpc.sock in the same directory as node socket." - --- | Produce just the brief help header for a given CLI option parser, --- without the options. -parserHelpHeader :: String -> Opt.Parser a -> OptI.Doc -parserHelpHeader = flip (OptI.parserUsage (Opt.prefs mempty)) - --- | Produce just the options help for a given CLI option parser, --- without the header. -parserHelpOptions :: Opt.Parser a -> OptI.Doc -parserHelpOptions = fromMaybe mempty . OptI.unChunk . OptI.fullDesc (Opt.prefs mempty) - --- | Render the help pretty document. -renderHelpDoc :: Int -> OptI.Doc -> String -renderHelpDoc cols = - (`PP.renderShowS` "") . OptI.layoutPretty (OptI.LayoutOptions (OptI.AvailablePerLine cols 1.0)) diff --git a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs index 9e5598b6b50..0904cd4ff50 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -39,6 +39,10 @@ import Ouroboros.Consensus.HardFork.Combinator.Condense () import Prelude import Data.Function ((&)) +import System.FilePath (takeDirectory) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) ------------------------------------------------------------------------------ -- Real Cardano protocol @@ -147,8 +151,12 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { firstExceptT CardanoProtocolInstantiationCheckpointsReadError $ readCheckpointsMap checkpointsConfiguration + -- Filesystem rooted at the Shelley genesis directory, used by the ledger to + -- read initial funds/staking injected from genesis (testnets only). + let shelleyGenesisFS = SomeHasFS $ ioHasFS $ MountPoint $ takeDirectory $ unGenesisFile npcShelleyGenesisFile + return $! - SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano $ Consensus.CardanoProtocolParams { + SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano shelleyGenesisFS $ Consensus.CardanoProtocolParams { Consensus.byronProtocolParams = Consensus.ProtocolParamsByron { byronGenesis = byronGenesis, diff --git a/cardano-node/src/Cardano/Node/Protocol/Conway.hs b/cardano-node/src/Cardano/Node/Protocol/Conway.hs index ef75e1c0c49..c64f5981a52 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Conway.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Conway.hs @@ -98,6 +98,7 @@ emptyConwayGenesis cm = , cgCommittee = DefaultClass.def , cgDelegs = mempty , cgInitialDReps = mempty + , cgExtraConfig = SNothing } diff --git a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index 22ccebee181..a8b930ae882 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -26,6 +26,7 @@ module Cardano.Node.Protocol.Shelley import Cardano.Api hiding (FileError) import qualified Cardano.Api as Api +import Cardano.Api.Experimental.Certificate (OperationalCertificate (..), getHotKey) import qualified Cardano.Crypto.Hash.Class as Crypto import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion) @@ -52,6 +53,10 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString as BS import qualified Data.Text as T import System.Directory (getFileSize) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) +import System.FilePath (takeDirectory) import qualified System.IO.MMap as MMap @@ -81,7 +86,12 @@ mkSomeConsensusProtocolShelley NodeShelleyProtocolConfiguration { leaderCredentials <- firstExceptT PraosLeaderCredentialsError $ readLeaderCredentials files + -- Filesystem rooted at the Shelley genesis directory, used by the ledger to + -- read initial funds/staking injected from genesis (testnets only). + let shelleyGenesisFS = SomeHasFS $ ioHasFS $ MountPoint $ takeDirectory $ unGenesisFile npcShelleyGenesisFile + return $ SomeConsensusProtocol Api.ShelleyBlockType $ Api.ProtocolInfoArgsShelley + shelleyGenesisFS genesis Consensus.ProtocolParamsShelleyBased { shelleyBasedInitialNonce = genesisHashToPraosNonce genesisHash, diff --git a/cardano-node/src/Cardano/Node/Protocol/Types.hs b/cardano-node/src/Cardano/Node/Protocol/Types.hs index 1bf0d8860ca..42fa4d46ef2 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Types.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Types.hs @@ -50,5 +50,5 @@ data SomeConsensusProtocol where , Api.FromCBOR (HeaderHash blk) ) => Api.BlockType blk - -> Api.ProtocolInfoArgs blk + -> Api.ProtocolInfoArgs IO blk -> SomeConsensusProtocol diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index f4f6d43e365..146e543102f 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -28,13 +28,15 @@ import Cardano.Api.Error (displayError) import qualified Cardano.Api as Api import System.Random (randomIO) +import qualified Cardano.Configuration as CC +import qualified Cardano.Configuration.CliArgs as CCCli import qualified Cardano.Crypto.Init as Crypto +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromCli) import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..), - PartialNodeConfiguration (..), TimeoutOverride (..), - defaultPartialNodeConfiguration, makeNodeConfiguration, - parseNodeConfigurationFP, getForkPolicy) + TimeoutOverride (..), + getForkPolicy) import Cardano.Node.Configuration.Socket (LocalSocketOrSocketInfo, SocketOrSocketInfo, SocketOrSocketInfo' (..), gatherConfiguredSockets, getSocketOrSocketInfoAddr) @@ -142,7 +144,6 @@ import Data.IP (toSockAddr) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) -import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.SOP.Dict @@ -154,7 +155,6 @@ import Data.Time.Clock (getCurrentTime) import Network.DNS (Resolver) import Network.Socket (Socket) import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) -import System.FilePath (takeDirectory, ()) import System.IO (hPutStrLn) #ifdef UNIX import GHC.Weak (deRefWeak) @@ -172,9 +172,9 @@ import GHC.Stack {- HLINT ignore "Use fewer imports" -} runNode - :: PartialNodeConfiguration + :: CC.CliArgs -> IO () -runNode cmdPc = do +runNode cli = do installSigTermHandler Crypto.cryptoInit @@ -182,7 +182,7 @@ runNode cmdPc = do nc@NodeConfiguration { ncProtocolConfig , ncProtocolFiles=ncProtocolFiles@ProtocolFilepaths{shelleyVRFFile=mShelleyVrfFile} - } <- buildNodeConfiguration cmdPc + } <- buildNodeConfiguration cli let earlyTracer = stdoutTracer traceWith earlyTracer $ "Node configuration: " <> show nc @@ -198,21 +198,21 @@ runNode cmdPc = do -- don't need these. (Just ncProtocolFiles) - handleNodeWithTracers cmdPc nc consensusProtocol + handleNodeWithTracers cli nc consensusProtocol runThrowExceptT :: Exception e => ExceptT e IO a -> IO a runThrowExceptT act = runExceptT act >>= either Exception.throwIO pure --- | Read node configuration from a file specified in 'PartialNodeConfiguration' +-- | Build the resolved 'NodeConfiguration' from the CLI arguments, using the +-- @cardano-config@ package to parse the configuration file(s) and combine them +-- with the CLI, then the node's own 'makeNodeConfiguration' to apply defaults +-- and validation. See 'Cardano.Node.Configuration.Adapter'. buildNodeConfiguration :: HasCallStack - => PartialNodeConfiguration -- ^ defaults + => CC.CliArgs -> IO NodeConfiguration -buildNodeConfiguration partialConf = do - configYamlPc <- parseNodeConfigurationFP . getLast $ pncConfigFile partialConf - either - (\err -> error $ "Error in creating the NodeConfiguration: " <> err) - pure - $ makeNodeConfiguration (defaultPartialNodeConfiguration <> configYamlPc <> partialConf) +buildNodeConfiguration cli = + nodeConfigurationFromCli cli >>= + either (\err -> error $ "Error in creating the NodeConfiguration: " <> err) pure -- | Workaround to ensure that the main thread throws an async exception on -- receiving a SIGTERM signal. @@ -233,20 +233,18 @@ installSigTermHandler = do return () handleNodeWithTracers - :: PartialNodeConfiguration + :: CC.CliArgs -> NodeConfiguration -> SomeConsensusProtocol -> IO () -handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do - let ProtocolInfo{pInfoConfig} = fst $ Api.protocolInfo @IO runP - networkMagic :: Api.NetworkMagic = getNetworkMagic $ Consensus.configBlock pInfoConfig +handleNodeWithTracers cli nc p@(SomeConsensusProtocol blockType runP) = do + (ProtocolInfo{pInfoConfig}, mkBlockForging) <- Api.protocolInfo @IO runP + let networkMagic :: Api.NetworkMagic = getNetworkMagic $ Consensus.configBlock pInfoConfig -- This IORef contains node kernel structure which holds node kernel. -- Used for ledger queries and peer connection status. nodeKernelData <- mkNodeKernelData - let fp = maybe "No file path found!" - unConfigPath - (getLast (pncConfigFile cmdPc)) - blockForging <- snd (Api.protocolInfo runP) nullTracer + let fp = CCCli.configFilePath cli + blockForging <- mkBlockForging nullTracer tracers <- initTraceDispatcher nc @@ -265,7 +263,7 @@ handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do then DisabledBlockForging else EnabledBlockForging)) - handleSimpleNode blockType runP tracers nc networkMagic + handleSimpleNode blockType runP tracers nc cli networkMagic (\nk -> do setNodeKernel nodeKernelData nk traceWith (nodeStateTracer tracers) NodeKernelOnline) @@ -302,16 +300,19 @@ handleSimpleNode ( Api.Protocol IO blk ) => Api.BlockType blk - -> Api.ProtocolInfoArgs blk + -> Api.ProtocolInfoArgs IO blk -> Tracers RemoteAddress LocalAddress blk IO -> NodeConfiguration + -> CC.CliArgs + -- ^ The original CLI arguments, retained so the SIGHUP handler can re-read and + -- re-resolve the configuration (e.g. to reload the RPC configuration). -> NetworkMagic -> (NodeKernel IO RemoteAddress LocalConnectionId blk -> IO ()) -- ^ Called on the 'NodeKernel' after creating it, but before the network -- layer is initialised. This implies this function must not block, -- otherwise the node won't actually start. -> IO () -handleSimpleNode blockType runP tracers nc networkMagic onKernel = do +handleSimpleNode blockType runP tracers nc cli networkMagic onKernel = do logStartupWarnings logDeprecatedLedgerDBOptions @@ -323,7 +324,7 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do traceWith (startupTracer tracers) StartupDBValidation - let pInfo = fst $ Api.protocolInfo @IO runP + pInfo <- fst <$> Api.protocolInfo @IO runP (publicIPv4SocketOrAddr, publicIPv6SocketOrAddr, localSocketOrPath) <- do result <- runExceptT (gatherConfiguredSockets $ ncSocketConfig nc) @@ -403,7 +404,8 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do } , rnNodeKernelHook = \registry nodeKernel -> do -- set the initial block forging - blockForging <- snd (Api.protocolInfo runP) (Consensus.kesAgentTracer $ consensusTracers tracers) + (_, mkBlockForging) <- Api.protocolInfo runP + blockForging <- mkBlockForging (Consensus.kesAgentTracer $ consensusTracers tracers) unless (ncStartAsNonProducingNode nc) $ setBlockForging nodeKernel blockForging @@ -439,7 +441,7 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) - updateRpcConfiguration (startupTracer tracers) (ncConfigFile nc) rpcConfigVar + updateRpcConfiguration (startupTracer tracers) cli rpcConfigVar traceWith (startupTracer tracers) (BlockForgingUpdate NotEffective) ) Nothing @@ -484,7 +486,7 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do rnNodeKernelHook = \registry nodeKernel -> do -- reinstall `SIGHUP` handler installSigHUPHandler (startupTracer tracers) (Consensus.kesAgentTracer $ consensusTracers tracers) - blockType nc networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar + blockType nc cli networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar useBootstrapVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar rpcConfigVar rnNodeKernelHook nodeArgs registry nodeKernel @@ -561,15 +563,11 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do Just version_ -> Map.takeWhileAntitone (<= version_) LedgerDbConfiguration - snapInterval - numSnaps + snapshotPolicyArgs queryBatchSize ldbBackend deprecatedOpts = ncLedgerDbConfig nc - snapshotPolicyArgs :: SnapshotPolicyArgs - snapshotPolicyArgs = SnapshotPolicyArgs numSnaps snapInterval - -------------------------------------------------------------------------------- -- SIGHUP Handlers -------------------------------------------------------------------------------- @@ -579,6 +577,7 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> Tracer IO KESAgentClientTrace -> Api.BlockType blk -> NodeConfiguration + -> CC.CliArgs -> NetworkMagic -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))] @@ -590,9 +589,9 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> StrictTVar IO RpcConfig -> IO () #ifndef UNIX -installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ _ _ = return () +installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ _ _ _ = return () #else -installSigHUPHandler startupTracer kesAgentTracer blockType nc networkMagic nodeKernel localRootsVar +installSigHUPHandler startupTracer kesAgentTracer blockType nc cli networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar rpcConfigVar = void $ Signals.installHandler @@ -609,7 +608,7 @@ installSigHUPHandler startupTracer kesAgentTracer blockType nc networkMagic node (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) - updateRpcConfiguration startupTracer (ncConfigFile nc) rpcConfigVar + updateRpcConfiguration startupTracer cli rpcConfigVar ) Nothing #endif @@ -638,7 +637,8 @@ updateBlockForging startupTracer kesAgentTracer blockType nodeKernel nc = do case Api.reflBlockType blockType blockType' of Just Refl -> do -- TODO: check if runP' has changed - blockForging <- snd (Api.protocolInfo runP') kesAgentTracer + (_, mkBlockForging) <- Api.protocolInfo runP' + blockForging <- mkBlockForging kesAgentTracer traceWith startupTracer (BlockForgingUpdate (if null blockForging then DisabledBlockForging @@ -786,22 +786,26 @@ rpcServerLoop startupTracer rpcTracer rpcConfigVar networkMagic = go atomically . modifyTVar rpcConfigVar $ \config -> config{isEnabled = Identity False} #ifdef UNIX --- | Reload RPC configuration from the configuration file -updateRpcConfiguration :: Tracer IO (StartupTrace blk) -- ^ tracer tracing the configuration reload - -> ConfigYamlFilePath -- ^ node configuration file, to reload configuration from +-- | Reload RPC configuration from the configuration file. +-- +-- We re-read and re-resolve the whole configuration through @cardano-config@ +-- (reusing 'buildNodeConfiguration'), then keep only the resulting RPC +-- configuration. The CLI arguments are re-applied, so a @--grpc-*@ flag given at +-- startup keeps taking precedence over the configuration file on reload. +updateRpcConfiguration :: HasCallStack + => Tracer IO (StartupTrace blk) -- ^ tracer tracing the configuration reload + -> CC.CliArgs -- ^ CLI arguments, to re-read and re-resolve the configuration -> StrictTVar IO RpcConfig -- ^ TVar storing RPC configuration -> IO () -updateRpcConfiguration tracer configFilePath rpcConfigVar = do - result <- fmap (join . first Exception.displayException) +updateRpcConfiguration tracer cli rpcConfigVar = do + result <- fmap (first Exception.displayException) . try @Exception.SomeException - . fmap makeNodeConfiguration - . parseNodeConfigurationFP - $ Just configFilePath + $ ncRpcConfig <$> buildNodeConfiguration cli case result of Left err -> -- reload failure, we don't do anything this time traceWith tracer (RpcConfigUpdateError $ pack err) - Right NodeConfiguration{ncRpcConfig=newConfig} -> + Right newConfig -> join . atomically $ do oldConfig <- readTVar rpcConfigVar if oldConfig /= newConfig diff --git a/cardano-node/src/Cardano/Node/Startup.hs b/cardano-node/src/Cardano/Node/Startup.hs index af9b9edee9f..a876e4bc919 100644 --- a/cardano-node/src/Cardano/Node/Startup.hs +++ b/cardano-node/src/Cardano/Node/Startup.hs @@ -211,6 +211,27 @@ prepareNodeInfo -> IO NodeInfo prepareNodeInfo nc (SomeConsensusProtocol whichP pForInfo) tc nodeStartTime = do nodeName <- prepareNodeName + cfg <- pInfoConfig . fst <$> Api.protocolInfo @IO pForInfo + let getSystemStartByron = WCT.getSystemStart . getSystemStart . configBlock $ cfg + systemStartTime :: UTCTime + systemStartTime = + case whichP of + Api.ByronBlockType -> + getSystemStartByron + Api.ShelleyBlockType -> + let DegenLedgerConfig cfgShelley = configLedger cfg + in getSystemStartShelley cfgShelley + Api.CardanoBlockType -> + let CardanoLedgerConfig _ cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = configLedger cfg + in minimum [ getSystemStartByron + , getSystemStartShelley cfgShelley + , getSystemStartShelley cfgAllegra + , getSystemStartShelley cfgMary + , getSystemStartShelley cfgAlonzo + , getSystemStartShelley cfgBabbage + , getSystemStartShelley cfgConway + , getSystemStartShelley cfgDijkstra + ] return $ NodeInfo { niName = nodeName , niProtocol = pack . show . ncProtocol $ nc @@ -220,29 +241,6 @@ prepareNodeInfo nc (SomeConsensusProtocol whichP pForInfo) tc nodeStartTime = do , niSystemStartTime = systemStartTime } where - cfg = pInfoConfig $ fst $ Api.protocolInfo @IO pForInfo - - systemStartTime :: UTCTime - systemStartTime = - case whichP of - Api.ByronBlockType -> - getSystemStartByron - Api.ShelleyBlockType -> - let DegenLedgerConfig cfgShelley = configLedger cfg - in getSystemStartShelley cfgShelley - Api.CardanoBlockType -> - let CardanoLedgerConfig _ cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = configLedger cfg - in minimum [ getSystemStartByron - , getSystemStartShelley cfgShelley - , getSystemStartShelley cfgAllegra - , getSystemStartShelley cfgMary - , getSystemStartShelley cfgAlonzo - , getSystemStartShelley cfgBabbage - , getSystemStartShelley cfgConway - , getSystemStartShelley cfgDijkstra - ] - - getSystemStartByron = WCT.getSystemStart . getSystemStart . configBlock $ cfg getSystemStartShelley = sgSystemStart . shelleyLedgerGenesis . shelleyLedgerConfig prepareNodeName = diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index b611c07fc90..addffca92e7 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -93,7 +93,6 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) import qualified Ouroboros.Network.Server as Server (Trace (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) -import Ouroboros.Network.Tracing.PeerSelection () import Ouroboros.Network.TxSubmission.Inbound.V2 (TraceTxSubmissionInbound) import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound) diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index e5b0a998ad6..b51824643c4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -20,9 +20,6 @@ module Cardano.Node.Tracing.Documentation , docTracersFirstPhase ) where -import Ouroboros.Network.Tracing.TxSubmission.Inbound () -import Ouroboros.Network.Tracing.TxSubmission.Outbound () -import Ouroboros.Network.Tracing.PeerSelection () import Cardano.Network.Tracing.PeerSelection () import Cardano.Network.Tracing.PeerSelectionCounters () import Cardano.Git.Rev (gitRev) diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index b048c027c0a..ae7c328db33 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -54,7 +54,6 @@ import Cardano.Protocol.TPraos.Rules.Overlay import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclPredicateFailure (OverlayFailure, UpdnFailure), PrtlSeqFailure (WrongBlockNoPrtclSeq, WrongBlockSequencePrtclSeq, WrongSlotIntervalPrtclSeq)) -import Cardano.Protocol.TPraos.Rules.Tickn (TicknPredicateFailure) import Cardano.Protocol.TPraos.Rules.Updn (UpdnPredicateFailure) import Cardano.Slotting.Block (BlockNo (..)) import Ouroboros.Consensus.Ledger.SupportsMempool (txId) @@ -64,11 +63,14 @@ import Ouroboros.Consensus.Protocol.TPraos (TPraosCannotForge (..)) import Ouroboros.Consensus.Shelley.Ledger hiding (TxId) import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import Ouroboros.Consensus.Shelley.Ledger.Inspect -import qualified Ouroboros.Consensus.Shelley.Protocol.Praos as Praos +import qualified Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks as Praos + (EnvelopeError (..)) import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot) import Ouroboros.Network.Point (WithOrigin, withOriginToMaybe) +import Control.DeepSeq (NFData) + import Data.Aeson (ToJSON (..), Value (..), (.=)) import qualified Data.Aeson.Key as Aeson (fromText) import qualified Data.Aeson.Types as Aeson @@ -220,8 +222,8 @@ instance instance ( Consensus.ShelleyBasedEra era - , LogFormatting (PredicateFailure (ShelleyUTXO era)) - , LogFormatting (PredicateFailure (ShelleyUTXOW era)) + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) , ToJSON (ApplyTxError era) ) => LogFormatting (ApplyTxError era) where @@ -249,9 +251,10 @@ instance instance ( Consensus.ShelleyBasedEra era - , LogFormatting (PredicateFailure (ShelleyUTXO era)) - , LogFormatting (PredicateFailure (ShelleyUTXOW era)) + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) , LogFormatting (PredicateFailure (Ledger.EraRule "BBODY" era)) + , NFData (PredicateFailure (Ledger.EraRule "BBODY" era)) ) => LogFormatting (BlockTransitionError era) where forMachine dtal (BlockTransitionError fs) = mconcat [ "kind" .= String "BlockTransitionError" @@ -320,8 +323,8 @@ instance LogFormatting PrtlSeqFailure where instance ( Consensus.ShelleyBasedEra era - , LogFormatting (PredicateFailure (ShelleyUTXO era)) - , LogFormatting (PredicateFailure (ShelleyUTXOW era)) + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGERS" era)) ) => LogFormatting (ShelleyBbodyPredFailure era) where @@ -342,8 +345,8 @@ instance instance ( Consensus.ShelleyBasedEra era - , LogFormatting (PredicateFailure (ShelleyUTXO era)) - , LogFormatting (PredicateFailure (ShelleyUTXOW era)) + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) ) => LogFormatting (ShelleyLedgersPredFailure era) where forMachine dtal (LedgerFailure f) = forMachine dtal f @@ -360,8 +363,8 @@ instance LogFormatting Withdrawals where instance ( Consensus.ShelleyBasedEra era - , LogFormatting (PredicateFailure (ShelleyUTXO era)) - , LogFormatting (PredicateFailure (ShelleyUTXOW era)) + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) , LogFormatting (PredicateFailure (Ledger.EraRule "DELEGS" era)) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" era)) ) => LogFormatting (ShelleyLedgerPredFailure era) where @@ -430,7 +433,7 @@ formatAsHex (Just bs) = show bs instance ( Consensus.ShelleyBasedEra era - , LogFormatting (PredicateFailure (ShelleyUTXO era)) + , LogFormatting (PredicateFailure (UTXO era)) , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era)) ) => LogFormatting (ShelleyUtxowPredFailure era) where forMachine _dtal (InvalidWitnessesUTXOW wits') = @@ -767,10 +770,6 @@ instance LogFormatting (ShelleyPoolPredFailure era) where ] -instance LogFormatting TicknPredicateFailure where - forMachine _dtal x = case x of {} -- no constructors - - instance ( Ledger.Crypto crypto ) => LogFormatting (PrtclPredicateFailure crypto) where @@ -1325,7 +1324,7 @@ instance LogFormatting (Praos.PraosCannotForge crypto) where , "opCertStartingKesPeriod" .= kesPeriodValue startingKesPeriod ] -instance LogFormatting Praos.PraosEnvelopeError where +instance LogFormatting Praos.EnvelopeError where forMachine _ err' = case err' of Praos.ObsoleteNode maxPtclVersionFromPparams blkHeaderPtclVersion -> diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index cbf985df114..e0d88261a9d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -60,7 +60,7 @@ import qualified Ouroboros.Network.Diffusion as Diffusion import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad (unless) -import "contra-tracer" Control.Tracer (Tracer (..)) +import "contra-tracer" Control.Tracer (mkTracer) import Cardano.Network.OrphanInstances () import Data.Aeson (ToJSON (..)) import Data.Proxy (Proxy (..)) @@ -175,26 +175,26 @@ mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig p = d pure Tracers { - chainDBTracer = Tracer (traceWith chainDBTr') - <> Tracer (traceWith replayBlockTr') - <> Tracer (SR.traceNodeStateChainDB p nodeStateDP) + chainDBTracer = mkTracer (traceWith chainDBTr') + <> mkTracer (traceWith replayBlockTr') + <> mkTracer (SR.traceNodeStateChainDB p nodeStateDP) , consensusTracers = consensusTr - , churnModeTracer = Tracer (traceWith churnModeTr) + , churnModeTracer = mkTracer (traceWith churnModeTr) , nodeToClientTracers = nodeToClientTr , nodeToNodeTracers = nodeToNodeTr , diffusionTracers = diffusionTr - , startupTracer = Tracer (traceWith startupTr) - <> Tracer (SR.traceNodeStateStartup nodeStateDP) - , shutdownTracer = Tracer (traceWith shutdownTr) - <> Tracer (SR.traceNodeStateShutdown nodeStateDP) - , nodeInfoTracer = Tracer (traceWith nodeInfoDP) - , nodeStartupInfoTracer = Tracer (traceWith nodeStartupInfoDP) - , nodeStateTracer = Tracer (traceWith stateTr) - <> Tracer (traceWith nodeStateDP) - , nodeVersionTracer = Tracer (traceWith nodeVersionTr) - , resourcesTracer = Tracer (traceWith resourcesTr) - , ledgerMetricsTracer = Tracer (traceWith ledgerMetricsTr) - , rpcTracer = Tracer (traceWith rpcTr) + , startupTracer = mkTracer (traceWith startupTr) + <> mkTracer (SR.traceNodeStateStartup nodeStateDP) + , shutdownTracer = mkTracer (traceWith shutdownTr) + <> mkTracer (SR.traceNodeStateShutdown nodeStateDP) + , nodeInfoTracer = mkTracer (traceWith nodeInfoDP) + , nodeStartupInfoTracer = mkTracer (traceWith nodeStartupInfoDP) + , nodeStateTracer = mkTracer (traceWith stateTr) + <> mkTracer (traceWith nodeStateDP) + , nodeVersionTracer = mkTracer (traceWith nodeVersionTr) + , resourcesTracer = mkTracer (traceWith resourcesTr) + , ledgerMetricsTracer = mkTracer (traceWith ledgerMetricsTr) + , rpcTracer = mkTracer (traceWith rpcTr) } mkConsensusTracers :: forall blk. @@ -354,60 +354,71 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf !txCountersTracer <- mkCardanoTracer trBase trForward mbTrEKG ["txCounters", "Remote"] + + !txPerasCertIn <- mkCardanoTracer trBase trForward mbTrEKG ["Peras", "Cert", "Inbound"] + !txPerasCertOut <- mkCardanoTracer trBase trForward mbTrEKG ["Peras", "Cert", "Outbound"] + !txPerasVoteIn <- mkCardanoTracer trBase trForward mbTrEKG ["Peras", "Vote", "Inbound"] + !txPerasVoteOut <- mkCardanoTracer trBase trForward mbTrEKG ["Peras", "Vote", "Outbound"] + + configureTracers configReflection trConfig [txCountersTracer] pure $ Consensus.Tracers - { Consensus.chainSyncClientTracer = Tracer $ + { Consensus.chainSyncClientTracer = mkTracer $ traceWith chainSyncClientTr - , Consensus.chainSyncServerHeaderTracer = Tracer $ + , Consensus.chainSyncServerHeaderTracer = mkTracer $ traceWith chainSyncServerHeaderTr <> traceWith chainSyncServerHeaderMetricsTr - , Consensus.chainSyncServerBlockTracer = Tracer $ + , Consensus.chainSyncServerBlockTracer = mkTracer $ traceWith chainSyncServerBlockTr - , Consensus.consensusSanityCheckTracer = Tracer $ + , Consensus.consensusSanityCheckTracer = mkTracer $ traceWith consensusSanityCheckTr - , Consensus.blockFetchDecisionTracer = Tracer $ + , Consensus.blockFetchDecisionTracer = mkTracer $ traceWith blockFetchDecisionTr - , Consensus.blockFetchClientTracer = Tracer $ + , Consensus.blockFetchClientTracer = mkTracer $ traceWith blockFetchClientTr <> traceWith blockFetchClientMetricsTr - , Consensus.blockFetchServerTracer = Tracer $ + , Consensus.blockFetchServerTracer = mkTracer $ traceWith blockFetchServerTr <> traceWith servedBlockLatestTr - , Consensus.forgeStateInfoTracer = Tracer $ + , Consensus.forgeStateInfoTracer = mkTracer $ traceWith (traceAsKESInfo (Proxy @blk) forgeKESInfoTr) - , Consensus.gddTracer = Tracer $ + , Consensus.gddTracer = mkTracer $ traceWith consensusGddTr - , Consensus.txInboundTracer = Tracer $ + , Consensus.txInboundTracer = mkTracer $ traceWith txInboundTr - , Consensus.txOutboundTracer = Tracer $ + , Consensus.txOutboundTracer = mkTracer $ traceWith txOutboundTr - , Consensus.localTxSubmissionServerTracer = Tracer $ + , Consensus.localTxSubmissionServerTracer = mkTracer $ traceWith localTxSubmissionServerTr - , Consensus.mempoolTracer = Tracer $ + , Consensus.mempoolTracer = mkTracer $ traceWith mempoolTr , Consensus.forgeTracer = - Tracer (\(Consensus.TraceLabelCreds _ x) -> traceWith forgeTr x) + mkTracer (\(Consensus.TraceLabelCreds _ x) -> traceWith forgeTr x) <> - Tracer (\(Consensus.TraceLabelCreds _ x) -> traceWith forgeStatsTr x) - , Consensus.blockchainTimeTracer = Tracer $ + mkTracer (\(Consensus.TraceLabelCreds _ x) -> traceWith forgeStatsTr x) + , Consensus.blockchainTimeTracer = mkTracer $ traceWith blockchainTimeTr - , Consensus.keepAliveClientTracer = Tracer $ + , Consensus.keepAliveClientTracer = mkTracer $ traceWith keepAliveClientTr - , Consensus.consensusErrorTracer = Tracer $ + , Consensus.consensusErrorTracer = mkTracer $ traceWith consensusStartupErrorTr . ConsensusStartupException - , Consensus.gsmTracer = Tracer $ + , Consensus.gsmTracer = mkTracer $ traceWith consensusGsmTr - , Consensus.csjTracer = Tracer $ + , Consensus.csjTracer = mkTracer $ traceWith consensusCsjTr - , Consensus.dbfTracer = Tracer $ + , Consensus.dbfTracer = mkTracer $ traceWith consensusDbfTr - , Consensus.kesAgentTracer = Tracer $ + , Consensus.kesAgentTracer = mkTracer $ traceWith consensusKesAgentTr - , Consensus.txLogicTracer = Tracer $ + , Consensus.txLogicTracer = mkTracer $ traceWith txLogicTracer - , Consensus.txCountersTracer = Tracer $ + , Consensus.txCountersTracer = mkTracer $ traceWith txCountersTracer + , Consensus.perasCertDiffusionInboundTracer = mkTracer $ traceWith txPerasCertIn + , Consensus.perasCertDiffusionOutboundTracer = mkTracer $ traceWith txPerasCertOut + , Consensus.perasVoteDiffusionInboundTracer = mkTracer $ traceWith txPerasVoteIn + , Consensus.perasVoteDiffusionOutboundTracer = mkTracer $ traceWith txPerasVoteOut } mkNodeToClientTracers :: forall blk. @@ -445,13 +456,13 @@ mkNodeToClientTracers configReflection trBase trForward mbTrEKG _trDataPoint trC configureTracers configReflection trConfig [stateQueryTr] pure $ NtC.Tracers - { NtC.tChainSyncTracer = Tracer $ + { NtC.tChainSyncTracer = mkTracer $ traceWith chainSyncTr - , NtC.tTxMonitorTracer = Tracer $ + , NtC.tTxMonitorTracer = mkTracer $ traceWith txMonitorTr - , NtC.tTxSubmissionTracer = Tracer $ + , NtC.tTxSubmissionTracer = mkTracer $ traceWith txSubmissionTr - , NtC.tStateQueryTracer = Tracer $ + , NtC.tStateQueryTracer = mkTracer $ traceWith stateQueryTr } @@ -505,25 +516,33 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon !txLogicTracer <- mkCardanoTracer trBase trForward mbTrEKG ["txLogic", "Remote"] + + !txPerasCertDiffusion <- mkCardanoTracer trBase trForward mbTrEKG ["Peras", "Cert", "Inbound"] + !txPerasVoteDiffusion <- mkCardanoTracer trBase trForward mbTrEKG ["Peras", "Vote", "Inbound"] + configureTracers configReflection trConfig [txLogicTracer] pure $ NtN.Tracers - { NtN.tChainSyncTracer = Tracer $ + { NtN.tChainSyncTracer = mkTracer $ traceWith chainSyncTracer - , NtN.tChainSyncSerialisedTracer = Tracer $ + , NtN.tChainSyncSerialisedTracer = mkTracer $ traceWith chainSyncSerialisedTr - , NtN.tBlockFetchTracer = Tracer $ + , NtN.tBlockFetchTracer = mkTracer $ traceWith blockFetchTr - , NtN.tBlockFetchSerialisedTracer = Tracer $ + , NtN.tBlockFetchSerialisedTracer = mkTracer $ traceWith blockFetchSerialisedTr - , NtN.tTxSubmission2Tracer = Tracer $ + , NtN.tTxSubmission2Tracer = mkTracer $ traceWith txSubmission2Tracer - , NtN.tKeepAliveTracer = Tracer $ + , NtN.tKeepAliveTracer = mkTracer $ traceWith keepAliveTracer - , NtN.tPeerSharingTracer = Tracer $ + , NtN.tPeerSharingTracer = mkTracer $ traceWith peerSharingTracer - , NtN.tTxLogicTracer = Tracer $ + , NtN.tTxLogicTracer = mkTracer $ traceWith txLogicTracer + , NtN.tPerasCertDiffusionTracer = mkTracer $ + traceWith txPerasCertDiffusion + , NtN.tPerasVoteDiffusionTracer = mkTracer $ + traceWith txPerasVoteDiffusion } mkDiffusionTracers :: @@ -668,54 +687,54 @@ mkDiffusionTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf configureTracers configReflection trConfig [dtDnsTr] pure $ Diffusion.Tracers - { Diffusion.dtMuxTracer = Tracer $ + { Diffusion.dtMuxTracer = mkTracer $ traceWith dtMuxTr - , Diffusion.dtChannelTracer = Tracer $ + , Diffusion.dtChannelTracer = mkTracer $ traceWith dtChannelTracer - , Diffusion.dtBearerTracer = Tracer $ + , Diffusion.dtBearerTracer = mkTracer $ traceWith dtBearerTracer - , Diffusion.dtHandshakeTracer = Tracer $ + , Diffusion.dtHandshakeTracer = mkTracer $ traceWith dtHandshakeTracer - , Diffusion.dtLocalMuxTracer = Tracer $ + , Diffusion.dtLocalMuxTracer = mkTracer $ traceWith dtLocalMuxTr - , Diffusion.dtLocalChannelTracer = Tracer $ + , Diffusion.dtLocalChannelTracer = mkTracer $ traceWith dtLocalChannelTracer - , Diffusion.dtLocalBearerTracer = Tracer $ + , Diffusion.dtLocalBearerTracer = mkTracer $ traceWith dtLocalBearerTracer - , Diffusion.dtLocalHandshakeTracer = Tracer $ + , Diffusion.dtLocalHandshakeTracer = mkTracer $ traceWith dtLocalHandshakeTracer - , Diffusion.dtDiffusionTracer = Tracer $ + , Diffusion.dtDiffusionTracer = mkTracer $ traceWith dtDiffusionInitializationTr - , Diffusion.dtTraceLocalRootPeersTracer = Tracer $ + , Diffusion.dtTraceLocalRootPeersTracer = mkTracer $ traceWith localRootPeersTr - , Diffusion.dtTracePublicRootPeersTracer = Tracer $ + , Diffusion.dtTracePublicRootPeersTracer = mkTracer $ traceWith publicRootPeersTr - , Diffusion.dtTracePeerSelectionTracer = Tracer $ + , Diffusion.dtTracePeerSelectionTracer = mkTracer $ traceWith peerSelectionTr - , Diffusion.dtDebugPeerSelectionTracer = Tracer $ + , Diffusion.dtDebugPeerSelectionTracer = mkTracer $ traceWith debugPeerSelectionTr - , Diffusion.dtTracePeerSelectionCounters = Tracer $ + , Diffusion.dtTracePeerSelectionCounters = mkTracer $ traceWith peerSelectionCountersTr - , Diffusion.dtPeerSelectionActionsTracer = Tracer $ + , Diffusion.dtPeerSelectionActionsTracer = mkTracer $ traceWith peerSelectionActionsTr - , Diffusion.dtConnectionManagerTracer = Tracer $ + , Diffusion.dtConnectionManagerTracer = mkTracer $ traceWith connectionManagerTr - , Diffusion.dtConnectionManagerTransitionTracer = Tracer $ + , Diffusion.dtConnectionManagerTransitionTracer = mkTracer $ traceWith connectionManagerTransitionsTr - , Diffusion.dtServerTracer = Tracer $ + , Diffusion.dtServerTracer = mkTracer $ traceWith serverTr - , Diffusion.dtInboundGovernorTracer = Tracer $ + , Diffusion.dtInboundGovernorTracer = mkTracer $ traceWith inboundGovernorTr - , Diffusion.dtLocalInboundGovernorTracer = Tracer $ + , Diffusion.dtLocalInboundGovernorTracer = mkTracer $ traceWith localInboundGovernorTr - , Diffusion.dtInboundGovernorTransitionTracer = Tracer $ + , Diffusion.dtInboundGovernorTransitionTracer = mkTracer $ traceWith inboundGovernorTransitionsTr - , Diffusion.dtLocalConnectionManagerTracer = Tracer $ + , Diffusion.dtLocalConnectionManagerTracer = mkTracer $ traceWith localConnectionManagerTr - , Diffusion.dtLocalServerTracer = Tracer $ + , Diffusion.dtLocalServerTracer = mkTracer $ traceWith localServerTr - , Diffusion.dtTraceLedgerPeersTracer = Tracer $ + , Diffusion.dtTraceLedgerPeersTracer = mkTracer $ traceWith dtLedgerPeersTr - , Diffusion.dtDnsTracer = Tracer $ + , Diffusion.dtDnsTracer = mkTracer $ traceWith dtDnsTr } diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 1427af94e67..4380a8e9414 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -43,12 +43,11 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (chunkN import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM -import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import qualified Ouroboros.Consensus.Storage.PerasVoteDB as PerasVoteDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense (condense) @@ -59,6 +58,7 @@ import Ouroboros.Network.Block (MaxSlotNo (..)) import Data.Aeson (Object, ToJSON, Value (Object, String), object, toJSON, (.=)) import qualified Data.ByteString.Base16 as B16 import Data.Int (Int64) +import qualified Data.List.NonEmpty as NonEmpty import Data.SOP (All, K (..), hcmap, hcollapse) import Data.Text (Text) import qualified Data.Text as Text @@ -104,6 +104,7 @@ instance ( LogFormatting (Header blk) ) => LogFormatting (ChainDB.TraceEvent blk) where forHuman ChainDB.TraceLastShutdownUnclean = "ChainDB is not clean. Validating all immutable chunks" + forHuman (ChainDB.TracePerasVoteDbEvent v) = forHuman v forHuman (ChainDB.TraceAddBlockEvent v) = forHuman v forHuman (ChainDB.TraceFollowerEvent v) = forHuman v forHuman (ChainDB.TraceCopyToImmutableDBEvent v) = forHuman v @@ -130,6 +131,8 @@ instance ( LogFormatting (Header blk) RisingEdge -> "risingEdge" .= True FallingEdgeWith pt -> "fallingEdge" .= forMachine dtal pt ] + forMachine details (ChainDB.TracePerasVoteDbEvent v) = + forMachine details v forMachine details (ChainDB.TraceAddBlockEvent v) = forMachine details v forMachine details (ChainDB.TraceFollowerEvent v) = @@ -158,6 +161,7 @@ instance ( LogFormatting (Header blk) asMetrics ChainDB.TraceLastShutdownUnclean = [] asMetrics (ChainDB.TraceChainSelStarvationEvent _) = [] + asMetrics (ChainDB.TracePerasVoteDbEvent v) = asMetrics v asMetrics (ChainDB.TraceAddBlockEvent v) = asMetrics v asMetrics (ChainDB.TraceFollowerEvent v) = asMetrics v asMetrics (ChainDB.TraceCopyToImmutableDBEvent v) = asMetrics v @@ -177,6 +181,8 @@ instance MetaTrace (ChainDB.TraceEvent blk) where Namespace [] ["LastShutdownUnclean"] namespaceFor ChainDB.TraceChainSelStarvationEvent{} = Namespace [] ["ChainSelStarvationEvent"] + namespaceFor (ChainDB.TracePerasVoteDbEvent ev) = + nsPrependInner "PerasVoteDbEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceAddBlockEvent ev) = nsPrependInner "AddBlockEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceFollowerEvent ev) = @@ -1642,6 +1648,79 @@ instance MetaTrace (ChainDB.UnknownRange blk) where , Namespace [] ["ForkTooOld"] ] +-- -------------------------------------------------------------------------------- +-- -- Peras +-- -------------------------------------------------------------------------------- + +instance MetaTrace (PerasVoteDB.TraceEvent blk) where + namespaceFor (PerasVoteDB.AddVote {}) = Namespace [] ["AddVote"] + namespaceFor (PerasVoteDB.GarbageCollected {}) = Namespace [] ["GarbageCollected"] + allNamespaces = + [ Namespace [] ["AddVote"] + , Namespace [] ["GarbageCollected"] + ] + + severityFor _ _ = Just Info + privacyFor _ _ = Just Public + detailsFor _ _ = Just DNormal + + documentFor (Namespace _ ["AddVote"]) = Just "AddVote" + documentFor (Namespace _ ["GarbageCollected"]) = Just "GarbageCollected" + documentFor _ = Nothing + +instance StandardHash blk => LogFormatting (PerasVoteDB.TraceEvent blk) where + forHuman (PerasVoteDB.AddVote voteId _vote result) = + "Peras vote " <> Text.pack (show voteId) <> ": " <> Text.pack (show result) + forHuman (PerasVoteDB.GarbageCollected slotNo) = + "Peras vote DB garbage collected at slot " <> Text.pack (show slotNo) + + forMachine _dtal (PerasVoteDB.AddVote voteId _vote result) = + mconcat [ "kind" .= String "AddVote" + , "voteId" .= String (Text.pack $ show voteId) + , "result" .= String (Text.pack $ show result) + ] + forMachine _dtal (PerasVoteDB.GarbageCollected slotNo) = + mconcat [ "kind" .= String "GarbageCollected" + , "slot" .= String (Text.pack $ show slotNo) + ] + + asMetrics _ = [] + +instance MetaTrace (PerasCertDB.TraceEvent blk) where + namespaceFor (PerasCertDB.AddCert _ _ _) = Namespace [] ["AddCert"] + namespaceFor (PerasCertDB.GarbageCollected _) = Namespace [] ["GarbageCollected"] + allNamespaces = + [ Namespace [] ["AddCert"] + , Namespace [] ["GarbageCollected"] + ] + + severityFor _ _ = Just Info + privacyFor _ _ = Just Public + detailsFor _ _ = Just DNormal + + documentFor (Namespace _ ["AddCert"]) = Just "AddCert" + documentFor (Namespace _ ["GarbageCollected"]) = Just "GarbageCollected" + documentFor _ = Nothing + +instance LogFormatting (PerasCertDB.TraceEvent blk) where + forHuman (PerasCertDB.AddCert roundNo _cert result) = + "Peras certificate for round " <> Text.pack (show roundNo) <> ": " <> Text.pack (show result) + forHuman (PerasCertDB.GarbageCollected slotNo) = + "Peras certificate DB garbage collected at slot " <> Text.pack (show slotNo) + + forMachine _dtal (PerasCertDB.AddCert roundNo _cert result) = + mconcat [ "kind" .= String "AddCert" + , "round" .= String (Text.pack $ show roundNo) + , "result" .= String (Text.pack $ show result) + ] + forMachine _dtal (PerasCertDB.GarbageCollected slotNo) = + mconcat [ "kind" .= String "GarbageCollected" + , "slot" .= String (Text.pack $ show slotNo) + ] + + asMetrics _ = [] + + -- -------------------------------------------------------------------------------- -- -- LedgerDB.TraceEvent -- -------------------------------------------------------------------------------- @@ -1712,6 +1791,13 @@ instance MetaTrace (LedgerDB.TraceEvent blk) where instance ( StandardHash blk , ConvertRawHash blk) => LogFormatting (LedgerDB.TraceSnapshotEvent blk) where + forHuman (LedgerDB.SnapshotRequestDelayed _snapshotRequestTime delayBeforeSnapshotting slots) = + Text.unwords [ "Scheduling to take ledger state snapshots at slots " + , showT (NonEmpty.toList slots) + , ", with a randomised delay of" + , showT delayBeforeSnapshotting + ] + forHuman LedgerDB.SnapshotRequestCompleted = "Completed taking a ledger state snapshot" forHuman (LedgerDB.TookSnapshot snap pt RisingEdge) = Text.unwords [ "Taking ledger snapshot" , showT snap @@ -1750,6 +1836,15 @@ instance ( StandardHash blk " Snapshot was created for a different backend. Convert it with `snapshot-converter`." _ -> "" + forMachine _dtals (LedgerDB.SnapshotRequestDelayed snapshotRequestTime delayBeforeSnapshotting slots) = + mconcat [ "kind" .= String "SnapshotRequestDelayed" + , "requestTime" .= show snapshotRequestTime + , "delayBeforeSnapshotting" .= show delayBeforeSnapshotting + , "slots" .= toJSON (NonEmpty.toList slots) + ] + forMachine _dtals LedgerDB.SnapshotRequestCompleted = + mconcat [ "kind" .= String "SnapshotRequestCompleted" + ] forMachine dtals (LedgerDB.TookSnapshot snap pt enclosedTiming) = mconcat [ "kind" .= String "TookSnapshot" , "snapshot" .= forMachine dtals snap @@ -1765,10 +1860,14 @@ instance ( StandardHash blk , "failure" .= show failure ] instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where + namespaceFor LedgerDB.SnapshotRequestDelayed {} = Namespace [] ["SnapshotRequestDelayed"] + namespaceFor LedgerDB.SnapshotRequestCompleted {} = Namespace [] ["SnapshotRequestCompleted"] namespaceFor LedgerDB.TookSnapshot {} = Namespace [] ["TookSnapshot"] namespaceFor LedgerDB.DeletedSnapshot {} = Namespace [] ["DeletedSnapshot"] namespaceFor LedgerDB.InvalidSnapshot {} = Namespace [] ["InvalidSnapshot"] + severityFor (Namespace _ ["SnapshotRequestDelayed"]) _ = Just Debug + severityFor (Namespace _ ["SnapshotRequestCompleted"]) _ = Just Debug severityFor (Namespace _ ["TookSnapshot"]) _ = Just Info severityFor (Namespace _ ["DeletedSnapshot"]) _ = Just Debug severityFor (Namespace _ ["InvalidSnapshot"]) _ = Just Error @@ -1786,12 +1885,18 @@ instance MetaTrace (LedgerDB.TraceSnapshotEvent blk) where , " seems to be from an old node or different backend, it will" , " be deleted" ] + documentFor (Namespace _ ["SnapshotRequestDelayed"]) = Just + "A delayed snapshot request was issued. The snapshot will be initiated at the specified timestamp, with the specified delay and for the specified slots" + documentFor (Namespace _ ["SnapshotRequestCompleted"]) = Just + "The delayed snapshot request was completed" documentFor _ = Nothing allNamespaces = [ Namespace [] ["TookSnapshot"] , Namespace [] ["DeletedSnapshot"] , Namespace [] ["InvalidSnapshot"] + , Namespace [] ["SnapshotRequestDelayed"] + , Namespace [] ["SnapshotRequestCompleted"] ] -------------------------------------------------------------------------------- @@ -2018,303 +2123,28 @@ instance MetaTrace LedgerDB.TraceForkerEvent where -------------------------------------------------------------------------------- instance LogFormatting LedgerDB.FlavorImplSpecificTrace where - forMachine dtal (LedgerDB.FlavorImplSpecificTraceV1 ev) = forMachine dtal ev forMachine dtal (LedgerDB.FlavorImplSpecificTraceV2 ev) = forMachine dtal ev - forHuman (LedgerDB.FlavorImplSpecificTraceV1 ev) = forHuman ev forHuman (LedgerDB.FlavorImplSpecificTraceV2 ev) = forHuman ev instance MetaTrace LedgerDB.FlavorImplSpecificTrace where - namespaceFor (LedgerDB.FlavorImplSpecificTraceV1 ev) = - nsPrependInner "V1" (namespaceFor ev) namespaceFor (LedgerDB.FlavorImplSpecificTraceV2 ev) = nsPrependInner "V2" (namespaceFor ev) - severityFor (Namespace out ("V1" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.SomeBackendTrace) Nothing - severityFor (Namespace out ("V1" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV1 ev)) = - severityFor (Namespace out tl :: Namespace V1.SomeBackendTrace) (Just ev) severityFor (Namespace out ("V2" : tl)) Nothing = severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) Nothing severityFor (Namespace out ("V2" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV2 ev)) = severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) (Just ev) severityFor _ _ = Nothing - documentFor (Namespace out ("V1" : tl)) = - documentFor (Namespace out tl :: Namespace V1.SomeBackendTrace) documentFor (Namespace out ("V2" : tl)) = documentFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) documentFor _ = Nothing allNamespaces = - map (nsPrependInner "V1") - (allNamespaces :: [Namespace V1.SomeBackendTrace]) - ++ map (nsPrependInner "V2") + map (nsPrependInner "V2") (allNamespaces :: [Namespace V2.LedgerDBV2Trace]) --------------------------------------------------------------------------------- --- V1 --------------------------------------------------------------------------------- - -unwrapV1Trace :: forall a backend. Typeable backend => (V1.Trace LMDB.LMDB -> a) -> V1.Trace backend -> a -unwrapV1Trace g ev = - case cast @(V1.Trace backend) @(V1.Trace LMDB.LMDB) ev of - Just t -> g t - _ -> error "blah" - -instance LogFormatting V1.SomeBackendTrace where - forMachine dtal (V1.SomeBackendTrace ev) = - unwrapV1Trace (forMachine dtal) ev - - forHuman (V1.SomeBackendTrace ev) = - unwrapV1Trace forHuman ev - -instance MetaTrace V1.SomeBackendTrace where - namespaceFor (V1.SomeBackendTrace ev) = - unwrapV1Trace (nsPrependInner "LMDB" . namespaceFor) ev - - severityFor (Namespace out ("LMDB" : tl)) (Just (V1.SomeBackendTrace ev)) = - unwrapV1Trace (severityFor (Namespace out tl :: Namespace (V1.Trace LMDB.LMDB)) . Just) ev - severityFor (Namespace _ ("LMDB" : _)) Nothing = - Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ("LMDB" : _)) = - Just "An LMDB trace" - documentFor _ = Nothing - - allNamespaces = - map (nsPrependInner "LMDB") - (allNamespaces :: [Namespace (V1.Trace LMDB.LMDB)]) - -instance LogFormatting (V1.Trace LMDB.LMDB) where - forMachine _dtal (LMDB.OnDiskBackingStoreInitialise limits) = - mconcat [ "kind" .= String "LMDBBackingStoreInitialise", "limits" .= showT limits ] - forMachine dtal (LMDB.OnDiskBackingStoreTrace ev) = forMachine dtal ev - - forHuman (LMDB.OnDiskBackingStoreInitialise limits) = "Initializing LMDB backing store with limits " <> showT limits - forHuman (LMDB.OnDiskBackingStoreTrace ev) = forHuman ev - -instance MetaTrace (V1.Trace LMDB.LMDB) where - namespaceFor LMDB.OnDiskBackingStoreInitialise{} = - Namespace [] ["Initialise"] - namespaceFor (LMDB.OnDiskBackingStoreTrace ev) = - nsPrependInner "BackingStoreEvent" (namespaceFor ev) - - severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug - severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing - severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (LMDB.OnDiskBackingStoreTrace ev)) = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Initialise" : _)) = Just - "Backing store is being initialised" - documentFor (Namespace out ("BackingStoreEvent" : tl)) = - documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) - documentFor _ = Nothing - - allNamespaces = - Namespace [] ["Initialise"] - : map (nsPrependInner "BackingStoreEvent") - (allNamespaces :: [Namespace V1.BackingStoreTrace]) - -instance LogFormatting V1.BackingStoreTrace where - forMachine _dtals V1.BSOpening = mempty - forMachine _dtals (V1.BSOpened p) = - maybe mempty (\p' -> mconcat [ "path" .= showT p' ]) p - forMachine _dtals (V1.BSInitialisingFromCopy p) = - mconcat [ "path" .= showT p ] - forMachine _dtals (V1.BSInitialisedFromCopy p) = - mconcat [ "path" .= showT p ] - forMachine _dtals (V1.BSInitialisingFromValues sl) = - mconcat [ "slot" .= showT sl ] - forMachine _dtals (V1.BSInitialisedFromValues sl) = - mconcat [ "slot" .= showT sl ] - forMachine _dtals V1.BSClosing = mempty - forMachine _dtals V1.BSAlreadyClosed = mempty - forMachine _dtals V1.BSClosed = mempty - forMachine _dtals (V1.BSCopying p) = - mconcat [ "path" .= showT p ] - forMachine _dtals (V1.BSCopied p) = - mconcat [ "path" .= showT p ] - forMachine _dtals V1.BSCreatingValueHandle = mempty - forMachine _dtals V1.BSCreatedValueHandle = mempty - forMachine _dtals (V1.BSWriting s) = - mconcat [ "slot" .= showT s ] - forMachine _dtals (V1.BSWritten s1 s2) = - mconcat [ "old" .= showT s1, "new" .= showT s2 ] - forMachine _dtals (V1.BSValueHandleTrace i _ev) = - maybe mempty (\i' -> mconcat ["idx" .= showT i']) i -instance LogFormatting V1.BackingStoreValueHandleTrace where - forMachine _dtals V1.BSVHClosing = mempty - forMachine _dtals V1.BSVHAlreadyClosed = mempty - forMachine _dtals V1.BSVHClosed = mempty - forMachine _dtals V1.BSVHRangeReading = mempty - forMachine _dtals V1.BSVHRangeRead = mempty - forMachine _dtals V1.BSVHReading = mempty - forMachine _dtals V1.BSVHRead = mempty - forMachine _dtals V1.BSVHStatting = mempty - forMachine _dtals V1.BSVHStatted = mempty - -instance MetaTrace V1.BackingStoreTrace where - namespaceFor V1.BSOpening = Namespace [] ["Opening"] - namespaceFor V1.BSOpened{} = Namespace [] ["Opened"] - namespaceFor V1.BSInitialisingFromCopy{} = - Namespace [] ["InitialisingFromCopy"] - namespaceFor V1.BSInitialisedFromCopy{} = - Namespace [] ["InitialisedFromCopy"] - namespaceFor V1.BSInitialisingFromValues{} = - Namespace [] ["InitialisingFromValues"] - namespaceFor V1.BSInitialisedFromValues{} = - Namespace [] ["InitialisedFromValues"] - namespaceFor V1.BSClosing = Namespace [] ["Closing"] - namespaceFor V1.BSAlreadyClosed = Namespace [] ["AlreadyClosed"] - namespaceFor V1.BSClosed = Namespace [] ["Closed"] - namespaceFor V1.BSCopying{} = Namespace [] ["Copying"] - namespaceFor V1.BSCopied{} = Namespace [] ["Copied"] - namespaceFor V1.BSCreatingValueHandle = Namespace [] ["CreatingValueHandle"] - namespaceFor V1.BSCreatedValueHandle = Namespace [] ["CreatedValueHandle"] - namespaceFor (V1.BSValueHandleTrace _ bsValueHandleTrace) = - nsPrependInner "ValueHandleTrace" (namespaceFor bsValueHandleTrace) - namespaceFor V1.BSWriting{} = Namespace [] ["Writing"] - namespaceFor V1.BSWritten{} = Namespace [] ["Written"] - - severityFor (Namespace _ ("Opening" : _)) _ = Just Debug - severityFor (Namespace _ ("Opened" : _)) _ = Just Debug - severityFor (Namespace _ ("InitialisingFromCopy" : _)) _ = Just Debug - severityFor (Namespace _ ("InitialisedFromCopy" : _)) _ = Just Debug - severityFor (Namespace _ ("InitialisingFromValues" : _)) _ = Just Debug - severityFor (Namespace _ ("InitialisedFromValues" : _)) _ = Just Debug - severityFor (Namespace _ ("Closing" : _)) _ = Just Debug - severityFor (Namespace _ ("AlreadyClosed" : _)) _ = Just Debug - severityFor (Namespace _ ("Closed" : _)) _ = Just Debug - severityFor (Namespace _ ("Copying" : _)) _ = Just Debug - severityFor (Namespace _ ("Copied" : _)) _ = Just Debug - severityFor (Namespace _ ("CreatingValueHandle" : _)) _ = Just Debug - severityFor (Namespace _ ("CreatedValueHandle" : _)) _ = Just Debug - severityFor (Namespace out ("ValueHandleTrace" : t1)) Nothing = - severityFor - (Namespace out t1 :: Namespace V1.BackingStoreValueHandleTrace) - Nothing - severityFor - (Namespace out ("ValueHandleTrace" : t1)) - (Just (V1.BSValueHandleTrace _ bsValueHandleTrace)) = - severityFor - (Namespace out t1 :: Namespace V1.BackingStoreValueHandleTrace) - (Just bsValueHandleTrace) - severityFor (Namespace _ ("Writing" : _)) _ = Just Debug - severityFor (Namespace _ ("Written" : _)) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Opening" : _ )) = Just - "Opening backing store" - documentFor (Namespace _ ("Opened" : _ )) = Just - "Backing store opened" - documentFor (Namespace _ ("InitialisingFromCopy" : _ )) = Just - "Initialising backing store from copy" - documentFor (Namespace _ ("InitialisedFromCopy" : _ )) = Just - "Backing store initialised from copy" - documentFor (Namespace _ ("InitialisingFromValues" : _ )) = Just - "Initialising backing store from values" - documentFor (Namespace _ ("InitialisedFromValues" : _ )) = Just - "Backing store initialised from values" - documentFor (Namespace _ ("Closing" : _ )) = Just - "Closing backing store" - documentFor (Namespace _ ("AlreadyClosed" : _ )) = Just - "Backing store is already closed" - documentFor (Namespace _ ("Closed" : _ )) = Just - "Backing store closed" - documentFor (Namespace _ ("Copying" : _ )) = Just - "Copying backing store" - documentFor (Namespace _ ("Copied" : _ )) = Just - "Backing store copied" - documentFor (Namespace _ ("CreatingValueHandle" : _ )) = Just - "Creating value handle for backing store" - documentFor (Namespace _ ("CreatedValueHandle" : _ )) = Just - "Value handle for backing store created" - documentFor (Namespace out ("ValueHandleTrace" : t1 )) = - documentFor (Namespace out t1 :: Namespace V1.BackingStoreValueHandleTrace) - documentFor (Namespace _ ("Writing" : _ )) = Just - "Writing backing store" - documentFor (Namespace _ ("Written" : _ )) = Just - "Backing store written" - documentFor _ = Nothing - - allNamespaces = - [ Namespace [] ["Opening"] - , Namespace [] ["Opened"] - , Namespace [] ["InitialisingFromCopy"] - , Namespace [] ["InitialisedFromCopy"] - , Namespace [] ["InitialisingFromValues"] - , Namespace [] ["InitialisedFromValues"] - , Namespace [] ["Closing"] - , Namespace [] ["AlreadyClosed"] - , Namespace [] ["Closed"] - , Namespace [] ["Copying"] - , Namespace [] ["Copied"] - , Namespace [] ["CreatingValueHandle"] - , Namespace [] ["CreatedValueHandle"] - , Namespace [] ["Writing"] - , Namespace [] ["Written"] - ] ++ map (nsPrependInner "ValueHandleTrace") - (allNamespaces :: [Namespace V1.BackingStoreValueHandleTrace]) - - -instance MetaTrace V1.BackingStoreValueHandleTrace where - namespaceFor V1.BSVHClosing = Namespace [] ["Closing"] - namespaceFor V1.BSVHAlreadyClosed = Namespace [] ["AlreadyClosed"] - namespaceFor V1.BSVHClosed = Namespace [] ["Closed"] - namespaceFor V1.BSVHRangeReading = Namespace [] ["RangeReading"] - namespaceFor V1.BSVHRangeRead = Namespace [] ["RangeRead"] - namespaceFor V1.BSVHReading = Namespace [] ["Reading"] - namespaceFor V1.BSVHRead = Namespace [] ["Read"] - namespaceFor V1.BSVHStatting = Namespace [] ["Statting"] - namespaceFor V1.BSVHStatted = Namespace [] ["Statted"] - - severityFor (Namespace _ ("Closing" : _ )) _ = Just Debug - severityFor (Namespace _ ("AlreadyClosed" : _ )) _ = Just Debug - severityFor (Namespace _ ("Closed" : _ )) _ = Just Debug - severityFor (Namespace _ ("RangeReading" : _ )) _ = Just Debug - severityFor (Namespace _ ("RangeRead" : _ )) _ = Just Debug - severityFor (Namespace _ ("Reading" : _ )) _ = Just Debug - severityFor (Namespace _ ("Read" : _ )) _ = Just Debug - severityFor (Namespace _ ("Statting" : _ )) _ = Just Debug - severityFor (Namespace _ ("Statted" : _ )) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Closing" : _ )) = Just - "Closing backing store value handle" - documentFor (Namespace _ ("AlreadyClosed" : _ )) = Just - "Backing store value handle already clsoed" - documentFor (Namespace _ ("Closed" : _ )) = Just - "Backing store value handle closed" - documentFor (Namespace _ ("RangeReading" : _ )) = Just - "Reading range for backing store value handle" - documentFor (Namespace _ ("RangeRead" : _ )) = Just - "Range for backing store value handle read" - documentFor (Namespace _ ("Reading" : _ )) = Just - "Reading backing store value handle" - documentFor (Namespace _ ("Read" : _ )) = Just - "Backing store value handle read" - documentFor (Namespace _ ("Statting" : _ )) = Just - "Statting backing store value handle" - documentFor (Namespace _ ("Statted" : _ )) = Just - "Backing store value handle statted" - documentFor _ = Nothing - - allNamespaces = - [ Namespace [] ["Closing"] - , Namespace [] ["AlreadyClosed"] - , Namespace [] ["Closed"] - , Namespace [] ["RangeReading"] - , Namespace [] ["RangeRead"] - , Namespace [] ["Reading"] - , Namespace [] ["Read"] - , Namespace [] ["Statting"] - , Namespace [] ["Statted"] - ] - {------------------------------------------------------------------------------- V2 -------------------------------------------------------------------------------} @@ -3088,30 +2918,6 @@ instance (Show (PBFT.PBftVerKeyHash c)) , "numForged" .= numForged ] --- PerasCertDB.TraceEvent instances -instance LogFormatting (PerasCertDB.TraceEvent blk) where - forHuman (PerasCertDB.AddedPerasCert _cert _peer) = "Added Peras certificate to database" - forHuman (PerasCertDB.IgnoredCertAlreadyInDB _cert _peer) = "Ignored Peras certificate already in database" - forHuman PerasCertDB.OpenedPerasCertDB = "Opened Peras certificate database" - forHuman PerasCertDB.ClosedPerasCertDB = "Closed Peras certificate database" - forHuman (PerasCertDB.AddingPerasCert _cert _peer) = "Adding Peras certificate to database" - - forMachine _dtal (PerasCertDB.AddedPerasCert cert _peer) = - mconcat ["kind" .= String "AddedPerasCert", - "cert" .= String (Text.pack $ show cert)] - forMachine _dtal (PerasCertDB.IgnoredCertAlreadyInDB cert _peer) = - mconcat ["kind" .= String "IgnoredCertAlreadyInDB", - "cert" .= String (Text.pack $ show cert)] - forMachine _dtal PerasCertDB.OpenedPerasCertDB = - mconcat ["kind" .= String "OpenedPerasCertDB"] - forMachine _dtal PerasCertDB.ClosedPerasCertDB = - mconcat ["kind" .= String "ClosedPerasCertDB"] - forMachine _dtal (PerasCertDB.AddingPerasCert cert _peer) = - mconcat ["kind" .= String "AddingPerasCert", - "cert" .= String (Text.pack $ show cert)] - - asMetrics _ = [] - -- ChainDB.TraceAddPerasCertEvent instances instance ConvertRawHash blk => LogFormatting (ChainDB.TraceAddPerasCertEvent blk) where forHuman (ChainDB.AddedPerasCertToQueue roundNo boostedBlock _queueSize) = @@ -3168,54 +2974,6 @@ instance ConvertRawHash blk => LogFormatting (ChainDB.TraceAddPerasCertEvent blk asMetrics _ = [] --- PerasCertDB.TraceEvent MetaTrace instance -instance MetaTrace (PerasCertDB.TraceEvent blk) where - namespaceFor (PerasCertDB.AddedPerasCert _ _) = - Namespace [] ["AddedPerasCert"] - namespaceFor (PerasCertDB.IgnoredCertAlreadyInDB _ _) = - Namespace [] ["IgnoredCertAlreadyInDB"] - namespaceFor PerasCertDB.OpenedPerasCertDB = - Namespace [] ["OpenedPerasCertDB"] - namespaceFor PerasCertDB.ClosedPerasCertDB = - Namespace [] ["ClosedPerasCertDB"] - namespaceFor (PerasCertDB.AddingPerasCert _ _) = - Namespace [] ["AddingPerasCert"] - - severityFor (Namespace _ ["AddedPerasCert"]) _ = Just Info - severityFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just Info - severityFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just Info - severityFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just Info - severityFor (Namespace _ ["AddingPerasCert"]) _ = Just Debug - severityFor _ _ = Nothing - - privacyFor (Namespace _ ["AddedPerasCert"]) _ = Just Public - privacyFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just Public - privacyFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just Public - privacyFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just Public - privacyFor (Namespace _ ["AddingPerasCert"]) _ = Just Public - privacyFor _ _ = Nothing - - detailsFor (Namespace _ ["AddedPerasCert"]) _ = Just DNormal - detailsFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just DNormal - detailsFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just DNormal - detailsFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just DNormal - detailsFor (Namespace _ ["AddingPerasCert"]) _ = Just DDetailed - detailsFor _ _ = Nothing - - documentFor (Namespace _ ["AddedPerasCert"]) = Just "Certificate added to Peras certificate database" - documentFor (Namespace _ ["IgnoredCertAlreadyInDB"]) = Just "Certificate ignored as it was already in the database" - documentFor (Namespace _ ["OpenedPerasCertDB"]) = Just "Peras certificate database opened" - documentFor (Namespace _ ["ClosedPerasCertDB"]) = Just "Peras certificate database closed" - documentFor (Namespace _ ["AddingPerasCert"]) = Just "Adding certificate to Peras certificate database" - documentFor _ = Nothing - - allNamespaces = - [Namespace [] ["AddedPerasCert"], - Namespace [] ["IgnoredCertAlreadyInDB"], - Namespace [] ["OpenedPerasCertDB"], - Namespace [] ["ClosedPerasCertDB"], - Namespace [] ["AddingPerasCert"]] - -- ChainDB.TraceAddPerasCertEvent MetaTrace instance instance MetaTrace (ChainDB.TraceAddPerasCertEvent blk) where namespaceFor ChainDB.AddedPerasCertToQueue{} = Namespace [] ["AddedPerasCertToQueue"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 36ae550c0f2..edb2462b0d0 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -84,6 +84,8 @@ import qualified Data.Text as Text import Data.Time (NominalDiffTime) import Data.Word (Word32, Word64) import Network.TypedProtocol.Core +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound (TraceObjectDiffusionInbound (..)) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (TraceObjectDiffusionOutbound (..)) enclosingValue :: ToJSON a => Enclosing' a -> Value enclosingValue RisingEdge = object [ "edge" .= String "Starting" ] @@ -1040,6 +1042,7 @@ instance ( HasHeader blk instance MetaTrace SanityCheckIssue where namespaceFor InconsistentSecurityParam {} = Namespace [] ["SanityCheckIssue"] + namespaceFor _ = Namespace [] ["SanityCheckIssue"] severityFor (Namespace _ ["SanityCheckIssue"]) _ = Just Error severityFor _ _ = Nothing @@ -1054,8 +1057,12 @@ instance LogFormatting SanityCheckIssue where mconcat [ "kind" .= String "InconsistentSecurityParam" , "error" .= String (Text.pack $ show e) ] + forMachine _ _ = + mconcat [ "kind" .= String "SnapshotIssue" + ] forHuman (InconsistentSecurityParam e) = "Configuration contains multiple security parameters: " <> Text.pack (show e) + forHuman _ = "SnapshotIssue" -------------------------------------------------------------------------------- -- TxSubmissionServer Tracer @@ -2308,3 +2315,128 @@ instance MetaTrace KESAgentClientTrace where allNamespaces = Namespace [] ["KESAgentClientException"] : fmap nsCast (allNamespaces :: [Namespace Agent.ServiceClientTrace]) + +-------------------------------------------------------------------------------- +-- Peras +-------------------------------------------------------------------------------- + +-- TODO: Move this to a proper place. A lot of this is duplicated in the +-- ToObject instance. This is likely in an incorrect place. Fix +-- duplication. +instance LogFormatting (TraceObjectDiffusionInbound objectId object) where + forMachine _ (TraceObjectDiffusionInboundCollectedObjects payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundCollectedObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionInboundAddedObjects payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundAddedObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionInboundRecvControlMessage payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundRecvControlMessage" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionInboundCanRequestMoreObjects payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundCanRequestMoreObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionInboundCannotRequestMoreObjects payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionInboundCannotRequestMoreObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + +instance MetaTrace (TraceObjectDiffusionInbound objectId object) where + namespaceFor (TraceObjectDiffusionInboundCollectedObjects _) = + Namespace [] ["TraceObjectDiffusionInboundCollectedObjects"] + namespaceFor (TraceObjectDiffusionInboundAddedObjects _) = + Namespace [] ["TraceObjectDiffusionInboundAddedObjects"] + namespaceFor (TraceObjectDiffusionInboundRecvControlMessage _) = + Namespace [] ["TraceObjectDiffusionInboundRecvControlMessage"] + namespaceFor (TraceObjectDiffusionInboundCanRequestMoreObjects _) = + Namespace [] ["TraceObjectDiffusionInboundCanRequestMoreObjects"] + namespaceFor (TraceObjectDiffusionInboundCannotRequestMoreObjects _) = + Namespace [] ["TraceObjectDiffusionInboundCannotRequestMoreObjects"] + + severityFor (Namespace [] ["TraceObjectDiffusionInboundCollectedObjects"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionInboundAddedObjects"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionInboundRecvControlMessage"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionInboundCanRequestMoreObjects"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionInboundCannotRequestMoreObjects"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["TraceObjectDiffusionInboundCollectedObjects"] + , Namespace [] ["TraceObjectDiffusionInboundAddedObjects"] + , Namespace [] ["TraceObjectDiffusionInboundRecvControlMessage"] + , Namespace [] ["TraceObjectDiffusionInboundCanRequestMoreObjects"] + , Namespace [] ["TraceObjectDiffusionInboundCannotRequestMoreObjects"] + ] + +instance + ( Show objectId + , Show object + ) => + LogFormatting (TraceObjectDiffusionOutbound objectId object) + where + forMachine _ (TraceObjectDiffusionOutboundRecvMsgRequestObjectIds payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundRecvMsgRequestObjectIds" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionOutboundSendMsgReplyObjectIds payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundSendMsgReplyObjectIds" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionOutboundRecvMsgRequestObjects payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundRecvMsgRequestObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ (TraceObjectDiffusionOutboundSendMsgReplyObjects payload) = + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundSendMsgReplyObjects" + , "payload" .= String (Text.pack . show $ payload) + ] + forMachine _ TraceObjectDiffusionOutboundTerminated = + mconcat + [ "kind" .= String "TraceObjectDiffusionOutboundTerminated" + ] + + +instance MetaTrace (TraceObjectDiffusionOutbound objectId object) where + namespaceFor (TraceObjectDiffusionOutboundRecvMsgRequestObjectIds _) = + Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"] + namespaceFor (TraceObjectDiffusionOutboundSendMsgReplyObjectIds _) = + Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"] + namespaceFor (TraceObjectDiffusionOutboundRecvMsgRequestObjects _) = + Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"] + namespaceFor (TraceObjectDiffusionOutboundSendMsgReplyObjects _) = + Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] + namespaceFor TraceObjectDiffusionOutboundTerminated = + Namespace [] ["TraceObjectDiffusionOutboundTerminated"] + + + severityFor (Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjects"]) _ = Just Info + severityFor (Namespace [] ["TraceObjectDiffusionOutboundTerminated"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjectIds"] + , Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjectIds"] + , Namespace [] ["TraceObjectDiffusionOutboundRecvMsgRequestObjects"] + , Namespace [] ["TraceObjectDiffusionOutboundSendMsgReplyObjects"] + , Namespace [] ["TraceObjectDiffusionOutboundTerminated"] + ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs index 6f2e0820ff4..a94086dbc4c 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs @@ -40,7 +40,7 @@ import GHC.Conc (labelThread, myThreadId) startLedgerMetricsTracer :: forall blk - . IsLedger (LedgerState blk) + . IsLedger LedgerState blk => LedgerQueries blk => AF.HasHeader (Header blk) => AF.HasHeader blk @@ -93,7 +93,7 @@ data LedgerMetrics = } traceLedgerMetrics :: - ( IsLedger (LedgerState blk) + ( IsLedger LedgerState blk , LedgerQueries blk , AF.HasHeader blk , AF.HasHeader (Header blk)) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index ff105fbc036..e634e504d2f 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs @@ -17,6 +17,8 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Tracing () +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) +import qualified Ouroboros.Network.Protocol.ObjectDiffusion.Type as OD import Data.Aeson (Value (String), (.=)) import Data.Text (Text, pack) @@ -466,3 +468,72 @@ instance MetaTrace (Stateful.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk)) , Namespace [] ["ReAcquire"] , Namespace [] ["Done"] ] + +-- -------------------------------------------------------------------------------- +-- -- TObjectDiffusion Tracer +-- -------------------------------------------------------------------------------- + +instance LogFormatting (Simple.AnyMessage (ObjectDiffusion objectId object)) where + forMachine _dtal (Simple.AnyMessageAndAgency stok OD.MsgInit {}) = + mconcat [ "kind" .= String "MsgInit" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Simple.AnyMessageAndAgency stok OD.MsgRequestObjectIds {}) = + mconcat [ "kind" .= String "MsgRequestObjectIds" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Simple.AnyMessageAndAgency stok OD.MsgReplyObjectIds {}) = + mconcat [ "kind" .= String "MsgReplyObjectIds" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Simple.AnyMessageAndAgency stok OD.MsgRequestObjects {}) = + mconcat [ "kind" .= String "MsgRequestObjects" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Simple.AnyMessageAndAgency stok OD.MsgReplyObjects {}) = + mconcat [ "kind" .= String "MsgReplyObjects" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (Simple.AnyMessageAndAgency stok OD.MsgDone {}) = + mconcat [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance MetaTrace (Simple.AnyMessage (ObjectDiffusion objectId object)) where + namespaceFor (Simple.AnyMessageAndAgency _agency OD.MsgInit {}) = + Namespace [] ["Init"] + namespaceFor (Simple.AnyMessageAndAgency _agency OD.MsgRequestObjectIds {}) = + Namespace [] ["RequestObjectIds"] + namespaceFor (Simple.AnyMessageAndAgency _agency OD.MsgReplyObjectIds {}) = + Namespace [] ["ReplyObjectIds"] + namespaceFor (Simple.AnyMessageAndAgency _agency OD.MsgRequestObjects {}) = + Namespace [] ["RequestObjects"] + namespaceFor (Simple.AnyMessageAndAgency _agency OD.MsgReplyObjects {}) = + Namespace [] ["ReplyObjects"] + namespaceFor (Simple.AnyMessageAndAgency _agency OD.MsgDone {}) = + Namespace [] ["Done"] + + severityFor (Namespace [] ["Init"]) _ = Just Info + severityFor (Namespace [] ["RequestObjectIds"]) _ = Just Info + severityFor (Namespace [] ["ReplyObjectIds"]) _ = Just Info + severityFor (Namespace [] ["RequestObjects"]) _ = Just Info + severityFor (Namespace [] ["ReplyObjects"]) _ = Just Info + severityFor (Namespace [] ["Done"]) _ = Just Info + severityFor _ _ = Nothing + + documentFor (Namespace [] ["Init"]) = Just "" + documentFor (Namespace [] ["RequestObjectIds"]) = Just "" + documentFor (Namespace [] ["ReplyObjectIds"]) = Just "" + documentFor (Namespace [] ["RequestObjects"]) = Just "" + documentFor (Namespace [] ["ReplyObjects"]) = Just "" + documentFor (Namespace [] ["Done"]) = Just "" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["Init"] + , Namespace [] ["RequestObjectIds"] + , Namespace [] ["ReplyObjectIds"] + , Namespace [] ["RequestObjects"] + , Namespace [] ["ReplyObjects"] + , Namespace [] ["Done"] + ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Rpc.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Rpc.hs index d81458625fb..f9781f5efe6 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Rpc.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Rpc.hs @@ -35,6 +35,10 @@ instance LogFormatting TraceRpc where [ "queryName" .= String "ReadUtxos" , spanToObject s ] + TraceRpcQuerySearchUtxosSpan s -> + [ "queryName" .= String "SearchUtxos" + , spanToObject s + ] TraceRpcSubmit submitTrace -> ["kind" .= String "SubmitService"] <> case submitTrace of @@ -42,6 +46,8 @@ instance LogFormatting TraceRpc where TraceRpcSubmitTxDecodingError _ -> [] TraceRpcSubmitTxValidationError _ -> [] TraceRpcSubmitSpan s -> [spanToObject s] + TraceRpcEvalTxDecodingError _ -> [] + TraceRpcEvalTxSpan s -> [spanToObject s] forHuman = docToText . pretty @@ -50,7 +56,9 @@ instance LogFormatting TraceRpc where -- query names here are taken from UTXORPC spec: https://utxorpc.org/query/intro/#operations TraceRpcQuery (TraceRpcQueryParamsSpan (SpanBegin _)) -> [CounterM "rpc.request.QueryService.ReadParams" Nothing] TraceRpcQuery (TraceRpcQueryReadUtxosSpan (SpanBegin _)) -> [CounterM "rpc.request.QueryService.ReadUtxos" Nothing] + TraceRpcQuery (TraceRpcQuerySearchUtxosSpan (SpanBegin _)) -> [CounterM "rpc.request.QueryService.SearchUtxos" Nothing] TraceRpcSubmit (TraceRpcSubmitSpan (SpanBegin _)) -> [CounterM "rpc.request.SubmitService.SubmitTx" Nothing] + TraceRpcSubmit (TraceRpcEvalTxSpan (SpanBegin _)) -> [CounterM "rpc.request.SubmitService.EvalTx" Nothing] _ -> [] instance MetaTrace TraceRpc where @@ -63,6 +71,7 @@ instance MetaTrace TraceRpc where : case queryTrace of TraceRpcQueryParamsSpan _ -> ["ReadParams", "Span"] TraceRpcQueryReadUtxosSpan _ -> ["ReadUtxos", "Span"] + TraceRpcQuerySearchUtxosSpan _ -> ["SearchUtxos", "Span"] TraceRpcSubmit submitTrace -> "SubmitService" : case submitTrace of @@ -70,16 +79,21 @@ instance MetaTrace TraceRpc where TraceRpcSubmitTxDecodingError _ -> ["TxDecodingError"] TraceRpcSubmitTxValidationError _ -> ["TxValidationError"] TraceRpcSubmitSpan _ -> ["SubmitTx", "Span"] + TraceRpcEvalTxDecodingError _ -> ["EvalTxDecodingError"] + TraceRpcEvalTxSpan _ -> ["EvalTx", "Span"] severityFor (Namespace _ nsInner) _ = case nsInner of ["FatalError"] -> Just Error -- RPC server startup errors ["Error"] -> Just Debug -- those are normal operation errors, like request errors, hide them by default ["QueryService", "ReadParams", "Span"] -> Just Debug ["QueryService", "ReadUtxos", "Span"] -> Just Debug + ["QueryService", "SearchUtxos", "Span"] -> Just Debug ["SubmitService", "SubmitTx", "Span"] -> Just Debug + ["SubmitService", "EvalTx", "Span"] -> Just Debug ["SubmitService", "N2cConnectionError"] -> Just Warning -- this is a more serious error, this shouldn't happen ["SubmitService", "TxDecodingError"] -> Just Debug -- request error ["SubmitService", "TxValidationError"] -> Just Debug -- request error + ["SubmitService", "EvalTxDecodingError"] -> Just Debug -- request error _ -> Nothing documentFor (Namespace _ nsInner) = case nsInner of @@ -87,12 +101,15 @@ instance MetaTrace TraceRpc where ["Error"] -> Just "Normal operation errors such as request errors. Those are not harmful to the RPC server itself." ["QueryService", "ReadParams", "Span"] -> Just "Span for the ReadParams UTXORPC method." ["QueryService", "ReadUtxos", "Span"] -> Just "Span for the ReadUtxos UTXORPC method." + ["QueryService", "SearchUtxos", "Span"] -> Just "Span for the SearchUtxos UTXORPC method." ["SubmitService", "SubmitTx", "Span"] -> Just "Span for the SubmitTx UTXORPC method." + ["SubmitService", "EvalTx", "Span"] -> Just "Span for the EvalTx UTXORPC method." ["SubmitService", "N2cConnectionError"] -> Just "Node connection error. This should not happen, as this means that there is an issue in cardano-rpc configuration." ["SubmitService", "TxDecodingError"] -> Just "A regular request error, when submitted transaction decoding fails." ["SubmitService", "TxValidationError"] -> Just "A regular request error, when submitted transaction is invalid." + ["SubmitService", "EvalTxDecodingError"] -> Just "A regular request error, when evalTx transaction decoding fails." _ -> Nothing metricsDocFor (Namespace _ nsInner) = case nsInner of @@ -100,8 +117,12 @@ instance MetaTrace TraceRpc where [("rpc.request.QueryService.ReadParams", "Span for the ReadParams UTXORPC method.")] ["QueryService", "ReadUtxos", "Span"] -> [("rpc.request.QueryService.ReadUtxos", "Span for the ReadUtxos UTXORPC method.")] + ["QueryService", "SearchUtxos", "Span"] -> + [("rpc.request.QueryService.SearchUtxos", "Span for the SearchUtxos UTXORPC method.")] ["SubmitService", "SubmitTx", "Span"] -> [("rpc.request.SubmitService.SubmitTx", "Span for the SubmitTx UTXORPC method.")] + ["SubmitService", "EvalTx", "Span"] -> + [("rpc.request.SubmitService.EvalTx", "Span for the EvalTx UTXORPC method.")] _ -> [] allNamespaces = @@ -110,10 +131,13 @@ instance MetaTrace TraceRpc where , ["Error"] , ["QueryService", "ReadParams", "Span"] , ["QueryService", "ReadUtxos", "Span"] + , ["QueryService", "SearchUtxos", "Span"] , ["SubmitService", "SubmitTx", "Span"] + , ["SubmitService", "EvalTx", "Span"] , ["SubmitService", "N2cConnectionError"] , ["SubmitService", "TxDecodingError"] , ["SubmitService", "TxValidationError"] + , ["SubmitService", "EvalTxDecodingError"] ] -- helper functions diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index c8eefaef1cf..3b513420fd0 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -67,8 +67,8 @@ getStartupInfo -> IO [StartupTrace blk] getStartupInfo nc (SomeConsensusProtocol whichP pForInfo) fp = do nodeStartTime <- getCurrentTime - let cfg = pInfoConfig $ fst $ Api.protocolInfo @IO pForInfo - basicInfoCommon = BICommon $ BasicInfoCommon { + cfg <- pInfoConfig . fst <$> Api.protocolInfo @IO pForInfo + let basicInfoCommon = BICommon $ BasicInfoCommon { biProtocol = pack . show $ ncProtocol nc , biVersion = pack . showVersion $ version , biCommit = $(gitRev) @@ -512,6 +512,7 @@ nodeToNodeVersionToInt :: NodeToNodeVersion -> Int nodeToNodeVersionToInt = \case NodeToNodeV_14 -> 14 NodeToNodeV_15 -> 15 + NodeToNodeV_16 -> 16 -- | Pretty print 'StartupInfoTrace' -- diff --git a/cardano-node/test/Test/Cardano/Config/Mainnet.hs b/cardano-node/test/Test/Cardano/Config/Mainnet.hs index 154f710d8cf..e9a02a56ac0 100644 --- a/cardano-node/test/Test/Cardano/Config/Mainnet.hs +++ b/cardano-node/test/Test/Cardano/Config/Mainnet.hs @@ -15,6 +15,9 @@ import qualified Data.Yaml as Y import qualified GHC.Stack as GHC import qualified System.Directory as IO import System.FilePath (()) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) import Hedgehog (Property, (===)) import qualified Hedgehog as H @@ -24,7 +27,8 @@ import qualified Hedgehog.Extras.Test.Process as H hprop_configMainnetHash :: Property hprop_configMainnetHash = H.propertyOnce $ do base <- H.note =<< H.evalIO . IO.canonicalizePath =<< H.getProjectBase - result <- H.evalIO $ runExceptT $ initialLedgerState $ File $ base "configuration/cardano/mainnet-config.json" + let fs = SomeHasFS (ioHasFS (MountPoint (base "configuration/cardano"))) + result <- H.evalIO $ runExceptT $ initialLedgerState fs $ File $ base "configuration/cardano/mainnet-config.json" case result of Right (_, _) -> return () Left e -> H.failWithCustom GHC.callStack Nothing (displayError e) diff --git a/cardano-node/test/Test/Cardano/Node/FilePermissions.hs b/cardano-node/test/Test/Cardano/Node/FilePermissions.hs index 0aa16e86453..faa50a0f01c 100644 --- a/cardano-node/test/Test/Cardano/Node/FilePermissions.hs +++ b/cardano-node/test/Test/Cardano/Node/FilePermissions.hs @@ -14,42 +14,39 @@ module Test.Cardano.Node.FilePermissions ( tests ) where -import Control.Monad.Except -import "contra-tracer" Control.Tracer -import Control.Tracer.Arrow -import Data.Foldable -import Data.IORef -import System.Directory (removeFile) - import Cardano.Api + import Cardano.Node.Run (checkVRFFilePermissions) +import Cardano.Node.Types (VRFPrivateKeyFilePermissionError (..)) + +import Control.Exception (bracket) import Control.Monad (Monad (..)) +import Control.Monad.Except import Control.Monad.Except (runExceptT) import Control.Monad.IO.Class (MonadIO (liftIO)) +import "contra-tracer" Control.Tracer +import Control.Tracer.Arrow import Data.Bool (Bool, not) import Data.Either (Either (..)) import Data.Eq ((==)) +import Data.Foldable import Data.Foldable (foldl', length) import Data.Function (const, ($), (.)) +import Data.IORef import qualified Data.List as L import Data.Maybe (Maybe (..)) import Data.Semigroup (Semigroup (..)) -import Hedgehog -import Hedgehog.Internal.Property (Group (..), failWith) +import System.Directory (removeFile) import System.IO (FilePath, IO) -import Text.Show (Show (..)) -import Cardano.Node.Types (VRFPrivateKeyFilePermissionError (..)) -import Control.Exception (bracket) - -#ifdef UNIX - import System.Posix.Files import System.Posix.IO (closeFd, createFile) import System.Posix.Types (FileMode) +import Text.Show (Show (..)) import Hedgehog import qualified Hedgehog.Extras as H import qualified Hedgehog.Gen as Gen +import Hedgehog.Internal.Property (Group (..), failWith) #endif @@ -166,7 +163,7 @@ mkCapturingTracer = do messages <- liftIO $ newIORef [] let registerMessage :: String -> IO () registerMessage msg = atomicModifyIORef messages (\msgs -> (msgs <> [msg], ())) - pure (Tracer registerMessage, messages) + pure (Tracer (emit registerMessage), messages) #endif -- ----------------------------------------------------------------------------- diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 2d131f83235..b829225fb04 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Test.Cardano.Node.POM @@ -22,8 +23,7 @@ import Cardano.Rpc.Server.Config (makeRpcConfig) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import Ouroboros.Consensus.Node.Genesis (disableGenesisConfig) import Ouroboros.Consensus.Storage.LedgerDB.Args -import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), - SnapshotInterval (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultSnapshotPolicyArgs) import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Types @@ -284,7 +284,7 @@ eExpectedConfig = do , ncConsensusMode = PraosMode , ncGenesisConfig = disableGenesisConfig , ncResponderCoreAffinityPolicy = NoResponderCoreAffinity - , ncLedgerDbConfig = LedgerDbConfiguration DefaultNumOfDiskSnapshots DefaultSnapshotInterval DefaultQueryBatchSize V2InMemory noDeprecatedOptions + , ncLedgerDbConfig = LedgerDbConfiguration defaultSnapshotPolicyArgs DefaultQueryBatchSize V2InMemory noDeprecatedOptions , ncRpcConfig , ncTxSubmissionLogicVersion = TxSubmissionLogicV1 , ncTxSubmissionInitDelay = defaultTxSubmissionInitDelay diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index 6ef4ff984f7..9d8f950df0d 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -39,16 +39,16 @@ library , aeson , async , bytestring - , cardano-api ^>= 11.0 + , cardano-api ^>= 11.3 , cardano-binary - , cardano-cli ^>= 11.0 - , cardano-crypto-class ^>=2.3 + , cardano-cli ^>= 11.1 + , cardano-crypto-class ^>=2.5 , containers , ekg-core , http-media , mtl , network - , optparse-applicative-fork + , optparse-applicative , ouroboros-consensus:cardano , ouroboros-network:{protocols} , prometheus >= 2.2.4 @@ -84,7 +84,7 @@ executable cardano-submit-api hs-source-dirs: app ghc-options: -threaded -rtsopts "-with-rtsopts=-T -I0" build-depends: base - , optparse-applicative-fork + , optparse-applicative , cardano-cli , cardano-crypto-class , cardano-git-rev ^>=0.2.2 @@ -99,4 +99,4 @@ test-suite unit main-is: test.hs hs-source-dirs: test build-depends: base - , cardano-crypto-class ^>=2.3 + , cardano-crypto-class ^>=2.5 diff --git a/cardano-submit-api/src/Cardano/TxSubmit/Web.hs b/cardano-submit-api/src/Cardano/TxSubmit/Web.hs index 430bee24bbf..dbcc78c84b1 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/Web.hs +++ b/cardano-submit-api/src/Cardano/TxSubmit/Web.hs @@ -17,8 +17,8 @@ import Cardano.Api (AllegraEra, AnyCardanoEra (AnyCardanoEra), AsType IsCardanoEra (..), LocalNodeConnectInfo (LocalNodeConnectInfo, localConsensusModeParams, localNodeNetworkId, localNodeSocketPath), NetworkId, SerialiseAsCBOR (..), ShelleyBasedEra (..), ShelleyEra, SocketPath, - ToJSON, Tx, TxId (..), TxInMode (TxInMode), TxValidationErrorInCardanoMode (..), - getTxBody, getTxId, submitTxToNodeLocal) + ToJSON, Tx (Tx), TxId (..), TxInMode (TxInMode), + TxValidationErrorInCardanoMode (..), getTxId, submitTxToNodeLocal) import qualified Cardano.Api import Cardano.Binary (DecoderError (..)) @@ -144,7 +144,8 @@ txSubmitPost trace p@(CardanoModeParams cModeParams) networkId socketPath txByte case res of Cardano.Api.TxSubmitSuccess -> do liftIO $ T.putStrLn "Transaction successfully submitted." - return $ getTxId (getTxBody tx) + let Tx txBody _ = tx + return $ getTxId txBody Cardano.Api.TxSubmitFail e -> left $ TxCmdTxSubmitValidationError e Cardano.Api.TxSubmitError e -> diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 3d24101a0ad..0f4d1f2976e 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -41,9 +41,9 @@ library , annotated-exception , ansi-terminal , bytestring - , cardano-api ^>= 11.0 - , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 11.0 - , cardano-crypto-class ^>=2.3 + , cardano-api ^>= 11.3 + , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 11.1 + , cardano-crypto-class ^>=2.5 , cardano-crypto-wrapper , cardano-git-rev ^>= 0.2.2 , cardano-ledger-alonzo @@ -57,13 +57,12 @@ library , cardano-ledger-dijkstra , cardano-ledger-shelley , cardano-node - , cardano-ping ^>= 0.10 + , cardano-diffusion:ping ^>= 1.0 , cardano-prelude , cardano-rpc , contra-tracer , containers , data-default-class - , cborg , containers , contra-tracer , data-default-class @@ -72,6 +71,7 @@ library , exceptions , extra , filepath + , fs-api ^>= 0.4 , hedgehog , hedgehog-extras ^>= 0.10 , http-conduit @@ -82,8 +82,7 @@ library , mono-traversable , mtl , network - , network-mux - , optparse-applicative-fork + , optparse-applicative , parsec , ouroboros-network:{api, framework, ouroboros-network} ^>= 1.1 , cardano-diffusion:{api, cardano-diffusion} ^>= 1.0 @@ -154,10 +153,10 @@ executable cardano-testnet main-is: cardano-testnet.hs - build-depends: cardano-crypto-class ^>=2.3 + build-depends: cardano-crypto-class ^>=2.5 , cardano-cli , cardano-testnet - , optparse-applicative-fork + , optparse-applicative ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" @@ -238,7 +237,9 @@ test-suite cardano-testnet-test Cardano.Testnet.Test.Gov.TreasuryDonation Cardano.Testnet.Test.Gov.TreasuryGrowth Cardano.Testnet.Test.Gov.TreasuryWithdrawal + Cardano.Testnet.Test.Rpc.Eval Cardano.Testnet.Test.Rpc.Query + Cardano.Testnet.Test.Rpc.SearchUtxos Cardano.Testnet.Test.Rpc.Transaction Cardano.Testnet.Test.Misc Cardano.Testnet.Test.Node.Shutdown @@ -275,6 +276,7 @@ test-suite cardano-testnet-test , directory , exceptions , filepath + , grpc-spec , hedgehog , hedgehog-extras , http-conduit diff --git a/cardano-testnet/changelog.d/20260527_120000_mgalazyn_bump_cardano_api_cardano_cli_chap.md b/cardano-testnet/changelog.d/20260527_120000_mgalazyn_bump_cardano_api_cardano_cli_chap.md new file mode 100644 index 00000000000..18cee6700a1 --- /dev/null +++ b/cardano-testnet/changelog.d/20260527_120000_mgalazyn_bump_cardano_api_cardano_cli_chap.md @@ -0,0 +1,7 @@ + +### Maintenance + +- Bump `cardano-api` to `^>= 11.3` +- Bump `cardano-cli` to `^>= 11.1` +- Bump CHaP index-state to `2026-05-27` + diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 8f085bd662f..7b688fe17ca 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -80,6 +80,7 @@ import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro (Lens', to, (^.)) +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Process.RunIO (liftIOAnnotated) import Testnet.Property.Assert import Testnet.Runtime @@ -102,9 +103,11 @@ waitUntilEpoch -> EpochNo -- ^ Desired epoch -> m EpochNo -- ^ The epoch number reached waitUntilEpoch nodeConfigFile socketPath desiredEpoch = withFrozenCallStack $ do - result <- H.evalIO . runExceptT $ - foldEpochState - nodeConfigFile socketPath QuickValidation desiredEpoch () (\_ _ _ -> pure ConditionNotMet) + result <- H.evalIO $ do + fs <- mkNodeConfigFs nodeConfigFile + runExceptT $ + foldEpochState + fs nodeConfigFile socketPath QuickValidation desiredEpoch () (\_ _ _ -> pure ConditionNotMet) case result of Left (FoldBlocksApplyBlockError (TerminationEpochReached epochNo)) -> pure epochNo @@ -388,7 +391,8 @@ getEpochStateView getEpochStateView nodeConfigFile socketPath = withFrozenCallStack $ do esv <- H.evalIO $ EpochStateView <$> newTVarIO (Left EpochStateNotInitialised) <*> newTVarIO 0 _ <- asyncRegister_ $ do - result <- runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation (EpochNo maxBound) () + fs <- mkNodeConfigFs nodeConfigFile + result <- runExceptT $ foldEpochState fs nodeConfigFile socketPath QuickValidation (EpochNo maxBound) () $ \epochState slotNumber blockNumber -> do liftIOAnnotated . atomically $ writeEpochStateView esv $ Right (epochState, slotNumber, blockNumber) pure ConditionNotMet diff --git a/cardano-testnet/src/Testnet/Defaults.hs b/cardano-testnet/src/Testnet/Defaults.hs index e6e743fb51c..d3bd2f95b05 100644 --- a/cardano-testnet/src/Testnet/Defaults.hs +++ b/cardano-testnet/src/Testnet/Defaults.hs @@ -190,6 +190,7 @@ defaultConwayGenesis = do , cgCommittee = DefaultClass.def , cgDelegs = mempty , cgInitialDReps = mempty + , cgExtraConfig = SNothing } -- | The only era supported by cardano-testnet for the moment. diff --git a/cardano-testnet/src/Testnet/Filepath.hs b/cardano-testnet/src/Testnet/Filepath.hs index 59c5771ab56..ab87ce9c1e1 100644 --- a/cardano-testnet/src/Testnet/Filepath.hs +++ b/cardano-testnet/src/Testnet/Filepath.hs @@ -9,19 +9,27 @@ module Testnet.Filepath , makeSocketDir , makeSprocket , makeTmpBaseAbsPath + , mkNodeConfigFs ) where import Prelude import Data.String (IsString (..)) +import System.Directory (makeAbsolute) import System.FilePath import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..)) import RIO (Display (..)) +import Cardano.Api (File (..)) + import Cardano.Node.Testnet.Paths (defaultSocketDir) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) + makeSprocket :: TmpAbsolutePath @@ -51,3 +59,8 @@ makeTmpBaseAbsPath (TmpAbsolutePath fp) = addTrailingPathSeparator $ takeDirecto makeLogDir :: TmpAbsolutePath -> FilePath makeLogDir (TmpAbsolutePath fp) = addTrailingPathSeparator $ fp "logs" + +mkNodeConfigFs :: File content direction -> IO (SomeHasFS IO) +mkNodeConfigFs configFile = do + configDir <- takeDirectory <$> makeAbsolute (unFile configFile) + pure $ SomeHasFS (ioHasFS (MountPoint configDir)) diff --git a/cardano-testnet/src/Testnet/Ping.hs b/cardano-testnet/src/Testnet/Ping.hs index b2d2824de09..02df9d68830 100644 --- a/cardano-testnet/src/Testnet/Ping.hs +++ b/cardano-testnet/src/Testnet/Ping.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Testnet.Ping @@ -12,36 +7,22 @@ module Testnet.Ping , waitForSprocket , waitForPortClosed , TestnetMagic - , PingClientError(..) + , CNP.PingClientException ) where -import Cardano.Api (Error (..)) +import qualified Cardano.Network.Ping as CNP -import Cardano.Network.Ping (HandshakeFailure, NodeVersion (..), handshakeDec, - handshakeReq, isSameVersionAndMagic, supportedNodeToClientVersions) - -import qualified Codec.CBOR.Read as CBOR import Control.Exception.Safe -import Control.Monad -import Control.Monad.Class.MonadTime.SI (Time) +import Control.Monad (when) import qualified Control.Monad.Class.MonadTimer.SI as MT import Control.Monad.IO.Class import qualified Control.Retry as R import Control.Tracer (nullTracer) -import qualified Data.ByteString.Lazy as LBS import Data.Either import Data.IORef -import qualified Data.List as L import Data.Word (Word32) -import qualified Network.Mux as Mux -import Network.Mux.Bearer (MakeBearer (..), makeSocketBearer) -import Network.Mux.Timeout (TimeoutFn, withTimeoutSerial) -import Network.Mux.Types (MiniProtocolDir (InitiatorDir), MiniProtocolNum (..), - RemoteClockModel (RemoteClockModel), SDU (..), SDUHeader (..)) -import qualified Network.Mux.Types as Mux -import Network.Socket (AddrInfo (..), PortNumber, StructLinger (..)) +import Network.Socket (AddrInfo (..), PortNumber) import qualified Network.Socket as Socket -import Prettyprinter import Testnet.Process.RunIO (liftIOAnnotated) @@ -50,93 +31,25 @@ import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO type TestnetMagic = Word32 --- | Mini protocol number. We're only sending ping, so 0. -handshakeNum :: MiniProtocolNum -handshakeNum = MiniProtocolNum 0 - --- | Timeout for reading a multiplexer service data unit, in seconds. -sduTimeout :: MT.DiffTime -sduTimeout = 30 - --- | Perform handshake query to obtain supported version numbers by node. -doHandshakeQuery :: Bool -doHandshakeQuery = True - -- | Ping the node once pingNode :: MonadIO m => TestnetMagic -- ^ testnet magic -> IO.Sprocket -- ^ node sprocket - -> m (Either PingClientError ()) -- ^ '()' means success -pingNode networkMagic sprocket = liftIOAnnotated $ bracket - (Socket.socket (Socket.addrFamily peer) Socket.Stream Socket.defaultProtocol) - Socket.close - (\sd -> handle (pure . Left . PceException) $ withTimeoutSerial $ \timeoutfn -> do - when (Socket.addrFamily peer /= Socket.AF_UNIX) $ do - Socket.setSocketOption sd Socket.NoDelay 1 - Socket.setSockOpt sd Socket.Linger - StructLinger - { sl_onoff = 1 - , sl_linger = 0 - } - - Socket.connect sd (Socket.addrAddress peer) - peerStr <- peerString - - bearer <- getBearer makeSocketBearer sduTimeout sd Nothing - - let versions = supportedNodeToClientVersions networkMagic - !_ <- Mux.write bearer nullTracer timeoutfn $ wrap handshakeNum InitiatorDir (handshakeReq versions doHandshakeQuery) - (msg, !_) <- nextMsg bearer timeoutfn handshakeNum - - pure $ case CBOR.deserialiseFromBytes handshakeDec msg of - Left err -> Left $ PceDecodingError peerStr err - Right (_, Left err) -> Left $ PceProtocolError peerStr err - Right (_, Right recVersions) - | areVersionsAccepted versions recVersions -> pure () - | otherwise -> Left $ PceVersionNegotiationError peerStr versions recVersions - ) + -> m (Either CNP.PingClientException ()) -- ^ 'Right ()' means success +pingNode networkMagic sprocket = + liftIOAnnotated $ + CNP.pingClient nullTracer nullTracer (pingOpts networkMagic) (sprocketToAddrInfo sprocket) where - peer = sprocketToAddrInfo sprocket :: AddrInfo - - -- | Wrap a message in a mux service data unit. - wrap :: MiniProtocolNum -> MiniProtocolDir -> LBS.ByteString -> SDU - wrap mhNum mhDir msBlob = SDU - { msHeader = SDUHeader - { mhTimestamp = RemoteClockModel 0 - , mhNum - , mhDir - , mhLength = fromIntegral $ LBS.length msBlob - } - , msBlob + pingOpts magic = CNP.PingOpts + { CNP.pingOptsCount = 1 + , CNP.pingOptsMagic = CNP.NetworkMagic magic + , CNP.pingOptsJson = CNP.AsText + , CNP.pingOptsQuiet = True + , CNP.pingOptsMode = CNP.PingMode + , CNP.pingOptsSRVPrefix = "_cardano._tcp" + , CNP.pingOptsColor = CNP.ColorAuto } - areVersionsAccepted :: [NodeVersion] -> [NodeVersion] -> Bool - areVersionsAccepted accVersions recVersions = - let intersects = L.intersectBy isSameVersionAndMagic recVersions accVersions in - not $ null intersects - - peerString :: IO String - peerString = - case Socket.addrFamily peer of - Socket.AF_UNIX -> pure . show $ Socket.addrAddress peer - _ -> do - (Just host, Just port) <- - Socket.getNameInfo - [Socket.NI_NUMERICHOST, Socket.NI_NUMERICSERV] - True True (Socket.addrAddress peer) - pure $ host <> ":" <> port - - -- | Fetch next message from mux bearer. Ignores messages not matching handshake protocol number. - nextMsg :: Mux.Bearer IO -- ^ a mux bearer - -> TimeoutFn IO -- ^ timeout function, for reading messages - -> MiniProtocolNum -- ^ handshake protocol number - -> IO (LBS.ByteString, Time) -- ^ raw message and timestamp - nextMsg bearer timeoutfn ptclNum = do - (sdu, t_e) <- Mux.read bearer nullTracer timeoutfn - if mhNum (msHeader sdu) == ptclNum - then pure (msBlob sdu, t_e) - else nextMsg bearer timeoutfn ptclNum - -- | Wait for 'sprocket' to become ready. Periodically tries to connect to 'sprocket', with the provided interval. -- If there was no success within 'timeout' period, return the last exception thrown during a connection -- attempt. @@ -185,29 +98,3 @@ waitForPortClosed timeout interval portNumber = liftIOAnnotated $ do let retryPolicy = R.constantDelay (round @Double $ realToFrac interval) <> R.limitRetries (ceiling $ toRational timeout / toRational interval) fmap not . R.retrying retryPolicy (const pure) $ \_ -> liftIOAnnotated (IO.isPortOpen (fromIntegral portNumber)) - -data PingClientError - = PceDecodingError - !String -- ^ peer string - !CBOR.DeserialiseFailure -- ^ deserialization exception - | PceProtocolError - !String -- ^ peer string - !HandshakeFailure -- ^ handshake exception - | PceVersionNegotiationError - !String -- ^ peer string - ![NodeVersion] -- ^ requested versions - ![NodeVersion] -- ^ received node versions - | PceException - !SomeException - -instance Error PingClientError where - prettyError = \case - PceDecodingError peerStr exception -> pretty peerStr <+> "Decoding error:" <+> pretty (displayException exception) - PceProtocolError peerStr exception -> pretty peerStr <+> "Protocol error:" <+> viaShow exception - PceVersionNegotiationError peerStr requestedVersions receivedVersions -> vsep - [ pretty peerStr <+> "Version negotiation error: No overlapping versions with" <+> viaShow requestedVersions - , "Received versions:" <+> viaShow receivedVersions - ] - PceException exception -> "An unknown exception occurred:" <+> pretty (displayException exception) - - diff --git a/cardano-testnet/src/Testnet/Process/Cli/DRep.hs b/cardano-testnet/src/Testnet/Process/Cli/DRep.hs index c7c4ac72ded..d2a7c481163 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/DRep.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/DRep.hs @@ -17,7 +17,7 @@ module Testnet.Process.Cli.DRep , makeActivityChangeProposal ) where -import Cardano.Api hiding (Certificate, TxBody, txId) +import Cardano.Api hiding (TxBody, txId) import Cardano.Api.Experimental (Some (..)) import Cardano.Api.Ledger (EpochInterval (EpochInterval, unEpochInterval)) diff --git a/cardano-testnet/src/Testnet/Process/Cli/SPO.hs b/cardano-testnet/src/Testnet/Process/Cli/SPO.hs index 703ff345b65..65fe2375332 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/SPO.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/SPO.hs @@ -16,6 +16,7 @@ module Testnet.Process.Cli.SPO ) where import Cardano.Api hiding (cardanoEra) +import Cardano.Api.Experimental.Certificate (PoolId) import qualified Cardano.Api.Ledger as L import qualified Cardano.Ledger.Shelley.LedgerState as L @@ -100,7 +101,9 @@ checkStakeKeyRegistered tempAbsP nodeConfigFile sPath terminationEpoch execConfi sAddr <- case deserialiseAddress AsStakeAddress $ Text.pack stakeAddr of Just sAddr -> return sAddr Nothing -> H.failWithCustom GHC.callStack Nothing $ "Invalid stake address: " <> stakeAddr + fs <- liftIO $ mkNodeConfigFs nodeConfigFile result <- runExceptT $ foldEpochState + fs nodeConfigFile sPath QuickValidation diff --git a/cardano-testnet/src/Testnet/Process/Cli/Transaction.hs b/cardano-testnet/src/Testnet/Process/Cli/Transaction.hs index 5ecbed60686..6a4c3984feb 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/Transaction.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/Transaction.hs @@ -17,7 +17,7 @@ module Testnet.Process.Cli.Transaction ) where -import Cardano.Api hiding (Certificate, TxBody) +import Cardano.Api hiding (TxBody) import Cardano.Api.Experimental (Some (..)) import Prelude diff --git a/cardano-testnet/src/Testnet/Property/Assert.hs b/cardano-testnet/src/Testnet/Property/Assert.hs index 2c0e6a0afd1..2e610847b86 100644 --- a/cardano-testnet/src/Testnet/Property/Assert.hs +++ b/cardano-testnet/src/Testnet/Property/Assert.hs @@ -16,6 +16,7 @@ module Testnet.Property.Assert import Cardano.Api hiding (Value) +import Cardano.Api.Experimental.Certificate (PoolId) import Prelude hiding (lines) diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index e271f264d42..cb0dd06bdd5 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -490,8 +490,11 @@ startLedgerNewEpochStateLogging testnetRuntime tmpWorkspace = withFrozenCallStac Just (sprocket, _) -> H.sprocketSystemName sprocket Nothing -> throwString "No testnet sprocket available" + fs <- liftIOAnnotated $ mkNodeConfigFs (configurationFile testnetRuntime) + void $ asyncRegister_ . runExceptT $ foldEpochState + fs (configurationFile testnetRuntime) (Api.File socketPath) Api.QuickValidation diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index c4df60856cb..2cb2272536d 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -433,8 +433,10 @@ cardanoTestnet -> TestnetNode -> m () waitForBlockThrow timeoutSeconds nodeConfigFile node@TestnetNode{nodeName} = do + fs <- liftIO $ mkNodeConfigFs nodeConfigFile result <- timeout (timeoutSeconds * 1_000_000) $ runExceptT . foldEpochState + fs nodeConfigFile (nodeSocketPath node) QuickValidation diff --git a/cardano-testnet/src/Testnet/Types.hs b/cardano-testnet/src/Testnet/Types.hs index 150087cd361..1a9b84e3237 100644 --- a/cardano-testnet/src/Testnet/Types.hs +++ b/cardano-testnet/src/Testnet/Types.hs @@ -51,6 +51,7 @@ import Cardano.Api.Experimental (Some (..)) import qualified Cardano.Chain.Genesis as G import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic (..)) +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromFile) import Cardano.Node.Configuration.POM import qualified Cardano.Node.Protocol.Byron as Byron import Cardano.Node.Types @@ -232,9 +233,8 @@ getStartTime tempRootPath TestnetRuntime{configurationFile} = withFrozenCallStac SystemStart . G.gdStartTime . G.configGenesisData <$> decodeGenesisFile byronGenesisFilePath where decodeNodeConfiguration :: File NodeConfig In -> ExceptT String IO NodeProtocolConfiguration - decodeNodeConfiguration (File file) = do - partialNodeCfg <- ExceptT $ A.eitherDecodeFileStrict' file - fmap ncProtocolConfig . liftEither . makeNodeConfiguration $ defaultPartialNodeConfiguration <> partialNodeCfg + decodeNodeConfiguration (File file) = + ncProtocolConfig <$> ExceptT (nodeConfigurationFromFile file) decodeGenesisFile :: FilePath -> ExceptT String IO G.Config decodeGenesisFile fp = withExceptT (docToString . prettyError) $ Byron.readGenesis (GenesisFile fp) Nothing RequiresNoMagic diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/version_cmd.cli b/cardano-testnet/test/cardano-testnet-golden/files/golden/version_cmd.cli index 47df628e4e8..f701358c870 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/version_cmd.cli +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/version_cmd.cli @@ -1,2 +1,2 @@ -built against cardano-api 11.0.0.0 -built against cardano-cli 11.0.0.0 +built against cardano-api 11.3.0.0 +built against cardano-cli 11.1.0.0 diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs index ba614728b7e..c6204ca365c 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Testnet.Test.Api.TxReferenceInputDatum ( hprop_tx_refin_datum @@ -11,10 +12,13 @@ module Cardano.Testnet.Test.Api.TxReferenceInputDatum where import Cardano.Api hiding (txId) +import qualified Cardano.Api.Experimental as Exp +import qualified Cardano.Api.Experimental.Tx as Exp import qualified Cardano.Api.Ledger as L import qualified Cardano.Api.Network as Net import qualified Cardano.Api.UTxO as Utxo +import Cardano.Ledger.Plutus.Data (hashData) import Cardano.Testnet import Prelude @@ -25,6 +29,7 @@ import Data.List (isInfixOf) import qualified Data.Map.Strict as M import Data.Maybe import Data.Set (Set) +import qualified Data.Set as Set import GHC.Exts (IsList (..)) import GHC.Stack import Lens.Micro @@ -53,9 +58,10 @@ hprop_tx_refin_datum = integrationRetryWorkspace 2 "api-tx-refin-dat" $ \tempAbs conf@Conf{tempAbsPath} <- mkConf tempAbsBasePath' let tempAbsPath' = unTmpAbsPath tempAbsPath - let ceo = ConwayEraOnwardsConway + let era = Exp.ConwayEra + sbe = convert era + ceo = convert era beo = convert ceo - sbe = convert ceo eraProxy = proxyToAsType Proxy creationOptions = def{creationEra = AnyShelleyBasedEra sbe} @@ -115,6 +121,7 @@ hprop_tx_refin_datum = integrationRetryWorkspace 2 "api-tx-refin-dat" $ \tempAbs -- prepare txout let txOutValue = lovelaceToTxOutValue sbe 100_000_000 + txOuts :: [TxOut CtxTx ConwayEra] txOuts = [ TxOut addr1 txOutValue txDatum1 ReferenceScriptNone , TxOut addr1 txOutValue txDatum2 ReferenceScriptNone @@ -122,28 +129,40 @@ hprop_tx_refin_datum = integrationRetryWorkspace 2 "api-tx-refin-dat" $ \tempAbs ] -- build a transaction + expTxOuts = map (Exp.TxOut . toShelleyTxOut sbe . toCtxUTxOTxOut) txOuts + -- toCtxUTxOTxOut strips the TxOutSupplementalDatum marker, so we must pass + -- supplemental datums explicitly + supplementalDatums = Exp.obtainCommonConstraints era $ M.fromList + [ let ledgerData = toAlonzoData @(ShelleyLedgerEra ConwayEra) sd + in (hashData ledgerData, ledgerData) + | sd <- [scriptData3] + ] content = - defaultTxBodyContent sbe - & setTxIns [(txIn, pure $ KeyWitness KeyWitnessForSpending)] - & setTxOuts txOuts - & setTxProtocolParams (pure $ pure pparams) + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxOuts expTxOuts + & Exp.setTxProtocolParams (unLedgerProtocolParameters pparams) + & Exp.setTxSupplementalDatums supplementalDatums utxo <- findAllUtxos epochStateView sbe + let ledgerUtxo = Utxo.toShelleyUTxO sbe utxo - BalancedTxBody _ txBody@(ShelleyTxBody _ lbody _ (TxBodyScriptData _ (L.TxDats datums) _) _ _) _ fee <- + (unsignedTx@(Exp.UnsignedTx ledgerTx), _finalContent) <- H.leftFail $ - makeTransactionBodyAutoBalance - sbe + Exp.makeTransactionBodyAutoBalance @ConwayEra systemStart epochInfo - pparams + (unLedgerProtocolParameters pparams) mempty mempty mempty - utxo + ledgerUtxo content addr0 Nothing -- keys override + + let lbody = ledgerTx ^. L.bodyTxL + fee = Exp.getUnsignedTxFee unsignedTx H.noteShow_ fee H.noteShowPretty_ lbody @@ -151,17 +170,20 @@ hprop_tx_refin_datum = integrationRetryWorkspace 2 "api-tx-refin-dat" $ \tempAbs -- sanity check that the integrity hash was calculated lbody ^. L.scriptIntegrityHashTxBodyL /== L.SNothing - let bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData + let L.TxDats datums = ledgerTx ^. L.witsTxL . L.datsTxWitsL + bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData -- Only supplemental datums are included here [ scriptData3 ] === bodyScriptData - let tx = signShelleyTransaction sbe txBody [wit0] - txId <- H.noteShow . getTxId $ getTxBody tx + let keyWit = Exp.makeKeyWitness era unsignedTx wit0 + Exp.SignedTx signedLedgerTx = Exp.signTx era [] [keyWit] unsignedTx + txId <- H.noteShow . Exp.obtainCommonConstraints era . TxId $ Exp.hashTxBody (signedLedgerTx ^. L.bodyTxL) - H.noteShowPretty_ tx + let signedTx = ShelleyTx sbe signedLedgerTx + H.noteShowPretty_ signedTx - expectTxSubmissionSuccess =<< submitTx sbe connectionInfo tx + expectTxSubmissionSuccess =<< submitTx sbe connectionInfo signedTx -- wait till transaction gets included in the block txUtxo <- retryUntilM epochStateView (WaitForBlocks 5) @@ -196,33 +218,42 @@ hprop_tx_refin_datum = integrationRetryWorkspace 2 "api-tx-refin-dat" $ \tempAbs -- manually balance txOutValue = lovelaceToTxOutValue sbe (100_000_000 - txFee) txOut = TxOut addr0 txOutValue txDatum ReferenceScriptNone - -- add actual datum values for the two reference inputs - txInsReference = TxInsReference beo [txIn1, txIn3] $ pure [scriptData1, scriptData3] + -- add actual datum values for the two reference inputs via supplemental datums + ledgerPparams = unLedgerProtocolParameters pparams + supplementalDatums = Exp.obtainCommonConstraints era $ M.fromList + [ let ledgerData = toAlonzoData @(ShelleyLedgerEra ConwayEra) sd + in (hashData ledgerData, ledgerData) + | sd <- [scriptData1, scriptData3, scriptData4] + ] let content = - defaultTxBodyContent sbe - & setTxIns [(txIn2, pure $ KeyWitness KeyWitnessForSpending)] - & setTxInsReference txInsReference - & setTxFee (TxFeeExplicit sbe txFee) - & setTxOuts [txOut] - & setTxProtocolParams (pure $ pure pparams) - - txBody@(ShelleyTxBody _ lbody _ (TxBodyScriptData _ (L.TxDats datums) _) _ _) <- - H.leftFail $ createTransactionBody sbe content - - let bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn2, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxInsReference (Exp.TxInsReference [txIn1, txIn3] Set.empty) + & Exp.setTxFee txFee + & Exp.setTxOuts [Exp.TxOut . toShelleyTxOut sbe $ toCtxUTxOTxOut txOut] + & Exp.setTxProtocolParams ledgerPparams + & Exp.setTxSupplementalDatums supplementalDatums + + unsignedTx@(Exp.UnsignedTx ledgerTx) <- + H.leftFail $ Exp.makeUnsignedTx era content + + let lbody = ledgerTx ^. L.bodyTxL + L.TxDats datums = ledgerTx ^. L.witsTxL . L.datsTxWitsL + bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData -- only hashes (1 & 3) and supplemental (4) are present here [scriptData1, scriptData3, scriptData4] === bodyScriptData - H.noteShowPretty_ txBody + H.noteShowPretty_ lbody -- make sure that the script integrity hash was calculated lbody ^. L.scriptIntegrityHashTxBodyL /== L.SNothing - let tx = signShelleyTransaction sbe txBody [wit1] - txId <- H.noteShow . getTxId $ getTxBody tx + let keyWit = Exp.makeKeyWitness era unsignedTx wit1 + Exp.SignedTx signedLedgerTx = Exp.signTx era [] [keyWit] unsignedTx + txId <- H.noteShow . Exp.obtainCommonConstraints era . TxId $ Exp.hashTxBody (signedLedgerTx ^. L.bodyTxL) - expectTxSubmissionSuccess =<< submitTx sbe connectionInfo tx + expectTxSubmissionSuccess =<< submitTx sbe connectionInfo (ShelleyTx sbe signedLedgerTx) -- wait till transaction gets included in the block txUtxo <- retryUntilM epochStateView (WaitForBlocks 5) @@ -244,34 +275,43 @@ hprop_tx_refin_datum = integrationRetryWorkspace 2 "api-tx-refin-dat" $ \tempAbs txOutValue = lovelaceToTxOutValue sbe (99_999_500 - txFee) txOut = TxOut addr0 txOutValue TxOutDatumNone ReferenceScriptNone -- add one reference input with datum hash and its datum, and one superfluous datum - txInsReference = TxInsReference beo [txIn1] $ pure [scriptData1, scriptData3] + ledgerPparams3 = unLedgerProtocolParameters pparams + supplementalDatums3 = Exp.obtainCommonConstraints era $ M.fromList + [ let ledgerData = toAlonzoData @(ShelleyLedgerEra ConwayEra) sd + in (hashData ledgerData, ledgerData) + | sd <- [scriptData1, scriptData3] + ] let content = - defaultTxBodyContent sbe - & setTxIns [(tx2In1, pure $ KeyWitness KeyWitnessForSpending)] - & setTxInsReference txInsReference - & setTxFee (TxFeeExplicit sbe txFee) - & setTxOuts [txOut] - & setTxProtocolParams (pure $ pure pparams) - - txBody@(ShelleyTxBody _ lbody _ (TxBodyScriptData _ (L.TxDats datums) _) _ _) <- - H.leftFail $ createTransactionBody sbe content - - let bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData + Exp.defaultTxBodyContent + & Exp.setTxIns [(tx2In1, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxInsReference (Exp.TxInsReference [txIn1] Set.empty) + & Exp.setTxFee txFee + & Exp.setTxOuts [Exp.TxOut . toShelleyTxOut sbe $ toCtxUTxOTxOut txOut] + & Exp.setTxProtocolParams ledgerPparams3 + & Exp.setTxSupplementalDatums supplementalDatums3 + + unsignedTx3@(Exp.UnsignedTx ledgerTx3) <- + H.leftFail $ Exp.makeUnsignedTx era content + + let lbody = ledgerTx3 ^. L.bodyTxL + L.TxDats datums = ledgerTx3 ^. L.witsTxL . L.datsTxWitsL + bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData -- all hashes of datums supplied to reference inputs (1 & 3) are present here [scriptData1, scriptData3] === bodyScriptData - H.noteShowPretty_ txBody + H.noteShowPretty_ lbody -- make sure that the script integrity hash was calculated lbody ^. L.scriptIntegrityHashTxBodyL /== L.SNothing - let tx = signShelleyTransaction sbe txBody [wit0] - -- H.noteShowPretty_ tx - H.noteShow_ . getTxId $ getTxBody tx + let keyWit = Exp.makeKeyWitness era unsignedTx3 wit0 + Exp.SignedTx signedLedgerTx = Exp.signTx era [] [keyWit] unsignedTx3 + Exp.obtainCommonConstraints era $ + H.noteShow_ . TxId $ Exp.hashTxBody (signedLedgerTx ^. L.bodyTxL) -- transaction contains not allowed supplemental datum, submission has to fail - submitTx sbe connectionInfo tx >>= \case + submitTx sbe connectionInfo (ShelleyTx sbe signedLedgerTx) >>= \case Right () -> do H.note_ "Transaction submission succeeded, but it should fail!" H.failure diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction.hs index 46265346eaa..af9d4b781d0 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/Transaction.hs @@ -13,7 +13,6 @@ import qualified Cardano.Api.Ledger as L import Cardano.CLI.Type.Common import Cardano.Crypto.Hash.Class (hashToStringAsHex) -import qualified Cardano.Ledger.Core as L import Cardano.Testnet import Prelude diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs index 5968465b287..49ced0b4ce8 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/FoldEpochState.hs @@ -16,6 +16,7 @@ import Data.Default.Class import qualified System.Directory as IO import System.FilePath (()) +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Property.Util (integrationRetryWorkspace) import Hedgehog ((===)) @@ -49,7 +50,9 @@ prop_foldEpochState = integrationRetryWorkspace 2 "foldEpochState" $ \tempAbsBas then pure ConditionMet else pure ConditionNotMet - (_, nums) <- H.leftFailM $ H.evalIO $ runExceptT $ - Api.foldEpochState configurationFile (Api.File socketPathAbs) Api.QuickValidation (EpochNo maxBound) [] handler + (_, nums) <- H.leftFailM $ H.evalIO $ do + fs <- mkNodeConfigFs configurationFile + runExceptT $ + Api.foldEpochState fs configurationFile (Api.File socketPathAbs) Api.QuickValidation (EpochNo maxBound) [] handler length nums === 10 diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs index b4d17b8703b..75b4548d405 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/InfoAction.hs @@ -34,6 +34,7 @@ import System.FilePath (()) import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Query import Testnet.Defaults +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Process.Cli.Keys import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) import Testnet.Process.Cli.Transaction (retrieveTransactionId) @@ -246,8 +247,10 @@ hprop_ledger_events_info_action = integrationRetryWorkspace 2 "info-hash" $ \tem ] -- We check that info action was successfully ratified + fs <- evalIO $ mkNodeConfigFs configurationFile !meInfoRatified <- H.timeout 120_000_000 $ runExceptT $ foldBlocks + fs configurationFile socketPath FullValidation diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs index 0e8df21398f..f8d517a1871 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs @@ -41,6 +41,7 @@ import Testnet.Components.Configuration import Testnet.Components.Query import Testnet.Defaults import Testnet.EpochStateProcessing (unsafeEraFromSbe, waitForGovActionVotes) +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Process.Cli.DRep import Testnet.Process.Cli.Keys import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) @@ -232,69 +233,29 @@ hprop_ledger_events_propose_new_constitution = integrationRetryWorkspace 2 "prop retryUntilJustM epochStateView (WaitForEpochs $ EpochInterval 1) $ maybeExtractGovernanceActionIndex governanceActionTxId <$> getEpochState epochStateView - -- Proposal was successfully submitted, now we vote on the proposal and confirm it was ratified - voteFiles <- generateVoteFiles execConfig work "vote-files" - governanceActionTxId governanceActionIndex - [(defaultDRepKeyPair idx, vote) | (vote, idx) <- allVotes] - - -- Submit votes - voteTxBodyFp <- createVotingTxBody execConfig epochStateView sbe work "vote-tx-body" - voteFiles wallet0 - - let signingKeys = Some <$> (paymentKeyInfoPair wallet0:(defaultDRepKeyPair . snd <$> allVotes)) - voteTxFp <- signTx execConfig cEra gov "signed-vote-tx" voteTxBodyFp signingKeys - - submitTx execConfig cEra voteTxFp - - waitForGovActionVotes epochStateView (EpochInterval 1) - - txId <- H.noteShowM $ retrieveTransactionId execConfig signedProposalTx - - -- Count votes before checking for ratification. It may happen that the proposal gets removed after - -- ratification because of a long waiting time, so we won't be able to access votes. - govState <- getGovState epochStateView ceo - govActionState <- H.headM $ govState ^. L.cgsProposalsL . L.pPropsL . to toList - let votes = govActionState ^. L.gasDRepVotesL . to toList - - length (filter ((== L.VoteYes) . snd) votes) === 4 - length (filter ((== L.VoteNo) . snd) votes) === 3 - length (filter ((== L.Abstain) . snd) votes) === 2 - length votes === fromIntegral numVotes - - -- We check that constitution was successfully ratified - void . H.leftFailM . H.evalIO . runExceptT $ - foldEpochState - configurationFile - socketPath - FullValidation - (EpochNo 10) - () - (\epochState _ _ -> foldBlocksCheckConstitutionWasRatified constitutionHash constitutionScriptHash epochState) - - proposalsJSON :: Aeson.Value <- execCliStdoutToJson execConfig - [ eraName, "query", "proposals", "--governance-action-tx-id", prettyShow txId - , "--governance-action-index", "0" - ] + -- Query proposals via CLI before voting to verify proposal structure. + -- This is race-free: the proposal cannot be ratified before votes are cast. + -- Retry until the DRep pulsing snapshot (used by `query proposals`) is refreshed + -- with the newly submitted proposal. The current proposals map is updated immediately, but the + -- pulsing snapshot only picks up new proposals at epoch boundaries. + (proposalsJSON, proposalsArray) <- + retryUntilJustM epochStateView (WaitForEpochs $ EpochInterval 2) $ do + json :: Aeson.Value <- execCliStdoutToJson execConfig + [ eraName, "query", "proposals", "--governance-action-tx-id", prettyShow governanceActionTxId + , "--governance-action-index", "0" + ] + pure $ do + arr <- json ^? Aeson._Array + guard (length arr == 1) + pure (json, arr) -- Display JSON returned in case of failure H.note_ $ Text.unpack . decodeUtf8 $ prettyPrintJSON proposalsJSON - - -- Check that the proposals array has only one element and fetch it - proposalsArray <- H.evalMaybe $ proposalsJSON ^? Aeson._Array - length proposalsArray === 1 let proposal = proposalsArray Vector.! 0 -- Check TxId returned is the same as the one we used proposalsTxId <- H.evalMaybe $ proposal ^? Aeson.key "actionId" . Aeson.key "txId" . Aeson._String - proposalsTxId === Text.pack (prettyShow txId) - - -- Check that committeeVotes is an empty object - proposalsCommitteeVotes <- H.evalMaybe $ proposal ^? Aeson.key "committeeVotes" . Aeson._Object - proposalsCommitteeVotes === mempty - - -- Check that dRepVotes has the expected number of votes - proposalsDRepVotes <- H.evalMaybe $ proposal ^? Aeson.key "dRepVotes" . Aeson._Object - length proposalsDRepVotes === numVotes + proposalsTxId === Text.pack (prettyShow governanceActionTxId) -- Fetch proposalProcedure and anchor proposalsProcedure <- H.evalMaybe $ proposal ^? Aeson.key "proposalProcedure" @@ -334,9 +295,76 @@ hprop_ledger_events_propose_new_constitution = integrationRetryWorkspace 2 "prop proposalsTag <- H.evalMaybe $ proposalsProcedure ^? Aeson.key "govAction" . Aeson.key "tag" . Aeson._String proposalsTag === "NewConstitution" - -- Check the stake pool votes are empty - proposalsStakePoolVotes <- H.evalMaybe $ proposal ^? Aeson.key "stakePoolVotes" . Aeson._Object - proposalsStakePoolVotes === mempty + -- Proposal was successfully submitted, now we vote on the proposal and confirm it was ratified + voteFiles <- generateVoteFiles execConfig work "vote-files" + governanceActionTxId governanceActionIndex + [(defaultDRepKeyPair idx, vote) | (vote, idx) <- allVotes] + + -- Submit votes + voteTxBodyFp <- createVotingTxBody execConfig epochStateView sbe work "vote-tx-body" + voteFiles wallet0 + + let signingKeys = Some <$> (paymentKeyInfoPair wallet0:(defaultDRepKeyPair . snd <$> allVotes)) + voteTxFp <- signTx execConfig cEra gov "signed-vote-tx" voteTxBodyFp signingKeys + + submitTx execConfig cEra voteTxFp + + waitForGovActionVotes epochStateView (EpochInterval 1) + + -- Count votes before checking for ratification. It may happen that the proposal gets removed after + -- ratification because of a long waiting time, so we won't be able to access votes. + govState <- getGovState epochStateView ceo + govActionState <- H.headM $ govState ^. L.cgsProposalsL . L.pPropsL . to toList + let votes = govActionState ^. L.gasDRepVotesL . to toList + + length (filter ((== L.VoteYes) . snd) votes) === 4 + length (filter ((== L.VoteNo) . snd) votes) === 3 + length (filter ((== L.Abstain) . snd) votes) === 2 + length votes === fromIntegral numVotes + + -- Query proposals via CLI to verify vote counts are reported correctly. + -- The proposal may have been ratified at an epoch boundary between the ledger check above and this + -- CLI query, in which case the proposal is removed from gov-state and the query returns []. + -- The pulsing snapshot may also not yet include the votes even though they are in the ledger state. + -- The ledger-level vote checks above already verified correctness, so we skip gracefully in both cases. + votedProposalsJSON :: Aeson.Value <- execCliStdoutToJson execConfig + [ eraName, "query", "proposals", "--governance-action-tx-id", prettyShow governanceActionTxId + , "--governance-action-index", "0" + ] + + H.note_ $ Text.unpack . decodeUtf8 $ prettyPrintJSON votedProposalsJSON + + votedProposalsArray <- H.evalMaybe $ votedProposalsJSON ^? Aeson._Array + unless (null votedProposalsArray) $ do + length votedProposalsArray === 1 + let votedProposal = votedProposalsArray Vector.! 0 + + -- Check that dRepVotes has the expected number of votes + proposalsDRepVotes <- H.evalMaybe $ votedProposal ^? Aeson.key "dRepVotes" . Aeson._Object + -- Skip if the pulsing snapshot has not yet refreshed with votes + unless (null proposalsDRepVotes) $ do + length proposalsDRepVotes === numVotes + + -- Check that committeeVotes is an empty object + proposalsCommitteeVotes <- H.evalMaybe $ votedProposal ^? Aeson.key "committeeVotes" . Aeson._Object + proposalsCommitteeVotes === mempty + + -- Check the stake pool votes are empty + proposalsStakePoolVotes <- H.evalMaybe $ votedProposal ^? Aeson.key "stakePoolVotes" . Aeson._Object + proposalsStakePoolVotes === mempty + + -- We check that constitution was successfully ratified + void . H.leftFailM . H.evalIO $ do + fs <- mkNodeConfigFs configurationFile + runExceptT $ + foldEpochState + fs + configurationFile + socketPath + FullValidation + (EpochNo 10) + () + (\epochState _ _ -> foldBlocksCheckConstitutionWasRatified constitutionHash constitutionScriptHash epochState) foldBlocksCheckConstitutionWasRatified :: String -- submitted constitution hash diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs index 7add69da333..45b1572b5db 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs @@ -30,6 +30,7 @@ import System.FilePath (()) import Testnet.Components.Query import Testnet.Defaults import Testnet.EpochStateProcessing (unsafeEraFromSbe) +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Process.Cli.DRep import Testnet.Process.Cli.Keys import qualified Testnet.Process.Cli.SPO as SPO @@ -182,7 +183,8 @@ getConstitutionProposal -> EpochNo -- ^ The termination epoch: the constitution proposal must be found *before* this epoch -> m (Maybe L.GovActionId) getConstitutionProposal nodeConfigFile socketPath maxEpoch = do - result <- H.evalIO . runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation maxEpoch Nothing + fs <- H.evalIO $ mkNodeConfigFs nodeConfigFile + result <- H.evalIO . runExceptT $ foldEpochState fs nodeConfigFile socketPath QuickValidation maxEpoch Nothing $ \(AnyNewEpochState actualEra newEpochState _) _slotNb _blockNb -> obtainCommonConstraints (unsafeEraFromSbe actualEra) $ do let proposals = newEpochState diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs index ae7507f9124..fbaede662e5 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryGrowth.hs @@ -23,6 +23,7 @@ import Lens.Micro ((^.)) import qualified System.Directory as IO import System.FilePath (()) +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Process.Run (execCli', mkExecConfig) import Testnet.Property.Util (integrationRetryWorkspace) import Testnet.Start.Types @@ -58,8 +59,10 @@ prop_check_if_treasury_is_growing = integrationRetryWorkspace 2 "growing-treasur execConfig <- mkExecConfig tempBaseAbsPath poolSprocket1 testnetMagic pure (execConfig, socketPathAbs) - (_condition, treasuryValues) <- H.leftFailM . H.evalIO . runExceptT $ - Api.foldEpochState configurationFile socketPathAbs Api.QuickValidation (EpochNo 10) M.empty handler + (_condition, treasuryValues) <- H.leftFailM . H.evalIO $ do + fs <- mkNodeConfigFs configurationFile + runExceptT $ + Api.foldEpochState fs configurationFile socketPathAbs Api.QuickValidation (EpochNo 10) M.empty handler H.note_ $ "treasury for last 5 epochs: " <> show treasuryValues let treasuriesSortedByEpoch = diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs index a4ae043d71b..ac94cb48ca3 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryWithdrawal.hs @@ -41,6 +41,7 @@ import Test.Cardano.CLI.Hash (serveFilesWhile) import Testnet.Components.Query import Testnet.Defaults import Testnet.EpochStateProcessing (unsafeEraFromSbe) +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Process.Cli.Keys (cliStakeAddressKeyGen) import Testnet.Process.Cli.SPO (createStakeKeyRegistrationCertificate) import Testnet.Process.Cli.Transaction (retrieveTransactionId) @@ -271,7 +272,8 @@ getAnyWithdrawals -> EpochNo -> m (Maybe (Map (Credential Staking) Coin)) getAnyWithdrawals nodeConfigFile socketPath maxEpoch = withFrozenCallStack $ do - fmap snd . H.leftFailM . evalIO . runExceptT $ foldEpochState nodeConfigFile socketPath FullValidation maxEpoch Nothing + fs <- evalIO $ mkNodeConfigFs nodeConfigFile + fmap snd . H.leftFailM . evalIO . runExceptT $ foldEpochState fs nodeConfigFile socketPath FullValidation maxEpoch Nothing $ \(AnyNewEpochState actualEra newEpochState _) _ _ -> obtainCommonConstraints (unsafeEraFromSbe actualEra) $ do let withdrawals = newEpochState @@ -296,7 +298,8 @@ getTreasuryWithdrawalProposal -> EpochNo -- ^ The termination epoch: the withdrawal proposal must be found *before* this epoch -> m (Maybe L.GovActionId) getTreasuryWithdrawalProposal nodeConfigFile socketPath maxEpoch = withFrozenCallStack $ do - fmap snd . H.leftFailM . evalIO . runExceptT $ foldEpochState nodeConfigFile socketPath QuickValidation maxEpoch Nothing + fs <- evalIO $ mkNodeConfigFs nodeConfigFile + fmap snd . H.leftFailM . evalIO . runExceptT $ foldEpochState fs nodeConfigFile socketPath QuickValidation maxEpoch Nothing $ \(AnyNewEpochState actualEra newEpochState _) _ _ -> obtainCommonConstraints (unsafeEraFromSbe actualEra) $ do let proposals = newEpochState diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Eval.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Eval.hs new file mode 100644 index 00000000000..60b2f0ee22b --- /dev/null +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Eval.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Run with: +-- @TASTY_PATTERN='/RPC Eval Tx/' cabal test cardano-testnet-test@ +module Cardano.Testnet.Test.Rpc.Eval + ( hprop_rpc_eval_tx + ) +where + +import Cardano.Api +import qualified Cardano.Api.Experimental as Exp +import qualified Cardano.Api.Ledger as L + +import Cardano.Rpc.Client (Proto (..)) +import qualified Cardano.Rpc.Client as Rpc +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as U5c hiding (cardano) +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Submit as U5c +import Cardano.Rpc.Server.Internal.UtxoRpc.Type (utxoRpcBigIntToInteger) +import Cardano.Testnet + +import Prelude + +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp) +import Data.Default.Class +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Lens.Micro +import System.FilePath (()) + +import Testnet.Components.Query (TestnetWaitPeriod (..), findLargestUtxoForPaymentKey, + findLargestUtxoWithAddress, getEpochStateView, retryUntilJustM) +import Testnet.Defaults (plutusV3Script) +import Testnet.Process.Run (execCli', mkExecConfig) +import Testnet.Property.Util (integrationRetryWorkspace) +import Testnet.Start.Types (anyEraToString) +import Testnet.Types + +import Hedgehog +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.File as H +import qualified Hedgehog.Extras.Test.TestWatchdog as H + +-- | Evaluate a Plutus V3 spending transaction via the gRPC evalTx endpoint and +-- verify that the response contains a valid fee, non-zero execution units, one +-- redeemer, and no errors. +hprop_rpc_eval_tx :: Property +hprop_rpc_eval_tx = integrationRetryWorkspace 2 "rpc-eval-tx" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do + conf@Conf{tempAbsPath} <- mkConf tempAbsBasePath' + let tempAbsPath' = unTmpAbsPath tempAbsPath + work <- H.createDirectoryIfMissing $ tempAbsPath' "work" + + let tempBaseAbsPath = makeTmpBaseAbsPath $ TmpAbsolutePath tempAbsPath' + era = Exp.ConwayEra + sbe = convert era + anyEra = AnyCardanoEra $ toCardanoEra sbe + creationOptions = def{creationEra = AnyShelleyBasedEra sbe} + runtimeOptions = def{runtimeEnableRpc = RpcEnabled} + + TestnetRuntime + { configurationFile + , testnetMagic + , testnetNodes = node : _ + , wallets = wallet0 : wallet1 : _ + } <- + createAndRunTestnet creationOptions runtimeOptions conf + + poolSprocket <- H.noteShow $ nodeSprocket node + execConfig <- mkExecConfig tempBaseAbsPath poolSprocket testnetMagic + epochStateView <- getEpochStateView configurationFile $ nodeSocketPath node + rpcSocket <- H.note . unFile $ nodeRpcSocketPath node + + let rpcServer = Rpc.ServerUnix rpcSocket + utxoSKeyFile = signingKeyFp $ paymentKeyInfoPair wallet0 + utxoSKeyFile1 = signingKeyFp $ paymentKeyInfoPair wallet1 + + ------------------------------------ + -- Write Plutus V3 always-succeeds script + ------------------------------------ + plutusScriptFile <- H.note $ work "always-succeeds.plutusV3" + H.writeFile plutusScriptFile $ T.unpack plutusV3Script + + plutusSpendingScriptAddr <- + execCli' + execConfig + [ "latest" + , "address" + , "build" + , "--payment-script-file" , plutusScriptFile + ] + + scriptDatumHash <- + filter (/= '\n') + <$> execCli' + execConfig + [ "latest" + , "transaction" + , "hash-script-data" + , "--script-data-value" + , "0" + ] + + -- Send ADA to the script address with a datum hash, creating a script-locked + -- UTxO that the spending transaction can later reference with a redeemer. + ------------------------------------ + -- 1. Fund the script address + ------------------------------------ + txinFund <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 + + let fundTxBody = work "fund-script-tx-body" + fundTx = work "fund-script-tx" + + void $ + execCli' + execConfig + [ anyEraToString anyEra + , "transaction" + , "build" + , "--change-address" , T.unpack $ paymentKeyInfoAddr wallet0 + , "--tx-in" , T.unpack $ renderTxIn txinFund + , "--tx-out" , plutusSpendingScriptAddr <> "+" <> show @Int 5_000_000 + , "--tx-out-datum-hash" , scriptDatumHash + , "--out-file" , fundTxBody + ] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "sign" + , "--tx-body-file" , fundTxBody + , "--signing-key-file" , utxoSKeyFile + , "--out-file" , fundTx + ] + + ------------------------------------ + -- 1b. EvalTx on the funding tx (no scripts) + ------------------------------------ + (fundLedgerTx, fundTxEval) <- evalTxFile sbe rpcServer fundTx + + let fundCliFee = fundLedgerTx ^. L.bodyTxL . L.feeTxBodyL + + H.note_ "EvalTx minimum fee should not exceed the CLI-computed fee" + fundEvalFee <- H.leftFail $ fundTxEval ^. U5c.fee . to utxoRpcBigIntToInteger + H.assertWith fundEvalFee (<= L.unCoin fundCliFee) + + H.note_ "No execution units for a plain key-witnessed transaction" + fundTxEval ^. U5c.exUnits . U5c.steps === 0 + fundTxEval ^. U5c.exUnits . U5c.memory === 0 + + H.note_ "No redeemers for a plain key-witnessed transaction" + fundTxEval ^. U5c.redeemers === [] + + H.note_ "No evaluation errors" + fundTxEval ^. U5c.errors === [] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "submit" + , "--tx-file" , fundTx + ] + + ------------------------------------ + -- 2. Wait for the script UTxO, find collateral + ------------------------------------ + plutusScriptTxIn <- + fmap fst . retryUntilJustM epochStateView (WaitForBlocks 3) $ + findLargestUtxoWithAddress epochStateView sbe $ + T.pack plutusSpendingScriptAddr + + txinCollateral <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 + + ------------------------------------ + -- 3. Build and sign the spending tx + ------------------------------------ + let spendTxBody = work "spend-script-tx-body" + spendTx = work "spend-script-tx" + + void $ + execCli' + execConfig + [ anyEraToString anyEra + , "transaction" + , "build" + , "--change-address" , T.unpack $ paymentKeyInfoAddr wallet1 + , "--tx-in-collateral" , T.unpack $ renderTxIn txinCollateral + , "--tx-in" , T.unpack $ renderTxIn plutusScriptTxIn + , "--tx-in-script-file" , plutusScriptFile + , "--tx-in-datum-value" , "0" + , "--tx-in-redeemer-value" , "0" + , "--out-file" , spendTxBody + ] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "sign" + , "--tx-body-file" , spendTxBody + , "--signing-key-file" , utxoSKeyFile1 + , "--out-file" , spendTx + ] + + ------------------------------------ + -- 4. EvalTx on the spending tx (Plutus V3 always-succeeds) + ------------------------------------ + (ledgerTx, txEval) <- evalTxFile sbe rpcServer spendTx + + let cliFee = ledgerTx ^. L.bodyTxL . L.feeTxBodyL + + H.note_ "EvalTx minimum fee should not exceed the CLI-computed fee" + evalFee <- H.leftFail $ txEval ^. U5c.fee . to utxoRpcBigIntToInteger + H.assertWith evalFee (<= L.unCoin cliFee) + + H.note_ "Execution units should match the transaction" + (_, L.ExUnits txMem txSteps) <- H.headM . Map.elems . L.unRedeemers $ ledgerTx ^. L.witsTxL . L.rdmrsTxWitsL + txEval ^. U5c.exUnits . U5c.steps === fromIntegral txSteps + txEval ^. U5c.exUnits . U5c.memory === fromIntegral txMem + + H.note_ "One redeemer for the spend purpose at index 0" + let redeemers = txEval ^. U5c.redeemers + length redeemers === 1 + redeemer0 <- H.headM redeemers + redeemer0 ^. U5c.purpose === Proto U5c.REDEEMER_PURPOSE_SPEND + redeemer0 ^. U5c.index === 0 + redeemer0 ^. U5c.exUnits . U5c.steps === fromIntegral txSteps + redeemer0 ^. U5c.exUnits . U5c.memory === fromIntegral txMem + + H.note_ "No evaluation errors" + txEval ^. U5c.errors === [] + + ------------------------------------ + -- 5. Failure path: always-fails script + ------------------------------------ + let failScript = PlutusScript PlutusScriptV1 $ examplePlutusScriptAlwaysFails WitCtxTxIn + failScriptFile <- H.note $ work "always-fails.plutusV1" + H.leftFailM . H.evalIO $ + writeFileTextEnvelope (File failScriptFile) Nothing failScript + + failScriptAddr <- + execCli' + execConfig + [ "latest" + , "address" + , "build" + , "--payment-script-file" , failScriptFile + ] + + txinFund2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 + + let fundFailTxBody = work "fund-fail-script-tx-body" + fundFailTx = work "fund-fail-script-tx" + + void $ + execCli' + execConfig + [ anyEraToString anyEra + , "transaction" + , "build" + , "--change-address" , T.unpack $ paymentKeyInfoAddr wallet0 + , "--tx-in" , T.unpack $ renderTxIn txinFund2 + , "--tx-out" , failScriptAddr <> "+" <> show @Int 5_000_000 + , "--tx-out-datum-hash" , scriptDatumHash + , "--out-file" , fundFailTxBody + ] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "sign" + , "--tx-body-file" , fundFailTxBody + , "--signing-key-file" , utxoSKeyFile + , "--out-file" , fundFailTx + ] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "submit" + , "--tx-file" , fundFailTx + ] + + failScriptTxIn <- + fmap fst . retryUntilJustM epochStateView (WaitForBlocks 3) $ + findLargestUtxoWithAddress epochStateView sbe $ + T.pack failScriptAddr + + txinCollateral2 <- findLargestUtxoForPaymentKey epochStateView sbe wallet1 + + protocolParamsFile <- H.note $ work "protocol-params.json" + void $ + execCli' + execConfig + [ "latest" + , "query" + , "protocol-parameters" + , "--out-file" , protocolParamsFile + ] + + -- Use build-raw because `transaction build` would reject the always-fails script. + let failSpendTxBody = work "fail-spend-tx-body" + failSpendTx = work "fail-spend-tx" + + void $ + execCli' + execConfig + [ anyEraToString anyEra + , "transaction" + , "build-raw" + , "--tx-in" , T.unpack $ renderTxIn failScriptTxIn + , "--tx-in-collateral" , T.unpack $ renderTxIn txinCollateral2 + , "--tx-in-script-file" , failScriptFile + , "--tx-in-datum-value" , "0" + , "--tx-in-redeemer-value" , "0" + , "--tx-in-execution-units" , "(10000000000,10000000)" + , "--tx-out" , T.unpack (paymentKeyInfoAddr wallet1) <> "+4700000" + , "--fee" , "300000" + , "--protocol-params-file" , protocolParamsFile + , "--out-file" , failSpendTxBody + ] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "sign" + , "--tx-body-file" , failSpendTxBody + , "--signing-key-file" , utxoSKeyFile1 + , "--out-file" , failSpendTx + ] + + ------------------------------------ + -- 5b. EvalTx on the always-fails spending tx + ------------------------------------ + (_, failTxEval) <- evalTxFile sbe rpcServer failSpendTx + + H.note_ "Evaluation errors for always-fails script" + failTxEval ^. U5c.errors /== [] + + ------------------------------------ + -- 6. Unbalanced key-witnessed tx + ------------------------------------ + txinUnbal <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 + + let unbalTxBody = work "unbal-tx-body" + unbalTx = work "unbal-tx" + + void $ + execCli' + execConfig + [ anyEraToString anyEra + , "transaction" + , "build-raw" + , "--tx-in" , T.unpack $ renderTxIn txinUnbal + , "--tx-out" , T.unpack (paymentKeyInfoAddr wallet0) <> "+1000000" + , "--fee" , "200000" + , "--out-file" , unbalTxBody + ] + + void $ + execCli' + execConfig + [ "latest" + , "transaction" + , "sign" + , "--tx-body-file" , unbalTxBody + , "--signing-key-file" , utxoSKeyFile + , "--out-file" , unbalTx + ] + + (_, unbalTxEval) <- evalTxFile sbe rpcServer unbalTx + + H.note_ "Balance error for unbalanced transaction" + unbalTxEval ^. U5c.errors /== [] + unbalError <- H.headM $ unbalTxEval ^. U5c.errors + H.assertWith (unbalError ^. U5c.msg) $ T.isInfixOf "not balanced" + + H.note_ "Non-zero fee is still returned" + unbalEvalFee <- H.leftFail $ unbalTxEval ^. U5c.fee . to utxoRpcBigIntToInteger + H.assertWith unbalEvalFee (> 0) + +-- | Read a signed transaction from a file and evaluate it via the gRPC evalTx +-- endpoint, returning the ledger transaction and the TxEval result. +evalTxFile + :: forall era m + . (HasCallStack, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadTest m) + => ShelleyBasedEra era + -> Rpc.Server + -> FilePath + -> m (L.Tx L.TopTx (ShelleyLedgerEra era), Proto U5c.TxEval) +evalTxFile sbe' rpcServer txFile = withFrozenCallStack $ shelleyBasedEraConstraints sbe' $ do + textEnvelope <- H.leftFailM . H.evalIO $ readTextEnvelopeFromFile txFile + ShelleyTx _ ledgerTx <- H.leftFail $ deserialiseFromTextEnvelope @(Tx era) textEnvelope + let request = def & U5c.tx . U5c.raw .~ textEnvelopeRawCBOR textEnvelope + (response :: Proto U5c.EvalTxResponse) <- + liftBaseOp (Rpc.withConnection def rpcServer) $ \conn -> + H.noteShowPrettyM . H.evalIO $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf U5c.SubmitService "evalTx")) request + pure (ledgerTx, response ^. U5c.report . U5c.cardano) diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs index 316917617ea..c21ee856091 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs @@ -29,15 +29,20 @@ import Cardano.Testnet import Prelude import Control.Exception +import Control.Monad import qualified Data.ByteString.Short as SBS import Data.Default.Class import qualified Data.Map.Strict as M +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word64) +import GHC.Exts (toList) import Lens.Micro import Testnet.Components.Query import Testnet.Process.Run import Testnet.Property.Util (integrationRetryWorkspace) import Testnet.Start.Types +import Testnet.Types (nodeConnectionInfo) import Hedgehog import qualified Hedgehog as H @@ -57,7 +62,7 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem creationOptions = def{creationEra = AnyShelleyBasedEra sbe} runtimeOptions = def{runtimeEnableRpc = RpcEnabled} - TestnetRuntime + tr@TestnetRuntime { testnetMagic , configurationFile , testnetNodes = node0@TestnetNode{nodeSprocket} : _ @@ -80,6 +85,20 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem ChainTipAtGenesis -> H.failure -- impossible ChainTip (SlotNo slot) (HeaderHash hash) (BlockNo blockNo) -> pure (slot, SBS.fromShort hash, blockNo) + ----------------------------------- + -- Compute expected tip timestamp + ----------------------------------- + connectionInfo <- nodeConnectionInfo tr 0 + (systemStart, eraHistory) <- + (H.leftFail <=< H.leftFailM) . H.evalIO $ + executeLocalStateQueryExpr connectionInfo VolatileTip $ do + ss <- querySystemStart + eh <- queryEraHistory + pure $ (,) <$> ss <*> eh + expectedTimestampMs :: Word64 <- H.leftFail $ do + utcTime <- slotToUTCTime systemStart eraHistory (SlotNo slot) + pure . round $ utcTimeToPOSIXSeconds utcTime * 1000 + -------------- -- RPC queries -------------- @@ -90,7 +109,10 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf U5c.QueryService "readParams")) req utxos' <- do - let req = Rpc.defMessage + let req = Rpc.defMessage & U5c.keys .~ + [ def & U5c.hash .~ serialiseToRawBytes tid & U5c.index .~ fromIntegral tix + | (TxIn tid (TxIx tix), _) <- toList utxos + ] Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf U5c.QueryService "readUtxos")) req pure (pparams', utxos') @@ -100,7 +122,7 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem pparamsResponse ^. U5c.ledgerTip . U5c.slot === slot pparamsResponse ^. U5c.ledgerTip . U5c.hash === blockHash pparamsResponse ^. U5c.ledgerTip . U5c.height === blockNo - pparamsResponse ^. U5c.ledgerTip . U5c.timestamp === 0 -- not possible to implement at this moment + H.assertWithinTolerance (pparamsResponse ^. U5c.ledgerTip . U5c.timestamp) expectedTimestampMs 1000 -- https://docs.cardano.org/about-cardano/explore-more/parameter-guide let chainParams = pparamsResponse ^. U5c.values . U5c.cardano @@ -108,9 +130,10 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem pparams ^. L.ppCoinsPerUTxOByteL . to L.unCoinPerByte . to L.fromCompact . to L.unCoin ===^ chainParams ^. U5c.coinsPerUtxoByte . to utxoRpcBigIntToInteger pparams ^. L.ppMaxTxSizeL === chainParams ^. U5c.maxTxSize . to fromIntegral - pparams ^. L.ppTxFeeFixedL ===^ chainParams ^. U5c.minFeeCoefficient . to (fmap L.Coin . utxoRpcBigIntToInteger) - pparams ^. L.ppTxFeePerByteL . to L.unCoinPerByte . to L.fromCompact . to L.unCoin + pparams ^. L.ppTxFeeFixedL . to L.unCoin ===^ chainParams ^. U5c.minFeeConstant . to utxoRpcBigIntToInteger + pparams ^. L.ppTxFeePerByteL . to L.unCoinPerByte . to L.fromCompact . to L.unCoin + ===^ chainParams ^. U5c.minFeeCoefficient . to utxoRpcBigIntToInteger pparams ^. L.ppMaxBBSizeL === chainParams ^. U5c.maxBlockBodySize . to fromIntegral pparams ^. L.ppMaxBHSizeL === chainParams ^. U5c.maxBlockHeaderSize . to fromIntegral pparams ^. L.ppKeyDepositL ===^ chainParams ^. U5c.stakeKeyDeposit . to (fmap L.Coin . utxoRpcBigIntToInteger) diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/SearchUtxos.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/SearchUtxos.hs new file mode 100644 index 00000000000..0ab696971a2 --- /dev/null +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/SearchUtxos.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Testnet.Test.Rpc.SearchUtxos + ( hprop_rpc_search_utxos + ) +where + +import Cardano.Api +import qualified Cardano.Api.Experimental as Exp +import qualified Cardano.Api.Experimental.Tx as Exp +import qualified Cardano.Api.Ledger as L + +import Cardano.Rpc.Client (Proto) +import qualified Cardano.Rpc.Client as Rpc +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as U5c hiding (cardano) +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as UtxoRpc +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Submit as U5c +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Submit as UtxoRpc +import Cardano.Rpc.Server.Internal.UtxoRpc.Predicate (serialisePaymentCredential) +import Cardano.Rpc.Server.Internal.UtxoRpc.Type +import Cardano.Testnet + +import Prelude + +import Control.Exception (try) +import Control.Monad.Trans.Control (liftBaseOp) +import Data.ByteString (ByteString) +import Data.Default.Class +import GHC.Stack +import Lens.Micro +import Network.GRPC.Spec (GrpcError (..), GrpcException (..)) + +import Testnet.Components.Query (TestnetWaitPeriod (..), getEpochStateView, retryUntilM) +import Testnet.Property.Util (integrationRetryWorkspace) +import Testnet.Types + +import Hedgehog +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Test.Base as H +import qualified Hedgehog.Extras.Test.TestWatchdog as H + +-- | E2E test for the SearchUtxos gRPC method. +-- +-- Spins up a testnet, submits a transaction to create UTxOs at a known address, +-- waits for them to appear in the UTxO set, then exercises SearchUtxos with +-- exact-address and payment-credential predicates. +-- +-- Run with: +-- @TASTY_PATTERN='/RPC SearchUtxos/' cabal test cardano-testnet-test@ +hprop_rpc_search_utxos :: Property +hprop_rpc_search_utxos = integrationRetryWorkspace 2 "rpc-search-utxos" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do + conf <- mkConf tempAbsBasePath' + let era = Exp.ConwayEra + sbe = convert era + creationOptions = def{creationEra = AnyShelleyBasedEra sbe} + runtimeOptions = def{runtimeEnableRpc = RpcEnabled} + addressInEra = asAddressInEra sbe + + TestnetRuntime + { configurationFile + , testnetNodes = node0 : _ + , wallets = wallet0@(PaymentKeyInfo _ addressText0) : (PaymentKeyInfo _ addressText1) : _ + } <- + createAndRunTestnet creationOptions runtimeOptions conf + + epochStateView <- getEpochStateView configurationFile $ nodeSocketPath node0 + rpcSocket <- H.note . unFile $ nodeRpcSocketPath node0 + + H.noteShow_ addressText0 + address0 <- H.nothingFail $ deserialiseAddress addressInEra addressText0 + + H.noteShow_ addressText1 + address1 <- H.nothingFail $ deserialiseAddress addressInEra addressText1 + + wit0 :: ShelleyWitnessSigningKey <- + H.leftFailM . H.evalIO $ + readFileTextEnvelopeAnyOf + [FromSomeType asType WitnessGenesisUTxOKey] + (signingKey $ paymentKeyInfoPair wallet0) + + let rpcServer = Rpc.ServerUnix rpcSocket + + ---------------------- + -- Build and submit tx + ---------------------- + (pparamsResponse, initialSearch) <- H.noteShowM . H.evalIO . Rpc.withConnection def rpcServer $ \conn -> do + pparams' <- + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readParams")) def + + search' <- + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ addressPredicate address0 + pure (pparams', search') + + pparams <- H.leftFail $ utxoRpcPParamsToProtocolParams era $ pparamsResponse ^. U5c.values . U5c.cardano + + txOut0 : _ <- H.noteShow $ initialSearch ^. U5c.items + txIn0 <- txoRefToTxIn $ txOut0 ^. U5c.txoRef + + outputCoin <- H.leftFail $ txOut0 ^. U5c.cardano . U5c.coin . to utxoRpcBigIntToInteger + let amount = 200_000_000 + fee = 500 + change = outputCoin - amount - fee + mkOut ledgerAddress coin = Exp.obtainCommonConstraints era $ + Exp.TxOut $ L.mkBasicTxOut ledgerAddress $ L.inject $ L.Coin coin + content = + Exp.defaultTxBodyContent + & Exp.setTxIns [(txIn0, Exp.AnyKeyWitnessPlaceholder)] + & Exp.setTxFee (L.Coin fee) + & Exp.setTxOuts [mkOut (toShelleyAddr address1) amount, mkOut (toShelleyAddr address0) change] + & Exp.setTxProtocolParams pparams + + unsignedTx <- H.leftFail $ Exp.makeUnsignedTx era content + let keyWit = Exp.makeKeyWitness era unsignedTx wit0 + Exp.SignedTx signedLedgerTx = Exp.signTx era [] [keyWit] unsignedTx + + liftBaseOp (Rpc.withConnection def rpcServer) $ \conn -> do + _submitResponse <- H.noteShowM . H.evalIO $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.SubmitService "submitTx")) $ + def & U5c.tx .~ (def & U5c.raw .~ serialiseToRawBytes (Exp.SignedTx signedLedgerTx)) + + ------------------------------------------- + -- Wait for UTxOs to appear at address1 + ------------------------------------------- + H.note_ $ "Wait for 2 UTxOs at address " <> show addressText1 + utxosAtAddress1 <- retryUntilM epochStateView (WaitForBlocks 10) + (do searchResult <- H.evalIO $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ addressPredicate address1 + pure $ searchResult ^. U5c.items + ) + (\xs -> length xs == 2) + + ------------------------------------------- + -- Test 1: exact address predicate returns correct amounts + ------------------------------------------- + H.note_ "Test 1: Verify exact address search returns correct coin values" + let outputAmounts = map (^. U5c.cardano . U5c.coin) utxosAtAddress1 + H.assertWith outputAmounts $ elem (inject amount) + + ------------------------------------------- + -- Test 2: exact address + payment credential predicate + ------------------------------------------- + H.note_ "Test 2: Verify exact address + payment credential predicate matches same UTxOs" + let paymentCredBytes :: ByteString + paymentCredBytes = case address1 of + AddressInEra ShelleyAddressInEra{} (ShelleyAddress _ payCred _) -> + serialisePaymentCredential $ fromShelleyPaymentCredential payCred + _ -> error "Expected a Shelley address" + paymentPredicate :: Proto UtxoRpc.UtxoPredicate + paymentPredicate = + def + & U5c.match + .~ ( def + & U5c.cardano + .~ (def & U5c.address .~ (def & U5c.exactAddress .~ serialiseToRawBytes address1 + & U5c.paymentPart .~ paymentCredBytes)) + ) + payCredSearch <- H.noteShowM . H.evalIO $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ paymentPredicate + + let payCredUtxos = payCredSearch ^. U5c.items + H.assertWith payCredUtxos $ \xs -> length xs == 2 + + ------------------------------------------- + -- Test 3: search with invalid address is rejected + ------------------------------------------- + H.note_ "Test 3: Verify search with invalid address returns GrpcInvalidArgument" + let bogusAddressPredicate :: Proto UtxoRpc.UtxoPredicate + bogusAddressPredicate = + def + & U5c.match + .~ ( def + & U5c.cardano + .~ (def & U5c.address .~ (def & U5c.exactAddress .~ "\x00\x01\x02\x03")) + ) + bogusResult <- H.evalIO . try @GrpcException $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ bogusAddressPredicate + + case bogusResult of + Left err -> grpcError err === GrpcInvalidArgument + Right _ -> do + H.note_ "Expected GrpcInvalidArgument but search succeeded" + H.failure + + ------------------------------------------- + -- Test 4: combined address predicate returns UTxOs from both addresses + ------------------------------------------- + H.note_ "Test 4: Verify anyOf predicate with both addresses returns all UTxOs" + allUtxosSearch <- H.noteShowM . H.evalIO $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ (def & U5c.anyOf .~ [addressPredicate address0, addressPredicate address1]) + + H.assertWith (allUtxosSearch ^. U5c.items) $ \xs -> length xs > 2 + +asAddressInEra :: ShelleyBasedEra era -> AsType (AddressInEra era) +asAddressInEra s = shelleyBasedEraConstraints s $ AsAddressInEra asType + +txoRefToTxIn :: (HasCallStack, MonadTest m) => Proto UtxoRpc.TxoRef -> m TxIn +txoRefToTxIn r = withFrozenCallStack $ do + txId' <- H.leftFail $ deserialiseFromRawBytes AsTxId $ r ^. U5c.hash + pure $ TxIn txId' (TxIx . fromIntegral $ r ^. U5c.index) + +addressPredicate :: IsCardanoEra era => AddressInEra era -> Proto UtxoRpc.UtxoPredicate +addressPredicate address = + def + & U5c.match + .~ ( def + & U5c.cardano + .~ (def & U5c.address .~ (def & U5c.exactAddress .~ serialiseToRawBytes address)) + ) diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Transaction.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Transaction.hs index ea88dfe501c..a447f7c4a16 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Transaction.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Transaction.hs @@ -18,7 +18,7 @@ import qualified Cardano.Api.Ledger as L import Cardano.Rpc.Client (Proto) import qualified Cardano.Rpc.Client as Rpc -import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as U5c hiding (cardano, items, tx) +import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as U5c hiding (cardano) import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as UtxoRpc import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Submit as U5c import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Submit as UtxoRpc @@ -27,10 +27,8 @@ import Cardano.Testnet import Prelude -import Control.Monad import Control.Monad.Trans.Control (liftBaseOp) import Data.Default.Class -import qualified Data.Text.Encoding as T import GHC.Stack import Lens.Micro @@ -43,8 +41,6 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Base as H import qualified Hedgehog.Extras.Test.TestWatchdog as H -import RIO (ByteString) - -- | Run with: -- @TASTY_PATTERN='/RPC Transaction Submit/' cabal test cardano-testnet-test@ hprop_rpc_transaction :: Property @@ -84,21 +80,18 @@ hprop_rpc_transaction = integrationRetryWorkspace 2 "rpc-tx" $ \tempAbsBasePath' -- RPC queries -------------- let rpcServer = Rpc.ServerUnix rpcSocket - (pparamsResponse, utxosResponse) <- H.noteShowM . H.evalIO . Rpc.withConnection def rpcServer $ \conn -> do - pparams' <- do - let req = def - Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readParams")) req + (pparamsResponse, searchResponse) <- H.noteShowM . H.evalIO . Rpc.withConnection def rpcServer $ \conn -> do + pparams' <- + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readParams")) def - utxos' <- do - let req = def -- & # U5c.keys .~ [T.encodeUtf8 addressText0] - Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readUtxos")) req - pure (pparams', utxos') + search' <- + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ addressPredicate address0 + pure (pparams', search') pparams <- H.leftFail $ utxoRpcPParamsToProtocolParams era $ pparamsResponse ^. U5c.values . U5c.cardano - txOut0 : _ <- H.noteShowM . flip filterM (utxosResponse ^. U5c.items) $ \utxo -> do - utxoAddress <- deserialiseAddressBs addressInEra $ utxo ^. U5c.cardano . U5c.address - pure $ address0 == utxoAddress + txOut0 : _ <- H.noteShow $ searchResponse ^. U5c.items txIn0 <- txoRefToTxIn $ txOut0 ^. U5c.txoRef outputCoin <- H.leftFail $ txOut0 ^. U5c.cardano . U5c.coin . to utxoRpcBigIntToInteger @@ -119,7 +112,7 @@ hprop_rpc_transaction = integrationRetryWorkspace 2 "rpc-tx" $ \tempAbsBasePath' Exp.SignedTx signedLedgerTx = Exp.signTx era [] [keyWit] unsignedTx txId' <- H.noteShow . Exp.obtainCommonConstraints era . TxId $ Exp.hashTxBody (signedLedgerTx ^. L.bodyTxL) - H.noteShowPretty_ utxosResponse + H.noteShowPretty_ searchResponse liftBaseOp (Rpc.withConnection def rpcServer) $ \conn -> do submitResponse <- H.noteShowM . H.evalIO $ @@ -131,14 +124,12 @@ hprop_rpc_transaction = integrationRetryWorkspace 2 "rpc-tx" $ \tempAbsBasePath' H.note_ "Ensure that submitTx returns the same transaction ID as the locally computed signed transaction ID" txId' === submittedTxId - -- TODO use searchUtxos when available H.note_ $ "Ensure that there are 2 UTXOs in the address " <> show addressText1 utxosForAddress <- retryUntilM epochStateView (WaitForBlocks 10) - (do utxos <- H.evalIO $ - Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readUtxos")) def - flip filterM (utxos ^. U5c.items) $ \utxo -> do - utxoAddress <- deserialiseAddressBs addressInEra $ utxo ^. U5c.cardano . U5c.address - pure $ address1 == utxoAddress + (do searchResult <- H.evalIO $ + Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "searchUtxos")) $ + def & U5c.predicate .~ addressPredicate address1 + pure $ searchResult ^. U5c.items ) (\xs -> length xs == 2) @@ -154,5 +145,11 @@ txoRefToTxIn r = withFrozenCallStack $ do txId' <- H.leftFail $ deserialiseFromRawBytes AsTxId $ r ^. U5c.hash pure $ TxIn txId' (TxIx . fromIntegral $ r ^. U5c.index) -deserialiseAddressBs :: (MonadTest m, SerialiseAddress c) => AsType c -> ByteString -> m c -deserialiseAddressBs addressInEra = H.nothingFail . deserialiseAddress addressInEra <=< H.leftFail . T.decodeUtf8' +addressPredicate :: IsCardanoEra era => AddressInEra era -> Proto UtxoRpc.UtxoPredicate +addressPredicate address = + def + & U5c.match + .~ ( def + & U5c.cardano + .~ (def & U5c.address .~ (def & U5c.exactAddress .~ serialiseToRawBytes address)) + ) diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/SanityCheck.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/SanityCheck.hs index 5beec8c1999..88f403e17dd 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/SanityCheck.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/SanityCheck.hs @@ -23,6 +23,7 @@ import Data.Time.Clock import GHC.Conc (ThreadStatus (..), threadStatus) import GHC.Stack +import Testnet.Filepath (mkNodeConfigFs) import Testnet.Property.Util (integrationRetryWorkspace) import Testnet.Runtime import Testnet.Start.Types @@ -67,8 +68,10 @@ hprop_ledger_events_sanity_check = integrationRetryWorkspace 2 "ledger-events-sa H.note_ $ "Abs path: " <> tempAbsBasePath' H.note_ $ "Socketpath: " <> unFile socketPath + fs <- evalIO $ mkNodeConfigFs configurationFile !ret <- runExceptT $ handleIOExceptionsWith IOE $ evalIO $ runExceptT $ foldBlocks + fs configurationFile socketPath FullValidation diff --git a/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs b/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs index 49fe74b79a4..c1d7ab52310 100644 --- a/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs +++ b/cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs @@ -35,7 +35,9 @@ import qualified Cardano.Testnet.Test.Gov.TreasuryWithdrawal as Gov import qualified Cardano.Testnet.Test.MainnetParams import qualified Cardano.Testnet.Test.Node.Shutdown import qualified Cardano.Testnet.Test.Parser +import qualified Cardano.Testnet.Test.Rpc.Eval import qualified Cardano.Testnet.Test.Rpc.Query +import qualified Cardano.Testnet.Test.Rpc.SearchUtxos import qualified Cardano.Testnet.Test.Rpc.Transaction import qualified Cardano.Testnet.Test.RunTestnet import qualified Cardano.Testnet.Test.SanityCheck @@ -147,7 +149,9 @@ tests = do ] , T.testGroup "RPC" [ ignoreOnWindows "RPC Query Protocol Params" Cardano.Testnet.Test.Rpc.Query.hprop_rpc_query_pparams + , ignoreOnWindows "RPC SearchUtxos" Cardano.Testnet.Test.Rpc.SearchUtxos.hprop_rpc_search_utxos , ignoreOnWindows "RPC Transaction Submit" Cardano.Testnet.Test.Rpc.Transaction.hprop_rpc_transaction + , ignoreOnWindows "RPC Eval Tx" Cardano.Testnet.Test.Rpc.Eval.hprop_rpc_eval_tx ] , T.testGroup "NodesWithOptions parser" [ H.testPropertyNamed "Roundtrip" (fromString "prop_parseNodeSpecs_roundtrip") diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs index 997fb031b57..6fc787bf5bc 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs @@ -20,7 +20,7 @@ import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (. MiniProtocolNum (..), OuroborosApplication (..), OuroborosApplicationWithMinimalCtx, RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) -import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, +import Ouroboros.Network.Protocol.Handshake.Codec (mkVersionedCodecCBORTerm, codecHandshake, noTimeLimitsHandshake, timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Type (Handshake) import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, queryVersion, @@ -144,7 +144,7 @@ doConnectToForwarderLocal snocket address netMagic timeLimits app = do args = ConnectToArgs { ctaHandshakeCodec = codecHandshake forwardingVersionCodec, ctaHandshakeTimeLimits = timeLimits, - ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaVersionDataCodec = mkVersionedCodecCBORTerm forwardingCodecCBORTerm, ctaConnectTracers = nullNetworkConnectTracers, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } @@ -178,7 +178,7 @@ doConnectToForwarderSocket snocket address netMagic timeLimits app = do args = ConnectToArgs { ctaHandshakeCodec = codecHandshake forwardingVersionCodec, ctaHandshakeTimeLimits = timeLimits, - ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaVersionDataCodec = mkVersionedCodecCBORTerm forwardingCodecCBORTerm, ctaConnectTracers = nullNetworkConnectTracers, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs index 18b2b373835..84f3d47a2c6 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs @@ -130,7 +130,7 @@ doListenToForwarderLocal snocket address netMagic timeLimits app = do haHandshakeTracer = nullTracer, haBearerTracer = nullTracer, haHandshakeCodec = Handshake.codecHandshake forwardingVersionCodec, - haVersionDataCodec = Handshake.cborTermVersionDataCodec forwardingCodecCBORTerm, + haVersionDataCodec = Handshake.mkVersionedCodecCBORTerm forwardingCodecCBORTerm, haAcceptVersion = Handshake.acceptableVersion, haQueryVersion = Handshake.queryVersion, haTimeLimits = timeLimits @@ -162,7 +162,7 @@ doListenToForwarderSocket snocket address netMagic timeLimits app = do haHandshakeTracer = nullTracer, haBearerTracer = nullTracer, haHandshakeCodec = Handshake.codecHandshake forwardingVersionCodec, - haVersionDataCodec = Handshake.cborTermVersionDataCodec forwardingCodecCBORTerm, + haVersionDataCodec = Handshake.mkVersionedCodecCBORTerm forwardingCodecCBORTerm, haAcceptVersion = Handshake.acceptableVersion, haQueryVersion = Handshake.queryVersion, haTimeLimits = timeLimits diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs index 90a277c8683..be93092b328 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs @@ -30,7 +30,7 @@ import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (. miniProtocolLimits, miniProtocolNum, miniProtocolRun) import Ouroboros.Network.Protocol.Handshake (Handshake, HandshakeArguments (..)) import qualified Ouroboros.Network.Protocol.Handshake as Handshake -import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, +import Ouroboros.Network.Protocol.Handshake.Codec (mkVersionedCodecCBORTerm, codecHandshake, noTimeLimitsHandshake) import qualified Ouroboros.Network.Server.Simple as Server import Ouroboros.Network.Snocket (MakeBearer, Snocket, localAddressFromPath, localSnocket, @@ -232,7 +232,7 @@ doConnectToAcceptor TestSetup{..} snocket muxBearer address timeLimits (ekgConfi args = ConnectToArgs { ctaHandshakeCodec = codecHandshake forwardingVersionCodec, ctaHandshakeTimeLimits = timeLimits, - ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaVersionDataCodec = mkVersionedCodecCBORTerm forwardingCodecCBORTerm, ctaConnectTracers = nullNetworkConnectTracers, ctaHandshakeCallbacks = HandshakeCallbacks Handshake.acceptableVersion Handshake.queryVersion } @@ -281,7 +281,7 @@ doListenToAcceptor TestSetup{..} haHandshakeTracer = nullTracer, haBearerTracer = nullTracer, haHandshakeCodec = codecHandshake forwardingVersionCodec, - haVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + haVersionDataCodec = mkVersionedCodecCBORTerm forwardingCodecCBORTerm, haAcceptVersion = Handshake.acceptableVersion, haQueryVersion = Handshake.queryVersion, haTimeLimits = timeLimits diff --git a/configuration/cardano/mainnet-config-legacy.json b/configuration/cardano/mainnet-config-legacy.json index f4bc557037e..a83cf83f481 100644 --- a/configuration/cardano/mainnet-config-legacy.json +++ b/configuration/cardano/mainnet-config-legacy.json @@ -13,9 +13,11 @@ "LastKnownBlockVersion-Minor": 0, "LedgerDB": { "Backend": "V2InMemory", - "NumOfDiskSnapshots": 2, "QueryBatchSize": 100000, - "SnapshotInterval": 4320 + "Snapshots": { + "NumOfDiskSnapshots": 2, + "SnapshotInterval": 4320 + } }, "MaxKnownMajorProtocolVersion": 2, "MinNodeVersion": "10.7.0", diff --git a/configuration/cardano/mainnet-config.json b/configuration/cardano/mainnet-config.json index b587e72e99d..a63aa6f45c9 100644 --- a/configuration/cardano/mainnet-config.json +++ b/configuration/cardano/mainnet-config.json @@ -13,9 +13,11 @@ "LastKnownBlockVersion-Minor": 0, "LedgerDB": { "Backend": "V2InMemory", - "NumOfDiskSnapshots": 2, "QueryBatchSize": 100000, - "SnapshotInterval": 4320 + "Snapshots": { + "NumOfDiskSnapshots": 2, + "SnapshotInterval": 4320 + } }, "MaxKnownMajorProtocolVersion": 2, "MinNodeVersion": "10.7.0", diff --git a/configuration/cardano/mainnet-config.yaml b/configuration/cardano/mainnet-config.yaml index 86f805d4e8e..b0ebdd0892e 100644 --- a/configuration/cardano/mainnet-config.yaml +++ b/configuration/cardano/mainnet-config.yaml @@ -80,19 +80,22 @@ ConsensusMode: PraosMode # Additional configuration options can be found at: # https://ouroboros-consensus.cardano.intersectmbo.org/docs/for-developers/utxo-hd/migrating LedgerDB: - # The time interval between snapshots, in seconds. - SnapshotInterval: 4320 - - # The number of disk snapshots to keep. - NumOfDiskSnapshots: 2 + # The backend can either be in memory with `V2InMemory` or on disk with + # `V2LSM`. + Backend: V2InMemory # When querying the store for a big range of UTxOs (such as with # QueryUTxOByAddress), the store will be read in batches of this size. QueryBatchSize: 100000 - # The backend can either be in memory with `V2InMemory` or on disk with - # `V1LMDB`. - Backend: V2InMemory + # Instead of an object with individual options, a predefined snapshot + # policy can be selected by name, e.g. `Snapshots: Mithril`. + Snapshots: + # The time interval between snapshots, in slots. + SnapshotInterval: 4320 + + # The number of disk snapshots to keep. + NumOfDiskSnapshots: 2 ##### Version Information ##### diff --git a/configuration/cardano/testnet-template-config-legacy.json b/configuration/cardano/testnet-template-config-legacy.json index 1d58efae3f3..42a402569f7 100644 --- a/configuration/cardano/testnet-template-config-legacy.json +++ b/configuration/cardano/testnet-template-config-legacy.json @@ -12,9 +12,11 @@ "LastKnownBlockVersion-Minor": 1, "LedgerDB": { "Backend": "V2InMemory", - "NumOfDiskSnapshots": 2, "QueryBatchSize": 100000, - "SnapshotInterval": 216 + "Snapshots": { + "NumOfDiskSnapshots": 2, + "SnapshotInterval": 216 + } }, "MaxConcurrencyDeadline": 4, "MaxKnownMajorProtocolVersion": 2, diff --git a/configuration/cardano/testnet-template-config.json b/configuration/cardano/testnet-template-config.json index 0ab850d4bad..ad1471cb456 100644 --- a/configuration/cardano/testnet-template-config.json +++ b/configuration/cardano/testnet-template-config.json @@ -13,9 +13,11 @@ "LastKnownBlockVersion-Minor": 1, "LedgerDB": { "Backend": "V2InMemory", - "NumOfDiskSnapshots": 2, "QueryBatchSize": 100000, - "SnapshotInterval": 216 + "Snapshots": { + "NumOfDiskSnapshots": 2, + "SnapshotInterval": 216 + } }, "MaxConcurrencyDeadline": 4, "MaxKnownMajorProtocolVersion": 2, diff --git a/flake.lock b/flake.lock index 07c24c46639..2f38f596a20 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1777742585, - "narHash": "sha256-ZzXz2vOhqethlqPgBExPXEnKWvaTbidsIxh5MGv+pwE=", + "lastModified": 1781102605, + "narHash": "sha256-lipiKNOJ/NIGO/pcwQT030+sSgbTkP3N0w/ck5jBJlw=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "e8a483522ee73c8c9493ea6055553e5c2532e66b", + "rev": "0aa7afd943dbcf2dc51fe652c982da281f8cb621", "type": "github" }, "original": { @@ -273,11 +273,11 @@ "hackageNix_2": { "flake": false, "locked": { - "lastModified": 1778061448, - "narHash": "sha256-cPUF8+l1ej7x4UZcuuf6IDsxU1WWmGWC0vFBH+6jXZk=", + "lastModified": 1781588317, + "narHash": "sha256-bLPzRuyhb9kLvcZd3jmLqEjxYXoF7kRSY36k1bpXSpQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "ba6ab6f3b781c8f308cba4fa384eafa48033f3cc", + "rev": "0304ab7fcb57c73b725bfdc0ebecea4476700366", "type": "github" }, "original": { diff --git a/nix/haskell.nix b/nix/haskell.nix index eb2dbf88ce3..d086e60638f 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -137,6 +137,8 @@ let package-keys = ["plutus-tx-plugin"]; packages.plutus-tx-plugin.components.library.platforms = with lib.platforms; [ linux darwin ]; + # GHC 9.6.7 haddock panics on TopTx type family (tyConStupidTheta) + packages.cardano-api.components.library.doHaddock = false; packages.fs-api.components.library.doHaddock = false; packages.cardano-ledger-allegra.components.library.doHaddock = false; packages.cardano-ledger-alonzo.components.library.doHaddock = false; diff --git a/nix/workbench/service/nodes.nix b/nix/workbench/service/nodes.nix index 22e5a5f85cd..8766d5949ed 100644 --- a/nix/workbench/service/nodes.nix +++ b/nix/workbench/service/nodes.nix @@ -1,30 +1,28 @@ -{ pkgs -, workbenchNix - -## The cardano-node config used as baseline: -, baseNodeConfig - -, backend -, profile -, profiling -, nodeSpecs - -# Derivations used to generate the topology projections -, profileJsonPath, topologyJsonPath +{ + pkgs, + workbenchNix, + ## The cardano-node config used as baseline: + baseNodeConfig, + backend, + profile, + profiling, + nodeSpecs, + # Derivations used to generate the topology projections + profileJsonPath, + topologyJsonPath, }: - -with pkgs.lib; - -let - readJSONMay = fp: - let fv = __tryEval (__readFile fp); - in if fv.success - then __fromJSON fv.value - else {}; +with pkgs.lib; let + readJSONMay = fp: let + fv = __tryEval (__readFile fp); + in + if fv.success + then __fromJSON fv.value + else {}; profileName = profile.name; - eras = [ ## This defines the order of eras -- which is important. + eras = [ + ## This defines the order of eras -- which is important. "byron" "shelley" "allegra" @@ -34,24 +32,26 @@ let "conway" ]; - configHardforksIntoEra = era: - let go = acc: curEra: rest: - let ret = acc // eraSetupHardforks.${curEra}; - in if curEra == era - then ret - else go ret (__head rest) (__tail rest); - eraSetupHardforks = { - byron = {}; - shelley = { TestShelleyHardForkAtEpoch = 0; }; - allegra = { TestAllegraHardForkAtEpoch = 0; }; - mary = { TestMaryHardForkAtEpoch = 0; }; - alonzo = { TestAlonzoHardForkAtEpoch = 0; }; - babbage = { TestBabbageHardForkAtEpoch = 0; }; - conway = { TestConwayHardForkAtEpoch = 0; }; - }; - in if __hasAttr era eraSetupHardforks - then go {} (__head eras) (__tail eras) - else throw "configHardforksIntoEra: unknown era '${era}'"; + configHardforksIntoEra = era: let + go = acc: curEra: rest: let + ret = acc // eraSetupHardforks.${curEra}; + in + if curEra == era + then ret + else go ret (__head rest) (__tail rest); + eraSetupHardforks = { + byron = {}; + shelley = {TestShelleyHardForkAtEpoch = 0;}; + allegra = {TestAllegraHardForkAtEpoch = 0;}; + mary = {TestMaryHardForkAtEpoch = 0;}; + alonzo = {TestAlonzoHardForkAtEpoch = 0;}; + babbage = {TestBabbageHardForkAtEpoch = 0;}; + conway = {TestConwayHardForkAtEpoch = 0;}; + }; + in + if __hasAttr era eraSetupHardforks + then go {} (__head eras) (__tail eras) + else throw "configHardforksIntoEra: unknown era '${era}'"; liveTablesPath = i: if (profile.node ? "ssd_directory" && profile.node.ssd_directory != null) @@ -61,24 +61,30 @@ let ## ## nodeServiceConfig :: NodeSpec -> ServiceConfig ## - nodeServiceConfig = - { name, i, kind, port, isProducer, ... }@nodeSpec: valency: + nodeServiceConfig = { + name, + i, + kind, + port, + isProducer, + ... + } @ nodeSpec: valency: { inherit isProducer port; inherit (profile.node) rts_flags_override; - nodeId = i; - databasePath = "db"; - socketPath = "node.socket"; - topology = "topology.json"; + nodeId = i; + databasePath = "db"; + socketPath = "node.socket"; + topology = "topology.json"; nodeConfigFile = "config.json"; # Allow for local clusters to have multiple LMDB directories in the same physical ssd_directory; # non-block producers (like the explorer node) keep using the in-memory backend - withUtxoHdLmdb = profile.node.utxo_lmdb && isProducer; - withUtxoHdLsmt = profile.node.utxo_lsmt && isProducer; + withUtxoHdLmdb = profile.node.utxo_lmdb && isProducer; + withUtxoHdLsmt = profile.node.utxo_lsmt && isProducer; lmdbDatabasePath = liveTablesPath i; - lsmDatabasePath = liveTablesPath i; + lsmDatabasePath = liveTablesPath i; ## Combine: ## 0. baseNodeConfig (coming cardanoLib's testnet environ) @@ -88,123 +94,146 @@ let ## 4. tracing backend's config nodeConfig = import ./tracing.nix - { - inherit (pkgs) lib; - inherit nodeSpec; - inherit (profile.node) tracing_backend tracer; - } + { + inherit (pkgs) lib; + inherit nodeSpec; + inherit (profile.node) tracing_backend tracer; + } + (recursiveUpdate (recursiveUpdate - (recursiveUpdate + ( + recursiveUpdate (removeAttrs baseNodeConfig - [ ## Let the genesis hashes be auto-computed by the node: + [ + ## Let the genesis hashes be auto-computed by the node: "ByronGenesisHash" "ShelleyGenesisHash" "AlonzoGenesisHash" "ConwayGenesisHash" "DijkstraGenesisHash" - ] // - { + ] + // { ExperimentalHardForksEnabled = true; ExperimentalProtocolsEnabled = true; - TurnOnLogMetrics = true; - SnapshotInterval = 4230; - ChainSyncIdleTimeout = 0; - PeerSharing = false; + TurnOnLogMetrics = true; + ChainSyncIdleTimeout = 0; + PeerSharing = false; ## defaults taken from: ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs ## NB. the following inequality must hold: known >= established >= active >= 0 - SyncTargetNumberOfActivePeers = max 15 valency; # set to same value as TargetNumberOfActivePeers + SyncTargetNumberOfActivePeers = max 15 valency; # set to same value as TargetNumberOfActivePeers SyncTargetNumberOfEstablishedPeers = max 40 valency; - TargetNumberOfActivePeers = max 15 valency; - TargetNumberOfEstablishedPeers = max 40 valency; + TargetNumberOfActivePeers = max 15 valency; + TargetNumberOfEstablishedPeers = max 40 valency; - ByronGenesisFile = "../genesis/byron/genesis.json"; - ShelleyGenesisFile = "../genesis/genesis-shelley.json"; - AlonzoGenesisFile = "../genesis/genesis.alonzo.json"; - ConwayGenesisFile = "../genesis/genesis.conway.json"; - DijkstraGenesisFile = "../genesis/genesis.dijkstra.json"; - } // optionalAttrs (profile.node.utxo_lsmt && isProducer) + ByronGenesisFile = "../genesis/byron/genesis.json"; + ShelleyGenesisFile = "../genesis/genesis-shelley.json"; + AlonzoGenesisFile = "../genesis/genesis.alonzo.json"; + ConwayGenesisFile = "../genesis/genesis.conway.json"; + DijkstraGenesisFile = "../genesis/genesis.dijkstra.json"; + } + // optionalAttrs (profile.node.utxo_lsmt && isProducer) { LedgerDB = { Backend = "V2LSM"; LSMDatabasePath = liveTablesPath i; }; - } // optionalAttrs (profile.node.utxo_lmdb && isProducer) + } + // optionalAttrs (profile.node.utxo_lmdb && isProducer) { LedgerDB = { Backend = "V1LMDB"; LiveTablesPath = liveTablesPath i; }; }) - (if __hasAttr "preset" profile && profile.preset != null - ## It's either an undisturbed preset, - ## or a hardforked setup. - then readJSONMay (../profile/presets + "/${profile.preset}/config.json") - else configHardforksIntoEra profile.era)) - profile.node.verbatim); + { + ## This LedgerDB attrset is defined regardless of backend choice. + ## It assumes the Backend default to be "V2InMemory"; it must not overwrite any of the above, more specfic choices. + LedgerDB = { + Snapshots = { + SnapshotInterval = 4230; + # Disable the randomised delay for kicking off snapshots: + # For benchmarks, exact timing needs to be reproducible, and identical for all nodes. + MinDelay = 0; + MaxDelay = 0; + }; + }; + } + ) + ( + if __hasAttr "preset" profile && profile.preset != null + ## It's either an undisturbed preset, + ## or a hardforked setup. + then readJSONMay (../profile/presets + "/${profile.preset}/config.json") + else configHardforksIntoEra profile.era + )) + profile.node.verbatim); extraArgs = - [ "+RTS" "-scardano-node.gcstats" "-RTS" ] - ++ - optionals (nodeSpec.shutdown_on_block_synced != null) [ + ["+RTS" "-scardano-node.gcstats" "-RTS"] + ++ optionals (nodeSpec.shutdown_on_block_synced != null) [ "--shutdown-on-block-synced" (toString nodeSpec.shutdown_on_block_synced) - ] ++ - optionals (nodeSpec.shutdown_on_slot_synced != null) [ + ] + ++ optionals (nodeSpec.shutdown_on_slot_synced != null) [ "--shutdown-on-slot-synced" (toString nodeSpec.shutdown_on_slot_synced) ]; - } // optionalAttrs ((profiling.profilingTypeParam or "none") != "none") { + } + // optionalAttrs ((profiling.profilingTypeParam or "none") != "none") { # Add the profiling `-h*` RTS option. profiling = profiling.profilingTypeParam; - } // optionalAttrs (profiling.eventlog or false) { + } + // optionalAttrs (profiling.eventlog or false) { # Add the `-l` RTS param with profiling. eventlog = true; - # Decide where the executable comes from: - ######################################### - } // optionalAttrs (!backend.useCabalRun) { - package = workbenchNix.haskellProject.exes.cardano-node; - } // optionalAttrs backend.useCabalRun { + # Decide where the executable comes from: + ######################################### + } + // optionalAttrs (!backend.useCabalRun) { + package = workbenchNix.haskellProject.exes.cardano-node; + } + // optionalAttrs backend.useCabalRun { # Allow the shell function to take precedence. executable = "cardano-node"; - ######################################### - } // optionalAttrs isProducer { + ######################################### + } + // optionalAttrs isProducer { operationalCertificate = "../genesis/node-keys/node${toString i}.opcert"; - kesKey = "../genesis/node-keys/node-kes${toString i}.skey"; - vrfKey = "../genesis/node-keys/node-vrf${toString i}.skey"; - } // optionalAttrs profile.node.tracer { + kesKey = "../genesis/node-keys/node-kes${toString i}.skey"; + vrfKey = "../genesis/node-keys/node-vrf${toString i}.skey"; + } + // optionalAttrs profile.node.tracer { tracerSocketPathConnect = mkDefault "../tracer/tracer.socket"; }; - time_fmtstr = - "{ " + escape [''"''] (concatStringsSep ''\n, '' time_entries) + " }"; - time_entries = [ - ''"wall_clock_s": %e'' - ''"user_cpu_s": %U'' - ''"sys_cpu_s": %S'' - ''"avg_cpu_pct": "%P"'' - ''"rss_peak_kb": %M'' - ''"signals_received": %k'' - ''"ctxsw_involuntary": %c'' - ''"ctxsw_volunt_waits": %w'' - ''"pageflt_major": %F'' - ''"pageflt_minor": %R'' - ''"swaps": %W'' - ''"io_fs_reads": %I'' - ''"io_fs_writes": %O'' - ''"cmdline": "%C"'' - ''"exit_code": %x'' - ]; + time_fmtstr = + "{ " + escape [''"''] (concatStringsSep ''\n, '' time_entries) + " }"; + time_entries = [ + ''"wall_clock_s": %e'' + ''"user_cpu_s": %U'' + ''"sys_cpu_s": %S'' + ''"avg_cpu_pct": "%P"'' + ''"rss_peak_kb": %M'' + ''"signals_received": %k'' + ''"ctxsw_involuntary": %c'' + ''"ctxsw_volunt_waits": %w'' + ''"pageflt_major": %F'' + ''"pageflt_minor": %R'' + ''"swaps": %W'' + ''"io_fs_reads": %I'' + ''"io_fs_writes": %O'' + ''"cmdline": "%C"'' + ''"exit_code": %x'' + ]; ## Given an env config, evaluate it and produce the node service. ## Call the given function on this service. ## ## evalServiceConfigToService :: NodeServiceConfig -> NodeService ## - evalServiceConfigToService = - serviceConfig: - let + evalServiceConfigToService = serviceConfig: let systemdCompat.options = { systemd.services = mkOption {}; systemd.sockets = mkOption {}; @@ -215,98 +244,108 @@ let }; eval = let extra = { - services.cardano-node = { - enable = true; - } // serviceConfig; + services.cardano-node = + { + enable = true; + } + // serviceConfig; }; - in evalModules { - prefix = []; - modules = import ../../nixos/module-list.nix - ++ [ systemdCompat extra - { config._module.args = { inherit pkgs; }; } - ] - ++ [ backend.service-modules.node or {} ]; - }; in - eval.config.services.cardano-node; - - topologiesJsonPaths = - let projections = - pkgs.runCommand "workbench-profile-files-${profileName}-topologies" - { nativeBuildInputs = with pkgs; - # A workbench with only the dependencies needed for this command. - [ workbenchNix.workbench - jq - workbenchNix.haskellProject.exes.cardano-topology - ]; - } - '' - mkdir "$out" - ${builtins.concatStringsSep - "\n" - (pkgs.lib.mapAttrsToList - (name: nodeSpec: '' - wb topology projection-for \ - "local-${nodeSpec.kind}" \ - "${toString nodeSpec.i}" \ - "${profileJsonPath}" \ - "${topologyJsonPath}" \ - "${toString backend.basePort}" \ - > "$out"/"topology-${name}.json" - '') - nodeSpecs - ) - } - '' - ; - in pkgs.lib.mapAttrs - (name: _: "${projections}/topology-${name}.json") - nodeSpecs - ; + evalModules { + prefix = []; + modules = + import ../../nixos/module-list.nix + ++ [ + systemdCompat + extra + {config._module.args = {inherit pkgs;};} + ] + ++ [backend.service-modules.node or {}]; + }; + in + eval.config.services.cardano-node; - nodeService = - { name, i, mode ? null, ... }@nodeSpec: - let - modeIdSuffix = if mode == null then "" else "." + mode; - serviceConfig = nodeServiceConfig nodeSpec valency; - service = evalServiceConfigToService serviceConfig; + topologiesJsonPaths = let + projections = + pkgs.runCommand "workbench-profile-files-${profileName}-topologies" + { + nativeBuildInputs = with pkgs; + # A workbench with only the dependencies needed for this command. + [ + workbenchNix.workbench + jq + workbenchNix.haskellProject.exes.cardano-topology + ]; + } + '' + mkdir "$out" + ${ + builtins.concatStringsSep + "\n" + ( + pkgs.lib.mapAttrsToList + (name: nodeSpec: '' + wb topology projection-for \ + "local-${nodeSpec.kind}" \ + "${toString nodeSpec.i}" \ + "${profileJsonPath}" \ + "${topologyJsonPath}" \ + "${toString backend.basePort}" \ + > "$out"/"topology-${name}.json" + '') + nodeSpecs + ) + } + ''; + in + pkgs.lib.mapAttrs + (name: _: "${projections}/topology-${name}.json") + nodeSpecs; - topology = - rec { - JSON = topologiesJsonPaths.${name}; - value = __fromJSON (__readFile JSON); - } - ; + nodeService = { + name, + i, + mode ? null, + ... + } @ nodeSpec: let + modeIdSuffix = + if mode == null + then "" + else "." + mode; + serviceConfig = nodeServiceConfig nodeSpec valency; + service = evalServiceConfigToService serviceConfig; - valency = - let - topo = topology.value; - val = if hasAttr "localRoots" topo && __length topo.localRoots > 0 - then let lr = head topo.localRoots; in lr.valency - else length (topo.Producers or []); - in val; + topology = rec { + JSON = topologiesJsonPaths.${name}; + value = __fromJSON (__readFile JSON); + }; - in { - start = - '' - #!${pkgs.stdenv.shell} + valency = let + topo = topology.value; + val = + if hasAttr "localRoots" topo && __length topo.localRoots > 0 + then let lr = head topo.localRoots; in lr.valency + else length (topo.Producers or []); + in + val; + in { + start = '' + #!${pkgs.stdenv.shell} - export TRACE_DISPATCHER_LOGGING_HOSTNAME=${name} + export TRACE_DISPATCHER_LOGGING_HOSTNAME=${name} - ${service.script} - '' - ; + ${service.script} + ''; - config = service.nodeConfig; + config = service.nodeConfig; - inherit topology; - }; + inherit topology; + }; ## ## node-services :: Map NodeName (NodeSpec, ServiceConfig, Service, NodeConfig, Script) ## node-services = mapAttrs (_: nodeService) nodeSpecs; -in -{ +in { inherit node-services; } diff --git a/trace-forward/src/Trace/Forward/Forwarding.hs b/trace-forward/src/Trace/Forward/Forwarding.hs index 2960db6c85d..cb078f62470 100644 --- a/trace-forward/src/Trace/Forward/Forwarding.hs +++ b/trace-forward/src/Trace/Forward/Forwarding.hs @@ -24,7 +24,7 @@ import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (. MiniProtocolNum (..), OuroborosApplication (..), RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) -import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, +import Ouroboros.Network.Protocol.Handshake.Codec (mkVersionedCodecCBORTerm, codecHandshake, noTimeLimitsHandshake, timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Type (Handshake) import Ouroboros.Network.Protocol.Handshake.Version (acceptableVersion, queryVersion, @@ -288,7 +288,7 @@ doConnectToAcceptor magic snocket makeBearer configureSocket address timeLimits args = ConnectToArgs { ctaHandshakeCodec = codecHandshake forwardingVersionCodec, ctaHandshakeTimeLimits = timeLimits, - ctaVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + ctaVersionDataCodec = mkVersionedCodecCBORTerm forwardingCodecCBORTerm, ctaConnectTracers = nullNetworkConnectTracers, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } forwarderApp @@ -337,7 +337,7 @@ doListenToAcceptor magic snocket makeBearer configureSocket address timeLimits haBearerTracer = nullTracer, haHandshakeTracer = nullTracer, haHandshakeCodec = codecHandshake forwardingVersionCodec, - haVersionDataCodec = cborTermVersionDataCodec forwardingCodecCBORTerm, + haVersionDataCodec = mkVersionedCodecCBORTerm forwardingCodecCBORTerm, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = timeLimits