From c03ccee0af1348143655bbdbd2d8fc96eab5b3a6 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 16 Feb 2023 13:06:03 +1100 Subject: [PATCH 1/4] Remove use of multiline literals from cardano-cli --- cardano-cli/src/Cardano/CLI/Parsers.hs | 13 +- cardano-cli/src/Cardano/CLI/Shelley/Output.hs | 9 +- .../src/Cardano/CLI/Shelley/Parsers.hs | 518 ++++++++++-------- .../src/Cardano/CLI/Shelley/Run/Key.hs | 8 +- .../src/Cardano/CLI/Shelley/Run/Read.hs | 9 +- .../Cardano/CLI/Shelley/Run/Transaction.hs | 38 +- cardano-cli/test/Test/Cli/ITN.hs | 16 +- cardano-cli/test/Test/Golden/TxView.hs | 131 ++--- 8 files changed, 411 insertions(+), 331 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/Parsers.hs b/cardano-cli/src/Cardano/CLI/Parsers.hs index 59f4613de28..d55810264cc 100644 --- a/cardano-cli/src/Cardano/CLI/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Parsers.hs @@ -26,11 +26,14 @@ command' c descr p = opts :: ParserInfo ClientCommand opts = Opt.info (parseClientCommand <**> Opt.helper) - ( Opt.fullDesc - <> Opt.header - "cardano-cli - utility to support a variety of key\ - \ operations (genesis generation, migration,\ - \ pretty-printing..) for different system generations." + ( mconcat + [ Opt.fullDesc + , Opt.header $ mconcat + [ "cardano-cli - utility to support a variety of key" + , " operations (genesis generation, migration," + , " pretty-printing..) for different system generations." + ] + ] ) pref :: ParserPrefs diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Output.hs b/cardano-cli/src/Cardano/CLI/Shelley/Output.hs index 0acd7650b10..d0f35712c9a 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Output.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Output.hs @@ -219,9 +219,12 @@ instance FromJSON QueryTipLocalStateOutput where mEra' mEpoch' mSyncProgress' - (_,_,_) -> fail "QueryTipLocalStateOutput was incorrectly JSON encoded.\ - \ Expected slot, header hash and block number (ChainTip)\ - \ or none (ChainTipAtGenesis)" + (_,_,_) -> + fail $ mconcat + [ "QueryTipLocalStateOutput was incorrectly JSON encoded." + , " Expected slot, header hash and block number (ChainTip)" + , " or none (ChainTipAtGenesis)" + ] data ScriptCostOutput = ScriptCostOutput diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index c3e0358551f..4ff9479b043 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -231,21 +231,25 @@ pScriptFor name (Just deprecated) help = pReferenceTxIn :: String -> String -> Parser TxIn pReferenceTxIn prefix scriptType = - Opt.option (readerFromParsecParser parseTxIn) - ( Opt.long (prefix ++ "tx-in-reference") - <> Opt.metavar "TX-IN" - <> Opt.help ("TxId#TxIx - Specify a reference input. The reference input must have\ - \ a " <> scriptType <> " reference script attached.") - ) + Opt.option (readerFromParsecParser parseTxIn) $ mconcat + [ Opt.long (prefix ++ "tx-in-reference") + , Opt.metavar "TX-IN" + , Opt.help $ mconcat + [ "TxId#TxIx - Specify a reference input. The reference input must have" + , " a " <> scriptType <> " reference script attached." + ] + ] pReadOnlyReferenceTxIn :: Parser TxIn pReadOnlyReferenceTxIn = - Opt.option (readerFromParsecParser parseTxIn) - ( Opt.long "read-only-tx-in-reference" - <> Opt.metavar "TX-IN" - <> Opt.help "Specify a read only reference input. This reference input is not witnessing anything \ - \it is simply provided in the plutus script context." - ) + Opt.option (readerFromParsecParser parseTxIn) $ mconcat + [ Opt.long "read-only-tx-in-reference" + , Opt.metavar "TX-IN" + , Opt.help $ mconcat + [ "Specify a read only reference input. This reference input is not witnessing anything " + , "it is simply provided in the plutus script context." + ] + ] pScriptWitnessFiles :: forall witctx. @@ -317,30 +321,33 @@ pScriptDataOrFile dataFlagPrefix helpTextForValue helpTextForFile = <|> pScriptDataFile <|> pScriptDataValue where - pScriptDataCborFile = ScriptDataCborFile <$> - Opt.strOption - ( Opt.long (dataFlagPrefix ++ "-cbor-file") - <> Opt.metavar "CBOR FILE" - <> Opt.help (helpTextForFile ++ " The file must follow the special \ - \JSON schema for script data.") - ) + pScriptDataCborFile = fmap ScriptDataCborFile . Opt.strOption $ mconcat + [ Opt.long (dataFlagPrefix ++ "-cbor-file") + , Opt.metavar "CBOR FILE" + , Opt.help $ mconcat + [ helpTextForFile + , " The file must follow the special JSON schema for script data." + ] + ] - pScriptDataFile = ScriptDataJsonFile <$> - Opt.strOption - ( Opt.long (dataFlagPrefix ++ "-file") - <> Opt.metavar "JSON FILE" - <> Opt.help (helpTextForFile ++ " The file must follow the special \ - \JSON schema for script data.") - ) + pScriptDataFile = fmap ScriptDataJsonFile . Opt.strOption $ mconcat + [ Opt.long (dataFlagPrefix ++ "-file") + , Opt.metavar "JSON FILE" + , Opt.help $ mconcat + [ helpTextForFile ++ " The file must follow the special " + , "JSON schema for script data." + ] + ] - pScriptDataValue = ScriptDataValue <$> - Opt.option readerScriptData - ( Opt.long (dataFlagPrefix ++ "-value") - <> Opt.metavar "JSON VALUE" - <> Opt.help (helpTextForValue ++ " There is no schema: (almost) any \ - \JSON value is supported, including \ - \top-level strings and numbers.") - ) + pScriptDataValue = fmap ScriptDataValue . Opt.option readerScriptData $ mconcat + [ Opt.long (dataFlagPrefix ++ "-value") + , Opt.metavar "JSON VALUE" + , Opt.help $ mconcat + [ helpTextForValue + , " There is no schema: (almost) any JSON value is supported, including " + , "top-level strings and numbers." + ] + ] readerScriptData = do v <- readerJSON @@ -825,25 +832,25 @@ pTransaction = pNodeCmd :: Parser NodeCmd pNodeCmd = asum - [ subParser "key-gen" - (Opt.info pKeyGenOperator $ - Opt.progDesc "Create a key pair for a node operator's offline \ - \ key and a new certificate issue counter") - , subParser "key-gen-KES" - (Opt.info pKeyGenKES $ - Opt.progDesc "Create a key pair for a node KES operational key") - , subParser "key-gen-VRF" - (Opt.info pKeyGenVRF $ - Opt.progDesc "Create a key pair for a node VRF operational key") - , subParser "key-hash-VRF" - (Opt.info pKeyHashVRF $ - Opt.progDesc "Print hash of a node's operational VRF key.") - , subParser "new-counter" - (Opt.info pNewCounter $ - Opt.progDesc "Create a new certificate issue counter") - , subParser "issue-op-cert" - (Opt.info pIssueOpCert $ - Opt.progDesc "Issue a node operational certificate") + [ subParser "key-gen" . Opt.info pKeyGenOperator . Opt.progDesc $ mconcat + [ "Create a key pair for a node operator's offline " + , "key and a new certificate issue counter" + ] + , subParser "key-gen-KES" . Opt.info pKeyGenKES . Opt.progDesc $ mconcat + [ "Create a key pair for a node KES operational key" + ] + , subParser "key-gen-VRF" . Opt.info pKeyGenVRF . Opt.progDesc $ mconcat + [ "Create a key pair for a node VRF operational key" + ] + , subParser "key-hash-VRF". Opt.info pKeyHashVRF . Opt.progDesc $ mconcat + [ "Print hash of a node's operational VRF key." + ] + , subParser "new-counter" . Opt.info pNewCounter . Opt.progDesc $ mconcat + [ "Create a new certificate issue counter" + ] + , subParser "issue-op-cert" . Opt.info pIssueOpCert . Opt.progDesc $ mconcat + [ "Issue a node operational certificate" + ] ] where pKeyGenOperator :: Parser NodeCmd @@ -1060,28 +1067,29 @@ pQueryCmd = pGovernanceCmd :: Parser GovernanceCmd pGovernanceCmd = - asum - [ subParser "create-mir-certificate" - (Opt.info (pMIRPayStakeAddresses <|> mirCertParsers) $ - Opt.progDesc "Create an MIR (Move Instantaneous Rewards) certificate") - , subParser "create-genesis-key-delegation-certificate" - (Opt.info pGovernanceGenesisKeyDelegationCertificate $ - Opt.progDesc "Create a genesis key delegation certificate") - , subParser "create-update-proposal" - (Opt.info pUpdateProposal $ - Opt.progDesc "Create an update proposal") - ] + asum + [ subParser "create-mir-certificate" + $ Opt.info (pMIRPayStakeAddresses <|> mirCertParsers) + $ Opt.progDesc "Create an MIR (Move Instantaneous Rewards) certificate" + , subParser "create-genesis-key-delegation-certificate" + $ Opt.info pGovernanceGenesisKeyDelegationCertificate + $ Opt.progDesc "Create a genesis key delegation certificate" + , subParser "create-update-proposal" + $ Opt.info pUpdateProposal + $ Opt.progDesc "Create an update proposal" + ] where mirCertParsers :: Parser GovernanceCmd mirCertParsers = asum - [ subParser "stake-addresses" (Opt.info pMIRPayStakeAddresses $ - Opt.progDesc "Create an MIR certificate to pay stake addresses") - , subParser "transfer-to-treasury" (Opt.info pMIRTransferToTreasury $ - Opt.progDesc "Create an MIR certificate to transfer from the reserves pot\ - \ to the treasury pot") - , subParser "transfer-to-rewards" (Opt.info pMIRTransferToReserves $ - Opt.progDesc "Create an MIR certificate to transfer from the treasury pot\ - \ to the reserves pot") + [ subParser "stake-addresses" + $ Opt.info pMIRPayStakeAddresses + $ Opt.progDesc "Create an MIR certificate to pay stake addresses" + , subParser "transfer-to-treasury" + $ Opt.info pMIRTransferToTreasury + $ Opt.progDesc "Create an MIR certificate to transfer from the reserves pot to the treasury pot" + , subParser "transfer-to-rewards" + $ Opt.info pMIRTransferToReserves + $ Opt.progDesc "Create an MIR certificate to transfer from the treasury pot to the reserves pot" ] pMIRPayStakeAddresses :: Parser GovernanceCmd @@ -1491,9 +1499,11 @@ pCertificateFile balanceExecUnits = "the use of the certificate." <|> pPlutusStakeReferenceScriptWitnessFiles "certificate-" bExecUnits - helpText = "Filepath of the certificate. This encompasses all \ - \types of certificates (stake pool certificates, \ - \stake key certificates etc). Optionally specify a script witness." + helpText = mconcat + [ "Filepath of the certificate. This encompasses all " + , "types of certificates (stake pool certificates, " + , "stake key certificates etc). Optionally specify a script witness." + ] pPoolMetadataFile :: Parser PoolMetadataFile pPoolMetadataFile = @@ -1571,10 +1581,12 @@ pWithdrawal balance = "the withdrawal of rewards." <|> pPlutusStakeReferenceScriptWitnessFiles "withdrawal-" balance - helpText = "The reward withdrawal as StakeAddress+Lovelace where \ - \StakeAddress is the Bech32-encoded stake address \ - \followed by the amount in Lovelace. Optionally specify \ - \a script witness." + helpText = mconcat + [ "The reward withdrawal as StakeAddress+Lovelace where " + , "StakeAddress is the Bech32-encoded stake address " + , "followed by the amount in Lovelace. Optionally specify " + , "a script witness." + ] parseWithdrawal :: Parsec.Parser (StakeAddress, Lovelace) parseWithdrawal = @@ -1641,22 +1653,25 @@ pRequiredSigner = <|> RequiredSignerHash <$> sPayKeyHash where sKeyFile :: Parser SigningKeyFile - sKeyFile = SigningKeyFile <$> - Opt.strOption - ( Opt.long "required-signer" - <> Opt.metavar "FILE" - <> Opt.help "Input filepath of the signing key (zero or more) whose \ - \signature is required." - <> Opt.completer (Opt.bashCompleter "file") - ) + sKeyFile = fmap SigningKeyFile $ Opt.strOption $ mconcat + [ Opt.long "required-signer" + , Opt.metavar "FILE" + , Opt.help $ mconcat + [ "Input filepath of the signing key (zero or more) whose " + , "signature is required." + ] + , Opt.completer (Opt.bashCompleter "file") + ] sPayKeyHash :: Parser (Hash PaymentKey) sPayKeyHash = - Opt.option (readerFromParsecParser $ parseHash (AsHash AsPaymentKey)) - ( Opt.long "required-signer-hash" - <> Opt.metavar "HASH" - <> Opt.help "Hash of the verification key (zero or more) whose \ - \signature is required." - ) + Opt.option (readerFromParsecParser $ parseHash (AsHash AsPaymentKey)) $ mconcat + [ Opt.long "required-signer-hash" + , Opt.metavar "HASH" + , Opt.help $ mconcat + [ "Hash of the verification key (zero or more) whose " + , "signature is required." + ] + ] pVrfSigningKeyFile :: Parser SigningKeyFile pVrfSigningKeyFile = @@ -2147,35 +2162,39 @@ pTxInCollateral = pReturnCollateral :: Parser TxOutAnyEra pReturnCollateral = Opt.option (readerFromParsecParser parseTxOutAnyEra) - ( Opt.long "tx-out-return-collateral" - <> Opt.metavar "ADDRESS VALUE" - -- TODO alonzo: Update the help text to describe the new syntax as well. - <> Opt.help "The transaction output as ADDRESS VALUE where ADDRESS is \ - \the Bech32-encoded address followed by the value in \ - \Lovelace. In the situation where your collateral txin \ - \over collateralizes the transaction, you can optionally \ - \specify a tx out of your choosing to return the excess Lovelace." + ( mconcat + [ Opt.long "tx-out-return-collateral" + , Opt.metavar "ADDRESS VALUE" + -- TODO alonzo: Update the help text to describe the new syntax as well. + , Opt.help ( "The transaction output as ADDRESS VALUE where ADDRESS is " <> + "the Bech32-encoded address followed by the value in " <> + "Lovelace. In the situation where your collateral txin " <> + "over collateralizes the transaction, you can optionally " <> + "specify a tx out of your choosing to return the excess Lovelace." + ) + ] ) <*> pure TxOutDatumByNone -- TODO: Babbage era - we should be able to return these <*> pure ReferenceScriptAnyEraNone -- TODO: Babbage era - we should be able to return these pTotalCollateral :: Parser Lovelace pTotalCollateral = - Opt.option (Lovelace <$> readerFromParsecParser decimal) - ( Opt.long "tx-total-collateral" - <> Opt.metavar "INTEGER" - <> Opt.help "The total amount of collateral that will be collected \ - \as fees in the event of a Plutus script failure. Must be used \ - \in conjuction with \"--tx-out-return-collateral\"." - ) + Opt.option (Lovelace <$> readerFromParsecParser decimal) $ mconcat + [ Opt.long "tx-total-collateral" + , Opt.metavar "INTEGER" + , Opt.help $ mconcat + [ "The total amount of collateral that will be collected " + , "as fees in the event of a Plutus script failure. Must be used " + , "in conjuction with \"--tx-out-return-collateral\"." + ] + ] pWitnessOverride :: Parser Word -pWitnessOverride = Opt.option Opt.auto - ( Opt.long "witness-override" - <> Opt.metavar "WORD" - <> Opt.help "Specify and override the number of \ - \witnesses the transaction requires." - ) +pWitnessOverride = Opt.option Opt.auto $ mconcat + [ Opt.long "witness-override" + , Opt.metavar "WORD" + , Opt.help "Specify and override the number of witnesses the transaction requires." + ] parseTxIn :: Parsec.Parser TxIn parseTxIn = TxIn <$> parseTxId <*> (Parsec.char '#' *> parseTxIx) @@ -2214,40 +2233,60 @@ pTxOutDatum = <|> pure TxOutDatumByNone where pTxOutDatumByHashOnly = - TxOutDatumByHashOnly <$> - Opt.option (readerFromParsecParser $ parseHash (AsHash AsScriptData)) - ( Opt.long "tx-out-datum-hash" - <> Opt.metavar "HASH" - <> Opt.help "The script datum hash for this tx output, as \ - \the raw datum hash (in hex)." - ) + fmap TxOutDatumByHashOnly + $ Opt.option (readerFromParsecParser $ parseHash (AsHash AsScriptData)) + $ mconcat + [ Opt.long "tx-out-datum-hash" + , Opt.metavar "HASH" + , Opt.help $ mconcat + [ "The script datum hash for this tx output, as " + , "the raw datum hash (in hex)." + ] + ] - pTxOutDatumByHashOf = - TxOutDatumByHashOf <$> + pTxOutDatumByHashOf = TxOutDatumByHashOf <$> pScriptDataOrFile "tx-out-datum-hash" - "The script datum hash for this tx output, by hashing the \ - \script datum given here in JSON syntax." - "The script datum hash for this tx output, by hashing the \ - \script datum in the given JSON file." + ( mconcat + [ "The script datum hash for this tx output, by hashing the " + , "script datum given here in JSON syntax." + ] + ) + ( mconcat + [ "The script datum hash for this tx output, by hashing the " + , "script datum in the given JSON file." + ] + ) pTxOutDatumByValue = TxOutDatumByValue <$> pScriptDataOrFile "tx-out-datum-embed" - "The script datum to embed in the tx for this output, \ - \given here in JSON syntax." - "The script datum to embed in the tx for this output, \ - \in the given JSON file." + ( mconcat + [ "The script datum to embed in the tx for this output, " + , "given here in JSON syntax." + ] + ) + ( mconcat + [ "The script datum to embed in the tx for this output, " + , "in the given JSON file." + ] + ) pTxOutInlineDatumByValue = TxOutInlineDatumByValue <$> pScriptDataOrFile "tx-out-inline-datum" - "The script datum to embed in the tx output as an inline datum, \ - \given here in JSON syntax." - "The script datum to embed in the tx output as an inline datum, \ - \in the given JSON file." + ( mconcat + [ "The script datum to embed in the tx output as an inline datum, " + , "given here in JSON syntax." + ] + ) + ( mconcat + [ "The script datum to embed in the tx output as an inline datum, " + , "in the given JSON file." + ] + ) pRefScriptFp :: Parser ReferenceScriptAnyEra pRefScriptFp = @@ -2309,8 +2348,10 @@ pMintMultiAsset balanceExecUnits = ManualBalance -> pExecutionUnits "mint-reference-tx-in") <*> (Just <$> pPolicyId) - helpText = "Mint multi-asset value(s) with the multi-asset cli syntax. \ - \You must specify a script witness." + helpText = mconcat + [ "Mint multi-asset value(s) with the multi-asset cli syntax. " + , "You must specify a script witness." + ] pPolicyId :: Parser PolicyId pPolicyId = @@ -2322,47 +2363,47 @@ pPolicyId = pInvalidBefore :: Parser SlotNo -pInvalidBefore = - SlotNo <$> - ( Opt.option Opt.auto - ( Opt.long "invalid-before" - <> Opt.metavar "SLOT" - <> Opt.help "Time that transaction is valid from (in slots)." - ) - <|> - Opt.option Opt.auto - ( Opt.long "lower-bound" - <> Opt.metavar "SLOT" - <> Opt.help "Time that transaction is valid from (in slots) \ - \(deprecated; use --invalid-before instead)." - <> Opt.internal - ) - ) +pInvalidBefore = fmap SlotNo $ asum + [ Opt.option Opt.auto $ mconcat + [ Opt.long "invalid-before" + , Opt.metavar "SLOT" + , Opt.help "Time that transaction is valid from (in slots)." + ] + , Opt.option Opt.auto $ mconcat + [ Opt.long "lower-bound" + , Opt.metavar "SLOT" + , Opt.help $ mconcat + [ "Time that transaction is valid from (in slots) " + , "(deprecated; use --invalid-before instead)." + ] + , Opt.internal + ] + ] pInvalidHereafter :: Parser SlotNo pInvalidHereafter = - SlotNo <$> - ( Opt.option Opt.auto - ( Opt.long "invalid-hereafter" - <> Opt.metavar "SLOT" - <> Opt.help "Time that transaction is valid until (in slots)." - ) - <|> - Opt.option Opt.auto - ( Opt.long "upper-bound" - <> Opt.metavar "SLOT" - <> Opt.help "Time that transaction is valid until (in slots) \ - \(deprecated; use --invalid-hereafter instead)." - <> Opt.internal - ) - <|> - Opt.option Opt.auto - ( Opt.long "ttl" - <> Opt.metavar "SLOT" - <> Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)." - <> Opt.internal - ) - ) + fmap SlotNo $ asum + [ Opt.option Opt.auto $ mconcat + [ Opt.long "invalid-hereafter" + , Opt.metavar "SLOT" + , Opt.help "Time that transaction is valid until (in slots)." + ] + , Opt.option Opt.auto $ mconcat + [ Opt.long "upper-bound" + , Opt.metavar "SLOT" + , Opt.help $ mconcat + [ "Time that transaction is valid until (in slots) " + , "(deprecated; use --invalid-hereafter instead)." + ] + , Opt.internal + ] + , Opt.option Opt.auto $ mconcat + [ Opt.long "ttl" + , Opt.metavar "SLOT" + , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)." + , Opt.internal + ] + ] pTxFee :: Parser Lovelace pTxFee = @@ -2782,14 +2823,16 @@ pMultiHostName = pSingleHostName :: Parser StakePoolRelay pSingleHostName = StakePoolRelayDnsARecord <$> pDNSName <*> optional pPort - where - pDNSName :: Parser ByteString - pDNSName = Opt.option (Opt.eitherReader eDNSName) - ( Opt.long "single-host-pool-relay" - <> Opt.metavar "STRING" - <> Opt.help "The stake pool relay's DNS name that corresponds to an\ - \ A or AAAA DNS record" - ) + where + pDNSName :: Parser ByteString + pDNSName = Opt.option (Opt.eitherReader eDNSName) $ mconcat + [ Opt.long "single-host-pool-relay" + , Opt.metavar "STRING" + , Opt.help $ mconcat + [ "The stake pool relay's DNS name that corresponds to an" + , " A or AAAA DNS record" + ] + ] eDNSName :: String -> Either String ByteString eDNSName str = @@ -3091,65 +3134,86 @@ pUTxOCostPerByte = pExecutionUnitPrices :: Parser ExecutionUnitPrices pExecutionUnitPrices = ExecutionUnitPrices <$> Opt.option readRational - ( Opt.long "price-execution-steps" - <> Opt.metavar "RATIONAL" - <> Opt.help "Step price of execution units for script languages that use \ - \them (from Alonzo era). (Examples: '1.1', '11/10')" + ( mconcat + [ Opt.long "price-execution-steps" + , Opt.metavar "RATIONAL" + , Opt.help $ mconcat + [ "Step price of execution units for script languages that use " + , "them (from Alonzo era). (Examples: '1.1', '11/10')" + ] + ] ) <*> Opt.option readRational - ( Opt.long "price-execution-memory" - <> Opt.metavar "RATIONAL" - <> Opt.help "Memory price of execution units for script languages that \ - \use them (from Alonzo era). (Examples: '1.1', '11/10')" + ( mconcat + [ Opt.long "price-execution-memory" + , Opt.metavar "RATIONAL" + , Opt.help $ mconcat + [ "Memory price of execution units for script languages that " + , "use them (from Alonzo era). (Examples: '1.1', '11/10')" + ] + ] ) pMaxTxExecutionUnits :: Parser ExecutionUnits pMaxTxExecutionUnits = uncurry ExecutionUnits <$> Opt.option Opt.auto - ( Opt.long "max-tx-execution-units" - <> Opt.metavar "(INT, INT)" - <> Opt.help "Max total script execution resources units allowed per tx \ - \(from Alonzo era). They are denominated as follows (steps, memory)." - ) + ( mconcat + [ Opt.long "max-tx-execution-units" + , Opt.metavar "(INT, INT)" + , Opt.help $ mconcat + [ "Max total script execution resources units allowed per tx " + , "(from Alonzo era). They are denominated as follows (steps, memory)." + ] + ] + ) pMaxBlockExecutionUnits :: Parser ExecutionUnits pMaxBlockExecutionUnits = uncurry ExecutionUnits <$> Opt.option Opt.auto - ( Opt.long "max-block-execution-units" - <> Opt.metavar "(INT, INT)" - <> Opt.help "Max total script execution resources units allowed per block \ - \(from Alonzo era). They are denominated as follows (steps, memory)." - ) + ( mconcat + [ Opt.long "max-block-execution-units" + , Opt.metavar "(INT, INT)" + , Opt.help $ mconcat + [ "Max total script execution resources units allowed per block " + , "(from Alonzo era). They are denominated as follows (steps, memory)." + ] + ] + ) pMaxValueSize :: Parser Natural pMaxValueSize = - Opt.option Opt.auto - ( Opt.long "max-value-size" - <> Opt.metavar "INT" - <> Opt.help "Max size of a multi-asset value in a tx output (from Alonzo \ - \era)." - ) + Opt.option Opt.auto $ mconcat + [ Opt.long "max-value-size" + , Opt.metavar "INT" + , Opt.help $ mconcat + [ "Max size of a multi-asset value in a tx output (from Alonzo era)." + ] + ] pCollateralPercent :: Parser Natural pCollateralPercent = - Opt.option Opt.auto - ( Opt.long "collateral-percent" - <> Opt.metavar "INT" - <> Opt.help "The percentage of the script contribution to the txfee that \ - \must be provided as collateral inputs when including Plutus \ - \scripts (from Alonzo era)." - ) + Opt.option Opt.auto $ mconcat + [ Opt.long "collateral-percent" + , Opt.metavar "INT" + , Opt.help $ mconcat + [ "The percentage of the script contribution to the txfee that " + , "must be provided as collateral inputs when including Plutus " + , "scripts (from Alonzo era)." + ] + ] pMaxCollateralInputs :: Parser Natural pMaxCollateralInputs = - Opt.option Opt.auto - ( Opt.long "max-collateral-inputs" - <> Opt.metavar "INT" - <> Opt.help "The maximum number of collateral inputs allowed in a \ - \transaction (from Alonzo era)." - ) + Opt.option Opt.auto $ mconcat + [ Opt.long "max-collateral-inputs" + , Opt.metavar "INT" + , Opt.help $ mconcat + [ "The maximum number of collateral inputs allowed in a " + , "transaction (from Alonzo era)." + ] + ] pConsensusModeParams :: Parser AnyConsensusModeParams pConsensusModeParams = asum @@ -3201,12 +3265,14 @@ pProtocolVersion = <> Opt.help "Major protocol version. An increase indicates a hard fork." ) pProtocolMinorVersion = - Opt.option Opt.auto - ( Opt.long "protocol-minor-version" - <> Opt.metavar "NATURAL" - <> Opt.help "Minor protocol version. An increase indicates a soft fork\ - \ (old software canvalidate but not produce new blocks)." - ) + Opt.option Opt.auto $ mconcat + [ Opt.long "protocol-minor-version" + , Opt.metavar "NATURAL" + , Opt.help $ mconcat + [ "Minor protocol version. An increase indicates a soft fork" + , " (old software canvalidate but not produce new blocks)." + ] + ] -- -- Shelley CLI flag field parsers diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs index 191fa6161d1..a053bd6ae51 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Key.hs @@ -76,12 +76,12 @@ renderShelleyKeyCmdError err = ShelleyKeyCmdByronKeyFailure e -> Byron.renderByronKeyFailure e ShelleyKeyCmdByronKeyParseError errTxt -> errTxt ShelleyKeyCmdItnKeyConvError convErr -> renderConversionError convErr - ShelleyKeyCmdWrongKeyTypeError -> Text.pack "Please use a signing key file \ - \when converting ITN BIP32 or Extended keys" + ShelleyKeyCmdWrongKeyTypeError -> + Text.pack "Please use a signing key file when converting ITN BIP32 or Extended keys" ShelleyKeyCmdCardanoAddressSigningKeyFileError fileErr -> Text.pack (displayError fileErr) - ShelleyKeyCmdNonLegacyKey fp -> "Signing key at: " <> Text.pack fp <> " is not a legacy Byron signing key and should \ - \ not need to be converted." + ShelleyKeyCmdNonLegacyKey fp -> + "Signing key at: " <> Text.pack fp <> " is not a legacy Byron signing key and should not need to be converted." ShelleyKeyCmdVerificationKeyReadError e -> renderVerificationKeyTextOrFileError e ShelleyKeyCmdExpectedExtendedVerificationKey someVerKey -> "Expected an extended verification key but got: " <> renderSomeAddressVerificationKey someVerKey diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs index 456bb0abb4c..16a877d5f54 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Read.hs @@ -475,10 +475,11 @@ data CddlError = CddlErrorTextEnv | CddlIOError (FileError TextEnvelopeError) renderCddlError :: CddlError -> Text -renderCddlError (CddlErrorTextEnv textEnvErr cddlErr) = - "Failed to decode neither the cli's serialisation format nor the ledger's \ - \CDDL serialisation format. TextEnvelope error: " <> Text.pack (displayError textEnvErr) <> "\n" <> - "TextEnvelopeCddl error: " <> Text.pack (displayError cddlErr) +renderCddlError (CddlErrorTextEnv textEnvErr cddlErr) = mconcat + [ "Failed to decode neither the cli's serialisation format nor the ledger's " + , "CDDL serialisation format. TextEnvelope error: " <> Text.pack (displayError textEnvErr) <> "\n" + , "TextEnvelopeCddl error: " <> Text.pack (displayError cddlErr) + ] renderCddlError (CddlIOError e) = Text.pack $ displayError e acceptTxCDDLSerialisation diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs index f08ca6d043d..0f83a789dd5 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Run/Transaction.hs @@ -172,16 +172,18 @@ renderShelleyTxCmdError err = ShelleyTxCmdEraConsensusModeMismatch fp mode era -> "Submitting " <> renderEra era <> " era transaction (" <> textShow fp <> ") is not supported in the " <> renderMode mode <> " consensus mode." - ShelleyTxCmdPolicyIdsMissing policyids -> - "The \"--mint\" flag specifies an asset with a policy Id, but no \ - \corresponding monetary policy script has been provided as a witness \ - \(via the \"--mint-script-file\" flag). The policy Id in question is: " - <> Text.intercalate ", " (map serialiseToRawBytesHexText policyids) - - ShelleyTxCmdPolicyIdsExcess policyids -> - "A script provided to witness minting does not correspond to the policy \ - \id of any asset specified in the \"--mint\" field. The script hash is: " - <> Text.intercalate ", " (map serialiseToRawBytesHexText policyids) + ShelleyTxCmdPolicyIdsMissing policyids -> mconcat + [ "The \"--mint\" flag specifies an asset with a policy Id, but no " + , "corresponding monetary policy script has been provided as a witness " + , "(via the \"--mint-script-file\" flag). The policy Id in question is: " + , Text.intercalate ", " (map serialiseToRawBytesHexText policyids) + ] + + ShelleyTxCmdPolicyIdsExcess policyids -> mconcat + [ "A script provided to witness minting does not correspond to the policy " + , "id of any asset specified in the \"--mint\" field. The script hash is: " + , Text.intercalate ", " (map serialiseToRawBytesHexText policyids) + ] ShelleyTxCmdUnsupportedMode mode -> "Unsupported mode: " <> renderMode mode ShelleyTxCmdByronEra -> "This query cannot be used for the Byron era" ShelleyTxCmdEraConsensusModeMismatchTxBalance fp mode era -> @@ -192,15 +194,17 @@ renderShelleyTxCmdError err = renderTxInsExistError e ShelleyTxCmdMinimumUTxOErr err' -> Text.pack $ displayError err' ShelleyTxCmdPParamsErr err' -> Text.pack $ displayError err' - ShelleyTxCmdTextEnvCddlError textEnvErr cddlErr -> - "Failed to decode neither the cli's serialisation format nor the ledger's \ - \CDDL serialisation format. TextEnvelope error: " <> Text.pack (displayError textEnvErr) <> "\n" <> - "TextEnvelopeCddl error: " <> Text.pack (displayError cddlErr) + ShelleyTxCmdTextEnvCddlError textEnvErr cddlErr -> mconcat + [ "Failed to decode neither the cli's serialisation format nor the ledger's " + , "CDDL serialisation format. TextEnvelope error: " <> Text.pack (displayError textEnvErr) <> "\n" + , "TextEnvelopeCddl error: " <> Text.pack (displayError cddlErr) + ] ShelleyTxCmdTxExecUnitsErr err' -> Text.pack $ displayError err' ShelleyTxCmdPlutusScriptCostErr err'-> Text.pack $ displayError err' - ShelleyTxCmdPParamExecutionUnitsNotAvailable -> - "Execution units not available in the protocol parameters. This is \ - \likely due to not being in the Alonzo era" + ShelleyTxCmdPParamExecutionUnitsNotAvailable -> mconcat + [ "Execution units not available in the protocol parameters. This is " + , "likely due to not being in the Alonzo era" + ] ShelleyTxCmdReferenceScriptsNotSupportedInEra (AnyCardanoEra era) -> "TxCmd: Reference scripts not supported in era: " <> textShow era ShelleyTxCmdTxEraCastErr (EraCastError value fromEra toEra) -> diff --git a/cardano-cli/test/Test/Cli/ITN.hs b/cardano-cli/test/Test/Cli/ITN.hs index 7798bd144c8..23b9c6aaaa5 100644 --- a/cardano-cli/test/Test/Cli/ITN.hs +++ b/cardano-cli/test/Test/Cli/ITN.hs @@ -65,9 +65,10 @@ prop_convertITNKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- | 1. Convert a bech32 ITN extended signing key to a haskell stake signing key prop_convertITNExtendedSigningKey :: Property prop_convertITNExtendedSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - let itnExtendedSignKey = "\ - \ed25519e_sk1qpcplz38tg4fusw0fkqljzspe9qmj06ldu9lgcve99v4fphuk9a535kwj\ - \f38hkyn0shcycyaha4k9tmjy6xgvzaz7stw5t7rqjadyjcwfyx6k" + let itnExtendedSignKey = mconcat + [ "ed25519e_sk1qpcplz38tg4fusw0fkqljzspe9qmj06ldu9lgcve99v4fphuk9a535kwj" + , "f38hkyn0shcycyaha4k9tmjy6xgvzaz7stw5t7rqjadyjcwfyx6k" + ] -- ITN input file paths itnSignKeyFp <- noteTempFile tempDir "itnExtendedSignKey.key" @@ -92,10 +93,11 @@ prop_convertITNExtendedSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \te -- | 1. Convert a bech32 ITN BIP32 signing key to a haskell stake signing key prop_convertITNBIP32SigningKey :: Property prop_convertITNBIP32SigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - let itnExtendedSignKey = "\ - \xprv1spkw5suj39723c40mr55gwh7j3vryjv2zdm4e47xs0deka\ - \jcza9ud848ckdqf48md9njzc5pkujfxwu2j8wdvtxkx02n3s2qa\ - \euhqnfx6zu9dyccpua6vf5x3kur9hsganq2kl0yw7y9hpunts0e9kc5xv3pz0yj" + let itnExtendedSignKey = mconcat + [ "xprv1spkw5suj39723c40mr55gwh7j3vryjv2zdm4e47xs0deka" + , "jcza9ud848ckdqf48md9njzc5pkujfxwu2j8wdvtxkx02n3s2qa" + , "euhqnfx6zu9dyccpua6vf5x3kur9hsganq2kl0yw7y9hpunts0e9kc5xv3pz0yj" + ] -- ITN input file paths itnSignKeyFp <- noteTempFile tempDir "itnBIP32SignKey.key" diff --git a/cardano-cli/test/Test/Golden/TxView.hs b/cardano-cli/test/Test/Golden/TxView.hs index a9b7f85a63d..a29c27c431c 100644 --- a/cardano-cli/test/Test/Golden/TxView.hs +++ b/cardano-cli/test/Test/Golden/TxView.hs @@ -37,11 +37,9 @@ golden_view_byron = [ "transaction", "build-raw" , "--byron-era" , "--tx-in" - , "F8EC302D19E3C8251C30B1434349BF2E949A1DBF14A4EBC3D512918D2D4D5C56\ - \#88" + , "F8EC302D19E3C8251C30B1434349BF2E949A1DBF14A4EBC3D512918D2D4D5C56#88" , "--tx-out" - , "5oP9ib6ym3XfwXuy3ksXZzgtBzXSArXAACQVXKqcPhiLnHVYjXJNu2T6Zomh8LAWLV\ - \+68" + , "5oP9ib6ym3XfwXuy3ksXZzgtBzXSArXAACQVXKqcPhiLnHVYjXJNu2T6Zomh8LAWLV+68" , "--out-file", transactionBodyFile ] @@ -71,13 +69,15 @@ golden_view_shelley = let let extraEntropySeed = "c0ffee" note_ $ "extra entropy seed: " ++ extraEntropySeed - note_ - "extra entropy hash:\ - \ 88f04f011dcded879039ae4b9b20219d9448e5c7b42c2d1f638fb8740e0ab8be" + note_ $ mconcat + [ "extra entropy hash:" + , " 88f04f011dcded879039ae4b9b20219d9448e5c7b42c2d1f638fb8740e0ab8be" + ] - note_ - "genesis-verification-key-file hash:\ - \ 81cb0bc5b6fbba391e6f7ec3d9271cbea25bcbf907181b7c4d5f8c2f" + note_ $ mconcat + [ "genesis-verification-key-file hash:" + , " 81cb0bc5b6fbba391e6f7ec3d9271cbea25bcbf907181b7c4d5f8c2f" + ] -- Create update proposal void $ @@ -113,15 +113,13 @@ golden_view_shelley = let [ "transaction", "build-raw" , "--shelley-era" , "--tx-in" - , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891\ - \#29" + , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#29" , "--tx-out" , "addr_test1vz7w0r9epak6nmnh3mc8e2ypkjyu8zsc3xf7dpct6k577acxmcfyv+31" , "--fee", "32" , "--invalid-hereafter", "33" , "--withdrawal" - , "stake_test1up00fz9lyqs5sjks82k22eqz7a9srym9vysjgp3h2ua2v2cm522kg\ - \+42" + , "stake_test1up00fz9lyqs5sjks82k22eqz7a9srym9vysjgp3h2ua2v2cm522kg+42" , "--update-proposal-file", updateProposalFile , "--out-file", transactionBodyFile ] @@ -146,13 +144,14 @@ golden_view_allegra = [ "transaction", "build-raw" , "--allegra-era" , "--tx-in" - , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891\ - \#94" + , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#94" , "--tx-out" - , "addr_test1\ - \qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r7\ - \9jmxlyk4eqt6z6hj5g8jd8393msqaw47f4\ - \+99" + , mconcat + [ "addr_test1" + , "qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r7" + , "9jmxlyk4eqt6z6hj5g8jd8393msqaw47f4" + , "+99" + ] , "--fee", "100" , "--invalid-hereafter", "101" , "--out-file", transactionBodyFile @@ -176,48 +175,51 @@ golden_view_mary = [ "transaction", "build-raw" , "--mary-era" , "--tx-in" - , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891\ - \#135" + , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#135" , "--tx-out" - , "addr_test1\ - \qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r7\ - \9jmxlyk4eqt6z6hj5g8jd8393msqaw47f4\ - \ + \ - \138\ - \ + \ - \130 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf\ - \ + \ - \132 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.cafe\ - \ + \ - \134 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf.f00d\ - \ + \ - \136 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.dead\ - \ + \ - \138\ - \ d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf\ - \.736e6f77\ - \ + \ - \142\ - \ a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067\ - \.736b79" + , mconcat + [ "addr_test1" + , "qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r7" + , "9jmxlyk4eqt6z6hj5g8jd8393msqaw47f4" + , " + " + , "138" + , " + " + , "130 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" + , " + " + , "132 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.cafe" + , " + " + , "134 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf.f00d" + , " + " + , "136 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.dead" + , " + " + , "138" + , " d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" + , ".736e6f77" + , " + " + , "142" + , " a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067" + , ".736b79" + ] , "--fee", "139" , "--invalid-before", "140" , "--mint" - , "130 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf\ - \ + \ - \132 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.cafe\ - \ + \ - \134 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf.f00d\ - \ + \ - \136 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.dead\ - \ + \ - \138\ - \ d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf\ - \.736e6f77\ - \ + \ - \142\ - \ a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067\ - \.736b79" + , mconcat + [ "130 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" + , " + " + , "132 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.cafe" + , " + " + , "134 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf.f00d" + , " + " + , "136 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.dead" + , " + " + , "138" + , " d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" + , ".736e6f77" + , " + " + , "142" + , " a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067" + , ".736b79" + ] , "--mint-script-file", "test/data/golden/mary/scripts/mint.all" , "--mint-script-file", "test/data/golden/mary/scripts/mint.sig" , "--out-file", transactionBodyFile @@ -236,11 +238,9 @@ createAlonzoTxBody mUpdateProposalFile transactionBodyFile = do ( [ "transaction", "build-raw" , "--alonzo-era" , "--tx-in" - , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20\ - \#212" + , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#212" , "--tx-in-collateral" - , "c9765d7d0e3955be8920e6d7a38e1f3f2032eac48c7c59b0b9193caa87727e7e\ - \#256" + , "c9765d7d0e3955be8920e6d7a38e1f3f2032eac48c7c59b0b9193caa87727e7e#256" , "--fee", "213" , "--required-signer-hash" , "98717eaba8105a50a2a71831267552e337dfdc893bef5e40b8676d27" @@ -260,9 +260,10 @@ golden_view_alonzo = updateProposalFile <- noteTempFile tempDir "update-proposal" transactionBodyFile <- noteTempFile tempDir "transaction-body" - note_ - "genesis-verification-key-file hash:\ - \ 1bafa294233a5a7ffbf539ae798da0943aa83d2a19398c2d0e5af114" + note_ $ mconcat + [ "genesis-verification-key-file hash:" + , " 1bafa294233a5a7ffbf539ae798da0943aa83d2a19398c2d0e5af114" + ] -- Create update proposal void $ From c88ab23b20756a43f83b496503a4e6b751be37dd Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 16 Feb 2023 13:17:32 +1100 Subject: [PATCH 2/4] Remove use of multiline literals from cardano-api --- .../src/Cardano/Api/ProtocolParameters.hs | 20 +++++---- .../src/Cardano/Api/SerialiseBech32.hs | 26 ++++++------ cardano-api/src/Cardano/Api/TxBody.hs | 42 +++++++++++-------- 3 files changed, 49 insertions(+), 39 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index bb9ae64a44a..48797338aba 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -1790,15 +1790,17 @@ data ProtocolParametersError = deriving Show instance Error ProtocolParametersError where - displayError (PParamsErrorMissingMinUTxoValue (AnyCardanoEra era)) = - "The " <> show era <> " protocol parameters value is missing the following \ - \field: MinUTxoValue. Did you intend to use a " <> show era <> " protocol \ - \ parameters value?" - displayError PParamsErrorMissingAlonzoProtocolParameter = - "The Alonzo era protocol parameters in use is missing one or more of the \ - \following fields: UTxOCostPerWord, CostModels, Prices, MaxTxExUnits, \ - \MaxBlockExUnits, MaxValueSize, CollateralPercent, MaxCollateralInputs. Did \ - \you intend to use an Alonzo era protocol parameters value?" + displayError (PParamsErrorMissingMinUTxoValue (AnyCardanoEra era)) = mconcat + [ "The " <> show era <> " protocol parameters value is missing the following " + , "field: MinUTxoValue. Did you intend to use a " <> show era <> " protocol " + , " parameters value?" + ] + displayError PParamsErrorMissingAlonzoProtocolParameter = mconcat + [ "The Alonzo era protocol parameters in use is missing one or more of the " + , "following fields: UTxOCostPerWord, CostModels, Prices, MaxTxExUnits, " + , "MaxBlockExUnits, MaxValueSize, CollateralPercent, MaxCollateralInputs. Did " + , "you intend to use an Alonzo era protocol parameters value?" + ] checkProtocolParameters :: forall era. IsCardanoEra era diff --git a/cardano-api/src/Cardano/Api/SerialiseBech32.hs b/cardano-api/src/Cardano/Api/SerialiseBech32.hs index fe5daca06f7..b8e23c5c4f4 100644 --- a/cardano-api/src/Cardano/Api/SerialiseBech32.hs +++ b/cardano-api/src/Cardano/Api/SerialiseBech32.hs @@ -155,15 +155,17 @@ instance Error Bech32DecodeError where <> ", but it was expected to be " <> List.intercalate " or " (map show (Set.toList permitted)) - Bech32DataPartToBytesError _dataPart -> - "There was an error in extracting the bytes from the data part of the \ - \Bech32-encoded string." - - Bech32DeserialiseFromBytesError _bytes -> - "There was an error in deserialising the data part of the \ - \Bech32-encoded string into a value of the expected type." - - Bech32WrongPrefix actual expected -> - "Mismatch in the Bech32 prefix: the actual prefix is " <> show actual - <> ", but the prefix for this payload value should be " <> show expected - + Bech32DataPartToBytesError _dataPart -> mconcat + [ "There was an error in extracting the bytes from the data part of the " + , "Bech32-encoded string." + ] + + Bech32DeserialiseFromBytesError _bytes -> mconcat + [ "There was an error in deserialising the data part of the " + , "Bech32-encoded string into a value of the expected type." + ] + + Bech32WrongPrefix actual expected -> mconcat + [ "Mismatch in the Bech32 prefix: the actual prefix is " <> show actual + , ", but the prefix for this payload value should be " <> show expected + ] diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 9b3697149c9..86c67f78116 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -203,6 +203,8 @@ import qualified Cardano.Crypto.Hashing as Byron import qualified Cardano.Ledger.Address as Shelley import qualified Cardano.Ledger.AuxiliaryData as Ledger +import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..), + BabbageTxBody (BabbageTxBody), BabbageTxOut (BabbageTxOut)) import Cardano.Ledger.BaseTypes (StrictMaybe (..), maybeToStrictMaybe) import qualified Cardano.Ledger.Block as Ledger import qualified Cardano.Ledger.Coin as Ledger @@ -214,8 +216,6 @@ import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Era as CC import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.SafeHash as SafeHash -import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..), - BabbageTxBody (BabbageTxBody), BabbageTxOut (BabbageTxOut)) import qualified Cardano.Ledger.TxIn as Ledger import Cardano.Ledger.Val (isZero) @@ -226,23 +226,23 @@ import qualified Cardano.Ledger.Shelley.Metadata as Shelley import qualified Cardano.Ledger.Shelley.Tx as Shelley import qualified Cardano.Ledger.Shelley.TxBody as Shelley -import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Allegra +import Cardano.Ledger.Mary.Value (MaryValue) import Cardano.Ledger.ShelleyMA.AuxiliaryData (MAAuxiliaryData (..)) +import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Allegra +import Cardano.Ledger.ShelleyMA.TxBody (MATxBody (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as Allegra import qualified Cardano.Ledger.ShelleyMA.TxBody as Mary -import Cardano.Ledger.ShelleyMA.TxBody (MATxBody (..)) -import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Alonzo.Data (AlonzoAuxiliaryData (AlonzoAuxiliaryData)) +import qualified Cardano.Ledger.Alonzo.Data as Alonzo import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo -import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo -import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo -import Cardano.Ledger.Alonzo.Data (AlonzoAuxiliaryData (AlonzoAuxiliaryData)) -import qualified Cardano.Ledger.Alonzo.Data as Alonzo import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody (AlonzoTxBody), AlonzoTxOut (AlonzoTxOut)) +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo +import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo import qualified Cardano.Ledger.Babbage.PParams as Babbage import qualified Cardano.Ledger.Babbage.TxBody as Babbage @@ -1909,9 +1909,11 @@ deserialiseShelleyBasedTxBody era bs = 4 -> do sValiditySupported <- case txScriptValiditySupportedInShelleyBasedEra era of - Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports the \ - \script validity flag but got: " - <> show era + Nothing -> fail $ mconcat + [ "deserialiseShelleyBasedTxBody: Expected an era that supports the " + , "script validity flag but got: " + , show era + ] Just supported -> return supported txbody <- fromCBOR @@ -1928,16 +1930,20 @@ deserialiseShelleyBasedTxBody era bs = 6 -> do sDataSupported <- case scriptDataSupportedInEra (shelleyBasedToCardanoEra era) of - Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports script\ - \ data but got: " - <> show era + Nothing -> fail $ mconcat + [ "deserialiseShelleyBasedTxBody: Expected an era that supports script" + , " data but got: " + , show era + ] Just supported -> return supported sValiditySupported <- case txScriptValiditySupportedInShelleyBasedEra era of - Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports the \ - \script validity flag but got: " - <> show era + Nothing -> fail $ mconcat + [ "deserialiseShelleyBasedTxBody: Expected an era that supports the " + , "script validity flag but got: " + , show era + ] Just supported -> return supported txbody <- fromCBOR From 9d3b52d6063a74cbdb8403a161bbd2b7496e4745 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 16 Feb 2023 16:48:50 +1100 Subject: [PATCH 3/4] Remove use of multiline literals from cardano-node --- .../src/Cardano/Node/Configuration/POM.hs | 8 +- .../Cardano/Node/Configuration/Topology.hs | 15 +- .../Cardano/Node/Configuration/TopologyP2P.hs | 15 +- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 92 ++-- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 373 ++++++++------- .../Cardano/Node/Tracing/Tracers/Consensus.hs | 437 ++++++++++-------- .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 32 +- .../Node/Tracing/Tracers/NodeToClient.hs | 136 +++--- .../Node/Tracing/Tracers/NodeToNode.hs | 165 +++---- .../Cardano/Node/Tracing/Tracers/NonP2P.hs | 7 +- .../src/Cardano/Node/Tracing/Tracers/P2P.hs | 42 +- .../Cardano/Node/Tracing/Tracers/Startup.hs | 54 ++- .../Tracing/OrphanInstances/Consensus.hs | 51 +- .../Tracing/OrphanInstances/Shelley.hs | 92 ++-- .../test/Test/Cli/KesPeriodInfo.hs | 12 +- 15 files changed, 863 insertions(+), 668 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index ccd19eb09c8..e7d91217d5e 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -306,9 +306,11 @@ instance FromJSON PartialNodeConfiguration where maybeString :: Maybe String <- v .:? "MempoolCapacityBytesOverride" case maybeString of Just "NoOverride" -> return (Just NoMempoolCapacityBytesOverride) - Just invalid -> fmap Just . Aeson.parseFail $ - "Invalid value for 'MempoolCapacityBytesOverride'. \ - \Expecting byte count or NoOverride. Value was: " <> show invalid + Just invalid -> fmap Just . Aeson.parseFail $ mconcat + [ "Invalid value for 'MempoolCapacityBytesOverride'. " + , "Expecting byte count or NoOverride. Value was: " + , show invalid + ] Nothing -> return Nothing parseByronProtocol v = do primary <- v .:? "ByronGenesisFile" diff --git a/cardano-node/src/Cardano/Node/Configuration/Topology.hs b/cardano-node/src/Cardano/Node/Configuration/Topology.hs index 826431f33bc..942fb83cda0 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Topology.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Topology.hs @@ -145,12 +145,15 @@ readTopologyFile nc = do handler e = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: " ++ displayException e handlerJSON :: String -> Text - handlerJSON err = "Is your topology file formatted correctly? \ - \Expecting Non-P2P Topology file format. \ - \The port and valency fields should be numerical. \ - \If you specified the correct topology file \ - \make sure that you correctly setup EnableP2P \ - \configuration flag. " <> Text.pack err + handlerJSON err = mconcat + [ "Is your topology file formatted correctly? " + , "Expecting Non-P2P Topology file format. " + , "The port and valency fields should be numerical. " + , "If you specified the correct topology file " + , "make sure that you correctly setup EnableP2P " + , "configuration flag. " + , Text.pack err + ] readTopologyFileOrError :: NodeConfiguration -> IO NetworkTopology readTopologyFileOrError nc = diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index 1f9aebbd638..e3c5f9ba3a8 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -260,12 +260,15 @@ readTopologyFile tr nc = do handler e = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: " ++ displayException e handlerJSON :: String -> Text - handlerJSON err = "Is your topology file formatted correctly? \ - \Expecting P2P Topology file format. \ - \The port and valency fields should be numerical. \ - \If you specified the correct topology file \ - \make sure that you correctly setup EnableP2P \ - \configuration flag. " <> Text.pack err + handlerJSON err = mconcat + [ "Is your topology file formatted correctly? " + , "Expecting P2P Topology file format. " + , "The port and valency fields should be numerical. " + , "If you specified the correct topology file " + , "make sure that you correctly setup EnableP2P " + , "configuration flag. " + , Text.pack err + ] readTopologyFileOrError :: Tracer IO (StartupTrace blk) -> NodeConfiguration -> IO NetworkTopology diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 79643cda838..c558a186811 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -209,11 +209,13 @@ instance LogFormatting ChainPredicateFailure where , "currentProtocol" .= currentPtcl , "supportedProtocol" .= supportedPtcl ] where - explanation = "A scheduled major protocol version change (hard fork) \ - \has taken place on the chain, but this node does not \ - \understand the new major protocol version. This node \ - \must be upgraded before it can continue with the new \ - \protocol version." + explanation = mconcat + [ "A scheduled major protocol version change (hard fork) " + , "has taken place on the chain, but this node does not " + , "understand the new major protocol version. This node " + , "must be upgraded before it can continue with the new " + , "protocol version." + ] instance LogFormatting (PrtlSeqFailure crypto) where forMachine _dtal (WrongSlotIntervalPrtclSeq (SlotNo lastSlot) (SlotNo currSlot)) = @@ -411,10 +413,14 @@ instance ( ShelleyBasedEra era -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO forMachine _dtal (OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String "The output is smaller than the allow minimum \ - \UTxO value defined in the protocol parameters" - ] + , "outputs" .= badOutputs + , "error" .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] forMachine _dtal (OutputBootAddrAttrsTooBig badOutputs) = mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" , "outputs" .= badOutputs @@ -489,10 +495,14 @@ instance ( ShelleyBasedEra era -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO forMachine _dtal (MA.OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String "The output is smaller than the allow minimum \ - \UTxO value defined in the protocol parameters" - ] + , "outputs" .= badOutputs + , "error" .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] forMachine dtal (MA.UpdateFailure f) = forMachine dtal f forMachine _dtal (MA.OutputBootAddrAttrsTooBig badOutputs) = mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" @@ -797,26 +807,38 @@ instance Core.Crypto crypto => LogFormatting (OverlayPredicateFailure crypto) wh instance LogFormatting (OcertPredicateFailure crypto) where forMachine _dtal (KESBeforeStartOCERT (KESPeriod oCertstart) (KESPeriod current)) = mconcat [ "kind" .= String "KESBeforeStartOCERT" - , "opCertKESStartPeriod" .= String (textShow oCertstart) - , "currentKESPeriod" .= String (textShow current) - , "error" .= String "Your operational certificate's KES start period \ - \is before the KES current period." - ] + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "currentKESPeriod" .= String (textShow current) + , "error" .= String + ( mconcat + [ "Your operational certificate's KES start period " + , "is before the KES current period." + ] + ) + ] forMachine _dtal (KESAfterEndOCERT (KESPeriod current) (KESPeriod oCertstart) maxKESEvolutions) = mconcat [ "kind" .= String "KESAfterEndOCERT" - , "currentKESPeriod" .= String (textShow current) - , "opCertKESStartPeriod" .= String (textShow oCertstart) - , "maxKESEvolutions" .= String (textShow maxKESEvolutions) - , "error" .= String "The operational certificate's KES start period is \ - \greater than the max number of KES + the KES current period" - ] + , "currentKESPeriod" .= String (textShow current) + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "maxKESEvolutions" .= String (textShow maxKESEvolutions) + , "error" .= String + ( mconcat + [ "The operational certificate's KES start period is " + , "greater than the max number of KES + the KES current period" + ] + ) + ] forMachine _dtal (CounterTooSmallOCERT lastKEScounterUsed currentKESCounter) = mconcat [ "kind" .= String "CounterTooSmallOCert" - , "currentKESCounter" .= String (textShow currentKESCounter) - , "lastKESCounter" .= String (textShow lastKEScounterUsed) - , "error" .= String "The operational certificate's last KES counter is greater \ - \than the current KES counter." - ] + , "currentKESCounter" .= String (textShow currentKESCounter) + , "lastKESCounter" .= String (textShow lastKEScounterUsed) + , "error" .= String + ( mconcat + [ "The operational certificate's last KES counter is greater " + , "than the current KES counter." + ] + ) + ] forMachine _dtal (InvalidSignatureOCERT oCertCounter oCertKESStartPeriod) = mconcat [ "kind" .= String "InvalidSignatureOCERT" , "opCertKESStartPeriod" .= String (textShow oCertKESStartPeriod) @@ -893,10 +915,14 @@ instance ( ShelleyBasedEra era ] forMachine _dtal (Alonzo.OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String "The output is smaller than the allow minimum \ - \UTxO value defined in the protocol parameters" - ] + , "outputs" .= badOutputs + , "error" .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] forMachine dtal (Alonzo.UtxosFailure predFailure) = forMachine dtal predFailure forMachine _dtal (Alonzo.OutputBootAddrAttrsTooBig txouts) = diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 5f347183eca..6e970752a6b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -594,78 +594,106 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where detailsFor _ _ = Just DNormal metricsDocFor (Namespace _ ["SwitchedToAFork"]) = - [ ("ChainDB.Density", - "The actual number of blocks created over the maximum expected number\ - \ of blocks that could be created over the span of the last @k@ blocks.") - , ("ChainDB.Slots", - "Number of slots in this chain fragment.") - , ("ChainDB.Blocks", - "Number of blocks in this chain fragment.") - , ("ChainDB.SlotInEpoch", - "Relative slot number of the tip of the current chain within the\ - \epoch..") - , ("ChainDB.Epoch", - "In which epoch is the tip of the current chain.") + [ ( "ChainDB.Density" + , mconcat + [ "The actual number of blocks created over the maximum expected number" + , " of blocks that could be created over the span of the last @k@ blocks." + ] + ) + , ( "ChainDB.Slots" + , "Number of slots in this chain fragment." + ) + , ( "ChainDB.Blocks" + , "Number of blocks in this chain fragment." + ) + , ( "ChainDB.SlotInEpoch" + , mconcat + [ "Relative slot number of the tip of the current chain within the" + , " epoch.." + ] + ) + , ( "ChainDB.Epoch" + , "In which epoch is the tip of the current chain." + ) ] metricsDocFor (Namespace _ ["AddedToCurrentChain"]) = - [("ChainDB.Density", - "The actual number of blocks created over the maximum expected number\ - \ of blocks that could be created over the span of the last @k@ blocks.") - , ("ChainDB.Slots", - "Number of slots in this chain fragment.") - , ("ChainDB.Blocks", - "Number of blocks in this chain fragment.") - , ("ChainDB.SlotInEpoch", - "Relative slot number of the tip of the current chain within the\ - \epoch..") - , ("ChainDB.Epoch", - "In which epoch is the tip of the current chain.") + [ ( "ChainDB.Density" + , mconcat + [ "The actual number of blocks created over the maximum expected number" + , " of blocks that could be created over the span of the last @k@ blocks." + ] + ) + , ( "ChainDB.Slots" + , "Number of slots in this chain fragment." + ) + , ( "ChainDB.Blocks" + , "Number of blocks in this chain fragment." + ) + , ( "ChainDB.SlotInEpoch" + , mconcat + [ "Relative slot number of the tip of the current chain within the" + , " epoch.." + ] + ) + , ( "ChainDB.Epoch" + , "In which epoch is the tip of the current chain." + ) ] metricsDocFor _ = [] - documentFor (Namespace _ ["IgnoreBlockOlderThanK"]) = Just - "A block with a 'BlockNo' more than @k@ back than the current tip\ - \ was ignored." + documentFor (Namespace _ ["IgnoreBlockOlderThanK"]) = Just $ mconcat + [ "A block with a 'BlockNo' more than @k@ back than the current tip" + , " was ignored." + ] documentFor (Namespace _ ["IgnoreBlockAlreadyInVolatileDB"]) = Just "A block that is already in the Volatile DB was ignored." documentFor (Namespace _ ["IgnoreInvalidBlock"]) = Just "A block that is invalid was ignored." - documentFor (Namespace _ ["AddedBlockToQueue"]) = Just - "The block was added to the queue and will be added to the ChainDB by\ - \ the background thread. The size of the queue is included.." - documentFor (Namespace _ ["BlockInTheFuture"]) = Just - "The block is from the future, i.e., its slot number is greater than\ - \ the current slot (the second argument)." + documentFor (Namespace _ ["AddedBlockToQueue"]) = Just $ mconcat + [ "The block was added to the queue and will be added to the ChainDB by" + , " the background thread. The size of the queue is included.." + ] + documentFor (Namespace _ ["BlockInTheFuture"]) = Just $ mconcat + [ "The block is from the future, i.e., its slot number is greater than" + , " the current slot (the second argument)." + ] documentFor (Namespace _ ["AddedBlockToVolatileDB"]) = Just "A block was added to the Volatile DB" - documentFor (Namespace _ ["PoppedBlockFromQueue"]) = Just"" - documentFor (Namespace _ ["TryAddToCurrentChain"]) = Just - "The block fits onto the current chain, we'll try to use it to extend\ - \ our chain." - documentFor (Namespace _ ["TrySwitchToAFork"]) = Just - "The block fits onto some fork, we'll try to switch to that fork (if\ - \ it is preferable to our chain)" - documentFor (Namespace _ ["StoreButDontChange"]) = Just - "The block fits onto some fork, we'll try to switch to that fork (if\ - \ it is preferable to our chain)." - documentFor (Namespace _ ["ChangingSelection"]) = Just - "The new block fits onto the current chain (first\ - \ fragment) and we have successfully used it to extend our (new) current\ - \ chain (second fragment)." - documentFor (Namespace _ ["AddedToCurrentChain"]) = Just - "The new block fits onto the current chain (first\ - \ fragment) and we have successfully used it to extend our (new) current\ - \ chain (second fragment)." - documentFor (Namespace _out ["SwitchedToAFork"]) = Just - "The new block fits onto some fork and we have switched to that fork\ - \ (second fragment), as it is preferable to our (previous) current chain\ - \ (first fragment)." + documentFor (Namespace _ ["PoppedBlockFromQueue"]) = Just "" + documentFor (Namespace _ ["TryAddToCurrentChain"]) = Just $ mconcat + [ "The block fits onto the current chain, we'll try to use it to extend" + , " our chain." + ] + documentFor (Namespace _ ["TrySwitchToAFork"]) = Just $ mconcat + [ "The block fits onto some fork, we'll try to switch to that fork (if" + , " it is preferable to our chain)" + ] + documentFor (Namespace _ ["StoreButDontChange"]) = Just $ mconcat + [ "The block fits onto some fork, we'll try to switch to that fork (if" + , " it is preferable to our chain)." + ] + documentFor (Namespace _ ["ChangingSelection"]) = Just $ mconcat + [ "The new block fits onto the current chain (first" + , " fragment) and we have successfully used it to extend our (new) current" + , " chain (second fragment)." + ] + documentFor (Namespace _ ["AddedToCurrentChain"]) = Just $ mconcat + [ "The new block fits onto the current chain (first" + , " fragment) and we have successfully used it to extend our (new) current" + , " chain (second fragment)." + ] + documentFor (Namespace _out ["SwitchedToAFork"]) = Just $ mconcat + [ "The new block fits onto some fork and we have switched to that fork" + , " (second fragment), as it is preferable to our (previous) current chain" + , " (first fragment)." + ] documentFor (Namespace out ("AddBlockValidation" : tl)) = documentFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk)) - documentFor (Namespace _ ["ChainSelectionForFutureBlock"]) = Just - "Run chain selection for a block that was previously from the future.\ - \ This is done for all blocks from the future each time a new block is\ - \ added." + documentFor (Namespace _ ["ChainSelectionForFutureBlock"]) = Just $ mconcat + [ "Run chain selection for a block that was previously from the future." + , " This is done for all blocks from the future each time a new block is" + , " added." + ] documentFor (Namespace out ("PipeliningEvent" : tl)) = documentFor (Namespace out tl :: Namespace (ChainDB.TracePipeliningEvent blk)) documentFor _ = Nothing @@ -764,17 +792,20 @@ addedHdrsNewChain fro to_ = instance (ConvertRawHash blk, StandardHash blk) => LogFormatting (ChainDB.TraceFollowerEvent blk) where forHuman ChainDB.NewFollower = "A new Follower was created" - forHuman (ChainDB.FollowerNoLongerInMem _rrs) = - "The follower was in the 'FollowerInMem' state but its point is no longer on\ - \ the in-memory chain fragment, so it has to switch to the\ - \ 'FollowerInImmutableDB' state" - forHuman (ChainDB.FollowerSwitchToMem point slot) = - "The follower was in the 'FollowerInImmutableDB' state and is switched to\ - \ the 'FollowerInMem' state. Point: " <> showT point <> " slot: " <> showT slot - forHuman (ChainDB.FollowerNewImmIterator point slot) = - "The follower is in the 'FollowerInImmutableDB' state but the iterator is\ - \ exhausted while the ImmDB has grown, so we open a new iterator to\ - \ stream these blocks too. Point: " <> showT point <> " slot: " <> showT slot + forHuman (ChainDB.FollowerNoLongerInMem _rrs) = mconcat + [ "The follower was in the 'FollowerInMem' state but its point is no longer on" + , " the in-memory chain fragment, so it has to switch to the" + , " 'FollowerInImmutableDB' state" + ] + forHuman (ChainDB.FollowerSwitchToMem point slot) = mconcat + [ "The follower was in the 'FollowerInImmutableDB' state and is switched to" + , " the 'FollowerInMem' state. Point: " <> showT point <> " slot: " <> showT slot + ] + forHuman (ChainDB.FollowerNewImmIterator point slot) = mconcat + [ "The follower is in the 'FollowerInImmutableDB' state but the iterator is" + , " exhausted while the ImmDB has grown, so we open a new iterator to" + , " stream these blocks too. Point: " <> showT point <> " slot: " <> showT slot + ] forMachine _dtal ChainDB.NewFollower = mconcat [ "kind" .= String "NewFollower" ] @@ -803,16 +834,19 @@ instance MetaTrace (ChainDB.TraceFollowerEvent blk) where documentFor (Namespace _ ["NewFollower"]) = Just "A new follower was created." - documentFor (Namespace _ ["FollowerNoLongerInMem"]) = Just - "The follower was in 'FollowerInMem' state and is switched to\ - \ the 'FollowerInImmutableDB' state." - documentFor (Namespace _ ["FollowerSwitchToMem"]) = Just - "The follower was in the 'FollowerInImmutableDB' state and is switched to\ - \ the 'FollowerInMem' state." - documentFor (Namespace _ ["FollowerNewImmIterator"]) = Just - "The follower is in the 'FollowerInImmutableDB' state but the iterator is\ - \ exhausted while the ImmDB has grown, so we open a new iterator to\ - \ stream these blocks too." + documentFor (Namespace _ ["FollowerNoLongerInMem"]) = Just $ mconcat + [ "The follower was in 'FollowerInMem' state and is switched to" + , " the 'FollowerInImmutableDB' state." + ] + documentFor (Namespace _ ["FollowerSwitchToMem"]) = Just $ mconcat + [ "The follower was in the 'FollowerInImmutableDB' state and is switched to" + , " the 'FollowerInMem' state." + ] + documentFor (Namespace _ ["FollowerNewImmIterator"]) = Just $ mconcat + [ "The follower is in the 'FollowerInImmutableDB' state but the iterator is" + , " exhausted while the ImmDB has grown, so we open a new iterator to" + , " stream these blocks too." + ] documentFor _ = Nothing allNamespaces = @@ -891,9 +925,10 @@ instance MetaTrace (ChainDB.TraceGCEvent blk) where documentFor (Namespace _ ["PerformedGC"]) = Just "A garbage collection for the given 'SlotNo' was performed." - documentFor (Namespace _ ["ScheduledGC"]) = Just - "A garbage collection for the given 'SlotNo' was scheduled to happen\ - \ at the given time." + documentFor (Namespace _ ["ScheduledGC"]) = Just $ mconcat + [ "A garbage collection for the given 'SlotNo' was scheduled to happen" + , " at the given time." + ] documentFor _ = Nothing allNamespaces = @@ -963,9 +998,10 @@ instance MetaTrace (ChainDB.TraceInitChainSelEvent blk) where documentFor (Namespace _ ["InitalChainSelected"]) = Just "A garbage collection for the given 'SlotNo' was performed." - documentFor (Namespace _ ["StartedInitChainSelection"]) = Just - "A garbage collection for the given 'SlotNo' was scheduled to happen\ - \ at the given time." + documentFor (Namespace _ ["StartedInitChainSelection"]) = Just $ mconcat + [ "A garbage collection for the given 'SlotNo' was scheduled to happen" + , " at the given time." + ] documentFor (Namespace o ("InitChainSelValidation" : tl)) = documentFor (Namespace o tl :: Namespace (ChainDB.TraceValidationEvent blk)) documentFor _ = Nothing @@ -1059,20 +1095,24 @@ instance MetaTrace (ChainDB.TraceValidationEvent blk) where severityFor (Namespace _ ["UpdateLedgerDb"]) _ = Just Debug severityFor _ _ = Nothing - documentFor (Namespace _ ["ValidCandidate"]) = Just - "An event traced during validating performed while adding a block.\ - \ A candidate chain was valid." - documentFor (Namespace _ ["CandidateContainsFutureBlocks"]) = Just - "An event traced during validating performed while adding a block.\ - \ Candidate contains headers from the future which do no exceed the\ - \ clock skew." - documentFor (Namespace _ ["CandidateContainsFutureBlocksExceedingClockSkew"]) = Just - "An event traced during validating performed while adding a block.\ - \ Candidate contains headers from the future which exceed the\ - \ clock skew." - documentFor (Namespace _ ["InvalidBlock"]) = Just - "An event traced during validating performed while adding a block.\ - \ A point was found to be invalid." + documentFor (Namespace _ ["ValidCandidate"]) = Just $ mconcat + [ "An event traced during validating performed while adding a block." + , " A candidate chain was valid." + ] + documentFor (Namespace _ ["CandidateContainsFutureBlocks"]) = Just $ mconcat + [ "An event traced during validating performed while adding a block." + , " Candidate contains headers from the future which do no exceed the" + , " clock skew." + ] + documentFor (Namespace _ ["CandidateContainsFutureBlocksExceedingClockSkew"]) = Just $ mconcat + [ "An event traced during validating performed while adding a block." + , " Candidate contains headers from the future which exceed the" + , " clock skew." + ] + documentFor (Namespace _ ["InvalidBlock"]) = Just $ mconcat + [ "An event traced during validating performed while adding a block." + , " A point was found to be invalid." + ] documentFor (Namespace _ ["UpdateLedgerDb"]) = Just "" documentFor _ = Nothing @@ -1202,27 +1242,33 @@ instance ( StandardHash blk , ConvertRawHash blk ) => LogFormatting (ChainDB.TraceIteratorEvent blk) where forHuman (ChainDB.UnknownRangeRequested ev') = forHuman ev' - forHuman (ChainDB.BlockMissingFromVolatileDB realPt) = - "This block is no longer in the VolatileDB because it has been garbage\ - \ collected. It might now be in the ImmDB if it was part of the\ - \ current chain. Block: " <> renderRealPoint realPt - forHuman (ChainDB.StreamFromImmutableDB sFrom sTo) = - "Stream only from the ImmDB. StreamFrom:" <> showT sFrom <> - " StreamTo: " <> showT sTo - forHuman (ChainDB.StreamFromBoth sFrom sTo pts) = - "Stream from both the VolatileDB and the ImmDB." - <> " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo - <> " Points: " <> showT (map renderRealPoint pts) - forHuman (ChainDB.StreamFromVolatileDB sFrom sTo pts) = - "Stream only from the VolatileDB." - <> " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo - <> " Points: " <> showT (map renderRealPoint pts) - forHuman (ChainDB.BlockWasCopiedToImmutableDB pt) = - "This block has been garbage collected from the VolatileDB is now\ - \ found and streamed from the ImmDB. Block: " <> renderRealPoint pt - forHuman (ChainDB.BlockGCedFromVolatileDB pt) = - "This block no longer in the VolatileDB and isn't in the ImmDB\ - \ either; it wasn't part of the current chain. Block: " <> renderRealPoint pt + forHuman (ChainDB.BlockMissingFromVolatileDB realPt) = mconcat + [ "This block is no longer in the VolatileDB because it has been garbage" + , " collected. It might now be in the ImmDB if it was part of the" + , " current chain. Block: " <> renderRealPoint realPt + ] + forHuman (ChainDB.StreamFromImmutableDB sFrom sTo) = mconcat + [ "Stream only from the ImmDB. StreamFrom:" <> showT sFrom + , " StreamTo: " <> showT sTo + ] + forHuman (ChainDB.StreamFromBoth sFrom sTo pts) = mconcat + [ "Stream from both the VolatileDB and the ImmDB." + , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + , " Points: " <> showT (map renderRealPoint pts) + ] + forHuman (ChainDB.StreamFromVolatileDB sFrom sTo pts) = mconcat + [ "Stream only from the VolatileDB." + , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + , " Points: " <> showT (map renderRealPoint pts) + ] + forHuman (ChainDB.BlockWasCopiedToImmutableDB pt) = mconcat + [ "This block has been garbage collected from the VolatileDB is now" + , " found and streamed from the ImmDB. Block: " <> renderRealPoint pt + ] + forHuman (ChainDB.BlockGCedFromVolatileDB pt) = mconcat + [ "This block no longer in the VolatileDB and isn't in the ImmDB" + , " either; it wasn't part of the current chain. Block: " <> renderRealPoint pt + ] forHuman ChainDB.SwitchBackToVolatileDB = "SwitchBackToVolatileDB" forMachine _dtal (ChainDB.UnknownRangeRequested unkRange) = @@ -1312,21 +1358,25 @@ instance MetaTrace (ChainDB.TraceIteratorEvent blk) where "Stream only from the ImmDB." documentFor (Namespace _ ["StreamFromBoth"]) = Just "Stream from both the VolatileDB and the ImmDB." - documentFor (Namespace _ ["BlockMissingFromVolatileDB"]) = Just - "A block is no longer in the VolatileDB because it has been garbage\ - \ collected. It might now be in the ImmDB if it was part of the\ - \ current chain." - documentFor (Namespace _ ["BlockWasCopiedToImmutableDB"]) = Just - "A block that has been garbage collected from the VolatileDB is now\ - \ found and streamed from the ImmDB." - documentFor (Namespace _ ["BlockGCedFromVolatileDB"]) = Just - "A block is no longer in the VolatileDB and isn't in the ImmDB\ - \ either; it wasn't part of the current chain." - documentFor (Namespace _ ["SwitchBackToVolatileDB"]) = Just - "We have streamed one or more blocks from the ImmDB that were part\ - \ of the VolatileDB when initialising the iterator. Now, we have to look\ - \ back in the VolatileDB again because the ImmDB doesn't have the\ - \ next block we're looking for." + documentFor (Namespace _ ["BlockMissingFromVolatileDB"]) = Just $ mconcat + [ "A block is no longer in the VolatileDB because it has been garbage" + , " collected. It might now be in the ImmDB if it was part of the" + , " current chain." + ] + documentFor (Namespace _ ["BlockWasCopiedToImmutableDB"]) = Just $ mconcat + [ "A block that has been garbage collected from the VolatileDB is now" + , " found and streamed from the ImmDB." + ] + documentFor (Namespace _ ["BlockGCedFromVolatileDB"]) = Just $ mconcat + [ "A block is no longer in the VolatileDB and isn't in the ImmDB" + , " either; it wasn't part of the current chain." + ] + documentFor (Namespace _ ["SwitchBackToVolatileDB"]) = Just $ mconcat + [ "We have streamed one or more blocks from the ImmDB that were part" + , " of the VolatileDB when initialising the iterator. Now, we have to look" + , " back in the VolatileDB again because the ImmDB doesn't have the" + , " next block we're looking for." + ] documentFor _ = Nothing allNamespaces = @@ -1489,23 +1539,26 @@ instance MetaTrace (LedgerDB.TraceReplayEvent blk) where severityFor (Namespace _ ["ReplayedBlock"]) _ = Just Info severityFor _ _ = Nothing - documentFor (Namespace _ ["ReplayFromGenesis"]) = Just - "There were no LedgerDB snapshots on disk, so we're replaying all\ - \ blocks starting from Genesis against the initial ledger.\ - \ The @replayTo@ parameter corresponds to the block at the tip of the\ - \ ImmDB, i.e., the last block to replay." - documentFor (Namespace _ ["ReplayFromSnapshot"]) = Just - "There was a LedgerDB snapshot on disk corresponding to the given tip.\ - \ We're replaying more recent blocks against it.\ - \ The @replayTo@ parameter corresponds to the block at the tip of the\ - \ ImmDB, i.e., the last block to replay." - documentFor (Namespace _ ["ReplayedBlock"]) = Just - "We replayed the given block (reference) on the genesis snapshot\ - \ during the initialisation of the LedgerDB.\ - \\n\ - \ The @blockInfo@ parameter corresponds replayed block and the @replayTo@\ - \ parameter corresponds to the block at the tip of the ImmDB, i.e.,\ - \ the last block to replay." + documentFor (Namespace _ ["ReplayFromGenesis"]) = Just $ mconcat + [ "There were no LedgerDB snapshots on disk, so we're replaying all" + , " blocks starting from Genesis against the initial ledger." + , " The @replayTo@ parameter corresponds to the block at the tip of the" + , " ImmDB, i.e., the last block to replay." + ] + documentFor (Namespace _ ["ReplayFromSnapshot"]) = Just $ mconcat + [ "There was a LedgerDB snapshot on disk corresponding to the given tip." + , " We're replaying more recent blocks against it." + , " The @replayTo@ parameter corresponds to the block at the tip of the" + , " ImmDB, i.e., the last block to replay." + ] + documentFor (Namespace _ ["ReplayedBlock"]) = Just $ mconcat + [ "We replayed the given block (reference) on the genesis snapshot" + , " during the initialisation of the LedgerDB." + , "\n" + , " The @blockInfo@ parameter corresponds replayed block and the @replayTo@" + , " parameter corresponds to the block at the tip of the ImmDB, i.e.," + , " the last block to replay." + ] documentFor _ = Nothing allNamespaces = @@ -1659,9 +1712,10 @@ instance MetaTrace (ImmDB.TraceEvent blk) where "The last location was validatet" documentFor (Namespace o ("ChunkValidation" : tl)) = documentFor (Namespace o tl :: Namespace (ImmDB.TraceChunkValidation blk chunkNo)) - documentFor (Namespace _ ["ChunkFileDoesntFit"]) = Just - "The hash of the last block in the previous epoch doesn't match the\ - \ previous hash of the first block in the current epoch" + documentFor (Namespace _ ["ChunkFileDoesntFit"]) = Just $ mconcat + [ "The hash of the last block in the previous epoch doesn't match the" + , " previous hash of the first block in the current epoch" + ] documentFor (Namespace _ ["Migrating"]) = Just "Performing a migration of the on-disk files." documentFor (Namespace _ ["DeletingAfter"]) = Just @@ -1858,9 +1912,10 @@ instance MetaTrace ImmDB.TraceCacheEvent where "Past chunk found in the cache" documentFor (Namespace _ ["PastChunkMiss"]) = Just "Past chunk was not found in the cache" - documentFor (Namespace _ ["PastChunkEvict"]) = Just - "The least recently used past chunk was evicted because the cache\ - \ was full." + documentFor (Namespace _ ["PastChunkEvict"]) = Just $ mconcat + [ "The least recently used past chunk was evicted because the cache" + , " was full." + ] documentFor (Namespace _ ["PastChunkExpired"]) = Just "" documentFor _ = Nothing diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index ba5cfcf6da6..b85262b4282 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -154,18 +154,21 @@ instance (LogFormatting (LedgerUpdate blk), LogFormatting (LedgerWarning blk)) instance (ConvertRawHash blk, LedgerSupportsProtocol blk) => LogFormatting (TraceChainSyncClientEvent blk) where - forHuman (TraceDownloadedHeader pt) = - "While following a candidate chain, we rolled forward by downloading a\ - \ header. " <> showT (headerPoint pt) + forHuman (TraceDownloadedHeader pt) = mconcat + [ "While following a candidate chain, we rolled forward by downloading a" + , " header. " + , showT (headerPoint pt) + ] forHuman (TraceRolledBack tip) = "While following a candidate chain, we rolled back to the given point: " <> showT tip forHuman (TraceException exc) = "An exception was thrown by the Chain Sync Client. " <> showT exc - forHuman TraceFoundIntersection {} = - "We found an intersection between our chain fragment and the\ - \ candidate's chain." + forHuman TraceFoundIntersection {} = mconcat + [ "We found an intersection between our chain fragment and the" + , " candidate's chain." + ] forHuman (TraceTermination res) = "The client has terminated. " <> showT res @@ -212,16 +215,18 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where severityFor (Namespace _ ["Termination"]) _ = Just Notice severityFor _ _ = Nothing - documentFor (Namespace _ ["DownloadedHeader"]) = Just - "While following a candidate chain, we rolled forward by downloading a\ - \ header." + documentFor (Namespace _ ["DownloadedHeader"]) = Just $ mconcat + [ "While following a candidate chain, we rolled forward by downloading a" + , " header." + ] documentFor (Namespace _ ["RolledBack"]) = Just "While following a candidate chain, we rolled back to the given point." documentFor (Namespace _ ["Exception"]) = Just "An exception was thrown by the Chain Sync Client." - documentFor (Namespace _ ["FoundIntersection"]) = Just - "We found an intersection between our chain fragment and the\ - \ candidate's chain." + documentFor (Namespace _ ["FoundIntersection"]) = Just $ mconcat + [ "We found an intersection between our chain fragment and the" + , " candidate's chain." + ] documentFor (Namespace _ ["Termination"]) = Just "The client has terminated." documentFor _ = Nothing @@ -481,10 +486,11 @@ instance MetaTrace (FetchDecision [Point header]) where [("Blockfetch.ConnectedPeers", "Number of connected peers")] metricsDocFor _ = [] - documentFor _ = Just - "Throughout the decision making process we accumulate reasons to decline\ - \ to fetch any blocks. This message carries the intermediate and final\ - \ results." + documentFor _ = Just $ mconcat + [ "Throughout the decision making process we accumulate reasons to decline" + , " to fetch any blocks. This message carries the intermediate and final" + , " results." + ] allNamespaces = [ Namespace [] ["Decline"] , Namespace [] ["Accept"]] @@ -564,30 +570,36 @@ instance MetaTrace (BlockFetch.TraceFetchClientState header) where severityFor (Namespace _ ["ClientTerminating"]) _ = Just Notice severityFor _ _ = Nothing - documentFor (Namespace _ ["AddedFetchRequest"]) = Just - "The block fetch decision thread has added a new fetch instruction\ - \ consisting of one or more individual request ranges." - documentFor (Namespace _ ["AcknowledgedFetchRequest"]) = Just - "Mark the point when the fetch client picks up the request added\ - \ by the block fetch decision thread. Note that this event can happen\ - \ fewer times than the 'AddedFetchRequest' due to fetch request merging." - documentFor (Namespace _ ["SendFetchRequest"]) = Just - "Mark the point when fetch request for a fragment is actually sent\ - \ over the wire." - documentFor (Namespace _ ["StartedFetchBatch"]) = Just - "Mark the start of receiving a streaming batch of blocks. This will\ - \ be followed by one or more 'CompletedBlockFetch' and a final\ - \ 'CompletedFetchBatch'" + documentFor (Namespace _ ["AddedFetchRequest"]) = Just $ mconcat + [ "The block fetch decision thread has added a new fetch instruction" + , " consisting of one or more individual request ranges." + ] + documentFor (Namespace _ ["AcknowledgedFetchRequest"]) = Just $ mconcat + [ "Mark the point when the fetch client picks up the request added" + , " by the block fetch decision thread. Note that this event can happen" + , " fewer times than the 'AddedFetchRequest' due to fetch request merging." + ] + documentFor (Namespace _ ["SendFetchRequest"]) = Just $ mconcat + [ "Mark the point when fetch request for a fragment is actually sent" + , " over the wire." + ] + documentFor (Namespace _ ["StartedFetchBatch"]) = Just $ mconcat + [ "Mark the start of receiving a streaming batch of blocks. This will" + , " be followed by one or more 'CompletedBlockFetch' and a final" + , " 'CompletedFetchBatch'" + ] documentFor (Namespace _ ["CompletedFetchBatch"]) = Just "Mark the successful end of receiving a streaming batch of blocks." documentFor (Namespace _ ["CompletedBlockFetch"]) = Just "" - documentFor (Namespace _ ["RejectedFetchBatch"]) = Just - "If the other peer rejects our request then we have this event\ - \ instead of 'StartedFetchBatch' and 'CompletedFetchBatch'." - documentFor (Namespace _ ["ClientTerminating"]) = Just - "The client is terminating. Log the number of outstanding\ - \ requests." + documentFor (Namespace _ ["RejectedFetchBatch"]) = Just $ mconcat + [ "If the other peer rejects our request then we have this event" + , " instead of 'StartedFetchBatch' and 'CompletedFetchBatch'." + ] + documentFor (Namespace _ ["ClientTerminating"]) = Just $ mconcat + [ "The client is terminating. Log the number of outstanding" + , " requests." + ] documentFor _ = Nothing allNamespaces = [ @@ -702,14 +714,16 @@ instance MetaTrace (TraceTxSubmissionInbound txid tx) where "Just processed transaction pass/fail breakdown." documentFor (Namespace _ ["Terminated"]) = Just "Server received 'MsgDone'." - documentFor (Namespace _ ["CanRequestMoreTxs"]) = Just - "There are no replies in flight, but we do know some more txs we\ - \ can ask for, so lets ask for them and more txids." - documentFor (Namespace _ ["CannotRequestMoreTxs"]) = Just - "There's no replies in flight, and we have no more txs we can\ - \ ask for so the only remaining thing to do is to ask for more\ - \ txids. Since this is the only thing to do now, we make this a\ - \ blocking call." + documentFor (Namespace _ ["CanRequestMoreTxs"]) = Just $ mconcat + [ "There are no replies in flight, but we do know some more txs we" + , " can ask for, so lets ask for them and more txids." + ] + documentFor (Namespace _ ["CannotRequestMoreTxs"]) = Just $ mconcat + [ "There's no replies in flight, and we have no more txs we can" + , " ask for so the only remaining thing to do is to ask for more" + , " txids. Since this is the only thing to do now, we make this a" + , " blocking call." + ] documentFor _ = Nothing allNamespaces = [ @@ -906,13 +920,15 @@ instance MetaTrace (TraceEventMempool blk) where documentFor (Namespace _ ["AddedTx"]) = Just "New, valid transaction that was added to the Mempool." - documentFor (Namespace _ ["RejectedTx"]) = Just - "New, invalid transaction thas was rejected and thus not added to\ - \ the Mempool." - documentFor (Namespace _ ["RemoveTxs"]) = Just - "Previously valid transactions that are no longer valid because of\ - \ changes in the ledger state. These transactions have been removed\ - \ from the Mempool." + documentFor (Namespace _ ["RejectedTx"]) = Just $ mconcat + [ "New, invalid transaction thas was rejected and thus not added to" + , " the Mempool." + ] + documentFor (Namespace _ ["RemoveTxs"]) = Just $ mconcat + [ "Previously valid transactions that are no longer valid because of" + , " changes in the ledger state. These transactions have been removed" + , " from the Mempool." + ] documentFor (Namespace _ ["ManuallyRemovedTxs"]) = Just "Transactions that have been manually removed from the Mempool." documentFor _ = Nothing @@ -987,9 +1003,10 @@ instance MetaTrace (ForgeTracerType blk) where metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace (TraceForgeEvent blk)) - documentFor (Namespace _ ["StartLeadershipCheckPlus"]) = Just - "We adopted the block we produced, we also trace the transactions\ - \ that were adopted." + documentFor (Namespace _ ["StartLeadershipCheckPlus"]) = Just $ mconcat + [ "We adopted the block we produced, we also trace the transactions" + , " that were adopted." + ] documentFor ns = documentFor (nsCast ns :: Namespace (TraceForgeEvent blk)) @@ -1387,125 +1404,140 @@ instance MetaTrace (TraceForgeEvent blk) where documentFor (Namespace _ ["StartLeadershipCheck"]) = Just "Start of the leadership check." - documentFor (Namespace _ ["SlotIsImmutable"]) = Just - "Leadership check failed: the tip of the ImmutableDB inhabits the\ - \ current slot\ - \ \ - \ This might happen in two cases.\ - \ \ - \ 1. the clock moved backwards, on restart we ignored everything from the\ - \ VolatileDB since it's all in the future, and now the tip of the\ - \ ImmutableDB points to a block produced in the same slot we're trying\ - \ to produce a block in\ - \ \ - \ 2. k = 0 and we already adopted a block from another leader of the same\ - \ slot.\ - \ \ - \ We record both the current slot number as well as the tip of the\ - \ ImmutableDB.\ - \ \ - \ See also " - documentFor (Namespace _ ["BlockFromFuture"]) = Just - "Leadership check failed: the current chain contains a block from a slot\ - \ /after/ the current slot\ - \ \ - \ This can only happen if the system is under heavy load.\ - \ \ - \ We record both the current slot number as well as the slot number of the\ - \ block at the tip of the chain.\ - \ \ - \ See also " - documentFor (Namespace _ ["BlockContext"]) = Just - "We found out to which block we are going to connect the block we are about\ - \ to forge.\ - \ \ - \ We record the current slot number, the block number of the block to\ - \ connect to and its point.\ - \ \ - \ Note that block number of the block we will try to forge is one more than\ - \ the recorded block number." - documentFor (Namespace _ ["NoLedgerState"]) = Just - "Leadership check failed: we were unable to get the ledger state for the\ - \ point of the block we want to connect to\ - \ \ - \ This can happen if after choosing which block to connect to the node\ - \ switched to a different fork. We expect this to happen only rather\ - \ rarely, so this certainly merits a warning; if it happens a lot, that\ - \ merits an investigation.\ - \ \ - \ We record both the current slot number as well as the point of the block\ - \ we attempt to connect the new block to (that we requested the ledger\ - \ state for)." - documentFor (Namespace _ ["LedgerState"]) = Just - "We obtained a ledger state for the point of the block we want to\ - \ connect to\ - \ \ - \ We record both the current slot number as well as the point of the block\ - \ we attempt to connect the new block to (that we requested the ledger\ - \ state for)." - documentFor (Namespace _ ["NoLedgerView"]) = Just - "Leadership check failed: we were unable to get the ledger view for the\ - \ current slot number\ - \ \ - \ This will only happen if there are many missing blocks between the tip of\ - \ our chain and the current slot.\ - \ \ - \ We record also the failure returned by 'forecastFor'." - documentFor (Namespace _ ["LedgerView"]) = Just - "We obtained a ledger view for the current slot number\ - \ \ - \ We record the current slot number." - documentFor (Namespace _ ["ForgeStateUpdateError"]) = Just - "Updating the forge state failed.\ - \ \ - \ For example, the KES key could not be evolved anymore.\ - \ \ - \ We record the error returned by 'updateForgeState'." - documentFor (Namespace _ ["NodeCannotForge"]) = Just - "We did the leadership check and concluded that we should lead and forge\ - \ a block, but cannot.\ - \ \ - \ This should only happen rarely and should be logged with warning severity.\ - \ \ - \ Records why we cannot forge a block." - documentFor (Namespace _ ["NodeNotLeader"]) = Just - "We did the leadership check and concluded we are not the leader\ - \ \ - \ We record the current slot number" - documentFor (Namespace _ ["NodeIsLeader"]) = Just - "We did the leadership check and concluded we /are/ the leader\ - \\n\ - \ The node will soon forge; it is about to read its transactions from the\ - \ Mempool. This will be followed by ForgedBlock." + documentFor (Namespace _ ["SlotIsImmutable"]) = Just $ mconcat + [ "Leadership check failed: the tip of the ImmutableDB inhabits the" + , " current slot" + , " " + , " This might happen in two cases." + , " " + , " 1. the clock moved backwards, on restart we ignored everything from the" + , " VolatileDB since it's all in the future, and now the tip of the" + , " ImmutableDB points to a block produced in the same slot we're trying" + , " to produce a block in" + , " " + , " 2. k = 0 and we already adopted a block from another leader of the same" + , " slot." + , " " + , " We record both the current slot number as well as the tip of the" + , " ImmutableDB." + , " " + , " See also " + ] + documentFor (Namespace _ ["BlockFromFuture"]) = Just $ mconcat + [ "Leadership check failed: the current chain contains a block from a slot" + , " /after/ the current slot" + , " " + , " This can only happen if the system is under heavy load." + , " " + , " We record both the current slot number as well as the slot number of the" + , " block at the tip of the chain." + , " " + , " See also " + ] + documentFor (Namespace _ ["BlockContext"]) = Just $ mconcat + [ "We found out to which block we are going to connect the block we are about" + , " to forge." + , " " + , " We record the current slot number, the block number of the block to" + , " connect to and its point." + , " " + , " Note that block number of the block we will try to forge is one more than" + , " the recorded block number." + ] + documentFor (Namespace _ ["NoLedgerState"]) = Just $ mconcat + [ "Leadership check failed: we were unable to get the ledger state for the" + , " point of the block we want to connect to" + , " " + , " This can happen if after choosing which block to connect to the node" + , " switched to a different fork. We expect this to happen only rather" + , " rarely, so this certainly merits a warning; if it happens a lot, that" + , " merits an investigation." + , " " + , " We record both the current slot number as well as the point of the block" + , " we attempt to connect the new block to (that we requested the ledger" + , " state for)." + ] + documentFor (Namespace _ ["LedgerState"]) = Just $ mconcat + [ "We obtained a ledger state for the point of the block we want to" + , " connect to" + , " " + , " We record both the current slot number as well as the point of the block" + , " we attempt to connect the new block to (that we requested the ledger" + , " state for)." + ] + documentFor (Namespace _ ["NoLedgerView"]) = Just $ mconcat + [ "Leadership check failed: we were unable to get the ledger view for the" + , " current slot number" + , " " + , " This will only happen if there are many missing blocks between the tip of" + , " our chain and the current slot." + , " " + , " We record also the failure returned by 'forecastFor'." + ] + documentFor (Namespace _ ["LedgerView"]) = Just $ mconcat + [ "We obtained a ledger view for the current slot number" + , " " + , " We record the current slot number." + ] + documentFor (Namespace _ ["ForgeStateUpdateError"]) = Just $ mconcat + [ "Updating the forge state failed." + , " " + , " For example, the KES key could not be evolved anymore." + , " " + , " We record the error returned by 'updateForgeState'." + ] + documentFor (Namespace _ ["NodeCannotForge"]) = Just $ mconcat + [ "We did the leadership check and concluded that we should lead and forge" + , " a block, but cannot." + , " " + , " This should only happen rarely and should be logged with warning severity." + , " " + , " Records why we cannot forge a block." + ] + documentFor (Namespace _ ["NodeNotLeader"]) = Just $ mconcat + [ "We did the leadership check and concluded we are not the leader" + , " " + , " We record the current slot number" + ] + documentFor (Namespace _ ["NodeIsLeader"]) = Just $ mconcat + [ "We did the leadership check and concluded we /are/ the leader" + , "\n" + , " The node will soon forge; it is about to read its transactions from the" + , " Mempool. This will be followed by ForgedBlock." + ] documentFor (Namespace _ ["ForgeTickedLedgerState"]) = Just "" documentFor (Namespace _ ["ForgingMempoolSnapshot"]) = Just "" - documentFor (Namespace _ ["ForgedBlock"]) = Just - "We forged a block.\ - \\n\ - \ We record the current slot number, the point of the predecessor, the block\ - \ itself, and the total size of the mempool snapshot at the time we produced\ - \ the block (which may be significantly larger than the block, due to\ - \ maximum block size)\ - \\n\ - \ This will be followed by one of three messages:\ - \\n\ - \ * AdoptedBlock (normally)\ - \\n\ - \ * DidntAdoptBlock (rarely)\ - \\n\ - \ * ForgedInvalidBlock (hopefully never, this would indicate a bug)" - documentFor (Namespace _ ["DidntAdoptBlock"]) = Just - "We did not adopt the block we produced, but the block was valid. We\ - \ must have adopted a block that another leader of the same slot produced\ - \ before we got the chance of adopting our own block. This is very rare,\ - \ this warrants a warning." - documentFor (Namespace _ ["ForgedInvalidBlock"]) = Just - "We forged a block that is invalid according to the ledger in the\ - \ ChainDB. This means there is an inconsistency between the mempool\ - \ validation and the ledger validation. This is a serious error!" - documentFor (Namespace _ ["AdoptedBlock"]) = Just - "We adopted the block we produced, we also trace the transactions\ - \ that were adopted." + documentFor (Namespace _ ["ForgedBlock"]) = Just $ mconcat + [ "We forged a block." + , "\n" + , " We record the current slot number, the point of the predecessor, the block" + , " itself, and the total size of the mempool snapshot at the time we produced" + , " the block (which may be significantly larger than the block, due to" + , " maximum block size)" + , "\n" + , " This will be followed by one of three messages:" + , "\n" + , " * AdoptedBlock (normally)" + , "\n" + , " * DidntAdoptBlock (rarely)" + , "\n" + , " * ForgedInvalidBlock (hopefully never, this would indicate a bug)" + ] + documentFor (Namespace _ ["DidntAdoptBlock"]) = Just $ mconcat + [ "We did not adopt the block we produced, but the block was valid. We" + , " must have adopted a block that another leader of the same slot produced" + , " before we got the chance of adopting our own block. This is very rare," + , " this warrants a warning." + ] + documentFor (Namespace _ ["ForgedInvalidBlock"]) = Just $ mconcat + [ "We forged a block that is invalid according to the ledger in the" + , " ChainDB. This means there is an inconsistency between the mempool" + , " validation and the ledger validation. This is a serious error!" + ] + documentFor (Namespace _ ["AdoptedBlock"]) = Just $ mconcat + [ "We adopted the block we produced, we also trace the transactions" + , " that were adopted." + ] documentFor _ = Nothing allNamespaces = @@ -1573,36 +1605,39 @@ instance MetaTrace (TraceBlockchainTimeEvent t) where severityFor (Namespace _ ["SystemClockMovedBack"]) _ = Just Warning severityFor _ _ = Nothing - documentFor (Namespace _ ["StartTimeInTheFuture"]) = Just - "The start time of the blockchain time is in the future\ - \\n\ - \ We have to block (for 'NominalDiffTime') until that time comes." - documentFor (Namespace _ ["CurrentSlotUnknown"]) = Just - "Current slot is not yet known\ - \\n\ - \ This happens when the tip of our current chain is so far in the past that\ - \ we cannot translate the current wallclock to a slot number, typically\ - \ during syncing. Until the current slot number is known, we cannot\ - \ produce blocks. Seeing this message during syncing therefore is\ - \ normal and to be expected.\ - \\n\ - \ We record the current time (the time we tried to translate to a 'SlotNo')\ - \ as well as the 'PastHorizonException', which provides detail on the\ - \ bounds between which we /can/ do conversions. The distance between the\ - \ current time and the upper bound should rapidly decrease with consecutive\ - \ 'CurrentSlotUnknown' messages during syncing." - documentFor (Namespace _ ["SystemClockMovedBack"]) = Just - "The system clock moved back an acceptable time span, e.g., because of\ - \ an NTP sync.\ - \\n\ - \ The system clock moved back such that the new current slot would be\ - \ smaller than the previous one. If this is within the configured limit, we\ - \ trace this warning but *do not change the current slot*. The current slot\ - \ never decreases, but the current slot may stay the same longer than\ - \ expected.\ - \\n\ - \ When the system clock moved back more than the configured limit, we shut\ - \ down with a fatal exception." + documentFor (Namespace _ ["StartTimeInTheFuture"]) = Just $ mconcat + [ "The start time of the blockchain time is in the future" + , "\n" + , " We have to block (for 'NominalDiffTime') until that time comes." + ] + documentFor (Namespace _ ["CurrentSlotUnknown"]) = Just $ mconcat + [ "Current slot is not yet known" + , "\n" + , " This happens when the tip of our current chain is so far in the past that" + , " we cannot translate the current wallclock to a slot number, typically" + , " during syncing. Until the current slot number is known, we cannot" + , " produce blocks. Seeing this message during syncing therefore is" + , " normal and to be expected." + , "\n" + , " We record the current time (the time we tried to translate to a 'SlotNo')" + , " as well as the 'PastHorizonException', which provides detail on the" + , " bounds between which we /can/ do conversions. The distance between the" + , " current time and the upper bound should rapidly decrease with consecutive" + , " 'CurrentSlotUnknown' messages during syncing." + ] + documentFor (Namespace _ ["SystemClockMovedBack"]) = Just $ mconcat + [ "The system clock moved back an acceptable time span, e.g., because of" + , " an NTP sync." + , "\n" + , " The system clock moved back such that the new current slot would be" + , " smaller than the previous one. If this is within the configured limit, we" + , " trace this warning but *do not change the current slot*. The current slot" + , " never decreases, but the current slot may stay the same longer than" + , " expected." + , "\n" + , " When the system clock moved back more than the configured limit, we shut" + , " down with a fatal exception." + ] documentFor _ = Nothing allNamespaces = diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs index e7aadec69dd..58740fc56bf 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -258,17 +258,20 @@ instance MetaTrace (AnyMessageAndAgency (HS.Handshake nt term)) where severityFor (Namespace _ ["Refuse"]) _ = Just Info severityFor _ _ = Nothing - documentFor (Namespace _ ["ProposeVersions"]) = Just - "Propose versions together with version parameters. It must be\ - \ encoded to a sorted list.." - documentFor (Namespace _ ["ReplyVersions"]) = Just - "`MsgReplyVersions` received as a response to 'MsgProposeVersions'. It\ - \ is not supported to explicitly send this message. It can only be\ - \ received as a copy of 'MsgProposeVersions' in a simultaneous open\ - \ scenario." - documentFor (Namespace _ ["AcceptVersion"]) = Just - "The remote end decides which version to use and sends chosen version.\ - \The server is allowed to modify version parameters." + documentFor (Namespace _ ["ProposeVersions"]) = Just $ mconcat + [ "Propose versions together with version parameters. It must be" + , " encoded to a sorted list.." + ] + documentFor (Namespace _ ["ReplyVersions"]) = Just $ mconcat + [ "`MsgReplyVersions` received as a response to 'MsgProposeVersions'. It" + , " is not supported to explicitly send this message. It can only be" + , " received as a copy of 'MsgProposeVersions' in a simultaneous open" + , " scenario." + ] + documentFor (Namespace _ ["AcceptVersion"]) = Just $ mconcat + [ "The remote end decides which version to use and sends chosen version." + , "The server is allowed to modify version parameters." + ] documentFor (Namespace _ ["Refuse"]) = Just "It refuses to run any version." documentFor _ = Nothing @@ -548,9 +551,10 @@ instance MetaTrace TraceLedgerPeers where "Trace for a peer picked with accumulated and relative stake of its pool." documentFor (Namespace _ ["PickedPeers"]) = Just "Trace for the number of peers we wanted to pick and the list of peers picked." - documentFor (Namespace _ ["FetchingNewLedgerState"]) = Just - "Trace for fetching a new list of peers from the ledger. Int is the number of peers\ - \ returned." + documentFor (Namespace _ ["FetchingNewLedgerState"]) = Just $ mconcat + [ "Trace for fetching a new list of peers from the ledger. Int is the number of peers" + , " returned." + ] documentFor (Namespace _ ["DisabledLedgerPeers"]) = Just "Trace for when getting peers from the ledger is disabled, that is DontUseLedger." documentFor (Namespace _ ["TraceUseLedgerAfter"]) = Just diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index a4a2a18bc94..5e6bccc2cc1 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs @@ -159,42 +159,50 @@ instance MetaTrace (AnyMessageAndAgency (ChainSync blk pt tip)) where severityFor (Namespace _ ["Done"]) _ = Just Info severityFor _ _ = Nothing - documentFor (Namespace _ ["RequestNext"]) = Just - "Request the next update from the producer. The response can be a roll \ - \forward, a roll back or wait." - documentFor (Namespace _ ["AwaitReply"]) = Just - "Acknowledge the request but require the consumer to wait for the next \ - \update. This means that the consumer is synced with the producer, and \ - \the producer is waiting for its own chain state to change." - documentFor (Namespace _ ["RollForward"]) = Just - "Tell the consumer to extend their chain with the given header. \ - \\n \ - \The message also tells the consumer about the head point of the producer." - documentFor (Namespace _ ["RollBackward"]) = Just - "Tell the consumer to roll back to a given point on their chain. \ - \\n \ - \The message also tells the consumer about the head point of the producer." - documentFor (Namespace _ ["FindIntersect"]) = Just - "Ask the producer to try to find an improved intersection point between \ - \the consumer and producer's chains. The consumer sends a sequence of \ - \points and it is up to the producer to find the first intersection point \ - \on its chain and send it back to the consumer." - documentFor (Namespace _ ["IntersectFound"]) = Just - "The reply to the consumer about an intersection found. \ - \The consumer can decide weather to send more points. \ - \\n \ - \The message also tells the consumer about the head point of the producer." - documentFor (Namespace _ ["IntersectNotFound"]) = Just - "The reply to the consumer that no intersection was found: none of the \ - \points the consumer supplied are on the producer chain. \ - \\n \ - \The message also tells the consumer about the head point of the producer." - documentFor (Namespace _ ["Done"]) = Just - "We have to explain to the framework what our states mean, in terms of \ - \which party has agency in each state. \ - \\n \ - \Idle states are where it is for the client to send a message, \ - \busy states are where the server is expected to send a reply." + documentFor (Namespace _ ["RequestNext"]) = Just $ mconcat + [ "Request the next update from the producer. The response can be a roll " + , "forward, a roll back or wait." + ] + documentFor (Namespace _ ["AwaitReply"]) = Just $ mconcat + [ "Acknowledge the request but require the consumer to wait for the next " + , "update. This means that the consumer is synced with the producer, and " + , "the producer is waiting for its own chain state to change." + ] + documentFor (Namespace _ ["RollForward"]) = Just $ mconcat + [ "Tell the consumer to extend their chain with the given header. " + , "\n " + , "The message also tells the consumer about the head point of the producer." + ] + documentFor (Namespace _ ["RollBackward"]) = Just $ mconcat + [ "Tell the consumer to roll back to a given point on their chain. " + , "\n " + , "The message also tells the consumer about the head point of the producer." + ] + documentFor (Namespace _ ["FindIntersect"]) = Just $ mconcat + [ "Ask the producer to try to find an improved intersection point between " + , "the consumer and producer's chains. The consumer sends a sequence of " + , "points and it is up to the producer to find the first intersection point " + , "on its chain and send it back to the consumer." + ] + documentFor (Namespace _ ["IntersectFound"]) = Just $ mconcat + [ "The reply to the consumer about an intersection found. " + , "The consumer can decide weather to send more points. " + , "\n " + , "The message also tells the consumer about the head point of the producer." + ] + documentFor (Namespace _ ["IntersectNotFound"]) = Just $ mconcat + [ "The reply to the consumer that no intersection was found: none of the " + , "points the consumer supplied are on the producer chain. " + , "\n " + , "The message also tells the consumer about the head point of the producer." + ] + documentFor (Namespace _ ["Done"]) = Just $ mconcat + [ "We have to explain to the framework what our states mean, in terms of " + , "which party has agency in each state. " + , "\n " + , "Idle states are where it is for the client to send a message, " + , "busy states are where the server is expected to send a reply." + ] documentFor _ = Nothing allNamespaces = [ @@ -456,38 +464,42 @@ instance MetaTrace (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk)) severityFor (Namespace _ ["Done"]) _ = Just Info severityFor _ _ = Nothing - documentFor (Namespace _ ["Acquire"]) = Just - "The client requests that the state as of a particular recent point on \ - \the server's chain (within K of the tip) be made available to query, \ - \and waits for confirmation or failure. \ - \\n \ - \From 'NodeToClient_V8' onwards if the point is not specified, current tip \ - \will be acquired. For previous versions of the protocol 'point' must be \ - \given." + documentFor (Namespace _ ["Acquire"]) = Just $ mconcat + [ "The client requests that the state as of a particular recent point on " + , "the server's chain (within K of the tip) be made available to query, " + , "and waits for confirmation or failure. " + , "\n " + , "From 'NodeToClient_V8' onwards if the point is not specified, current tip " + , "will be acquired. For previous versions of the protocol 'point' must be " + , "given." + ] documentFor (Namespace _ ["Acquired"]) = Just "The server can confirm that it has the state at the requested point." - documentFor (Namespace _ ["Failure"]) = Just - "The server can report that it cannot obtain the state for the \ - \requested point." + documentFor (Namespace _ ["Failure"]) = Just $ mconcat + [ "The server can report that it cannot obtain the state for the " + , "requested point." + ] documentFor (Namespace _ ["Query"]) = Just "The client can perform queries on the current acquired state." documentFor (Namespace _ ["Result"]) = Just "The server must reply with the queries." - documentFor (Namespace _ ["Release"]) = Just - "The client can instruct the server to release the state. This lets \ - \the server free resources." - documentFor (Namespace _ ["ReAcquire"]) = Just - "This is like 'MsgAcquire' but for when the client already has a \ - \state. By moving to another state directly without a 'MsgRelease' it \ - \enables optimisations on the server side (e.g. moving to the state for \ - \the immediate next block). \ - \\n \ - \Note that failure to re-acquire is equivalent to 'MsgRelease', \ - \rather than keeping the exiting acquired state. \ - \\n \ - \From 'NodeToClient_V8' onwards if the point is not specified, current tip \ - \will be acquired. For previous versions of the protocol 'point' must be \ - \given." + documentFor (Namespace _ ["Release"]) = Just $ mconcat + [ "The client can instruct the server to release the state. This lets " + , "the server free resources." + ] + documentFor (Namespace _ ["ReAcquire"]) = Just $ mconcat + [ "This is like 'MsgAcquire' but for when the client already has a " + , "state. By moving to another state directly without a 'MsgRelease' it " + , "enables optimisations on the server side (e.g. moving to the state for " + , "the immediate next block). " + , "\n " + , "Note that failure to re-acquire is equivalent to 'MsgRelease', " + , "rather than keeping the exiting acquired state. " + , "\n " + , "From 'NodeToClient_V8' onwards if the point is not specified, current tip " + , "will be acquired. For previous versions of the protocol 'point' must be " + , "given." + ] documentFor (Namespace _ ["Done"]) = Just "The client can terminate the protocol." documentFor _ = Nothing diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index ae975bf5107..610c0d697de 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -244,86 +244,91 @@ instance MetaTrace (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where documentFor (Namespace _ ["MsgInit"]) = Just "Client side hello message." - documentFor (Namespace _ ["RequestTxIds"]) = Just - "Request a non-empty list of transaction identifiers from the client, \ - \and confirm a number of outstanding transaction identifiers. \ - \\n \ - \With 'TokBlocking' this is a a blocking operation: the response will \ - \always have at least one transaction identifier, and it does not expect \ - \a prompt response: there is no timeout. This covers the case when there \ - \is nothing else to do but wait. For example this covers leaf nodes that \ - \rarely, if ever, create and submit a transaction. \ - \\n \ - \With 'TokNonBlocking' this is a non-blocking operation: the response \ - \may be an empty list and this does expect a prompt response. This \ - \covers high throughput use cases where we wish to pipeline, by \ - \interleaving requests for additional transaction identifiers with \ - \requests for transactions, which requires these requests not block. \ - \\n \ - \The request gives the maximum number of transaction identifiers that \ - \can be accepted in the response. This must be greater than zero in the \ - \'TokBlocking' case. In the 'TokNonBlocking' case either the numbers \ - \acknowledged or the number requested must be non-zero. In either case, \ - \the number requested must not put the total outstanding over the fixed \ - \protocol limit. \ - \\n\ - \The request also gives the number of outstanding transaction \ - \identifiers that can now be acknowledged. The actual transactions \ - \to acknowledge are known to the peer based on the FIFO order in which \ - \they were provided. \ - \\n \ - \There is no choice about when to use the blocking case versus the \ - \non-blocking case, it depends on whether there are any remaining \ - \unacknowledged transactions (after taking into account the ones \ - \acknowledged in this message): \ - \\n \ - \* The blocking case must be used when there are zero remaining \ - \ unacknowledged transactions. \ - \\n \ - \* The non-blocking case must be used when there are non-zero remaining \ - \ unacknowledged transactions." - documentFor (Namespace _ ["ReplyTxIds"]) = Just - "Reply with a list of transaction identifiers for available \ - \transactions, along with the size of each transaction. \ - \\n \ - \The list must not be longer than the maximum number requested. \ - \\n \ - \In the 'StTxIds' 'StBlocking' state the list must be non-empty while \ - \in the 'StTxIds' 'StNonBlocking' state the list may be empty. \ - \\n \ - \These transactions are added to the notional FIFO of outstanding \ - \transaction identifiers for the protocol. \ - \\n \ - \The order in which these transaction identifiers are returned must be \ - \the order in which they are submitted to the mempool, to preserve \ - \dependent transactions." - documentFor (Namespace _ ["RequestTxs"]) = Just - "Request one or more transactions corresponding to the given \ - \transaction identifiers. \ - \\n \ - \While it is the responsibility of the replying peer to keep within \ - \pipelining in-flight limits, the sender must also cooperate by keeping \ - \the total requested across all in-flight requests within the limits. \ - \\n\ - \It is an error to ask for transaction identifiers that were not \ - \previously announced (via 'MsgReplyTxIds'). \ - \\n\ - \It is an error to ask for transaction identifiers that are not \ - \outstanding or that were already asked for." - documentFor (Namespace _ ["ReplyTxs"]) = Just - "Reply with the requested transactions, or implicitly discard.\ - \\n\ - \Transactions can become invalid between the time the transaction \ - \identifier was sent and the transaction being requested. Invalid \ - \(including committed) transactions do not need to be sent.\ - \\n\ - \Any transaction identifiers requested but not provided in this reply \ - \should be considered as if this peer had never announced them. (Note \ - \that this is no guarantee that the transaction is invalid, it may still \ - \be valid and available from another peer)." - documentFor (Namespace _ ["Done"]) = Just - "Termination message, initiated by the client when the server is \ - \making a blocking call for more transaction identifiers." + documentFor (Namespace _ ["RequestTxIds"]) = Just $ mconcat + [ "Request a non-empty list of transaction identifiers from the client, " + , "and confirm a number of outstanding transaction identifiers. " + , "\n " + , "With 'TokBlocking' this is a a blocking operation: the response will " + , "always have at least one transaction identifier, and it does not expect " + , "a prompt response: there is no timeout. This covers the case when there " + , "is nothing else to do but wait. For example this covers leaf nodes that " + , "rarely, if ever, create and submit a transaction. " + , "\n " + , "With 'TokNonBlocking' this is a non-blocking operation: the response " + , "may be an empty list and this does expect a prompt response. This " + , "covers high throughput use cases where we wish to pipeline, by " + , "interleaving requests for additional transaction identifiers with " + , "requests for transactions, which requires these requests not block. " + , "\n " + , "The request gives the maximum number of transaction identifiers that " + , "can be accepted in the response. This must be greater than zero in the " + , "'TokBlocking' case. In the 'TokNonBlocking' case either the numbers " + , "acknowledged or the number requested must be non-zero. In either case, " + , "the number requested must not put the total outstanding over the fixed " + , "protocol limit. " + , "\n" + , "The request also gives the number of outstanding transaction " + , "identifiers that can now be acknowledged. The actual transactions " + , "to acknowledge are known to the peer based on the FIFO order in which " + , "they were provided. " + , "\n " + , "There is no choice about when to use the blocking case versus the " + , "non-blocking case, it depends on whether there are any remaining " + , "unacknowledged transactions (after taking into account the ones " + , "acknowledged in this message): " + , "\n " + , "* The blocking case must be used when there are zero remaining " + , " unacknowledged transactions. " + , "\n " + , "* The non-blocking case must be used when there are non-zero remaining " + , " unacknowledged transactions." + ] + documentFor (Namespace _ ["ReplyTxIds"]) = Just $ mconcat + [ "Reply with a list of transaction identifiers for available " + , "transactions, along with the size of each transaction. " + , "\n " + , "The list must not be longer than the maximum number requested. " + , "\n " + , "In the 'StTxIds' 'StBlocking' state the list must be non-empty while " + , "in the 'StTxIds' 'StNonBlocking' state the list may be empty. " + , "\n " + , "These transactions are added to the notional FIFO of outstanding " + , "transaction identifiers for the protocol. " + , "\n " + , "The order in which these transaction identifiers are returned must be " + , "the order in which they are submitted to the mempool, to preserve " + , "dependent transactions." + ] + documentFor (Namespace _ ["RequestTxs"]) = Just $ mconcat + [ "Request one or more transactions corresponding to the given " + , "transaction identifiers. " + , "\n " + , "While it is the responsibility of the replying peer to keep within " + , "pipelining in-flight limits, the sender must also cooperate by keeping " + , "the total requested across all in-flight requests within the limits. " + , "\n" + , "It is an error to ask for transaction identifiers that were not " + , "previously announced (via 'MsgReplyTxIds'). " + , "\n" + , "It is an error to ask for transaction identifiers that are not " + , "outstanding or that were already asked for." + ] + documentFor (Namespace _ ["ReplyTxs"]) = Just $ mconcat + [ "Reply with the requested transactions, or implicitly discard." + , "\n" + , "Transactions can become invalid between the time the transaction " + , "identifier was sent and the transaction being requested. Invalid " + , "(including committed) transactions do not need to be sent." + , "\n" + , "Any transaction identifiers requested but not provided in this reply " + , "should be considered as if this peer had never announced them. (Note " + , "that this is no guarantee that the transaction is invalid, it may still " + , "be valid and available from another peer)." + ] + documentFor (Namespace _ ["Done"]) = Just $ mconcat + [ "Termination message, initiated by the client when the server is " + , "making a blocking call for more transaction identifiers." + ] documentFor _ = Nothing allNamespaces = [ diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NonP2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NonP2P.hs index c60d9f138b1..fa97224d497 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NonP2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NonP2P.hs @@ -203,9 +203,10 @@ instance MetaTrace (SubscriptionTrace adr) where "Waiting delay time before attempting a new connection." documentFor (Namespace _ ["Start"]) = Just "Starting Subscription Worker with a valency." - documentFor (Namespace _ ["Restart"]) = Just - "Restarting Subscription after duration with desired valency and\ - \ current valency." + documentFor (Namespace _ ["Restart"]) = Just $ mconcat + [ "Restarting Subscription after duration with desired valency and" + , " current valency." + ] documentFor (Namespace _ ["ConnectionExist"]) = Just "Connection exists to destination." documentFor (Namespace _ ["UnsupportedRemoteAddr"]) = Just diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index e882bc65125..8b77b6d3948 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -446,9 +446,10 @@ instance MetaTrace (TracePeerSelection SockAddr) where documentFor (Namespace [] ["PublicRootsRequest"]) = Just "" documentFor (Namespace [] ["PublicRootsResults"]) = Just "" documentFor (Namespace [] ["PublicRootsFailure"]) = Just "" - documentFor (Namespace [] ["GossipRequests"]) = Just - "target known peers, actual known peers, peers available for gossip,\ - \ peers selected for gossip" + documentFor (Namespace [] ["GossipRequests"]) = Just $ mconcat + [ "target known peers, actual known peers, peers available for gossip," + , " peers selected for gossip" + ] documentFor (Namespace [] ["GossipResults"]) = Just "" documentFor (Namespace [] ["ForgetColdPeers"]) = Just "target known peers, actual known peers, selected peers" @@ -456,9 +457,10 @@ instance MetaTrace (TracePeerSelection SockAddr) where "target established, actual established, selected peers" documentFor (Namespace [] ["PromoteColdLocalPeers"]) = Just "target local established, actual local established, selected peers" - documentFor (Namespace [] ["PromoteColdFailed"]) = Just - "target established, actual established, peer, delay until next\ - \ promotion, reason" + documentFor (Namespace [] ["PromoteColdFailed"]) = Just $ mconcat + [ "target established, actual established, peer, delay until next" + , " promotion, reason" + ] documentFor (Namespace [] ["PromoteColdDone"]) = Just "target active, actual active, selected peers" documentFor (Namespace [] ["PromoteWarmPeers"]) = Just @@ -1242,12 +1244,14 @@ instance MetaTrace (InboundGovernorTrace addr) where documentFor (Namespace _ ["ResponderTerminated"]) = Just "" documentFor (Namespace _ ["PromotedToWarmRemote"]) = Just "" documentFor (Namespace _ ["PromotedToHotRemote"]) = Just "" - documentFor (Namespace _ ["DemotedToColdRemote"]) = Just - "All mini-protocols terminated. The boolean is true if this connection\ - \ was not used by p2p-governor, and thus the connection will be terminated." - documentFor (Namespace _ ["DemotedToWarmRemote"]) = Just - "All mini-protocols terminated. The boolean is true if this connection\ - \ was not used by p2p-governor, and thus the connection will be terminated." + documentFor (Namespace _ ["DemotedToColdRemote"]) = Just $ mconcat + [ "All mini-protocols terminated. The boolean is true if this connection" + , " was not used by p2p-governor, and thus the connection will be terminated." + ] + documentFor (Namespace _ ["DemotedToWarmRemote"]) = Just $ mconcat + [ "All mini-protocols terminated. The boolean is true if this connection" + , " was not used by p2p-governor, and thus the connection will be terminated." + ] documentFor (Namespace _ ["WaitIdleRemote"]) = Just "" documentFor (Namespace _ ["MuxCleanExit"]) = Just "" documentFor (Namespace _ ["MuxErrored"]) = Just "" @@ -1361,12 +1365,14 @@ instance MetaTrace NtN.AcceptConnectionsPolicyTrace where severityFor (Namespace _ ["ConnectionLimitResume"]) _ = Just Info severityFor _ _ = Nothing - documentFor (Namespace _ ["ConnectionRateLimiting"]) = Just - "Rate limiting accepting connections,\ - \ delaying next accept for given time, currently serving n connections." - documentFor (Namespace _ ["ConnectionHardLimit"]) = Just - "Hard rate limit reached,\ - \ waiting until the number of connections drops below n." + documentFor (Namespace _ ["ConnectionRateLimiting"]) = Just $ mconcat + [ "Rate limiting accepting connections," + , " delaying next accept for given time, currently serving n connections." + ] + documentFor (Namespace _ ["ConnectionHardLimit"]) = Just $ mconcat + [ "Hard rate limit reached," + , " waiting until the number of connections drops below n." + ] documentFor (Namespace _ ["ConnectionLimitResume"]) = Just "" documentFor _ = Nothing diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index c469b381820..76f807499ac 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -311,31 +311,35 @@ instance MetaTrace (StartupTrace blk) where "" documentFor (Namespace [] ["WarningDevelopmentNetworkProtocols"]) = Just "" - documentFor (Namespace [] ["Common"]) = Just - "_biConfigPath_: is the path to the config in use. \ - \\n_biProtocol_: is the name of the protocol, e.g. \"Byron\", \"Shelley\" \ - \or \"Byron; Shelley\". \ - \\n_biVersion_: is the version of the node software running. \ - \\n_biCommit_: is the commit revision of the software running. \ - \\n_biNodeStartTime_: gives the time this node was started." - documentFor (Namespace [] ["ShelleyBased"]) = Just - "bisEra is the current era, e.g. \"Shelley\", \"Allegra\", \"Mary\" \ - \or \"Alonzo\". \ - \\n_bisSystemStartTime_: TODO JNF \ - \\n_bisSlotLength_: gives the length of a slot as time interval. \ - \\n_bisEpochLength_: gives the number of slots which forms an epoch. \ - \\n_bisSlotsPerKESPeriod_: gives the slots per KES period." - documentFor (Namespace [] ["Byron"]) = Just - "_bibSystemStartTime_: \ - \\n_bibSlotLength_: gives the length of a slot as time interval. \ - \\n_bibEpochLength_: gives the number of slots which forms an epoch." - documentFor (Namespace [] ["Network"]) = Just - "_niAddresses_: IPv4 or IPv6 socket ready to accept connections\ - \or diffusion addresses. \ - \\n_niDiffusionMode_: shows if the node runs only initiator or both\ - \initiator or responder node. \ - \\n_niDnsProducers_: shows the list of domain names to subscribe to. \ - \\n_niIpProducers_: shows the list of ip subscription addresses." + documentFor (Namespace [] ["Common"]) = Just $ mconcat + [ "_biConfigPath_: is the path to the config in use. " + , "\n_biProtocol_: is the name of the protocol, e.g. \"Byron\", \"Shelley\" " + , "or \"Byron; Shelley\". " + , "\n_biVersion_: is the version of the node software running. " + , "\n_biCommit_: is the commit revision of the software running. " + , "\n_biNodeStartTime_: gives the time this node was started." + ] + documentFor (Namespace [] ["ShelleyBased"]) = Just $ mconcat + [ "bisEra is the current era, e.g. \"Shelley\", \"Allegra\", \"Mary\" " + , "or \"Alonzo\". " + , "\n_bisSystemStartTime_: TODO JNF " + , "\n_bisSlotLength_: gives the length of a slot as time interval. " + , "\n_bisEpochLength_: gives the number of slots which forms an epoch. " + , "\n_bisSlotsPerKESPeriod_: gives the slots per KES period." + ] + documentFor (Namespace [] ["Byron"]) = Just $ mconcat + [ "_bibSystemStartTime_: " + , "\n_bibSlotLength_: gives the length of a slot as time interval. " + , "\n_bibEpochLength_: gives the number of slots which forms an epoch." + ] + documentFor (Namespace [] ["Network"]) = Just $ mconcat + [ "_niAddresses_: IPv4 or IPv6 socket ready to accept connections" + , "or diffusion addresses. " + , "\n_niDiffusionMode_: shows if the node runs only initiator or both" + , "initiator or responder node. " + , "\n_niDnsProducers_: shows the list of domain names to subscribe to. " + , "\n_niIpProducers_: shows the list of ip subscription addresses." + ] documentFor _ns = Nothing allNamespaces = diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index bafe808449a..ef8cc3ff1c3 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -618,27 +618,36 @@ instance ( ConvertRawHash blk ChainDB.ForkTooOld streamFrom -> "The requested range forks off too far in the past" <> showT streamFrom - ChainDB.BlockMissingFromVolatileDB realPt -> - "This block is no longer in the VolatileDB because it has been garbage\ - \ collected. It might now be in the ImmutableDB if it was part of the\ - \ current chain. Block: " <> renderRealPoint realPt - ChainDB.StreamFromImmutableDB sFrom sTo -> - "Stream only from the ImmutableDB. StreamFrom:" <> showT sFrom <> - " StreamTo: " <> showT sTo - ChainDB.StreamFromBoth sFrom sTo pts -> - "Stream from both the VolatileDB and the ImmutableDB." - <> " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo - <> " Points: " <> showT (map renderRealPoint pts) - ChainDB.StreamFromVolatileDB sFrom sTo pts -> - "Stream only from the VolatileDB." - <> " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo - <> " Points: " <> showT (map renderRealPoint pts) - ChainDB.BlockWasCopiedToImmutableDB pt -> - "This block has been garbage collected from the VolatileDB is now\ - \ found and streamed from the ImmutableDB. Block: " <> renderRealPoint pt - ChainDB.BlockGCedFromVolatileDB pt -> - "This block no longer in the VolatileDB and isn't in the ImmutableDB\ - \ either; it wasn't part of the current chain. Block: " <> renderRealPoint pt + ChainDB.BlockMissingFromVolatileDB realPt -> mconcat + [ "This block is no longer in the VolatileDB because it has been garbage" + , " collected. It might now be in the ImmutableDB if it was part of the" + , " current chain. Block: " + , renderRealPoint realPt + ] + ChainDB.StreamFromImmutableDB sFrom sTo -> mconcat + [ "Stream only from the ImmutableDB. StreamFrom:" + , showT sFrom + , " StreamTo: " + , showT sTo + ] + ChainDB.StreamFromBoth sFrom sTo pts -> mconcat + [ "Stream from both the VolatileDB and the ImmutableDB." + , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + , " Points: " <> showT (map renderRealPoint pts) + ] + ChainDB.StreamFromVolatileDB sFrom sTo pts -> mconcat + [ "Stream only from the VolatileDB." + , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + , " Points: " <> showT (map renderRealPoint pts) + ] + ChainDB.BlockWasCopiedToImmutableDB pt -> mconcat + [ "This block has been garbage collected from the VolatileDB is now" + , " found and streamed from the ImmutableDB. Block: " <> renderRealPoint pt + ] + ChainDB.BlockGCedFromVolatileDB pt -> mconcat + [ "This block no longer in the VolatileDB and isn't in the ImmutableDB" + , " either; it wasn't part of the current chain. Block: " <> renderRealPoint pt + ] ChainDB.SwitchBackToVolatileDB -> "SwitchBackToVolatileDB" ChainDB.TraceImmutableDBEvent ev -> case ev of ImmDB.NoValidLastLocation -> diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index 21ee18cafd8..97e4cd4a5c4 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -204,11 +204,13 @@ instance ToObject ChainPredicateFailure where , "currentProtocol" .= currentPtcl , "supportedProtocol" .= supportedPtcl ] where - explanation = "A scheduled major protocol version change (hard fork) \ - \has taken place on the chain, but this node does not \ - \understand the new major protocol version. This node \ - \must be upgraded before it can continue with the new \ - \protocol version." + explanation = mconcat + [ "A scheduled major protocol version change (hard fork) " + , "has taken place on the chain, but this node does not " + , "understand the new major protocol version. This node " + , "must be upgraded before it can continue with the new " + , "protocol version." + ] instance ToObject (PrtlSeqFailure crypto) where toObject _verb (WrongSlotIntervalPrtclSeq (SlotNo lastSlot) (SlotNo currSlot)) = @@ -396,10 +398,14 @@ instance ( ShelleyBasedEra era -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO toObject _verb (OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String "The output is smaller than the allow minimum \ - \UTxO value defined in the protocol parameters" - ] + , "outputs" .= badOutputs + , "error" .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] toObject _verb (OutputBootAddrAttrsTooBig badOutputs) = mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" , "outputs" .= badOutputs @@ -483,10 +489,14 @@ instance ( ShelleyBasedEra era -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO toObject _verb (MA.OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String "The output is smaller than the allow minimum \ - \UTxO value defined in the protocol parameters" - ] + , "outputs" .= badOutputs + , "error" .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] toObject verb (MA.UpdateFailure f) = toObject verb f toObject _verb (MA.OutputBootAddrAttrsTooBig badOutputs) = mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" @@ -789,26 +799,38 @@ instance Core.Crypto crypto => ToObject (OverlayPredicateFailure crypto) where instance ToObject (OcertPredicateFailure crypto) where toObject _verb (KESBeforeStartOCERT (KESPeriod oCertstart) (KESPeriod current)) = mconcat [ "kind" .= String "KESBeforeStartOCERT" - , "opCertKESStartPeriod" .= String (textShow oCertstart) - , "currentKESPeriod" .= String (textShow current) - , "error" .= String "Your operational certificate's KES start period \ - \is before the KES current period." - ] + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "currentKESPeriod" .= String (textShow current) + , "error" .= String + ( mconcat + [ "Your operational certificate's KES start period " + , "is before the KES current period." + ] + ) + ] toObject _verb (KESAfterEndOCERT (KESPeriod current) (KESPeriod oCertstart) maxKESEvolutions) = mconcat [ "kind" .= String "KESAfterEndOCERT" - , "currentKESPeriod" .= String (textShow current) - , "opCertKESStartPeriod" .= String (textShow oCertstart) - , "maxKESEvolutions" .= String (textShow maxKESEvolutions) - , "error" .= String "The operational certificate's KES start period is \ - \greater than the max number of KES + the KES current period" - ] + , "currentKESPeriod" .= String (textShow current) + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "maxKESEvolutions" .= String (textShow maxKESEvolutions) + , "error" .= String + ( mconcat + [ "The operational certificate's KES start period is " + , "greater than the max number of KES + the KES current period" + ] + ) + ] toObject _verb (CounterTooSmallOCERT lastKEScounterUsed currentKESCounter) = mconcat [ "kind" .= String "CounterTooSmallOCert" - , "currentKESCounter" .= String (textShow currentKESCounter) - , "lastKESCounter" .= String (textShow lastKEScounterUsed) - , "error" .= String "The operational certificate's last KES counter is greater \ - \than the current KES counter." - ] + , "currentKESCounter" .= String (textShow currentKESCounter) + , "lastKESCounter" .= String (textShow lastKEScounterUsed) + , "error" .= String + ( mconcat + [ "The operational certificate's last KES counter is greater " + , "than the current KES counter." + ] + ) + ] toObject _verb (InvalidSignatureOCERT oCertCounter oCertKESStartPeriod) = mconcat [ "kind" .= String "InvalidSignatureOCERT" , "opCertKESStartPeriod" .= String (textShow oCertKESStartPeriod) @@ -911,10 +933,14 @@ instance ( Ledger.Era era ] toObject _verb (Alonzo.OutputTooSmallUTxO badOutputs) = mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String "The output is smaller than the allow minimum \ - \UTxO value defined in the protocol parameters" - ] + , "outputs" .= badOutputs + , "error" .= String + ( mconcat + [ "The output is smaller than the allow minimum " + , "UTxO value defined in the protocol parameters" + ] + ) + ] toObject verb (Alonzo.UtxosFailure predFailure) = toObject verb predFailure toObject _verb (Alonzo.OutputBootAddrAttrsTooBig txouts) = diff --git a/cardano-testnet/test/Test/Cli/KesPeriodInfo.hs b/cardano-testnet/test/Test/Cli/KesPeriodInfo.hs index ccdd67fc3b6..2ad7901e190 100644 --- a/cardano-testnet/test/Test/Cli/KesPeriodInfo.hs +++ b/cardano-testnet/test/Test/Cli/KesPeriodInfo.hs @@ -397,8 +397,10 @@ hprop_kes_period_info = integration . H.runFinallies . H.workspace "chairman" $ _txin3 <- H.noteShow . head $ Map.keys utxo3 - H.note_ "Wait for the node to mint blocks. This will be in the following epoch so lets wait\ - \ until the END of the following epoch." + H.note_ $ mconcat + [ "Wait for the node to mint blocks. This will be in the following epoch so lets wait" + , " until the END of the following epoch." + ] void $ execCli' execConfig [ "query", "tip" @@ -446,8 +448,10 @@ hprop_kes_period_info = integration . H.runFinallies . H.workspace "chairman" $ H.note_ $ "Current Epoch: " <> show currEpoch2 - H.note_ "Check to see if the node has minted blocks. This confirms that the operational\ - \ certificate is valid" + H.note_ $ mconcat + [ "Check to see if the node has minted blocks. This confirms that the operational" + , " certificate is valid" + ] -- TODO: Linking to the node log file like this is fragile. spoLogFile <- H.note $ tempAbsPath "logs/node-pool1.stdout.log" From e609e9ed0faf8acc8897de216189d25b0eb0cf88 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 16 Feb 2023 17:00:36 +1100 Subject: [PATCH 4/4] Remove use of multiline literals from trace-dispatcher --- .../examples/Examples/TestObjects.hs | 65 ++++++++++--------- .../Cardano/Logging/TraceDispatcherMessage.hs | 21 +++--- 2 files changed, 47 insertions(+), 39 deletions(-) diff --git a/trace-dispatcher/examples/Examples/TestObjects.hs b/trace-dispatcher/examples/Examples/TestObjects.hs index fa525d76783..e1a1368ac03 100644 --- a/trace-dispatcher/examples/Examples/TestObjects.hs +++ b/trace-dispatcher/examples/Examples/TestObjects.hs @@ -112,34 +112,36 @@ instance MetaTrace (TraceForgeEvent blk) where "Start of the leadership check\n\ \\n\ \We record the current slot number." - documentFor (Namespace _ ["SlotIsImmutable"]) = Just - "Leadership check failed: the tip of the ImmutableDB inhabits the\n\ - \current slot\n\ - \\n\ - \This might happen in two cases.\n\ - \\n\ - \1. the clock moved backwards, on restart we ignored everything from the\n\ - \ VolatileDB since it's all in the future, and now the tip of the\n\ - \ ImmutableDB points to a block produced in the same slot we're trying\n\ - \ to produce a block in\n\ - \\n\ - \2. k = 0 and we already adopted a block from another leader of the same\n\ - \ slot.\n\ - \\n\ - \We record both the current slot number as well as the tip of the\n\ - \ImmutableDB.\n\ - \\n\ - \See also " - documentFor (Namespace _ ["BlockFromFuture"]) = Just - "Leadership check failed: the current chain contains a block from a slot\n\ - \/after/ the current slot\n\ - \\n\ - \This can only happen if the system is under heavy load.\n\ - \\n\ - \We record both the current slot number as well as the slot number of the\n\ - \block at the tip of the chain.\n\ - \\n\ - \See also " + documentFor (Namespace _ ["SlotIsImmutable"]) = Just $ mconcat + [ "Leadership check failed: the tip of the ImmutableDB inhabits the\n" + , "current slot\n" + , "\n" + , "This might happen in two cases.\n" + , "\n" + , "1. the clock moved backwards, on restart we ignored everything from the\n" + , " VolatileDB since it's all in the future, and now the tip of the\n" + , " ImmutableDB points to a block produced in the same slot we're trying\n" + , " to produce a block in\n" + , "\n" + , "2. k = 0 and we already adopted a block from another leader of the same\n" + , " slot.\n" + , "\n" + , "We record both the current slot number as well as the tip of the\n" + , "ImmutableDB.\n" + , "\n" + , "See also " + ] + documentFor (Namespace _ ["BlockFromFuture"]) = Just $ mconcat + [ "Leadership check failed: the current chain contains a block from a slot\n" + , "/after/ the current slot\n" + , "\n" + , "This can only happen if the system is under heavy load.\n" + , "\n" + , "We record both the current slot number as well as the slot number of the\n" + , "block at the tip of the chain.\n" + , "\n" + , "See also " + ] documentFor _ns = Nothing metricsDocFor (Namespace _ _) = [] allNamespaces = [ Namespace [] ["StartLeadershipCheck"] @@ -153,8 +155,11 @@ instance LogFormatting (TraceForgeEvent LogBlock) where (unSlotNo slotNo) forHuman (TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo) = pack $ printf - "Couldn't forge block because slot %u is immutable. \ - \ Immutable tip: %s, immutable tip block no: %i." + ( mconcat + [ "Couldn't forge block because slot %u is immutable. " + , " Immutable tip: %s, immutable tip block no: %i." + ] + ) (unSlotNo slotNo) (show immutableTipPoint) (unBlockNo immutableTipBlkNo) diff --git a/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs b/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs index 98cadc54949..e0dd68c1598 100644 --- a/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs +++ b/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs @@ -81,15 +81,18 @@ instance MetaTrace TraceDispatcherMessage where documentFor (Namespace _ ["StartLimiting"]) = Just "This message indicates the start of frequency limiting" - documentFor (Namespace _ ["StopLimiting"]) = Just - "This message indicates the stop of frequency limiting,\ - \ and gives the number of messages that has been suppressed" - documentFor (Namespace _ ["RememberLimiting"]) = Just - "^ This message remembers of ongoing frequency limiting,\ - \ and gives the number of messages that has been suppressed" - documentFor (Namespace _ ["UnknownNamespace"]) = Just - "A value was queried for a namespaces from a tracer,\ - \which is unknown. This inicates a bug in the tracer implementation." + documentFor (Namespace _ ["StopLimiting"]) = Just $ mconcat + [ "This message indicates the stop of frequency limiting," + , " and gives the number of messages that has been suppressed" + ] + documentFor (Namespace _ ["RememberLimiting"]) = Just $ mconcat + [ "^ This message remembers of ongoing frequency limiting," + , " and gives the number of messages that has been suppressed" + ] + documentFor (Namespace _ ["UnknownNamespace"]) = Just $ mconcat + [ "A value was queried for a namespaces from a tracer," + , "which is unknown. This inicates a bug in the tracer implementation." + ] allNamespaces = [ Namespace [] ["StartLimiting"]