diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index b1a1fe106f..b2fbad862a 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -1,452 +1,470 @@ cabal-version: 3.4 +name: cardano-cli +version: 9.0.0.1 +synopsis: The Cardano command-line interface +description: The Cardano command-line interface. +copyright: 2020-2023 Input Output Global Inc (IOG). +author: IOHK +maintainer: operations@iohk.io +category: + Cardano, + CLI, -name: cardano-cli -version: 9.0.0.1 -synopsis: The Cardano command-line interface -description: The Cardano command-line interface. -copyright: 2020-2023 Input Output Global Inc (IOG). -author: IOHK -maintainer: operations@iohk.io -category: Cardano, - CLI, -license: Apache-2.0 -license-files: LICENSE - NOTICE -build-type: Simple -extra-source-files: README.md +license: Apache-2.0 +license-files: + LICENSE + NOTICE -common project-config - default-language: Haskell2010 - - default-extensions: OverloadedStrings - build-depends: base >= 4.14 && < 4.20 +build-type: Simple +extra-source-files: README.md - ghc-options: -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wno-unticked-promoted-constructors - -Wpartial-fields - -Wredundant-constraints +common project-config + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >=4.14 && <4.20 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-unticked-promoted-constructors + -Wpartial-fields + -Wredundant-constraints if impl(ghc >= 9.6) - ghc-options: -Wunused-packages + ghc-options: -Wunused-packages common maybe-unix if !os(windows) - build-depends: unix + build-depends: unix library - import: project-config - , maybe-unix + import: + project-config + , maybe-unix if impl(ghc < 9.6) - ghc-options: -Wno-redundant-constraints - - hs-source-dirs: src - - exposed-modules: Cardano.CLI.Byron.Commands - Cardano.CLI.Byron.Delegation - Cardano.CLI.Byron.Genesis - Cardano.CLI.Byron.Key - Cardano.CLI.Byron.Legacy - Cardano.CLI.Byron.Parsers - Cardano.CLI.Byron.Run - Cardano.CLI.Byron.Tx - Cardano.CLI.Byron.UpdateProposal - Cardano.CLI.Byron.Vote - Cardano.CLI.Commands - Cardano.CLI.Commands.Hash - Cardano.CLI.Commands.Ping - Cardano.CLI.Commands.Debug - Cardano.CLI.Commands.Debug.LogEpochState - Cardano.CLI.Environment - Cardano.CLI.EraBased.Commands - Cardano.CLI.EraBased.Commands.Address - Cardano.CLI.EraBased.Commands.Genesis - Cardano.CLI.EraBased.Commands.Governance - Cardano.CLI.EraBased.Commands.Governance.Actions - Cardano.CLI.EraBased.Commands.Governance.Committee - Cardano.CLI.EraBased.Commands.Governance.DRep - Cardano.CLI.EraBased.Commands.Governance.Poll - Cardano.CLI.EraBased.Commands.Governance.Vote - Cardano.CLI.EraBased.Commands.Key - Cardano.CLI.EraBased.Commands.Node - Cardano.CLI.EraBased.Commands.Query - Cardano.CLI.EraBased.Commands.StakeAddress - Cardano.CLI.EraBased.Commands.StakePool - Cardano.CLI.EraBased.Commands.TextView - Cardano.CLI.EraBased.Commands.Transaction - Cardano.CLI.EraBased.Options.Address - Cardano.CLI.EraBased.Options.Common - Cardano.CLI.EraBased.Options.Genesis - Cardano.CLI.EraBased.Options.Governance - Cardano.CLI.EraBased.Options.Governance.Actions - Cardano.CLI.EraBased.Options.Governance.Committee - Cardano.CLI.EraBased.Options.Governance.DRep - Cardano.CLI.EraBased.Options.Governance.Poll - Cardano.CLI.EraBased.Options.Governance.Vote - Cardano.CLI.EraBased.Options.Key - Cardano.CLI.EraBased.Options.Node - Cardano.CLI.EraBased.Options.Query - Cardano.CLI.EraBased.Options.StakeAddress - Cardano.CLI.EraBased.Options.StakePool - Cardano.CLI.EraBased.Options.TextView - Cardano.CLI.EraBased.Options.Transaction - Cardano.CLI.EraBased.Run - Cardano.CLI.EraBased.Run.Address - Cardano.CLI.EraBased.Run.Address.Info - Cardano.CLI.EraBased.Run.CreateTestnetData - Cardano.CLI.EraBased.Run.Genesis - Cardano.CLI.EraBased.Run.Governance - Cardano.CLI.EraBased.Run.Governance.Actions - Cardano.CLI.EraBased.Run.Governance.Committee - Cardano.CLI.EraBased.Run.Governance.DRep - Cardano.CLI.EraBased.Run.Governance.GenesisKeyDelegationCertificate - Cardano.CLI.EraBased.Run.Governance.Poll - Cardano.CLI.EraBased.Run.Governance.Vote - Cardano.CLI.EraBased.Run.Key - Cardano.CLI.EraBased.Run.Node - Cardano.CLI.EraBased.Run.Query - Cardano.CLI.EraBased.Run.StakeAddress - Cardano.CLI.EraBased.Run.StakePool - Cardano.CLI.EraBased.Run.TextView - Cardano.CLI.EraBased.Run.Transaction - Cardano.CLI.Helpers - Cardano.CLI.IO.Compat - Cardano.CLI.IO.Lazy - Cardano.CLI.Json.Friendly - Cardano.CLI.Legacy.Commands - Cardano.CLI.Legacy.Commands.Address - Cardano.CLI.Legacy.Commands.Genesis - Cardano.CLI.Legacy.Commands.Governance - Cardano.CLI.Legacy.Commands.Key - Cardano.CLI.Legacy.Commands.Node - Cardano.CLI.Legacy.Commands.Query - Cardano.CLI.Legacy.Commands.StakeAddress - Cardano.CLI.Legacy.Commands.StakePool - Cardano.CLI.Legacy.Commands.TextView - Cardano.CLI.Legacy.Commands.Transaction - Cardano.CLI.Legacy.Options - Cardano.CLI.Legacy.Options.Key - Cardano.CLI.Legacy.Run - Cardano.CLI.Legacy.Run.Address - Cardano.CLI.Legacy.Run.Genesis - Cardano.CLI.Legacy.Run.Governance - Cardano.CLI.Legacy.Run.Key - Cardano.CLI.Legacy.Run.Node - Cardano.CLI.Legacy.Run.Query - Cardano.CLI.Legacy.Run.StakeAddress - Cardano.CLI.Legacy.Run.StakePool - Cardano.CLI.Legacy.Run.TextView - Cardano.CLI.Legacy.Run.Transaction - Cardano.CLI.Options - Cardano.CLI.Options.Debug - Cardano.CLI.Options.Hash - Cardano.CLI.Options.Ping - Cardano.CLI.Orphans - Cardano.CLI.OS.Posix - Cardano.CLI.Parser - Cardano.CLI.Pretty - Cardano.CLI.Read - Cardano.CLI.Render - Cardano.CLI.Run - Cardano.CLI.Run.Debug - Cardano.CLI.Run.Debug.LogEpochState - Cardano.CLI.Run.Hash - Cardano.CLI.Run.Ping - Cardano.CLI.TopHandler - Cardano.CLI.Types.Common - Cardano.CLI.Types.MonadWarning - Cardano.CLI.Types.Errors.AddressCmdError - Cardano.CLI.Types.Errors.AddressInfoError - Cardano.CLI.Types.Errors.BootstrapWitnessError - Cardano.CLI.Types.Errors.CardanoAddressSigningKeyConversionError - Cardano.CLI.Types.Errors.CmdError - Cardano.CLI.Types.Errors.DelegationError - Cardano.CLI.Types.Errors.GenesisCmdError - Cardano.CLI.Types.Errors.GovernanceActionsError - Cardano.CLI.Types.Errors.GovernanceCmdError - Cardano.CLI.Types.Errors.GovernanceCommitteeError - Cardano.CLI.Types.Errors.GovernanceQueryError - Cardano.CLI.Types.Errors.GovernanceVoteCmdError - Cardano.CLI.Types.Errors.HashCmdError - Cardano.CLI.Types.Errors.ItnKeyConversionError - Cardano.CLI.Types.Errors.KeyCmdError - Cardano.CLI.Types.Errors.NodeCmdError - Cardano.CLI.Types.Errors.NodeEraMismatchError - Cardano.CLI.Types.Errors.ProtocolParamsError - Cardano.CLI.Types.Errors.QueryCmdError - Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError - Cardano.CLI.Types.Errors.RegistrationError - Cardano.CLI.Types.Errors.ScriptDecodeError - Cardano.CLI.Types.Errors.StakeAddressCmdError - Cardano.CLI.Types.Errors.StakeAddressDelegationError - Cardano.CLI.Types.Errors.StakeAddressRegistrationError - Cardano.CLI.Types.Errors.StakeCredentialError - Cardano.CLI.Types.Errors.StakePoolCmdError - Cardano.CLI.Types.Errors.TextViewFileError - Cardano.CLI.Types.Errors.TxCmdError - Cardano.CLI.Types.Errors.TxValidationError - Cardano.CLI.Types.Governance - Cardano.CLI.Types.Key - Cardano.CLI.Types.Key.VerificationKey - Cardano.CLI.Types.Output - Cardano.CLI.Types.TxFeature + ghc-options: -Wno-redundant-constraints + hs-source-dirs: src + exposed-modules: + Cardano.CLI.Byron.Commands + Cardano.CLI.Byron.Delegation + Cardano.CLI.Byron.Genesis + Cardano.CLI.Byron.Key + Cardano.CLI.Byron.Legacy + Cardano.CLI.Byron.Parsers + Cardano.CLI.Byron.Run + Cardano.CLI.Byron.Tx + Cardano.CLI.Byron.UpdateProposal + Cardano.CLI.Byron.Vote + Cardano.CLI.Commands + Cardano.CLI.Commands.Debug + Cardano.CLI.Commands.Debug.LogEpochState + Cardano.CLI.Commands.Hash + Cardano.CLI.Commands.Ping + Cardano.CLI.Environment + Cardano.CLI.EraBased.Commands + Cardano.CLI.EraBased.Commands.Address + Cardano.CLI.EraBased.Commands.Genesis + Cardano.CLI.EraBased.Commands.Governance + Cardano.CLI.EraBased.Commands.Governance.Actions + Cardano.CLI.EraBased.Commands.Governance.Committee + Cardano.CLI.EraBased.Commands.Governance.DRep + Cardano.CLI.EraBased.Commands.Governance.Poll + Cardano.CLI.EraBased.Commands.Governance.Vote + Cardano.CLI.EraBased.Commands.Key + Cardano.CLI.EraBased.Commands.Node + Cardano.CLI.EraBased.Commands.Query + Cardano.CLI.EraBased.Commands.StakeAddress + Cardano.CLI.EraBased.Commands.StakePool + Cardano.CLI.EraBased.Commands.TextView + Cardano.CLI.EraBased.Commands.Transaction + Cardano.CLI.EraBased.Options.Address + Cardano.CLI.EraBased.Options.Common + Cardano.CLI.EraBased.Options.Genesis + Cardano.CLI.EraBased.Options.Governance + Cardano.CLI.EraBased.Options.Governance.Actions + Cardano.CLI.EraBased.Options.Governance.Committee + Cardano.CLI.EraBased.Options.Governance.DRep + Cardano.CLI.EraBased.Options.Governance.Poll + Cardano.CLI.EraBased.Options.Governance.Vote + Cardano.CLI.EraBased.Options.Key + Cardano.CLI.EraBased.Options.Node + Cardano.CLI.EraBased.Options.Query + Cardano.CLI.EraBased.Options.StakeAddress + Cardano.CLI.EraBased.Options.StakePool + Cardano.CLI.EraBased.Options.TextView + Cardano.CLI.EraBased.Options.Transaction + Cardano.CLI.EraBased.Run + Cardano.CLI.EraBased.Run.Address + Cardano.CLI.EraBased.Run.Address.Info + Cardano.CLI.EraBased.Run.CreateTestnetData + Cardano.CLI.EraBased.Run.Genesis + Cardano.CLI.EraBased.Run.Governance + Cardano.CLI.EraBased.Run.Governance.Actions + Cardano.CLI.EraBased.Run.Governance.Committee + Cardano.CLI.EraBased.Run.Governance.DRep + Cardano.CLI.EraBased.Run.Governance.GenesisKeyDelegationCertificate + Cardano.CLI.EraBased.Run.Governance.Poll + Cardano.CLI.EraBased.Run.Governance.Vote + Cardano.CLI.EraBased.Run.Key + Cardano.CLI.EraBased.Run.Node + Cardano.CLI.EraBased.Run.Query + Cardano.CLI.EraBased.Run.StakeAddress + Cardano.CLI.EraBased.Run.StakePool + Cardano.CLI.EraBased.Run.TextView + Cardano.CLI.EraBased.Run.Transaction + Cardano.CLI.Helpers + Cardano.CLI.IO.Compat + Cardano.CLI.IO.Lazy + Cardano.CLI.Json.Friendly + Cardano.CLI.Legacy.Commands + Cardano.CLI.Legacy.Commands.Address + Cardano.CLI.Legacy.Commands.Genesis + Cardano.CLI.Legacy.Commands.Governance + Cardano.CLI.Legacy.Commands.Key + Cardano.CLI.Legacy.Commands.Node + Cardano.CLI.Legacy.Commands.Query + Cardano.CLI.Legacy.Commands.StakeAddress + Cardano.CLI.Legacy.Commands.StakePool + Cardano.CLI.Legacy.Commands.TextView + Cardano.CLI.Legacy.Commands.Transaction + Cardano.CLI.Legacy.Options + Cardano.CLI.Legacy.Options.Key + Cardano.CLI.Legacy.Run + Cardano.CLI.Legacy.Run.Address + Cardano.CLI.Legacy.Run.Genesis + Cardano.CLI.Legacy.Run.Governance + Cardano.CLI.Legacy.Run.Key + Cardano.CLI.Legacy.Run.Node + Cardano.CLI.Legacy.Run.Query + Cardano.CLI.Legacy.Run.StakeAddress + Cardano.CLI.Legacy.Run.StakePool + Cardano.CLI.Legacy.Run.TextView + Cardano.CLI.Legacy.Run.Transaction + Cardano.CLI.OS.Posix + Cardano.CLI.Options + Cardano.CLI.Options.Debug + Cardano.CLI.Options.Hash + Cardano.CLI.Options.Ping + Cardano.CLI.Orphans + Cardano.CLI.Parser + Cardano.CLI.Pretty + Cardano.CLI.Read + Cardano.CLI.Render + Cardano.CLI.Run + Cardano.CLI.Run.Debug + Cardano.CLI.Run.Debug.LogEpochState + Cardano.CLI.Run.Hash + Cardano.CLI.Run.Ping + Cardano.CLI.TopHandler + Cardano.CLI.Types.Common + Cardano.CLI.Types.Errors.AddressCmdError + Cardano.CLI.Types.Errors.AddressInfoError + Cardano.CLI.Types.Errors.BootstrapWitnessError + Cardano.CLI.Types.Errors.CardanoAddressSigningKeyConversionError + Cardano.CLI.Types.Errors.CmdError + Cardano.CLI.Types.Errors.DelegationError + Cardano.CLI.Types.Errors.GenesisCmdError + Cardano.CLI.Types.Errors.GovernanceActionsError + Cardano.CLI.Types.Errors.GovernanceCmdError + Cardano.CLI.Types.Errors.GovernanceCommitteeError + Cardano.CLI.Types.Errors.GovernanceQueryError + Cardano.CLI.Types.Errors.GovernanceVoteCmdError + Cardano.CLI.Types.Errors.HashCmdError + Cardano.CLI.Types.Errors.ItnKeyConversionError + Cardano.CLI.Types.Errors.KeyCmdError + Cardano.CLI.Types.Errors.NodeCmdError + Cardano.CLI.Types.Errors.NodeEraMismatchError + Cardano.CLI.Types.Errors.ProtocolParamsError + Cardano.CLI.Types.Errors.QueryCmdError + Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError + Cardano.CLI.Types.Errors.RegistrationError + Cardano.CLI.Types.Errors.ScriptDecodeError + Cardano.CLI.Types.Errors.StakeAddressCmdError + Cardano.CLI.Types.Errors.StakeAddressDelegationError + Cardano.CLI.Types.Errors.StakeAddressRegistrationError + Cardano.CLI.Types.Errors.StakeCredentialError + Cardano.CLI.Types.Errors.StakePoolCmdError + Cardano.CLI.Types.Errors.TextViewFileError + Cardano.CLI.Types.Errors.TxCmdError + Cardano.CLI.Types.Errors.TxValidationError + Cardano.CLI.Types.Governance + Cardano.CLI.Types.Key + Cardano.CLI.Types.Key.VerificationKey + Cardano.CLI.Types.MonadWarning + Cardano.CLI.Types.Output + Cardano.CLI.Types.TxFeature - other-modules: Paths_cardano_cli - autogen-modules: Paths_cardano_cli - - build-depends: aeson >= 1.5.6.0 - , aeson-pretty >= 0.8.5 - , ansi-terminal - , attoparsec - , base16-bytestring >= 1.0 - , bech32 >= 1.1.0 - , binary - , bytestring - , canonical-json - , cardano-api ^>= 9.0 - , cardano-binary - , cardano-crypto - , cardano-crypto-class ^>= 2.1.2 - , cardano-crypto-wrapper ^>= 1.5.1 - , cardano-data >= 1.1 - , cardano-git-rev ^>= 0.2.2 - , cardano-ledger-api - , cardano-ledger-byron >= 1.0.1.0 - , cardano-ledger-shelley - , cardano-ping ^>= 0.2.0.13 - , cardano-prelude - , cardano-slotting ^>= 0.2.0.0 - , cardano-strict-containers ^>= 0.1 - , cborg >= 0.2.4 && < 0.3 - , cborg-json - , containers - , contra-tracer - , cryptonite - , deepseq - , directory - , filepath - , formatting - , io-classes - , iproute - , mtl - , microlens - , network - , optparse-applicative-fork - , ouroboros-consensus ^>= 0.20 - -- TODO: bump consensus back - , ouroboros-consensus-cardano ^>= 0.18 - , ouroboros-consensus-protocol ^>= 0.9.0.1 - , ouroboros-network-api ^>= 0.7.3 - , ouroboros-network-protocols - , parsec - , prettyprinter - , prettyprinter-ansi-terminal - , random - , split - , strict-stm - , text - , time - , transformers - , transformers-except ^>= 0.1.3 - , unliftio-core - , utf8-string - , vector - , yaml + other-modules: Paths_cardano_cli + autogen-modules: Paths_cardano_cli + build-depends: + -- TODO: bump consensus back + aeson >=1.5.6.0, + aeson-pretty >=0.8.5, + ansi-terminal, + attoparsec, + base16-bytestring >=1.0, + bech32 >=1.1.0, + binary, + bytestring, + canonical-json, + cardano-api ^>=9.0, + cardano-binary, + cardano-crypto, + cardano-crypto-class ^>=2.1.2, + cardano-crypto-wrapper ^>=1.5.1, + cardano-data >=1.1, + cardano-git-rev ^>=0.2.2, + cardano-ledger-api, + cardano-ledger-byron >=1.0.1.0, + cardano-ledger-shelley, + cardano-ping ^>=0.2.0.13, + cardano-prelude, + cardano-slotting ^>=0.2.0.0, + cardano-strict-containers ^>=0.1, + cborg >=0.2.4 && <0.3, + cborg-json, + containers, + contra-tracer, + cryptonite, + deepseq, + directory, + filepath, + formatting, + io-classes, + iproute, + microlens, + mtl, + network, + optparse-applicative-fork, + ouroboros-consensus ^>=0.20, + ouroboros-consensus-cardano ^>=0.18, + ouroboros-consensus-protocol ^>=0.9.0.1, + ouroboros-network-api ^>=0.7.3, + ouroboros-network-protocols, + parsec, + prettyprinter, + prettyprinter-ansi-terminal, + random, + split, + strict-stm, + text, + time, + transformers, + transformers-except ^>=0.1.3, + unliftio-core, + utf8-string, + vector, + yaml, executable cardano-cli - import: project-config - hs-source-dirs: app - main-is: cardano-cli.hs - ghc-options: -threaded -rtsopts "-with-rtsopts=-T" + import: project-config + hs-source-dirs: app + main-is: cardano-cli.hs + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-T - build-depends: cardano-cli - , cardano-crypto-class ^>= 2.1.2 - , optparse-applicative-fork - , transformers-except + build-depends: + cardano-cli, + cardano-crypto-class ^>=2.1.2, + optparse-applicative-fork, + transformers-except, library cardano-cli-test-lib - import: project-config - visibility: public - hs-source-dirs: test/cardano-cli-test-lib - exposed-modules: Test.Cardano.CLI.Aeson - Test.Cardano.CLI.Util - build-depends: aeson - , aeson-pretty - , bytestring - , cardano-api - , cardano-cli - , directory - , exceptions - , filepath - , hedgehog - , hedgehog-extras ^>= 0.6.1.0 - , lifted-base - , monad-control - , process - , text - , transformers-base - -test-suite cardano-cli-test - import: project-config + import: project-config + visibility: public + hs-source-dirs: test/cardano-cli-test-lib + exposed-modules: + Test.Cardano.CLI.Aeson + Test.Cardano.CLI.Util - hs-source-dirs: test/cardano-cli-test - main-is: cardano-cli-test.hs - type: exitcode-stdio-1.0 + build-depends: + aeson, + aeson-pretty, + bytestring, + cardano-api, + cardano-cli, + directory, + exceptions, + filepath, + hedgehog, + hedgehog-extras ^>=0.6.1.0, + lifted-base, + monad-control, + process, + text, + transformers-base, - build-depends: aeson - , base16-bytestring - , bech32 >= 1.1.0 - , bytestring - , cardano-api:{cardano-api, gen, internal} - , cardano-cli - , cardano-cli:cardano-cli-test-lib - , cardano-ledger-alonzo - , cardano-slotting - , containers - , filepath - , hedgehog - , hedgehog-extras ^>= 0.6.1.0 - , exceptions - , regex-tdfa - , tasty - , tasty-hedgehog - , text - , time - , transformers - - build-tool-depends: tasty-discover:tasty-discover +test-suite cardano-cli-test + import: project-config + hs-source-dirs: test/cardano-cli-test + main-is: cardano-cli-test.hs + type: exitcode-stdio-1.0 + build-depends: + aeson, + base16-bytestring, + bech32 >=1.1.0, + bytestring, + cardano-api:{cardano-api, gen, internal}, + cardano-cli, + cardano-cli:cardano-cli-test-lib, + cardano-ledger-alonzo, + cardano-slotting, + containers, + exceptions, + filepath, + hedgehog, + hedgehog-extras ^>=0.6.1.0, + regex-tdfa, + tasty, + tasty-hedgehog, + text, + time, + transformers, - other-modules: Test.Cli.AddCostModels - Test.Cli.CreateTestnetData - Test.Cli.FilePermissions - Test.Cli.Governance.DRep - Test.Cli.Governance.Hash - Test.Cli.ITN - Test.Cli.JSON - Test.Cli.MonadWarning - Test.Cli.Pioneers.Exercise1 - Test.Cli.Pioneers.Exercise2 - Test.Cli.Pioneers.Exercise3 - Test.Cli.Pioneers.Exercise4 - Test.Cli.Pioneers.Exercise5 - Test.Cli.Pioneers.Exercise6 - Test.Cli.Pipes - Test.Cli.VerificationKey - Test.Cli.Shelley.Run.Hash - Test.Cli.Shelley.Run.Query - Test.Cli.Shelley.Transaction.Build + build-tool-depends: tasty-discover:tasty-discover + other-modules: + Test.Cli.AddCostModels + Test.Cli.CreateTestnetData + Test.Cli.FilePermissions + Test.Cli.Governance.DRep + Test.Cli.Governance.Hash + Test.Cli.ITN + Test.Cli.JSON + Test.Cli.MonadWarning + Test.Cli.Pioneers.Exercise1 + Test.Cli.Pioneers.Exercise2 + Test.Cli.Pioneers.Exercise3 + Test.Cli.Pioneers.Exercise4 + Test.Cli.Pioneers.Exercise5 + Test.Cli.Pioneers.Exercise6 + Test.Cli.Pipes + Test.Cli.Shelley.Run.Hash + Test.Cli.Shelley.Run.Query + Test.Cli.Shelley.Transaction.Build + Test.Cli.VerificationKey - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -T" test-suite cardano-cli-golden - import: project-config - , maybe-unix + import: + project-config + , maybe-unix - hs-source-dirs: test/cardano-cli-golden - main-is: cardano-cli-golden.hs - type: exitcode-stdio-1.0 + hs-source-dirs: test/cardano-cli-golden + main-is: cardano-cli-golden.hs + type: exitcode-stdio-1.0 + build-depends: + aeson >=1.5.6.0, + base16-bytestring, + bytestring, + cardano-api:{cardano-api, gen}, + cardano-binary, + cardano-cli, + cardano-cli:cardano-cli-test-lib, + cardano-crypto-wrapper, + cardano-data >=1.1, + cardano-ledger-byron, + cardano-ledger-shelley >=1.10.0.0, + cardano-strict-containers ^>=0.1, + cborg, + containers, + directory, + extra, + filepath, + hedgehog ^>=1.4, + hedgehog-extras ^>=0.6.1.0, + regex-compat, + regex-tdfa, + tasty, + tasty-hedgehog, + text, + time, + transformers, + unordered-containers, - build-depends: aeson >= 1.5.6.0 - , base16-bytestring - , bytestring - , cardano-api:{cardano-api, gen} - , cardano-binary - , cardano-cli - , cardano-cli:cardano-cli-test-lib - , cardano-crypto-wrapper - , cardano-data >= 1.1 - , cardano-ledger-byron - , cardano-ledger-shelley >=1.10.0.0 - , cardano-strict-containers ^>= 0.1 - , cborg - , containers - , directory - , extra - , filepath - , hedgehog ^>= 1.4 - , hedgehog-extras ^>= 0.6.1.0 - , regex-compat - , regex-tdfa - , tasty - , tasty-hedgehog - , text - , time - , transformers - , unordered-containers - build-tool-depends: cardano-cli:cardano-cli - , tasty-discover:tasty-discover + build-tool-depends: + cardano-cli:cardano-cli, + tasty-discover:tasty-discover, - other-modules: Test.Golden.Babbage.Transaction.CalculateMinFee - Test.Golden.Byron.SigningKeys - Test.Golden.Byron.Tx - Test.Golden.Byron.TxBody - Test.Golden.Byron.UpdateProposal - Test.Golden.Byron.Vote - Test.Golden.Byron.Witness - Test.Golden.CreateStaked - Test.Golden.CreateTestnetData - Test.Golden.Conway.Transaction.Assemble - Test.Golden.Conway.Transaction.BuildRaw - Test.Golden.EraBased.Governance.AnswerPoll - Test.Golden.EraBased.Governance.CreatePoll - Test.Golden.EraBased.Governance.VerifyPoll - Test.Golden.ErrorsSpec - Test.Golden.Governance.Action - Test.Golden.Governance.Committee - Test.Golden.Governance.DRep - Test.Golden.Governance.StakeAddress - Test.Golden.Governance.Vote - Test.Golden.Hash.Hash - Test.Golden.Help - Test.Golden.Key.NonExtendedKey - Test.Golden.Shelley.Address.Build - Test.Golden.Shelley.Address.Info - Test.Golden.Shelley.Address.KeyGen - Test.Golden.Shelley.Genesis.Create - Test.Golden.Shelley.Genesis.InitialTxIn - Test.Golden.Shelley.Genesis.KeyGenDelegate - Test.Golden.Shelley.Genesis.KeyGenGenesis - Test.Golden.Shelley.Genesis.KeyGenUtxo - Test.Golden.Shelley.Genesis.KeyHash - Test.Golden.Shelley.Key.ConvertCardanoAddressKey - Test.Golden.Shelley.Metadata.StakePoolMetadata - Test.Golden.Shelley.MultiSig.Address - Test.Golden.Shelley.Node.IssueOpCert - Test.Golden.Shelley.Node.KeyGen - Test.Golden.Shelley.Node.KeyGenKes - Test.Golden.Shelley.Node.KeyGenVrf - Test.Golden.Shelley.StakeAddress.Build - Test.Golden.Shelley.StakeAddress.DeregistrationCertificate - Test.Golden.Shelley.StakeAddress.KeyGen - Test.Golden.Shelley.StakeAddress.KeyHash - Test.Golden.Shelley.StakeAddress.RegistrationCertificate - Test.Golden.Shelley.StakePool.RegistrationCertificate - Test.Golden.Shelley.TextEnvelope.Certificates.GenesisKeyDelegation - Test.Golden.Shelley.TextEnvelope.Certificates.MIR - Test.Golden.Shelley.TextEnvelope.Certificates.Operational - Test.Golden.Shelley.TextEnvelope.Certificates.StakeAddress - Test.Golden.Shelley.TextEnvelope.Certificates.StakePool - Test.Golden.Shelley.TextEnvelope.Keys.ExtendedPaymentKeys - Test.Golden.Shelley.TextEnvelope.Keys.GenesisDelegateKeys - Test.Golden.Shelley.TextEnvelope.Keys.GenesisKeys - Test.Golden.Shelley.TextEnvelope.Keys.GenesisUTxOKeys - Test.Golden.Shelley.TextEnvelope.Keys.KESKeys - Test.Golden.Shelley.TextEnvelope.Keys.PaymentKeys - Test.Golden.Shelley.TextEnvelope.Keys.StakeKeys - Test.Golden.Shelley.TextEnvelope.Keys.VRFKeys - Test.Golden.Shelley.TextEnvelope.Tx.Tx - Test.Golden.Shelley.TextEnvelope.Tx.TxBody - Test.Golden.Shelley.TextEnvelope.Tx.Witness - Test.Golden.Shelley.TextView.DecodeCbor - Test.Golden.Shelley.Transaction.Assemble - Test.Golden.Shelley.Transaction.Build - Test.Golden.Shelley.Transaction.CalculateMinFee - Test.Golden.Shelley.Transaction.CreateWitness - Test.Golden.Shelley.Transaction.Sign - Test.Golden.TxView - Test.Golden.Version + other-modules: + Test.Golden.Babbage.Transaction.CalculateMinFee + Test.Golden.Byron.SigningKeys + Test.Golden.Byron.Tx + Test.Golden.Byron.TxBody + Test.Golden.Byron.UpdateProposal + Test.Golden.Byron.Vote + Test.Golden.Byron.Witness + Test.Golden.Conway.Transaction.Assemble + Test.Golden.Conway.Transaction.BuildRaw + Test.Golden.CreateStaked + Test.Golden.CreateTestnetData + Test.Golden.EraBased.Governance.AnswerPoll + Test.Golden.EraBased.Governance.CreatePoll + Test.Golden.EraBased.Governance.VerifyPoll + Test.Golden.ErrorsSpec + Test.Golden.Governance.Action + Test.Golden.Governance.Committee + Test.Golden.Governance.DRep + Test.Golden.Governance.StakeAddress + Test.Golden.Governance.Vote + Test.Golden.Hash.Hash + Test.Golden.Help + Test.Golden.Key.NonExtendedKey + Test.Golden.Shelley.Address.Build + Test.Golden.Shelley.Address.Info + Test.Golden.Shelley.Address.KeyGen + Test.Golden.Shelley.Genesis.Create + Test.Golden.Shelley.Genesis.InitialTxIn + Test.Golden.Shelley.Genesis.KeyGenDelegate + Test.Golden.Shelley.Genesis.KeyGenGenesis + Test.Golden.Shelley.Genesis.KeyGenUtxo + Test.Golden.Shelley.Genesis.KeyHash + Test.Golden.Shelley.Key.ConvertCardanoAddressKey + Test.Golden.Shelley.Metadata.StakePoolMetadata + Test.Golden.Shelley.MultiSig.Address + Test.Golden.Shelley.Node.IssueOpCert + Test.Golden.Shelley.Node.KeyGen + Test.Golden.Shelley.Node.KeyGenKes + Test.Golden.Shelley.Node.KeyGenVrf + Test.Golden.Shelley.StakeAddress.Build + Test.Golden.Shelley.StakeAddress.DeregistrationCertificate + Test.Golden.Shelley.StakeAddress.KeyGen + Test.Golden.Shelley.StakeAddress.KeyHash + Test.Golden.Shelley.StakeAddress.RegistrationCertificate + Test.Golden.Shelley.StakePool.RegistrationCertificate + Test.Golden.Shelley.TextEnvelope.Certificates.GenesisKeyDelegation + Test.Golden.Shelley.TextEnvelope.Certificates.MIR + Test.Golden.Shelley.TextEnvelope.Certificates.Operational + Test.Golden.Shelley.TextEnvelope.Certificates.StakeAddress + Test.Golden.Shelley.TextEnvelope.Certificates.StakePool + Test.Golden.Shelley.TextEnvelope.Keys.ExtendedPaymentKeys + Test.Golden.Shelley.TextEnvelope.Keys.GenesisDelegateKeys + Test.Golden.Shelley.TextEnvelope.Keys.GenesisKeys + Test.Golden.Shelley.TextEnvelope.Keys.GenesisUTxOKeys + Test.Golden.Shelley.TextEnvelope.Keys.KESKeys + Test.Golden.Shelley.TextEnvelope.Keys.PaymentKeys + Test.Golden.Shelley.TextEnvelope.Keys.StakeKeys + Test.Golden.Shelley.TextEnvelope.Keys.VRFKeys + Test.Golden.Shelley.TextEnvelope.Tx.Tx + Test.Golden.Shelley.TextEnvelope.Tx.TxBody + Test.Golden.Shelley.TextEnvelope.Tx.Witness + Test.Golden.Shelley.TextView.DecodeCbor + Test.Golden.Shelley.Transaction.Assemble + Test.Golden.Shelley.Transaction.Build + Test.Golden.Shelley.Transaction.CalculateMinFee + Test.Golden.Shelley.Transaction.CreateWitness + Test.Golden.Shelley.Transaction.Sign + Test.Golden.TxView + Test.Golden.Version - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -T" diff --git a/cardano-cli/src/Cardano/CLI/Byron/Commands.hs b/cardano-cli/src/Cardano/CLI/Byron/Commands.hs index 6b65c50acd..84d077774d 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Commands.hs @@ -8,7 +8,8 @@ module Cardano.CLI.Byron.Commands , NewVerificationKeyFile (..) , CertificateFile (..) , NewCertificateFile (..) - ) where + ) +where import Cardano.Api hiding (GenesisParameters) import Cardano.Api.Byron hiding (GenesisParameters) @@ -22,95 +23,82 @@ import Cardano.CLI.Types.Common import Data.String (IsString) -data ByronCommand = - - --- Node Related Commands --- +data ByronCommand + = --- Node Related Commands --- NodeCmds - NodeCmds - - --- Genesis Related Commands --- - | Genesis - NewDirectory - GenesisParameters - + NodeCmds + | --- Genesis Related Commands --- + Genesis + NewDirectory + GenesisParameters | PrintGenesisHash - GenesisFile - - --- Key Related Commands --- - | Keygen - NewSigningKeyFile - + GenesisFile + | --- Key Related Commands --- + Keygen + NewSigningKeyFile | ToVerification - ByronKeyFormat - (SigningKeyFile In) - NewVerificationKeyFile - + ByronKeyFormat + (SigningKeyFile In) + NewVerificationKeyFile | PrettySigningKeyPublic - ByronKeyFormat - (SigningKeyFile In) - + ByronKeyFormat + (SigningKeyFile In) | MigrateDelegateKeyFrom - (SigningKeyFile In) - -- ^ Old key - NewSigningKeyFile - -- ^ New Key - + (SigningKeyFile In) + -- ^ Old key + NewSigningKeyFile + -- ^ New Key | PrintSigningKeyAddress - ByronKeyFormat - NetworkId - (SigningKeyFile In) - - ----------------------------------- - - | SubmitTx - SocketPath - NetworkId - (TxFile In) - -- ^ Filepath of transaction to submit. + ByronKeyFormat + NetworkId + (SigningKeyFile In) + | ----------------------------------- + -- | Filepath of transaction to submit. + SubmitTx + SocketPath + NetworkId + (TxFile In) | SpendGenesisUTxO - GenesisFile - NetworkId - ByronKeyFormat - NewTxFile - -- ^ Filepath of the newly created transaction. - (SigningKeyFile In) - -- ^ Signing key of genesis UTxO owner. - (Address ByronAddr) - -- ^ Genesis UTxO address. - [TxOut CtxTx ByronEra] - -- ^ Tx output. + GenesisFile + NetworkId + ByronKeyFormat + NewTxFile + -- ^ Filepath of the newly created transaction. + (SigningKeyFile In) + -- ^ Signing key of genesis UTxO owner. + (Address ByronAddr) + -- ^ Genesis UTxO address. + [TxOut CtxTx ByronEra] + -- ^ Tx output. | SpendUTxO - NetworkId - ByronKeyFormat - NewTxFile - -- ^ Filepath of the newly created transaction. - (SigningKeyFile In) - -- ^ Signing key of Tx underwriter. - [TxIn] - -- ^ Inputs available for spending to the Tx underwriter's key. - [TxOut CtxTx ByronEra] - -- ^ Genesis UTxO output Address. - + NetworkId + ByronKeyFormat + NewTxFile + -- ^ Filepath of the newly created transaction. + (SigningKeyFile In) + -- ^ Signing key of Tx underwriter. + [TxIn] + -- ^ Inputs available for spending to the Tx underwriter's key. + [TxOut CtxTx ByronEra] + -- ^ Genesis UTxO output Address. | GetTxId (TxFile In) + | --- Misc Commands --- - --- Misc Commands --- - - | ValidateCBOR - CBORObject - -- ^ Type of the CBOR object - FilePath - + ValidateCBOR + CBORObject + -- ^ Type of the CBOR object + FilePath | PrettyPrintCBOR - FilePath + FilePath deriving Show - -data NodeCmds = - CreateVote +data NodeCmds + = CreateVote NetworkId (SigningKeyFile In) - FilePath -- ^ filepath to update proposal + FilePath + -- ^ filepath to update proposal Bool FilePath | UpdateProposal @@ -122,16 +110,18 @@ data NodeCmds = InstallerHash FilePath ByronProtocolParametersUpdate - | SubmitUpdateProposal + | -- | Update proposal filepath. + SubmitUpdateProposal SocketPath NetworkId - FilePath -- ^ Update proposal filepath. - | SubmitVote + FilePath + | -- | Vote filepath. + SubmitVote SocketPath NetworkId - FilePath -- ^ Vote filepath. + FilePath deriving Show newtype NewCertificateFile - = NewCertificateFile { nFp :: FilePath } + = NewCertificateFile {nFp :: FilePath} deriving (Eq, Show, IsString) diff --git a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs index 8e49a865ae..40002fbf4a 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Byron.Delegation - ( ByronDelegationError(..) + ( ByronDelegationError (..) , checkByronGenesisDelegation , issueByronGenesisDelegation , renderByronDelegationError @@ -49,6 +49,7 @@ renderByronDelegationError = \case renderByronKeyFailure kerr -- TODO: we need to support password-protected secrets. + -- | Issue a certificate for genesis delegation to a delegate key, signed by the -- issuer key, for a given protocol magic and coming into effect at given epoch. issueByronGenesisDelegation @@ -59,7 +60,7 @@ issueByronGenesisDelegation -> Dlg.Certificate issueByronGenesisDelegation magic epoch issuerSK delegateVK = Dlg.signCertificate magic delegateVK epoch $ - Crypto.noPassSafeSigner issuerSK + Crypto.noPassSafeSigner issuerSK -- | Verify that a certificate signifies genesis delegation by assumed genesis key -- to a delegate key, for a given protocol magic. @@ -77,44 +78,54 @@ checkByronGenesisDelegation (CertificateFile certF) magic issuer delegate = do Right (cert :: Dlg.Certificate) -> do let issues = checkDlgCert cert magic issuer delegate unless (null issues) $ - left $ CertificateValidationErrors certF issues + left $ + CertificateValidationErrors certF issues checkDlgCert :: Dlg.ACertificate a -> ProtocolMagicId -> Crypto.VerificationKey - -> Crypto.VerificationKey -> [Text] + -> Crypto.VerificationKey + -> [Text] checkDlgCert cert magic issuerVK' delegateVK' = mconcat - [ [ sformat "Certificate does not have a valid signature." + [ [ sformat "Certificate does not have a valid signature." | not (Dlg.isValid magic' cert') - ] - , [ sformat ("Certificate issuer ".vkF." doesn't match expected: ".vkF) - ( Dlg.issuerVK cert) issuerVK' + ] + , [ sformat + ("Certificate issuer " . vkF . " doesn't match expected: " . vkF) + (Dlg.issuerVK cert) + issuerVK' | Dlg.issuerVK cert /= issuerVK' - ] - , [ sformat ("Certificate delegate ".vkF." doesn't match expected: ".vkF) - ( Dlg.delegateVK cert) delegateVK' + ] + , [ sformat + ("Certificate delegate " . vkF . " doesn't match expected: " . vkF) + (Dlg.delegateVK cert) + delegateVK' | Dlg.delegateVK cert /= delegateVK' + ] ] - ] - where - magic' :: L.Annotated ProtocolMagicId ByteString - magic' = L.Annotated magic (L.serialize' L.byronProtVer magic) - - epoch :: EpochNumber - epoch = L.unAnnotated $ Dlg.aEpoch cert - - cert' :: Dlg.ACertificate ByteString - cert' = - let unannotated = cert { Dlg.aEpoch = L.Annotated epoch () - , Dlg.annotation = () } - in unannotated { Dlg.annotation = L.serialize' L.byronProtVer unannotated - , Dlg.aEpoch = L.Annotated epoch (L.serialize' L.byronProtVer epoch) } - - vkF :: forall r. Format r (Crypto.VerificationKey -> r) - vkF = Crypto.fullVerificationKeyF - + where + magic' :: L.Annotated ProtocolMagicId ByteString + magic' = L.Annotated magic (L.serialize' L.byronProtVer magic) + + epoch :: EpochNumber + epoch = L.unAnnotated $ Dlg.aEpoch cert + + cert' :: Dlg.ACertificate ByteString + cert' = + let unannotated = + cert + { Dlg.aEpoch = L.Annotated epoch () + , Dlg.annotation = () + } + in unannotated + { Dlg.annotation = L.serialize' L.byronProtVer unannotated + , Dlg.aEpoch = L.Annotated epoch (L.serialize' L.byronProtVer epoch) + } + + vkF :: forall r. Format r (Crypto.VerificationKey -> r) + vkF = Crypto.fullVerificationKeyF serialiseDelegationCert :: Dlg.Certificate -> ByteString serialiseDelegationCert = LB.toStrict . canonicalEncodePretty @@ -124,4 +135,3 @@ serialiseByronWitness sk = case sk of AByronSigningKeyLegacy bSkey -> serialiseToRawBytes bSkey AByronSigningKey legBKey -> serialiseToRawBytes legBKey - diff --git a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs index 1e255a13ea..280e1dd161 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs @@ -2,9 +2,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.Genesis - ( ByronGenesisError(..) - , GenesisParameters(..) - , NewDirectory(..) + ( ByronGenesisError (..) + , GenesisParameters (..) + , NewDirectory (..) , dumpGenesis , mkGenesis , readGenesis @@ -15,7 +15,6 @@ where import Cardano.Api (Key (..), NetworkId, writeSecrets) import Cardano.Api.Byron (ByronKey, SerialiseAsRawBytes (..), SigningKey (..), toByronRequiresNetworkMagic) -import Cardano.CLI.Pretty import qualified Cardano.Chain.Common as Common import Cardano.Chain.Delegation hiding (Map, epoch) @@ -24,6 +23,7 @@ import qualified Cardano.Chain.Genesis as Genesis import qualified Cardano.Chain.UTxO as UTxO import Cardano.CLI.Byron.Delegation import Cardano.CLI.Byron.Key +import Cardano.CLI.Pretty import Cardano.CLI.Types.Common (GenesisFile (..)) import qualified Cardano.Crypto as Crypto import Cardano.Prelude (canonicalDecodePretty, canonicalEncodePretty) @@ -56,7 +56,6 @@ data ByronGenesisError | NoGenesisDelegationForKey !Text | ProtocolParametersParseFailed !FilePath !Text | PoorKeyFailure !ByronKeyFailure - deriving Show renderByronGenesisError :: ByronGenesisError -> Doc ann @@ -82,8 +81,8 @@ renderByronGenesisError = \case NoGenesisDelegationForKey verKey -> "Error while creating genesis, no delegation certificate for this verification key:" <> pshow verKey -newtype NewDirectory = - NewDirectory FilePath +newtype NewDirectory + = NewDirectory FilePath deriving (Eq, Ord, Show, IsString) -- | Parameters required for generation of new genesis. @@ -96,34 +95,37 @@ data GenesisParameters = GenesisParameters , gpFakeAvvmOptions :: !Genesis.FakeAvvmOptions , gpAvvmBalanceFactor :: !Common.LovelacePortion , gpSeed :: !(Maybe Integer) - } deriving Show - + } + deriving Show mkGenesisSpec :: GenesisParameters -> ExceptT ByronGenesisError IO Genesis.GenesisSpec mkGenesisSpec gp = do protoParamsRaw <- lift . LB.readFile $ gpProtocolParamsFile gp - protocolParameters <- withExceptT - (ProtocolParametersParseFailed (gpProtocolParamsFile gp)) $ - ExceptT . pure $ canonicalDecodePretty protoParamsRaw + protocolParameters <- + withExceptT + (ProtocolParametersParseFailed (gpProtocolParamsFile gp)) + $ ExceptT . pure + $ canonicalDecodePretty protoParamsRaw -- We're relying on the generator to fake AVVM and delegation. - genesisDelegation <- withExceptT MakeGenesisDelegationError $ - Genesis.mkGenesisDelegation [] + genesisDelegation <- + withExceptT MakeGenesisDelegationError $ + Genesis.mkGenesisDelegation [] withExceptT GenesisSpecError $ - ExceptT . pure $ Genesis.mkGenesisSpec - (Genesis.GenesisAvvmBalances mempty) - genesisDelegation - protocolParameters - (gpK gp) - (gpProtocolMagic gp) - (mkGenesisInitialiser True) - - where - mkGenesisInitialiser :: Bool -> Genesis.GenesisInitializer - mkGenesisInitialiser = - Genesis.GenesisInitializer + ExceptT . pure $ + Genesis.mkGenesisSpec + (Genesis.GenesisAvvmBalances mempty) + genesisDelegation + protocolParameters + (gpK gp) + (gpProtocolMagic gp) + (mkGenesisInitialiser True) + where + mkGenesisInitialiser :: Bool -> Genesis.GenesisInitializer + mkGenesisInitialiser = + Genesis.GenesisInitializer (gpTestnetBalance gp) (gpFakeAvvmOptions gp) (Common.lovelacePortionToRational (gpAvvmBalanceFactor gp)) @@ -144,18 +146,20 @@ mkGenesis gp = do Genesis.generateGenesisData (gpStartTime gp) genesisSpec -- | Read genesis from a file. -readGenesis :: GenesisFile - -> NetworkId - -> ExceptT ByronGenesisError IO Genesis.Config +readGenesis + :: GenesisFile + -> NetworkId + -> ExceptT ByronGenesisError IO Genesis.Config readGenesis (GenesisFile file) nw = firstExceptT (GenesisReadError file) $ do (genesisData, genesisHash) <- Genesis.readGenesisData file - return Genesis.Config { - Genesis.configGenesisData = genesisData, - Genesis.configGenesisHash = genesisHash, - Genesis.configReqNetMagic = toByronRequiresNetworkMagic nw, - Genesis.configUTxOConfiguration = UTxO.defaultUTxOConfiguration - } + return + Genesis.Config + { Genesis.configGenesisData = genesisData + , Genesis.configGenesisHash = genesisHash + , Genesis.configReqNetMagic = toByronRequiresNetworkMagic nw + , Genesis.configUTxOConfiguration = UTxO.defaultUTxOConfiguration + } -- | Write out genesis into a directory that must not yet exist. An error is -- thrown if the directory already exists, or the genesis has delegate keys that @@ -168,21 +172,30 @@ dumpGenesis dumpGenesis (NewDirectory outDir) genesisData gs = do exists <- liftIO $ doesPathExist outDir if exists - then left $ GenesisOutputDirAlreadyExists outDir - else liftIO $ createDirectory outDir + then left $ GenesisOutputDirAlreadyExists outDir + else liftIO $ createDirectory outDir liftIO $ LB.writeFile genesisJSONFile (canonicalEncodePretty genesisData) dlgCerts <- mapM (findDelegateCert . ByronSigningKey) $ gsRichSecrets gs - liftIO $ wOut "genesis-keys" "key" - serialiseToRawBytes - (map ByronSigningKey $ gsDlgIssuersSecrets gs) - liftIO $ wOut "delegate-keys" "key" - serialiseToRawBytes - (map ByronSigningKey $ gsRichSecrets gs) - liftIO $ wOut "poor-keys" "key" - serialiseToRawBytes - (map (ByronSigningKey . Genesis.poorSecretToKey) $ gsPoorSecrets gs) + liftIO $ + wOut + "genesis-keys" + "key" + serialiseToRawBytes + (map ByronSigningKey $ gsDlgIssuersSecrets gs) + liftIO $ + wOut + "delegate-keys" + "key" + serialiseToRawBytes + (map ByronSigningKey $ gsRichSecrets gs) + liftIO $ + wOut + "poor-keys" + "key" + serialiseToRawBytes + (map (ByronSigningKey . Genesis.poorSecretToKey) $ gsPoorSecrets gs) liftIO $ wOut "delegation-cert" "json" serialiseDelegationCert dlgCerts liftIO $ wOut "avvm-secrets" "secret" printFakeAvvmSecrets $ gsFakeAvvmSecrets gs where @@ -192,9 +205,12 @@ dumpGenesis (NewDirectory outDir) genesisData gs = do findDelegateCert :: SigningKey ByronKey -> ExceptT ByronGenesisError IO Certificate findDelegateCert bSkey@(ByronSigningKey sk) = case List.find (isCertForSK sk) (Map.elems dlgCertMap) of - Nothing -> left . NoGenesisDelegationForKey - . prettyPublicKey $ getVerificationKey bSkey - Just x -> right x + Nothing -> + left + . NoGenesisDelegationForKey + . prettyPublicKey + $ getVerificationKey bSkey + Just x -> right x genesisJSONFile :: FilePath genesisJSONFile = outDir <> "/genesis.json" diff --git a/cardano-cli/src/Cardano/CLI/Byron/Key.hs b/cardano-cli/src/Cardano/CLI/Byron/Key.hs index c743579831..50be69f03f 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Key.hs @@ -4,9 +4,9 @@ module Cardano.CLI.Byron.Key ( -- * Keys - ByronKeyFailure(..) - , NewSigningKeyFile(..) - , NewVerificationKeyFile(..) + ByronKeyFailure (..) + , NewSigningKeyFile (..) + , NewVerificationKeyFile (..) , VerificationKeyFile , prettyPublicKey , readByronSigningKey @@ -40,7 +40,7 @@ data ByronKeyFailure deriving Show renderByronKeyFailure :: ByronKeyFailure -> Doc ann -renderByronKeyFailure = \case +renderByronKeyFailure = \case CannotMigrateFromNonLegacySigningKey fp -> "Migrate from non-legacy Byron key unnecessary: " <> pshow fp ReadSigningKeyFailure sKeyFp readErr -> @@ -49,35 +49,44 @@ renderByronKeyFailure = \case "Error reading verification key at: " <> pshow vKeyFp <> " Error: " <> pshow readErr LegacySigningKeyDeserialisationFailed fp -> "Error attempting to deserialise a legacy signing key at: " <> pshow fp - SigningKeyDeserialisationFailed sKeyFp -> + SigningKeyDeserialisationFailed sKeyFp -> "Error deserialising signing key at: " <> pshow sKeyFp VerificationKeyDeserialisationFailed vKeyFp deSerError -> "Error deserialising verification key at: " <> pshow vKeyFp <> " Error: " <> pshow deSerError -newtype NewSigningKeyFile = - NewSigningKeyFile FilePath +newtype NewSigningKeyFile + = NewSigningKeyFile FilePath deriving (Eq, Ord, Show, IsString) -newtype NewVerificationKeyFile = - NewVerificationKeyFile FilePath - deriving (Eq, Ord, Show, IsString) +newtype NewVerificationKeyFile + = NewVerificationKeyFile FilePath + deriving (Eq, Ord, Show, IsString) -- | Print some invariant properties of a public key: -- its hash and formatted view. -prettyPublicKey :: VerificationKey ByronKey-> Text +prettyPublicKey :: VerificationKey ByronKey -> Text prettyPublicKey (ByronVerificationKey vk) = - sformat ( " public key hash: " % build % - "\npublic key (base64): " % Crypto.fullVerificationKeyF % - "\n public key (hex): " % Crypto.fullVerificationKeyHexF) - (Common.addressHash vk) vk vk + sformat + ( " public key hash: " + % build + % "\npublic key (base64): " + % Crypto.fullVerificationKeyF + % "\n public key (hex): " + % Crypto.fullVerificationKeyHexF + ) + (Common.addressHash vk) + vk + vk byronWitnessToVerKey :: SomeByronSigningKey -> VerificationKey ByronKey byronWitnessToVerKey (AByronSigningKeyLegacy sKeyLeg) = castVerificationKey $ getVerificationKey sKeyLeg byronWitnessToVerKey (AByronSigningKey sKeyNonLeg) = getVerificationKey sKeyNonLeg -- TODO: we need to support password-protected secrets. + -- | Read signing key from a file. -readByronSigningKey :: ByronKeyFormat -> SigningKeyFile In -> ExceptT ByronKeyFailure IO SomeByronSigningKey +readByronSigningKey + :: ByronKeyFormat -> SigningKeyFile In -> ExceptT ByronKeyFailure IO SomeByronSigningKey readByronSigningKey bKeyFormat (File fp) = do sK <- handleIOExceptT (ReadSigningKeyFailure fp . T.pack . displayException) $ SB.readFile fp case bKeyFormat of @@ -92,11 +101,11 @@ readByronSigningKey bKeyFormat (File fp) = do -- | Read verification key from a file. Throw an error if the file can't be read -- or the key fails to deserialise. -readPaymentVerificationKey :: VerificationKeyFile In -> ExceptT ByronKeyFailure IO Crypto.VerificationKey +readPaymentVerificationKey + :: VerificationKeyFile In -> ExceptT ByronKeyFailure IO Crypto.VerificationKey readPaymentVerificationKey (File fp) = do vkB <- handleIOExceptT (ReadVerificationKeyFailure fp . T.pack . displayException) (SB.readFile fp) -- Verification Key let eVk = hoistEither . Crypto.parseFullVerificationKey . fromString $ UTF8.toString vkB -- Convert error to 'CliError' firstExceptT (VerificationKeyDeserialisationFailed fp . T.pack . show) eVk - diff --git a/cardano-cli/src/Cardano/CLI/Byron/Legacy.hs b/cardano-cli/src/Cardano/CLI/Byron/Legacy.hs index 7df77c947e..e4925063b6 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Legacy.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Legacy.hs @@ -3,11 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cardano.CLI.Byron.Legacy ( - LegacyDelegateKey(..) - , encodeLegacyDelegateKey - , decodeLegacyDelegateKey - ) where +module Cardano.CLI.Byron.Legacy + ( LegacyDelegateKey (..) + , encodeLegacyDelegateKey + , decodeLegacyDelegateKey + ) +where import Cardano.Api (textShow) @@ -20,14 +21,13 @@ import Control.Monad (when) import Data.Text (Text) import Formatting (build, formatToString) - -- | LegacyDelegateKey is a subset of the UserSecret's from the legacy codebase: -- 1. the VSS keypair must be present -- 2. the signing key must be present -- 3. the rest must be absent (Nothing) -- -- Legacy reference: https://github.com/input-output-hk/cardano-sl/blob/release/3.0.1/lib/src/Pos/Util/UserSecret.hs#L189 -newtype LegacyDelegateKey = LegacyDelegateKey { lrkSigningKey :: SigningKey} +newtype LegacyDelegateKey = LegacyDelegateKey {lrkSigningKey :: SigningKey} encodeXPrv :: Wallet.XPrv -> E.Encoding encodeXPrv a = E.encodeBytes $ Wallet.unXPrv a @@ -37,42 +37,55 @@ decodeXPrv = either (fail . formatToString build) pure . Wallet.xprv =<< D.decodeBytesCanonical -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs + -- | Enforces that the input size is the same as the decoded one, failing in -- case it's not. enforceSize :: Text -> Int -> D.Decoder s () enforceSize lbl requestedSize = D.decodeListLenCanonical >>= matchSize requestedSize lbl -- Stolen from: cardano-sl/binary/src/Pos/Binary/Class/Core.hs + -- | Compare two sizes, failing if they are not equal. matchSize :: Int -> Text -> Int -> D.Decoder s () matchSize requestedSize lbl actualSize = when (actualSize /= requestedSize) $ - fail $ formatToString build (lbl <> " failed the size check. Expected " <> textShow requestedSize <> ", found " <> textShow actualSize) + fail $ + formatToString + build + ( lbl + <> " failed the size check. Expected " + <> textShow requestedSize + <> ", found " + <> textShow actualSize + ) -- | Encoder for a Byron/Classic signing key. -- Lifted from cardano-sl legacy codebase. encodeLegacyDelegateKey :: LegacyDelegateKey -> E.Encoding -encodeLegacyDelegateKey (LegacyDelegateKey (SigningKey sk)) - = E.encodeListLen 4 - <> E.encodeListLen 1 <> E.encodeBytes "vss deprecated" - <> E.encodeListLen 1 <> encodeXPrv sk - <> E.encodeListLenIndef <> E.encodeBreak - <> E.encodeListLen 0 +encodeLegacyDelegateKey (LegacyDelegateKey (SigningKey sk)) = + E.encodeListLen 4 + <> E.encodeListLen 1 + <> E.encodeBytes "vss deprecated" + <> E.encodeListLen 1 + <> encodeXPrv sk + <> E.encodeListLenIndef + <> E.encodeBreak + <> E.encodeListLen 0 -- | Decoder for a Byron/Classic signing key. -- Lifted from cardano-sl legacy codebase. decodeLegacyDelegateKey :: D.Decoder s LegacyDelegateKey decodeLegacyDelegateKey = do - enforceSize "UserSecret" 4 - _ <- do - enforceSize "vss" 1 - D.decodeBytes - pkey <- do - enforceSize "pkey" 1 - SigningKey <$> decodeXPrv - _ <- do - D.decodeListLenIndef - D.decodeSequenceLenIndef (flip (:)) [] reverse D.decodeNull - _ <- do - enforceSize "wallet" 0 - pure $ LegacyDelegateKey pkey + enforceSize "UserSecret" 4 + _ <- do + enforceSize "vss" 1 + D.decodeBytes + pkey <- do + enforceSize "pkey" 1 + SigningKey <$> decodeXPrv + _ <- do + D.decodeListLenIndef + D.decodeSequenceLenIndef (flip (:)) [] reverse D.decodeNull + _ <- do + enforceSize "wallet" 0 + pure $ LegacyDelegateKey pkey diff --git a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs index 39039aa0e6..96f545843a 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} module Cardano.CLI.Byron.Parsers - ( ByronCommand(..) - , NodeCmds(..) + ( ByronCommand (..) + , NodeCmds (..) , backwardsCompatibilityCommands , parseByronCommands , parseHeavyDelThd @@ -21,8 +21,8 @@ module Cardano.CLI.Byron.Parsers , parseUpdateProposalTTL , parseUnlockStakeEpoch , parseUpdateVoteThd - ) where - + ) +where import Cardano.Api hiding (GenesisParameters, UpdateProposal) import Cardano.Api.Byron (Address (..), ByronProtocolParametersUpdate (..), @@ -72,148 +72,166 @@ import qualified Options.Applicative as Opt backwardsCompatibilityCommands :: EnvCli -> Parser ClientCommand backwardsCompatibilityCommands envCli = asum hiddenCmds - - where - convertToByronCommand :: Mod CommandFields ByronCommand -> Parser ClientCommand - convertToByronCommand p = ByronCommand <$> Opt.subparser (p <> Opt.internal) - - hiddenCmds :: [Parser ClientCommand] - hiddenCmds = - concatMap (fmap convertToByronCommand) - [ parseGenesisRelatedValues - , parseKeyRelatedValues envCli - , parseTxRelatedValues envCli - , parseMiscellaneous - ] + where + convertToByronCommand :: Mod CommandFields ByronCommand -> Parser ClientCommand + convertToByronCommand p = ByronCommand <$> Opt.subparser (p <> Opt.internal) + + hiddenCmds :: [Parser ClientCommand] + hiddenCmds = + concatMap + (fmap convertToByronCommand) + [ parseGenesisRelatedValues + , parseKeyRelatedValues envCli + , parseTxRelatedValues envCli + , parseMiscellaneous + ] -- Implemented with asum so all commands don't get hidden when trying to hide -- the 'pNodeCmdBackwardCompatible' parser. parseByronCommands :: EnvCli -> Parser ByronCommand -parseByronCommands envCli = asum - [ subParser' "key" (Opt.info (asum $ map Opt.subparser (parseKeyRelatedValues envCli)) - $ Opt.progDesc "Byron key utility commands") - , subParser' "transaction" (Opt.info (asum $ map Opt.subparser (parseTxRelatedValues envCli)) - $ Opt.progDesc "Byron transaction commands") - , subParser' "genesis" (Opt.info (asum $ map Opt.subparser parseGenesisRelatedValues) - $ Opt.progDesc "Byron genesis block commands") - , subParser' "governance" (Opt.info (NodeCmds <$> Opt.subparser (pNodeCmds envCli)) - $ Opt.progDesc "Byron governance commands") - , subParser' "miscellaneous" (Opt.info (asum $ map Opt.subparser parseMiscellaneous) - $ Opt.progDesc "Byron miscellaneous commands") - , NodeCmds <$> pNodeCmdBackwardCompatible envCli - ] +parseByronCommands envCli = + asum + [ subParser' + "key" + ( Opt.info (asum $ map Opt.subparser (parseKeyRelatedValues envCli)) $ + Opt.progDesc "Byron key utility commands" + ) + , subParser' + "transaction" + ( Opt.info (asum $ map Opt.subparser (parseTxRelatedValues envCli)) $ + Opt.progDesc "Byron transaction commands" + ) + , subParser' + "genesis" + ( Opt.info (asum $ map Opt.subparser parseGenesisRelatedValues) $ + Opt.progDesc "Byron genesis block commands" + ) + , subParser' + "governance" + ( Opt.info (NodeCmds <$> Opt.subparser (pNodeCmds envCli)) $ + Opt.progDesc "Byron governance commands" + ) + , subParser' + "miscellaneous" + ( Opt.info (asum $ map Opt.subparser parseMiscellaneous) $ + Opt.progDesc "Byron miscellaneous commands" + ) + , NodeCmds <$> pNodeCmdBackwardCompatible envCli + ] where - subParser' :: String -> ParserInfo ByronCommand -> Parser ByronCommand - subParser' name pInfo = Opt.subparser $ Opt.command name pInfo <> Opt.metavar name + subParser' :: String -> ParserInfo ByronCommand -> Parser ByronCommand + subParser' name pInfo = Opt.subparser $ Opt.command name pInfo <> Opt.metavar name pNodeCmdBackwardCompatible :: EnvCli -> Parser NodeCmds pNodeCmdBackwardCompatible envCli = Opt.subparser $ pNodeCmds envCli <> Opt.internal parseCBORObject :: Parser CBORObject -parseCBORObject = asum - [ CBORBlockByron <$> Opt.option auto - ( long "byron-block" - <> help - ( "The CBOR file is a byron era block." - <> " Enter the number of slots in an epoch. The default value is 21600") - <> metavar "INT" - <> value (EpochSlots 21600) - ) - - , flag' CBORDelegationCertificateByron $ +parseCBORObject = + asum + [ CBORBlockByron + <$> Opt.option + auto + ( long "byron-block" + <> help + ( "The CBOR file is a byron era block." + <> " Enter the number of slots in an epoch. The default value is 21600" + ) + <> metavar "INT" + <> value (EpochSlots 21600) + ) + , flag' CBORDelegationCertificateByron $ long "byron-delegation-certificate" - <> help "The CBOR file is a byron era delegation certificate" - - , flag' CBORTxByron $ + <> help "The CBOR file is a byron era delegation certificate" + , flag' CBORTxByron $ long "byron-tx" - <> help "The CBOR file is a byron era tx" - - , flag' CBORUpdateProposalByron $ + <> help "The CBOR file is a byron era tx" + , flag' CBORUpdateProposalByron $ long "byron-update-proposal" - <> help "The CBOR file is a byron era update proposal" - , flag' CBORVoteByron $ + <> help "The CBOR file is a byron era update proposal" + , flag' CBORVoteByron $ long "byron-vote" - <> help "The CBOR file is a byron era vote" - ] + <> help "The CBOR file is a byron era vote" + ] -- | Values required to create genesis. parseGenesisParameters :: Parser GenesisParameters parseGenesisParameters = GenesisParameters <$> parseUTCTime - "start-time" - "Start time of the new cluster to be enshrined in the new genesis." + "start-time" + "Start time of the new cluster to be enshrined in the new genesis." <*> parseFilePath - "protocol-parameters-file" - "JSON file with protocol parameters." + "protocol-parameters-file" + "JSON file with protocol parameters." <*> parseK <*> parseProtocolMagic <*> parseTestnetBalanceOptions <*> parseFakeAvvmOptions - <*> (rationalToLovelacePortion <$> - parseFractionWithDefault - "avvm-balance-factor" - "AVVM balances will be multiplied by this factor (defaults to 1)." - 1) - <*> optional - ( parseIntegral - "secret-seed" - "Optionally specify the seed of generation." + <*> ( rationalToLovelacePortion + <$> parseFractionWithDefault + "avvm-balance-factor" + "AVVM balances will be multiplied by this factor (defaults to 1)." + 1 ) + <*> optional + ( parseIntegral + "secret-seed" + "Optionally specify the seed of generation." + ) parseGenesisRelatedValues :: [Mod CommandFields ByronCommand] parseGenesisRelatedValues = - [ command' "genesis" "Create genesis." - $ Genesis - <$> parseNewDirectory - "genesis-output-dir" - "Non-existent directory where genesis JSON file and secrets shall be placed." - <*> parseGenesisParameters - , command' "print-genesis-hash" "Compute hash of a genesis file." - $ PrintGenesisHash - <$> parseGenesisFile "genesis-json" - ] + [ command' "genesis" "Create genesis." $ + Genesis + <$> parseNewDirectory + "genesis-output-dir" + "Non-existent directory where genesis JSON file and secrets shall be placed." + <*> parseGenesisParameters + , command' "print-genesis-hash" "Compute hash of a genesis file." $ + PrintGenesisHash + <$> parseGenesisFile "genesis-json" + ] -- | Values required to create keys and perform -- transformation on keys. parseKeyRelatedValues :: EnvCli -> [Mod CommandFields ByronCommand] parseKeyRelatedValues envCli = - [ command' "keygen" "Generate a signing key." - $ Keygen - <$> parseNewSigningKeyFile "secret" - , command' - "to-verification" - "Extract a verification key in its base64 form." - $ ToVerification - <$> parseByronKeyFormat - <*> parseSigningKeyFile - "secret" - "Signing key file to extract the verification part from." - <*> parseNewVerificationKeyFile "to" - , command' - "signing-key-public" - "Pretty-print a signing key's verification key (not a secret)." - $ PrettySigningKeyPublic - <$> parseByronKeyFormat - <*> parseSigningKeyFile - "secret" - "Signing key to pretty-print." - , command' - "signing-key-address" - "Print address of a signing key." - $ PrintSigningKeyAddress - <$> parseByronKeyFormat - <*> pNetworkId envCli - <*> parseSigningKeyFile - "secret" - "Signing key, whose address is to be printed." - , command' - "migrate-delegate-key-from" - "Migrate a delegate key from an older version." - $ MigrateDelegateKeyFrom - <$> parseSigningKeyFile "from" "Legacy signing key file to migrate." - <*> parseNewSigningKeyFile "to" - ] + [ command' "keygen" "Generate a signing key." $ + Keygen + <$> parseNewSigningKeyFile "secret" + , command' + "to-verification" + "Extract a verification key in its base64 form." + $ ToVerification + <$> parseByronKeyFormat + <*> parseSigningKeyFile + "secret" + "Signing key file to extract the verification part from." + <*> parseNewVerificationKeyFile "to" + , command' + "signing-key-public" + "Pretty-print a signing key's verification key (not a secret)." + $ PrettySigningKeyPublic + <$> parseByronKeyFormat + <*> parseSigningKeyFile + "secret" + "Signing key to pretty-print." + , command' + "signing-key-address" + "Print address of a signing key." + $ PrintSigningKeyAddress + <$> parseByronKeyFormat + <*> pNetworkId envCli + <*> parseSigningKeyFile + "secret" + "Signing key, whose address is to be printed." + , command' + "migrate-delegate-key-from" + "Migrate a delegate key from an older version." + $ MigrateDelegateKeyFrom + <$> parseSigningKeyFile "from" "Legacy signing key file to migrate." + <*> parseNewSigningKeyFile "to" + ] parseMiscellaneous :: [Mod CommandFields ByronCommand] parseMiscellaneous = @@ -221,44 +239,44 @@ parseMiscellaneous = "validate-cbor" "Validate a CBOR blockchain object." $ ValidateCBOR - <$> parseCBORObject - <*> parseFilePath "filepath" "Filepath of CBOR file." + <$> parseCBORObject + <*> parseFilePath "filepath" "Filepath of CBOR file." , command' "pretty-print-cbor" "Pretty print a CBOR file." $ PrettyPrintCBOR - <$> parseFilePath "filepath" "Filepath of CBOR file." + <$> parseFilePath "filepath" "Filepath of CBOR file." ] parseTestnetBalanceOptions :: Parser TestnetBalanceOptions parseTestnetBalanceOptions = TestnetBalanceOptions <$> parseIntegral - "n-poor-addresses" - "Number of poor nodes (with small balance)." + "n-poor-addresses" + "Number of poor nodes (with small balance)." <*> parseIntegral - "n-delegate-addresses" - "Number of delegate nodes (with huge balance)." + "n-delegate-addresses" + "Number of delegate nodes (with huge balance)." <*> parseLovelace - "total-balance" - "Total balance owned by these nodes." + "total-balance" + "Total balance owned by these nodes." <*> parseFraction - "delegate-share" - "Portion of stake owned by all delegates together." + "delegate-share" + "Portion of stake owned by all delegates together." parseTxIn :: Parser TxIn parseTxIn = Opt.option - (readerFromAttoParser parseTxInAtto) - $ long "txin" - <> metavar "(TXID,INDEX)" - <> help "Transaction input is a pair of an UTxO TxId and a zero-based output index." + (readerFromAttoParser parseTxInAtto) + $ long "txin" + <> metavar "(TXID,INDEX)" + <> help "Transaction input is a pair of an UTxO TxId and a zero-based output index." parseTxInAtto :: Atto.Parser TxIn parseTxInAtto = - TxIn <$> (Atto.char '(' *> parseTxIdAtto <* Atto.char ',') - <*> (parseTxIxAtto <* Atto.char ')') - + TxIn + <$> (Atto.char '(' *> parseTxIdAtto <* Atto.char ',') + <*> (parseTxIxAtto <* Atto.char ')') parseTxIdAtto :: Atto.Parser TxId parseTxIdAtto = ( "Transaction ID (hexadecimal)") $ do @@ -273,11 +291,14 @@ parseTxIxAtto = toEnum <$> Atto.decimal parseTxOut :: Parser (TxOut CtxTx ByronEra) parseTxOut = Opt.option - ( (\(addr, lovelace) -> TxOut (pAddressInEra addr) - (pLovelaceTxOut lovelace) - TxOutDatumNone - ReferenceScriptNone) - <$> auto + ( ( \(addr, lovelace) -> + TxOut + (pAddressInEra addr) + (pLovelaceTxOut lovelace) + TxOutDatumNone + ReferenceScriptNone + ) + <$> auto ) $ long "txout" <> metavar "'(\"ADDR\", LOVELACE)'" @@ -301,60 +322,62 @@ readerFromAttoParser p = parseTxRelatedValues :: EnvCli -> [Mod CommandFields ByronCommand] parseTxRelatedValues envCli = - [ command' - "submit-tx" - "Submit a raw, signed transaction, in its on-wire representation." - $ SubmitTx - <$> pSocketPath envCli - <*> pNetworkId envCli - <*> parseTxFile "tx" - , command' - "issue-genesis-utxo-expenditure" - "Write a file with a signed transaction, spending genesis UTxO." - $ SpendGenesisUTxO - <$> parseGenesisFile "genesis-json" - <*> pNetworkId envCli - <*> parseByronKeyFormat - <*> parseNewTxFile "tx" - <*> parseSigningKeyFile - "wallet-key" - "Key that has access to all mentioned genesis UTxO inputs." - <*> parseAddress - "rich-addr-from" - "Tx source: genesis UTxO richman address (non-HD)." - <*> some parseTxOut - - , command' - "issue-utxo-expenditure" - "Write a file with a signed transaction, spending normal UTxO." - $ SpendUTxO - <$> pNetworkId envCli - <*> parseByronKeyFormat - <*> parseNewTxFile "tx" - <*> parseSigningKeyFile - "wallet-key" - "Key that has access to all mentioned genesis UTxO inputs." - <*> some parseTxIn - <*> some parseTxOut - - , command' - "txid" - "Print the txid of a raw, signed transaction." - $ GetTxId - <$> parseTxFile "tx" - ] + [ command' + "submit-tx" + "Submit a raw, signed transaction, in its on-wire representation." + $ SubmitTx + <$> pSocketPath envCli + <*> pNetworkId envCli + <*> parseTxFile "tx" + , command' + "issue-genesis-utxo-expenditure" + "Write a file with a signed transaction, spending genesis UTxO." + $ SpendGenesisUTxO + <$> parseGenesisFile "genesis-json" + <*> pNetworkId envCli + <*> parseByronKeyFormat + <*> parseNewTxFile "tx" + <*> parseSigningKeyFile + "wallet-key" + "Key that has access to all mentioned genesis UTxO inputs." + <*> parseAddress + "rich-addr-from" + "Tx source: genesis UTxO richman address (non-HD)." + <*> some parseTxOut + , command' + "issue-utxo-expenditure" + "Write a file with a signed transaction, spending normal UTxO." + $ SpendUTxO + <$> pNetworkId envCli + <*> parseByronKeyFormat + <*> parseNewTxFile "tx" + <*> parseSigningKeyFile + "wallet-key" + "Key that has access to all mentioned genesis UTxO inputs." + <*> some parseTxIn + <*> some parseTxOut + , command' + "txid" + "Print the txid of a raw, signed transaction." + $ GetTxId + <$> parseTxFile "tx" + ] pNodeCmds :: EnvCli -> Mod CommandFields NodeCmds pNodeCmds envCli = mconcat [ Opt.command "create-update-proposal" $ - Opt.info (parseByronUpdateProposal envCli) $ Opt.progDesc "Create an update proposal." + Opt.info (parseByronUpdateProposal envCli) $ + Opt.progDesc "Create an update proposal." , Opt.command "create-proposal-vote" $ - Opt.info (parseByronVote envCli) $ Opt.progDesc "Create an update proposal vote." + Opt.info (parseByronVote envCli) $ + Opt.progDesc "Create an update proposal vote." , Opt.command "submit-update-proposal" $ - Opt.info (parseByronUpdateProposalSubmission envCli) $ Opt.progDesc "Submit an update proposal." + Opt.info (parseByronUpdateProposalSubmission envCli) $ + Opt.progDesc "Submit an update proposal." , Opt.command "submit-proposal-vote" $ - Opt.info (parseByronVoteSubmission envCli) $ Opt.progDesc "Submit a proposal vote." + Opt.info (parseByronVoteSubmission envCli) $ + Opt.progDesc "Submit a proposal vote." ] parseByronUpdateProposal :: EnvCli -> Parser NodeCmds @@ -376,7 +399,6 @@ parseByronVoteSubmission envCli = do <*> pNetworkId envCli <*> parseFilePath "filepath" "Filepath of Byron update proposal vote." - pByronProtocolParametersUpdate :: Parser ByronProtocolParametersUpdate pByronProtocolParametersUpdate = ByronProtocolParametersUpdate @@ -417,72 +439,81 @@ parseByronVote envCli = parseScriptVersion :: Parser Word16 parseScriptVersion = - Opt.option auto + Opt.option + auto ( long "script-version" - <> metavar "WORD16" - <> help "Proposed script version." + <> metavar "WORD16" + <> help "Proposed script version." ) parseSlotDuration :: Parser Natural parseSlotDuration = - Opt.option auto + Opt.option + auto ( long "slot-duration" - <> metavar "NATURAL" - <> help "Proposed slot duration." + <> metavar "NATURAL" + <> help "Proposed slot duration." ) parseSystemTag :: Parser SystemTag -parseSystemTag = Opt.option (eitherReader checkSysTag) - ( long "system-tag" - <> metavar "STRING" - <> help "Identify which system (linux, win64, etc) the update proposal is for." - ) +parseSystemTag = + Opt.option + (eitherReader checkSysTag) + ( long "system-tag" + <> metavar "STRING" + <> help "Identify which system (linux, win64, etc) the update proposal is for." + ) where checkSysTag :: String -> Either String SystemTag checkSysTag name = let tag = SystemTag $ Text.pack name - in case checkSystemTag tag of - Left err -> Left . Text.unpack $ sformat build err - Right () -> Right tag + in case checkSystemTag tag of + Left err -> Left . Text.unpack $ sformat build err + Right () -> Right tag parseInstallerHash :: Parser InstallerHash parseInstallerHash = - InstallerHash . hashRaw . C8.pack - <$> strOption ( long "installer-hash" - <> metavar "HASH" - <> help "Software hash." - ) + InstallerHash . hashRaw . C8.pack + <$> strOption + ( long "installer-hash" + <> metavar "HASH" + <> help "Software hash." + ) parseMaxBlockSize :: Parser Natural parseMaxBlockSize = - Opt.option auto + Opt.option + auto ( long "max-block-size" - <> metavar "NATURAL" - <> help "Proposed max block size." + <> metavar "NATURAL" + <> help "Proposed max block size." ) parseMaxHeaderSize :: Parser Natural parseMaxHeaderSize = - Opt.option auto + Opt.option + auto ( long "max-header-size" - <> metavar "NATURAL" - <> help "Proposed max block header size." + <> metavar "NATURAL" + <> help "Proposed max block header size." ) parseMaxTxSize :: Parser Natural parseMaxTxSize = - Opt.option auto + Opt.option + auto ( long "max-tx-size" - <> metavar "NATURAL" - <> help "Proposed max transaction size." + <> metavar "NATURAL" + <> help "Proposed max transaction size." ) -parseMaxProposalSize :: Parser Natural +parseMaxProposalSize :: Parser Natural parseMaxProposalSize = - Opt.option auto + Opt.option + auto ( long "max-proposal-size" - <> metavar "NATURAL" - <> help "Proposed max update proposal size." + <> metavar "NATURAL" + <> help "Proposed max update proposal size." ) parseMpcThd :: Parser Byron.LovelacePortion @@ -492,9 +523,10 @@ parseMpcThd = parseProtocolVersion :: Parser ProtocolVersion parseProtocolVersion = - ProtocolVersion <$> (parseWord "protocol-version-major" "Protocol version major." "WORD16" :: Parser Word16) - <*> (parseWord "protocol-version-minor" "Protocol version minor." "WORD16" :: Parser Word16) - <*> (parseWord "protocol-version-alt" "Protocol version alt." "WORD8" :: Parser Word8) + ProtocolVersion + <$> (parseWord "protocol-version-major" "Protocol version major." "WORD16" :: Parser Word16) + <*> (parseWord "protocol-version-minor" "Protocol version minor." "WORD16" :: Parser Word16) + <*> (parseWord "protocol-version-alt" "Protocol version alt." "WORD8" :: Parser Word8) parseHeavyDelThd :: Parser Byron.LovelacePortion parseHeavyDelThd = @@ -514,37 +546,47 @@ parseUpdateProposalThd = parseUpdateProposalTTL :: Parser SlotNumber parseUpdateProposalTTL = SlotNumber - <$> Opt.option auto - ( long "time-to-live" + <$> Opt.option + auto + ( long "time-to-live" <> metavar "WORD64" <> help "Proposed time for an update proposal to live." - ) + ) parseSoftforkRule :: Parser SoftforkRule parseSoftforkRule = SoftforkRule - <$> (rationalToLovelacePortion <$> parseFraction "softfork-init-thd" "Propose initial threshold (right after proposal is confirmed).") - <*> (rationalToLovelacePortion <$> parseFraction "softfork-min-thd" "Propose minimum threshold (threshold can't be less than this).") - <*> (rationalToLovelacePortion <$> parseFraction "softfork-thd-dec" "Propose threshold decrement (threshold will decrease by this amount after each epoch).") - + <$> ( rationalToLovelacePortion + <$> parseFraction "softfork-init-thd" "Propose initial threshold (right after proposal is confirmed)." + ) + <*> ( rationalToLovelacePortion + <$> parseFraction "softfork-min-thd" "Propose minimum threshold (threshold can't be less than this)." + ) + <*> ( rationalToLovelacePortion + <$> parseFraction + "softfork-thd-dec" + "Propose threshold decrement (threshold will decrease by this amount after each epoch)." + ) parseSoftwareVersion :: Parser SoftwareVersion parseSoftwareVersion = SoftwareVersion <$> parseApplicationName <*> parseNumSoftwareVersion parseApplicationName :: Parser ApplicationName -parseApplicationName = Opt.option (eitherReader checkAppNameLength) - ( long "application-name" - <> metavar "STRING" - <> help "The name of the application." - ) +parseApplicationName = + Opt.option + (eitherReader checkAppNameLength) + ( long "application-name" + <> metavar "STRING" + <> help "The name of the application." + ) where checkAppNameLength :: String -> Either String ApplicationName checkAppNameLength name = let appName = ApplicationName $ Text.pack name - in case checkApplicationName appName of - Left err -> Left . Text.unpack $ sformat build err - Right () -> Right appName + in case checkApplicationName appName of + Left err -> Left . Text.unpack $ sformat build err + Right () -> Right appName parseNumSoftwareVersion :: Parser NumSoftwareVersion parseNumSoftwareVersion = @@ -556,53 +598,51 @@ parseNumSoftwareVersion = parseTxFeePolicy :: Parser TxFeePolicy parseTxFeePolicy = TxFeePolicyTxSizeLinear - <$> ( TxSizeLinear <$> parseLovelace "tx-fee-a-constant" "Propose the constant a for txfee = a + b*s where s is the size." - <*> parseFraction "tx-fee-b-constant" "Propose the constant b for txfee = a + b*s where s is the size." + <$> ( TxSizeLinear + <$> parseLovelace "tx-fee-a-constant" "Propose the constant a for txfee = a + b*s where s is the size." + <*> parseFraction "tx-fee-b-constant" "Propose the constant b for txfee = a + b*s where s is the size." ) parseVoteBool :: Parser Bool -parseVoteBool = flag' True (long "vote-yes" <> help "Vote yes with respect to an update proposal.") - <|> flag' False (long "vote-no" <> help "Vote no with respect to an update proposal.") +parseVoteBool = + flag' True (long "vote-yes" <> help "Vote yes with respect to an update proposal.") + <|> flag' False (long "vote-no" <> help "Vote no with respect to an update proposal.") parseUnlockStakeEpoch :: Parser EpochNumber parseUnlockStakeEpoch = EpochNumber - <$> Opt.option auto + <$> Opt.option + auto ( long "unlock-stake-epoch" - <> metavar "WORD64" - <> help "Proposed epoch to unlock all stake." + <> metavar "WORD64" + <> help "Proposed epoch to unlock all stake." ) - parseWord :: Integral a => String -> String -> String -> Parser a -parseWord optname desc metvar = Opt.option (fromInteger <$> auto) - $ long optname <> metavar metvar <> help desc - - +parseWord optname desc metvar = + Opt.option (fromInteger <$> auto) $ + long optname <> metavar metvar <> help desc parseAddress :: String -> String -> Parser (Address ByronAddr) parseAddress opt desc = - Opt.option (cliParseBase58Address <$> str) - $ long opt <> metavar "ADDR" <> help desc + Opt.option (cliParseBase58Address <$> str) $ + long opt <> metavar "ADDR" <> help desc parseByronKeyFormat :: Parser ByronKeyFormat -parseByronKeyFormat = asum - [ flag' LegacyByronKeyFormat $ +parseByronKeyFormat = + asum + [ flag' LegacyByronKeyFormat $ long "byron-legacy-formats" - <> help "Byron/cardano-sl formats and compatibility" - - , flag' NonLegacyByronKeyFormat $ + <> help "Byron/cardano-sl formats and compatibility" + , flag' NonLegacyByronKeyFormat $ long "byron-formats" - <> help "Byron era formats and compatibility" - - -- And hidden compatibility flag aliases that should be deprecated: - , flag' LegacyByronKeyFormat $ hidden <> long "byron-legacy" - , flag' NonLegacyByronKeyFormat $ hidden <> long "real-pbft" - - -- Default Byron key format - , pure NonLegacyByronKeyFormat - ] - + <> help "Byron era formats and compatibility" + , -- And hidden compatibility flag aliases that should be deprecated: + flag' LegacyByronKeyFormat $ hidden <> long "byron-legacy" + , flag' NonLegacyByronKeyFormat $ hidden <> long "real-pbft" + , -- Default Byron key format + pure NonLegacyByronKeyFormat + ] parseFakeAvvmOptions :: Parser FakeAvvmOptions parseFakeAvvmOptions = @@ -624,12 +664,14 @@ parseFractionWithDefault -> Double -> Parser Rational parseFractionWithDefault optname desc w = - toRational <$> Opt.option readDouble - ( long optname - <> metavar "DOUBLE" - <> help desc - <> value w - ) + toRational + <$> Opt.option + readDouble + ( long optname + <> metavar "DOUBLE" + <> help desc + <> value w + ) parseNewSigningKeyFile :: String -> Parser NewSigningKeyFile parseNewSigningKeyFile opt = @@ -663,8 +705,8 @@ parseTxFile opt = parseUTCTime :: String -> String -> Parser UTCTime parseUTCTime optname desc = - Opt.option (posixSecondsToUTCTime . fromInteger <$> auto) - $ long optname <> metavar "POSIXSECONDS" <> help desc + Opt.option (posixSecondsToUTCTime . fromInteger <$> auto) $ + long optname <> metavar "POSIXSECONDS" <> help desc cliParseBase58Address :: Text -> Address ByronAddr cliParseBase58Address t = @@ -675,30 +717,32 @@ cliParseBase58Address t = parseFraction :: String -> String -> Parser Rational parseFraction optname desc = Opt.option (toRational <$> readDouble) $ - long optname - <> metavar "DOUBLE" - <> help desc + long optname + <> metavar "DOUBLE" + <> help desc parseIntegral :: Integral a => String -> String -> Parser a -parseIntegral optname desc = Opt.option (fromInteger <$> auto) - $ long optname <> metavar "INT" <> help desc +parseIntegral optname desc = + Opt.option (fromInteger <$> auto) $ + long optname <> metavar "INT" <> help desc parseLovelace :: String -> String -> Parser Byron.Lovelace parseLovelace optname desc = - Opt.option (readerFromAttoParser parseLovelaceAtto) - ( long optname - <> metavar "INT" - <> help desc + Opt.option + (readerFromAttoParser parseLovelaceAtto) + ( long optname + <> metavar "INT" + <> help desc ) where parseLovelaceAtto :: Atto.Parser Byron.Lovelace parseLovelaceAtto = do i <- Atto.decimal if i > toInteger (maxBound :: Word64) - then fail $ show i <> " lovelace exceeds the Word64 upper bound" - else case toByronLovelace $ L.Coin i of - Just byronLovelace -> return byronLovelace - Nothing -> error $ "Error converting lovelace: " <> show i + then fail $ show i <> " lovelace exceeds the Word64 upper bound" + else case toByronLovelace $ L.Coin i of + Just byronLovelace -> return byronLovelace + Nothing -> error $ "Error converting lovelace: " <> show i readDouble :: ReadM Double readDouble = do @@ -710,8 +754,6 @@ readDouble = do parseSigningKeyFile :: String -> String -> Parser (SigningKeyFile In) parseSigningKeyFile opt desc = File <$> parseFilePath opt desc - parseGenesisFile :: String -> Parser GenesisFile parseGenesisFile opt = GenesisFile <$> parseFilePath opt "Genesis JSON file." - diff --git a/cardano-cli/src/Cardano/CLI/Byron/Run.hs b/cardano-cli/src/Cardano/CLI/Byron/Run.hs index d97d98713a..e03c11cbc5 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Run.hs @@ -6,7 +6,8 @@ module Cardano.CLI.Byron.Run ( ByronClientCmdError , renderByronClientCmdError , runByronClientCommand - ) where + ) +where import Cardano.Api hiding (GenesisParameters, UpdateProposal) import Cardano.Api.Byron (SomeByronSigningKey (..), serializeByronTx) @@ -63,7 +64,7 @@ runByronClientCommand c = PrettyPrintCBOR fp -> runPrettyPrintCBOR fp PrettySigningKeyPublic bKeyFormat skF -> runPrettySigningKeyPublic bKeyFormat skF MigrateDelegateKeyFrom oldKey nskf -> - runMigrateDelegateKeyFrom oldKey nskf + runMigrateDelegateKeyFrom oldKey nskf PrintGenesisHash genFp -> runPrintGenesisHash genFp PrintSigningKeyAddress bKeyFormat networkid skF -> runPrintSigningKeyAddress bKeyFormat networkid skF Keygen nskf -> runKeygen nskf @@ -75,21 +76,17 @@ runByronClientCommand c = SpendUTxO nw era nftx ctKey ins outs -> runSpendUTxO nw era nftx ctKey ins outs - runNodeCmds :: NodeCmds -> ExceptT ByronClientCmdError IO () runNodeCmds (CreateVote nw sKey upPropFp voteBool outputFp) = firstExceptT ByronCmdVoteError $ runVoteCreation nw sKey upPropFp voteBool outputFp - runNodeCmds (SubmitUpdateProposal nodeSocketPath network proposalFp) = do - firstExceptT ByronCmdUpdateProposalError - $ submitByronUpdateProposal nodeSocketPath network proposalFp - + firstExceptT ByronCmdUpdateProposalError $ + submitByronUpdateProposal nodeSocketPath network proposalFp runNodeCmds (SubmitVote nodeSocketPath network voteFp) = do firstExceptT ByronCmdVoteError $ submitByronVote nodeSocketPath network voteFp - runNodeCmds (UpdateProposal nw sKey pVer sVer sysTag insHash outputFp params) = - firstExceptT ByronCmdUpdateProposalError - $ runProposalCreation nw sKey pVer sVer sysTag insHash outputFp params + firstExceptT ByronCmdUpdateProposalError $ + runProposalCreation nw sKey pVer sVer sysTag insHash outputFp params runGenesisCommand :: NewDirectory -> GenesisParameters -> ExceptT ByronClientCmdError IO () runGenesisCommand outDir params = do @@ -107,7 +104,8 @@ runPrettyPrintCBOR fp = do bs <- firstExceptT ByronCmdHelpersError $ readCBOR fp firstExceptT ByronCmdHelpersError $ pPrintCBOR bs -runPrettySigningKeyPublic :: ByronKeyFormat -> SigningKeyFile In -> ExceptT ByronClientCmdError IO () +runPrettySigningKeyPublic + :: ByronKeyFormat -> SigningKeyFile In -> ExceptT ByronClientCmdError IO () runPrettySigningKeyPublic bKeyFormat skF = do sK <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey bKeyFormat skF liftIO . Text.putStrLn . prettyPublicKey $ byronWitnessToVerKey sK @@ -120,27 +118,29 @@ runMigrateDelegateKeyFrom runMigrateDelegateKeyFrom oldKey@(File fp) (NewSigningKeyFile newKey) = do sk <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey LegacyByronKeyFormat oldKey migratedWitness <- case sk of - AByronSigningKeyLegacy (ByronSigningKeyLegacy sKey) -> - return . AByronSigningKey $ ByronSigningKey sKey - AByronSigningKey _ -> - left . ByronCmdKeyFailure $ CannotMigrateFromNonLegacySigningKey fp + AByronSigningKeyLegacy (ByronSigningKeyLegacy sKey) -> + return . AByronSigningKey $ ByronSigningKey sKey + AByronSigningKey _ -> + left . ByronCmdKeyFailure $ CannotMigrateFromNonLegacySigningKey fp firstExceptT ByronCmdHelpersError . ensureNewFileLBS newKey $ serialiseByronWitness migratedWitness runPrintGenesisHash :: GenesisFile -> ExceptT ByronClientCmdError IO () runPrintGenesisHash genFp = do - genesis <- firstExceptT ByronCmdGenesisError $ - readGenesis genFp dummyNetwork - liftIO . Text.putStrLn $ formatter genesis - where - -- For this purpose of getting the hash, it does not matter what network - -- value we use here. - dummyNetwork :: NetworkId - dummyNetwork = Mainnet - - formatter :: Genesis.Config -> Text - formatter = F.sformat Crypto.hashHexF - . Genesis.unGenesisHash - . Genesis.configGenesisHash + genesis <- + firstExceptT ByronCmdGenesisError $ + readGenesis genFp dummyNetwork + liftIO . Text.putStrLn $ formatter genesis + where + -- For this purpose of getting the hash, it does not matter what network + -- value we use here. + dummyNetwork :: NetworkId + dummyNetwork = Mainnet + + formatter :: Genesis.Config -> Text + formatter = + F.sformat Crypto.hashHexF + . Genesis.unGenesisHash + . Genesis.configGenesisHash runPrintSigningKeyAddress :: ByronKeyFormat @@ -153,18 +153,19 @@ runPrintSigningKeyAddress bKeyFormat networkid skF = do liftIO $ Text.putStrLn sKeyAddr runKeygen :: NewSigningKeyFile -> ExceptT ByronClientCmdError IO () -runKeygen (NewSigningKeyFile skF) = do +runKeygen (NewSigningKeyFile skF) = do sK <- generateSigningKey AsByronKey firstExceptT ByronCmdHelpersError . ensureNewFileLBS skF $ serialiseToRawBytes sK -runToVerification :: ByronKeyFormat -> SigningKeyFile In -> NewVerificationKeyFile -> ExceptT ByronClientCmdError IO () +runToVerification + :: ByronKeyFormat -> SigningKeyFile In -> NewVerificationKeyFile -> ExceptT ByronClientCmdError IO () runToVerification bKeyFormat skFp (NewVerificationKeyFile vkFp) = do sk <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey bKeyFormat skFp let ByronVerificationKey vK = byronWitnessToVerKey sk let vKey = Builder.toLazyText $ Crypto.formatFullVerificationKey vK firstExceptT ByronCmdHelpersError $ ensureNewFile TL.writeFile vkFp vKey -runSubmitTx ::SocketPath -> NetworkId -> TxFile In -> ExceptT ByronClientCmdError IO () +runSubmitTx :: SocketPath -> NetworkId -> TxFile In -> ExceptT ByronClientCmdError IO () runSubmitTx nodeSocketPath network fp = do tx <- firstExceptT ByronCmdTxError $ readByronTx fp @@ -173,9 +174,9 @@ runSubmitTx nodeSocketPath network fp = do runGetTxId :: TxFile In -> ExceptT ByronClientCmdError IO () runGetTxId fp = firstExceptT ByronCmdTxError $ do - tx <- readByronTx fp - let txId = getTxIdByron tx - liftIO . BS.putStrLn $ serialiseToRawBytesHex txId + tx <- readByronTx fp + let txId = getTxIdByron tx + liftIO . BS.putStrLn $ serialiseToRawBytesHex txId runSpendGenesisUTxO :: GenesisFile @@ -187,12 +188,13 @@ runSpendGenesisUTxO -> [TxOut CtxTx ByronEra] -> ExceptT ByronClientCmdError IO () runSpendGenesisUTxO genesisFile nw bKeyFormat (NewTxFile ctTx) ctKey genRichAddr outs = do - genesis <- firstExceptT ByronCmdGenesisError $ readGenesis genesisFile nw - sk <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey bKeyFormat ctKey + genesis <- firstExceptT ByronCmdGenesisError $ readGenesis genesisFile nw + sk <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey bKeyFormat ctKey - let tx = txSpendGenesisUTxOByronPBFT genesis nw sk genRichAddr outs - firstExceptT ByronCmdHelpersError . ensureNewFileLBS ctTx - $ teRawCBOR $ serializeByronTx tx + let tx = txSpendGenesisUTxOByronPBFT genesis nw sk genRichAddr outs + firstExceptT ByronCmdHelpersError . ensureNewFileLBS ctTx $ + teRawCBOR $ + serializeByronTx tx -- Construct a Byron era tx runSpendUTxO @@ -204,8 +206,9 @@ runSpendUTxO -> [TxOut CtxTx ByronEra] -> ExceptT ByronClientCmdError IO () runSpendUTxO nw bKeyFormat (NewTxFile ctTx) ctKey ins outs = do - sk <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey bKeyFormat ctKey + sk <- firstExceptT ByronCmdKeyFailure $ readByronSigningKey bKeyFormat ctKey - let gTx = txSpendUTxOByronPBFT nw sk ins outs - firstExceptT ByronCmdHelpersError . ensureNewFileLBS ctTx - $ teRawCBOR $ serializeByronTx gTx + let gTx = txSpendUTxOByronPBFT nw sk ins outs + firstExceptT ByronCmdHelpersError . ensureNewFileLBS ctTx $ + teRawCBOR $ + serializeByronTx gTx diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index 17369e8efe..336bf67543 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -5,10 +5,10 @@ {-# LANGUAGE NamedFieldPuns #-} module Cardano.CLI.Byron.Tx - ( ByronTxError(..) + ( ByronTxError (..) , Tx , TxFile - , NewTxFile(..) + , NewTxFile (..) , prettyAddress , readByronTx , normalByronTxToGenTx @@ -16,12 +16,10 @@ module Cardano.CLI.Byron.Tx , txSpendUTxOByronPBFT , nodeSubmitTx , renderByronTxError - - --TODO: remove when they are exported from the ledger + -- TODO: remove when they are exported from the ledger , fromCborTxAux , toCborTxAux - - , ScriptValidity(..) + , ScriptValidity (..) ) where @@ -65,23 +63,27 @@ renderByronTxError :: ByronTxError -> Doc ann renderByronTxError = \case ByronTxSubmitError res -> "Error while submitting tx: " <> pretty res ByronTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> - "The era of the node and the tx do not match. " <> - "The node is running in the " <> pretty ledgerEraName <> - " era, but the transaction is for the " <> pretty otherEraName <> " era." + "The era of the node and the tx do not match. " + <> "The node is running in the " + <> pretty ledgerEraName + <> " era, but the transaction is for the " + <> pretty otherEraName + <> " era." TxDeserialisationFailed txFp decErr -> "Transaction deserialisation failed at " <> pshow txFp <> " Error: " <> pshow decErr -newtype NewTxFile = - NewTxFile FilePath +newtype NewTxFile + = NewTxFile FilePath deriving (Eq, Ord, Show, IsString) - -- | Pretty-print an address in its Base58 form, and also -- its full structure. prettyAddress :: Address ByronAddr -> Text -prettyAddress (ByronAddress addr) = sformat - (Common.addressF % "\n" % Common.addressDetailedF) - addr addr +prettyAddress (ByronAddress addr) = + sformat + (Common.addressF % "\n" % Common.addressDetailedF) + addr + addr -- TODO: Move to cardano-api readByronTx :: TxFile In -> ExceptT ByronTxError IO (UTxO.ATxAux ByteString) @@ -101,39 +103,43 @@ normalByronTxToGenTx tx' = Byron.ByronTx (Byron.byronIdTx tx') tx' genesisUTxOTxIn :: Genesis.Config -> Crypto.VerificationKey -> Common.Address -> UTxO.TxIn genesisUTxOTxIn gc vk genAddr = handleMissingAddr $ fst <$> Map.lookup genAddr initialUtxo - where - initialUtxo :: Map Common.Address (UTxO.TxIn, UTxO.TxOut) - initialUtxo = - Map.fromList - . mapMaybe (\(inp, out) -> mkEntry inp genAddr <$> keyMatchesUTxO vk out) - . fromCompactTxInTxOutList - . Map.toList - . UTxO.unUTxO - . UTxO.genesisUtxo - $ gc - where - mkEntry :: UTxO.TxIn - -> Common.Address - -> UTxO.TxOut - -> (Common.Address, (UTxO.TxIn, UTxO.TxOut)) - mkEntry inp addr out = (addr, (inp, out)) - - fromCompactTxInTxOutList :: [(UTxO.CompactTxIn, UTxO.CompactTxOut)] - -> [(UTxO.TxIn, UTxO.TxOut)] - fromCompactTxInTxOutList = - map (bimap UTxO.fromCompactTxIn UTxO.fromCompactTxOut) - - keyMatchesUTxO :: Crypto.VerificationKey -> UTxO.TxOut -> Maybe UTxO.TxOut - keyMatchesUTxO key out = - if Common.checkVerKeyAddress key (UTxO.txOutAddress out) - then Just out else Nothing - - handleMissingAddr :: Maybe UTxO.TxIn -> UTxO.TxIn - handleMissingAddr = fromMaybe . error - $ "\nGenesis UTxO has no address\n" - <> Text.unpack (prettyAddress (ByronAddress genAddr)) - <> "\n\nIt has the following, though:\n\n" - <> List.concatMap (Text.unpack . prettyAddress . ByronAddress) (Map.keys initialUtxo) + where + initialUtxo :: Map Common.Address (UTxO.TxIn, UTxO.TxOut) + initialUtxo = + Map.fromList + . mapMaybe (\(inp, out) -> mkEntry inp genAddr <$> keyMatchesUTxO vk out) + . fromCompactTxInTxOutList + . Map.toList + . UTxO.unUTxO + . UTxO.genesisUtxo + $ gc + where + mkEntry + :: UTxO.TxIn + -> Common.Address + -> UTxO.TxOut + -> (Common.Address, (UTxO.TxIn, UTxO.TxOut)) + mkEntry inp addr out = (addr, (inp, out)) + + fromCompactTxInTxOutList + :: [(UTxO.CompactTxIn, UTxO.CompactTxOut)] + -> [(UTxO.TxIn, UTxO.TxOut)] + fromCompactTxInTxOutList = + map (bimap UTxO.fromCompactTxIn UTxO.fromCompactTxOut) + + keyMatchesUTxO :: Crypto.VerificationKey -> UTxO.TxOut -> Maybe UTxO.TxOut + keyMatchesUTxO key out = + if Common.checkVerKeyAddress key (UTxO.txOutAddress out) + then Just out + else Nothing + + handleMissingAddr :: Maybe UTxO.TxIn -> UTxO.TxIn + handleMissingAddr = + fromMaybe . error $ + "\nGenesis UTxO has no address\n" + <> Text.unpack (prettyAddress (ByronAddress genAddr)) + <> "\n\nIt has the following, though:\n\n" + <> List.concatMap (Text.unpack . prettyAddress . ByronAddress) (Map.keys initialUtxo) -- | Generate a transaction spending genesis UTxO at a given address, -- to given outputs, signed by the given key. @@ -145,16 +151,17 @@ txSpendGenesisUTxOByronPBFT -> [TxOut CtxTx ByronEra] -> ATxAux ByteString txSpendGenesisUTxOByronPBFT gc nId sk (ByronAddress bAddr) outs = - let txins = [(fromByronTxIn txIn, BuildTxWith (KeyWitness KeyWitnessForSpending))] - in case makeByronTransactionBody txins outs of - Left err -> error $ "Error occurred while creating a Byron genesis based UTxO transaction: " <> show err - Right txBody -> let bWit = fromByronWitness sk nId txBody - in makeSignedByronTransaction [bWit] txBody - where - ByronVerificationKey vKey = byronWitnessToVerKey sk - - txIn :: UTxO.TxIn - txIn = genesisUTxOTxIn gc vKey bAddr + let txins = [(fromByronTxIn txIn, BuildTxWith (KeyWitness KeyWitnessForSpending))] + in case makeByronTransactionBody txins outs of + Left err -> error $ "Error occurred while creating a Byron genesis based UTxO transaction: " <> show err + Right txBody -> + let bWit = fromByronWitness sk nId txBody + in makeSignedByronTransaction [bWit] txBody + where + ByronVerificationKey vKey = byronWitnessToVerKey sk + + txIn :: UTxO.TxIn + txIn = genesisUTxOTxIn gc vKey bAddr -- | Generate a transaction from given Tx inputs to outputs, -- signed by the given key. @@ -165,12 +172,13 @@ txSpendUTxOByronPBFT -> [TxOut CtxTx ByronEra] -> ATxAux ByteString txSpendUTxOByronPBFT nId sk txIns outs = do - let apiTxIns = [ ( txIn, BuildTxWith (KeyWitness KeyWitnessForSpending)) | txIn <- txIns] + let apiTxIns = [(txIn, BuildTxWith (KeyWitness KeyWitnessForSpending)) | txIn <- txIns] case makeByronTransactionBody apiTxIns outs of Left err -> error $ "Error occurred while creating a Byron genesis based UTxO transaction: " <> show err - Right txBody -> let bWit = fromByronWitness sk nId txBody - in makeSignedByronTransaction [bWit] txBody + Right txBody -> + let bWit = fromByronWitness sk nId txBody + in makeSignedByronTransaction [bWit] txBody fromByronWitness :: SomeByronSigningKey -> NetworkId -> L.Annotated L.Tx ByteString -> KeyWitness ByronEra @@ -186,32 +194,33 @@ nodeSubmitTx -> GenTx ByronBlock -> ExceptT ByronTxError IO () nodeSubmitTx nodeSocketPath network gentx = do - let connctInfo = - LocalNodeConnectInfo { - localNodeSocketPath = nodeSocketPath, - localNodeNetworkId = network, - localConsensusModeParams = CardanoModeParams (EpochSlots 21600) + let connctInfo = + LocalNodeConnectInfo + { localNodeSocketPath = nodeSocketPath + , localNodeNetworkId = network + , localConsensusModeParams = CardanoModeParams (EpochSlots 21600) } - res <- liftIO $ submitTxToNodeLocal connctInfo (TxInByronSpecial gentx) - case res of - Net.Tx.SubmitSuccess -> liftIO $ Text.putStrLn "Transaction successfully submitted." - Net.Tx.SubmitFail reason -> - case reason of - TxValidationErrorInCardanoMode err -> left . ByronTxSubmitError . Text.pack $ show err - TxValidationEraMismatch mismatchErr -> left $ ByronTxSubmitErrorEraMismatch mismatchErr - - return () - - ---TODO: remove these local definitions when the updated ledger lib is available -fromCborTxAux :: LB.ByteString -> Either Binary.DecoderError (UTxO.ATxAux B.ByteString) + res <- liftIO $ submitTxToNodeLocal connctInfo (TxInByronSpecial gentx) + case res of + Net.Tx.SubmitSuccess -> liftIO $ Text.putStrLn "Transaction successfully submitted." + Net.Tx.SubmitFail reason -> + case reason of + TxValidationErrorInCardanoMode err -> left . ByronTxSubmitError . Text.pack $ show err + TxValidationEraMismatch mismatchErr -> left $ ByronTxSubmitErrorEraMismatch mismatchErr + + return () + +-- TODO: remove these local definitions when the updated ledger lib is available +fromCborTxAux :: LB.ByteString -> Either Binary.DecoderError (UTxO.ATxAux B.ByteString) fromCborTxAux lbs = - annotationBytes lbs - <$> Binary.decodeFullDecoder "Cardano.Chain.UTxO.TxAux.fromCborTxAux" - Binary.fromCBOR lbs - where - annotationBytes :: Functor f => LB.ByteString -> f L.ByteSpan -> f B.ByteString - annotationBytes bytes = fmap (LB.toStrict . L.slice bytes) + annotationBytes lbs + <$> Binary.decodeFullDecoder + "Cardano.Chain.UTxO.TxAux.fromCborTxAux" + Binary.fromCBOR + lbs + where + annotationBytes :: Functor f => LB.ByteString -> f L.ByteSpan -> f B.ByteString + annotationBytes bytes = fmap (LB.toStrict . L.slice bytes) toCborTxAux :: UTxO.ATxAux ByteString -> LB.ByteString toCborTxAux = LB.fromStrict . UTxO.aTaAnnotation -- The ByteString anotation is the CBOR encoded version. diff --git a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs index 4a2ac1eb6f..7528e8281e 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs @@ -3,17 +3,17 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.UpdateProposal - ( ByronUpdateProposalError(..) + ( ByronUpdateProposalError (..) , runProposalCreation , readByronUpdateProposal , renderByronUpdateProposalError , submitByronUpdateProposal - ) where + ) +where import Cardano.Api (NetworkId, SerialiseAsRawBytes (..), SocketPath) import Cardano.Api.Byron (AsType (AsByronUpdateProposal), ByronProtocolParametersUpdate, ByronUpdateProposal, makeByronUpdateProposal, toByronLedgerUpdateProposal) -import Cardano.CLI.Pretty import Cardano.Chain.Update (InstallerHash (..), ProtocolVersion (..), SoftwareVersion (..), SystemTag (..)) @@ -21,6 +21,7 @@ import Cardano.CLI.Byron.Genesis (ByronGenesisError) import Cardano.CLI.Byron.Key (ByronKeyFailure, readByronSigningKey) import Cardano.CLI.Byron.Tx (ByronTxError, nodeSubmitTx) import Cardano.CLI.Helpers (HelpersError, ensureNewFileLBS, renderHelpersError) +import Cardano.CLI.Pretty import Cardano.CLI.Types.Common import Ouroboros.Consensus.Ledger.SupportsMempool (txId) import Ouroboros.Consensus.Util.Condense (condense) @@ -68,17 +69,26 @@ runProposalCreation -> FilePath -> ByronProtocolParametersUpdate -> ExceptT ByronUpdateProposalError IO () -runProposalCreation nw sKey@(File sKeyfp) pVer sVer - sysTag insHash outputFp params = do - sK <- firstExceptT (ReadSigningKeyFailure sKeyfp) $ readByronSigningKey NonLegacyByronKeyFormat sKey - let proposal = makeByronUpdateProposal nw pVer sVer sysTag insHash sK params - firstExceptT ByronUpdateProposalWriteError $ - ensureNewFileLBS outputFp $ serialiseToRawBytes proposal +runProposalCreation + nw + sKey@(File sKeyfp) + pVer + sVer + sysTag + insHash + outputFp + params = do + sK <- firstExceptT (ReadSigningKeyFailure sKeyfp) $ readByronSigningKey NonLegacyByronKeyFormat sKey + let proposal = makeByronUpdateProposal nw pVer sVer sysTag insHash sK params + firstExceptT ByronUpdateProposalWriteError $ + ensureNewFileLBS outputFp $ + serialiseToRawBytes proposal readByronUpdateProposal :: FilePath -> ExceptT ByronUpdateProposalError IO ByronUpdateProposal readByronUpdateProposal fp = do - proposalBs <- handleIOExceptT (ByronReadUpdateProposalFileFailure fp . Text.pack . displayException) - $ BS.readFile fp + proposalBs <- + handleIOExceptT (ByronReadUpdateProposalFileFailure fp . Text.pack . displayException) $ + BS.readFile fp let proposalResult = deserialiseFromRawBytes AsByronUpdateProposal proposalBs hoistEither $ first (const (UpdateProposalDecodingError fp)) proposalResult diff --git a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs index 29c8502426..e83bfc4cad 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs @@ -3,12 +3,13 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Byron.Vote - ( ByronVoteError(..) + ( ByronVoteError (..) , readByronVote , renderByronVoteError , runVoteCreation , submitByronVote - ) where + ) +where import Cardano.Api.Byron @@ -42,7 +43,7 @@ data ByronVoteError renderByronVoteError :: ByronVoteError -> Doc ann renderByronVoteError = \case ByronVoteDecodingError fp -> - "Error decoding Byron vote at " <> pretty fp + "Error decoding Byron vote at " <> pretty fp ByronVoteGenesisReadError genErr -> "Error reading the genesis file:" <> pshow genErr ByronVoteReadFileFailure fp err -> @@ -58,7 +59,6 @@ renderByronVoteError = \case ByronVoteKeyReadFailure err -> "Error reading the signing key: " <> pshow err - runVoteCreation :: NetworkId -> SigningKeyFile In @@ -70,8 +70,8 @@ runVoteCreation nw sKey upPropFp voteBool outputFp = do sK <- firstExceptT ByronVoteKeyReadFailure $ readByronSigningKey NonLegacyByronKeyFormat sKey proposal <- firstExceptT ByronVoteUpdateProposalFailure $ readByronUpdateProposal upPropFp let vote = makeByronVote nw sK proposal voteBool - firstExceptT ByronVoteUpdateHelperError . ensureNewFileLBS outputFp - $ serialiseToRawBytes vote + firstExceptT ByronVoteUpdateHelperError . ensureNewFileLBS outputFp $ + serialiseToRawBytes vote submitByronVote :: SocketPath diff --git a/cardano-cli/src/Cardano/CLI/Commands.hs b/cardano-cli/src/Cardano/CLI/Commands.hs index 1b33439421..5f7b19f91e 100644 --- a/cardano-cli/src/Cardano/CLI/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Commands.hs @@ -1,8 +1,9 @@ {-# LANGUAGE GADTs #-} module Cardano.CLI.Commands - ( ClientCommand(..) - ) where + ( ClientCommand (..) + ) +where import Cardano.CLI.Byron.Commands (ByronCommand) import Cardano.CLI.Commands.Debug @@ -14,20 +15,15 @@ import Cardano.CLI.Legacy.Commands import Options.Applicative.Types (ParserInfo (..), ParserPrefs (..)) -- | Sub-commands of 'cardano-cli'. -data ClientCommand = - AnyEraCommand AnyEraCommand - - -- | Byron Related Commands - | ByronCommand ByronCommand - - -- | Era-agnostic hashing commands - | HashCmds HashCmds - - -- | Legacy shelley-based Commands - | LegacyCmds LegacyCmds - +data ClientCommand + = AnyEraCommand AnyEraCommand + | -- | Byron Related Commands + ByronCommand ByronCommand + | -- | Era-agnostic hashing commands + HashCmds HashCmds + | -- | Legacy shelley-based Commands + LegacyCmds LegacyCmds | CliPingCommand PingCmd | CliDebugCmds DebugCmds - | forall a. Help ParserPrefs (ParserInfo a) | DisplayVersion diff --git a/cardano-cli/src/Cardano/CLI/Commands/Debug.hs b/cardano-cli/src/Cardano/CLI/Commands/Debug.hs index e746143a13..8ab05d92b9 100644 --- a/cardano-cli/src/Cardano/CLI/Commands/Debug.hs +++ b/cardano-cli/src/Cardano/CLI/Commands/Debug.hs @@ -1,8 +1,9 @@ module Cardano.CLI.Commands.Debug ( DebugCmds (..) - ) where + ) +where import Cardano.CLI.Commands.Debug.LogEpochState -newtype DebugCmds = - DebugLogEpochStateCmd LogEpochStateCmdArgs +newtype DebugCmds + = DebugLogEpochStateCmd LogEpochStateCmdArgs diff --git a/cardano-cli/src/Cardano/CLI/Commands/Debug/LogEpochState.hs b/cardano-cli/src/Cardano/CLI/Commands/Debug/LogEpochState.hs index cff38428ae..90e7f07fd5 100644 --- a/cardano-cli/src/Cardano/CLI/Commands/Debug/LogEpochState.hs +++ b/cardano-cli/src/Cardano/CLI/Commands/Debug/LogEpochState.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-} module Cardano.CLI.Commands.Debug.LogEpochState - ( LogEpochStateCmdArgs(..) + ( LogEpochStateCmdArgs (..) , Configuration - ) where + ) +where import Cardano.Api @@ -16,7 +17,8 @@ data Configuration -- -- This command will connect to a local node and log the epoch state. data LogEpochStateCmdArgs = LogEpochStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , configurationFile :: !(NodeConfigFile 'In) - , outputFilePath :: !(File Configuration 'Out) - } deriving Show + , outputFilePath :: !(File Configuration 'Out) + } + deriving Show diff --git a/cardano-cli/src/Cardano/CLI/Commands/Hash.hs b/cardano-cli/src/Cardano/CLI/Commands/Hash.hs index dff2cf409a..f0509c74ea 100644 --- a/cardano-cli/src/Cardano/CLI/Commands/Hash.hs +++ b/cardano-cli/src/Cardano/CLI/Commands/Hash.hs @@ -8,7 +8,8 @@ module Cardano.CLI.Commands.Hash , HashScriptCmdArgs (..) , AnchorDataHashSource (..) , renderHashCmds - ) where + ) +where import Cardano.Api @@ -21,10 +22,12 @@ data HashCmds | HashScriptCmd !HashScriptCmdArgs data HashAnchorDataCmdArgs - = HashAnchorDataCmdArgs { - toHash :: !AnchorDataHashSource - , mOutFile :: !(Maybe (File () Out)) -- ^ The output file to which the hash is written - } deriving Show + = HashAnchorDataCmdArgs + { toHash :: !AnchorDataHashSource + , mOutFile :: !(Maybe (File () Out)) + -- ^ The output file to which the hash is written + } + deriving Show data AnchorDataHashSource = AnchorDataHashSourceBinaryFile (File ProposalBinary In) @@ -33,12 +36,14 @@ data AnchorDataHashSource deriving Show data HashScriptCmdArgs - = HashScriptCmdArgs { - toHash :: !ScriptFile - , mOutFile :: !(Maybe (File () Out)) -- ^ The output file to which the hash is written - } deriving Show + = HashScriptCmdArgs + { toHash :: !ScriptFile + , mOutFile :: !(Maybe (File () Out)) + -- ^ The output file to which the hash is written + } + deriving Show renderHashCmds :: HashCmds -> Text renderHashCmds = \case - HashAnchorDataCmd {} -> "hash anchor-data" - HashScriptCmd {} -> "hash script" + HashAnchorDataCmd{} -> "hash anchor-data" + HashScriptCmd{} -> "hash script" diff --git a/cardano-cli/src/Cardano/CLI/Commands/Ping.hs b/cardano-cli/src/Cardano/CLI/Commands/Ping.hs index 60c1e0f07a..11e07f7e78 100644 --- a/cardano-cli/src/Cardano/CLI/Commands/Ping.hs +++ b/cardano-cli/src/Cardano/CLI/Commands/Ping.hs @@ -1,21 +1,23 @@ module Cardano.CLI.Commands.Ping - ( EndPoint(..) - , PingCmd(..) - ) where + ( EndPoint (..) + , PingCmd (..) + ) +where import Data.Word -data EndPoint = - HostEndPoint String - | UnixSockEndPoint String +data EndPoint + = HostEndPoint String + | UnixSockEndPoint String deriving (Eq, Show) data PingCmd = PingCmd - { pingCmdCount :: !Word32 - , pingCmdEndPoint :: !EndPoint - , pingCmdPort :: !String - , pingCmdMagic :: !Word32 - , pingCmdJson :: !Bool - , pingCmdQuiet :: !Bool + { pingCmdCount :: !Word32 + , pingCmdEndPoint :: !EndPoint + , pingCmdPort :: !String + , pingCmdMagic :: !Word32 + , pingCmdJson :: !Bool + , pingCmdQuiet :: !Bool , pingOptsHandshakeQuery :: !Bool - } deriving (Eq, Show) + } + deriving (Eq, Show) diff --git a/cardano-cli/src/Cardano/CLI/Environment.hs b/cardano-cli/src/Cardano/CLI/Environment.hs index 46d352f36c..fd241a9a66 100644 --- a/cardano-cli/src/Cardano/CLI/Environment.hs +++ b/cardano-cli/src/Cardano/CLI/Environment.hs @@ -3,13 +3,14 @@ -- | This module defines constants derived from the environment. module Cardano.CLI.Environment - ( EnvCli(..) + ( EnvCli (..) , envCliAnyShelleyBasedEra , envCliAnyShelleyToBabbageEra , getEnvCli , getEnvNetworkId , getEnvSocketPath - ) where + ) +where import Cardano.Api (AnyCardanoEra (..), CardanoEra (..), EraInEon (..), NetworkId (..), NetworkMagic (..), ShelleyBasedEra (..), ShelleyToBabbageEra (..), @@ -32,11 +33,12 @@ getEnvCli = do mSocketPath <- getEnvSocketPath mCardanoEra <- getCardanoEra - pure EnvCli - { envCliNetworkId = mNetworkId - , envCliSocketPath = mSocketPath - , envCliAnyCardanoEra = mCardanoEra - } + pure + EnvCli + { envCliNetworkId = mNetworkId + , envCliSocketPath = mSocketPath + , envCliAnyCardanoEra = mCardanoEra + } envCliAnyShelleyBasedEra :: EnvCli -> Maybe (EraInEon ShelleyBasedEra) envCliAnyShelleyBasedEra envCli = do @@ -63,10 +65,11 @@ getEnvNetworkId = do case readMaybe @Word32 networkIdString of Just networkId -> pure $ Just $ Testnet $ NetworkMagic networkId Nothing -> do - IO.hPutStrLn IO.stderr $ mconcat - [ "The network id specified in CARDANO_NODE_NETWORK_ID invalid: " <> networkIdString - , " It should be either 'mainnet' or a number." - ] + IO.hPutStrLn IO.stderr $ + mconcat + [ "The network id specified in CARDANO_NODE_NETWORK_ID invalid: " <> networkIdString + , " It should be either 'mainnet' or a number." + ] pure Nothing -- | If the environment variable @CARDANO_NODE_SOCKET_PATH@ is set, then return the set value. @@ -91,5 +94,4 @@ getCardanoEra = do "babbage" -> pure $ Just $ AnyCardanoEra BabbageEra "conway" -> pure $ Just $ AnyCardanoEra ConwayEra unknown -> error $ "Unknown era: " <> unknown -- TODO improve error handling - - Nothing -> pure Nothing \ No newline at end of file + Nothing -> pure Nothing diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs index ca46a50f5d..9baa344a89 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands.hs @@ -8,7 +8,8 @@ module Cardano.CLI.EraBased.Commands , renderCmds , pAnyEraCommand , pCmds - ) where + ) +where import Cardano.Api (ShelleyBasedEra (..), toCardanoEra) @@ -48,16 +49,16 @@ renderAnyEraCommand = \case AnyEraCommandOf _ cmd -> renderCmds cmd data Cmds era - = AddressCmds (AddressCmds era) - | KeyCmds (KeyCmds era) - | GenesisCmds (GenesisCmds era) - | GovernanceCmds (GovernanceCmds era) - | NodeCmds (NodeCmds era) - | QueryCmds (QueryCmds era) - | StakeAddressCmds (StakeAddressCmds era) - | StakePoolCmds (StakePoolCmds era) - | TextViewCmds (TextViewCmds era) - | TransactionCmds (TransactionCmds era) + = AddressCmds (AddressCmds era) + | KeyCmds (KeyCmds era) + | GenesisCmds (GenesisCmds era) + | GovernanceCmds (GovernanceCmds era) + | NodeCmds (NodeCmds era) + | QueryCmds (QueryCmds era) + | StakeAddressCmds (StakeAddressCmds era) + | StakePoolCmds (StakePoolCmds era) + | TextViewCmds (TextViewCmds era) + | TransactionCmds (TransactionCmds era) renderCmds :: Cmds era -> Text renderCmds = \case @@ -87,41 +88,41 @@ pAnyEraCommand envCli = asum [ -- Note, byron is ommitted because there is already a legacy command group for it. - subParser "shelley" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraShelley <$> pCmds ShelleyBasedEraShelley envCli) - $ Opt.progDesc "Shelley era commands" - , subParser "allegra" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraAllegra <$> pCmds ShelleyBasedEraAllegra envCli) - $ Opt.progDesc "Allegra era commands" - , subParser "mary" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraMary <$> pCmds ShelleyBasedEraMary envCli) - $ Opt.progDesc "Mary era commands" - , subParser "alonzo" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraAlonzo <$> pCmds ShelleyBasedEraAlonzo envCli) - $ Opt.progDesc "Alonzo era commands" - , subParser "babbage" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraBabbage <$> pCmds ShelleyBasedEraBabbage envCli) - $ Opt.progDesc "Babbage era commands" - , subParser "conway" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraConway <$> pCmds ShelleyBasedEraConway envCli) - $ Opt.progDesc "Conway era commands" - - , subParser "latest" - $ Opt.info (AnyEraCommandOf ShelleyBasedEraBabbage <$> pCmds ShelleyBasedEraBabbage envCli) - $ Opt.progDesc "Latest era commands (Babbage)" + subParser "shelley" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraShelley <$> pCmds ShelleyBasedEraShelley envCli) $ + Opt.progDesc "Shelley era commands" + , subParser "allegra" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraAllegra <$> pCmds ShelleyBasedEraAllegra envCli) $ + Opt.progDesc "Allegra era commands" + , subParser "mary" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraMary <$> pCmds ShelleyBasedEraMary envCli) $ + Opt.progDesc "Mary era commands" + , subParser "alonzo" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraAlonzo <$> pCmds ShelleyBasedEraAlonzo envCli) $ + Opt.progDesc "Alonzo era commands" + , subParser "babbage" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraBabbage <$> pCmds ShelleyBasedEraBabbage envCli) $ + Opt.progDesc "Babbage era commands" + , subParser "conway" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraConway <$> pCmds ShelleyBasedEraConway envCli) $ + Opt.progDesc "Conway era commands" + , subParser "latest" $ + Opt.info (AnyEraCommandOf ShelleyBasedEraBabbage <$> pCmds ShelleyBasedEraBabbage envCli) $ + Opt.progDesc "Latest era commands (Babbage)" ] pCmds :: ShelleyBasedEra era -> EnvCli -> Parser (Cmds era) pCmds era envCli = - asum $ catMaybes - [ fmap AddressCmds <$> pAddressCmds (toCardanoEra era) envCli - , fmap KeyCmds <$> pKeyCmds - , fmap GenesisCmds <$> pGenesisCmds envCli - , fmap GovernanceCmds <$> pGovernanceCmds (toCardanoEra era) - , fmap NodeCmds <$> pNodeCmds - , fmap QueryCmds <$> pQueryCmds (toCardanoEra era) envCli - , fmap StakeAddressCmds <$> pStakeAddressCmds (toCardanoEra era) envCli - , fmap StakePoolCmds <$> pStakePoolCmds (toCardanoEra era) envCli - , fmap TextViewCmds <$> pTextViewCmds - , fmap TransactionCmds <$> pTransactionCmds era envCli - ] + asum $ + catMaybes + [ fmap AddressCmds <$> pAddressCmds (toCardanoEra era) envCli + , fmap KeyCmds <$> pKeyCmds + , fmap GenesisCmds <$> pGenesisCmds envCli + , fmap GovernanceCmds <$> pGovernanceCmds (toCardanoEra era) + , fmap NodeCmds <$> pNodeCmds + , fmap QueryCmds <$> pQueryCmds (toCardanoEra era) envCli + , fmap StakeAddressCmds <$> pStakeAddressCmds (toCardanoEra era) envCli + , fmap StakePoolCmds <$> pStakePoolCmds (toCardanoEra era) envCli + , fmap TextViewCmds <$> pTextViewCmds + , fmap TransactionCmds <$> pTransactionCmds era envCli + ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Address.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Address.hs index 4826f2eed5..66d16ee1e2 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Address.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Address.hs @@ -4,7 +4,8 @@ module Cardano.CLI.EraBased.Commands.Address ( AddressCmds (..) , renderAddressCmds - ) where + ) +where import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -36,7 +37,7 @@ data AddressCmds era renderAddressCmds :: AddressCmds era -> Text renderAddressCmds = \case - AddressKeyGen {} -> "address key-gen" - AddressKeyHash {} -> "address key-hash" - AddressBuild {} -> "address build" - AddressInfo {} -> "address info" + AddressKeyGen{} -> "address key-gen" + AddressKeyHash{} -> "address key-hash" + AddressBuild{} -> "address build" + AddressInfo{} -> "address info" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs index 339f3a2ad6..c6df5dba9d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs @@ -15,7 +15,8 @@ module Cardano.CLI.EraBased.Commands.Genesis , GenesisTxInCmdArgs (..) , GenesisAddrCmdArgs (..) , renderGenesisCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley @@ -48,7 +49,8 @@ data GenesisCreateCmdArgs = GenesisCreateCmdArgs , mSystemStart :: !(Maybe SystemStart) , mSupply :: !(Maybe Coin) , network :: !NetworkId - } deriving Show + } + deriving Show data GenesisCreateCardanoCmdArgs = GenesisCreateCardanoCmdArgs { genesisDir :: !GenesisDir @@ -65,7 +67,8 @@ data GenesisCreateCardanoCmdArgs = GenesisCreateCardanoCmdArgs , alonzoGenesisTemplate :: !FilePath , conwayGenesisTemplate :: !FilePath , mNodeConfigTemplate :: !(Maybe FilePath) - } deriving Show + } + deriving Show data GenesisCreateStakedCmdArgs = GenesisCreateStakedCmdArgs { keyOutputFormat :: !KeyOutputFormat @@ -81,83 +84,107 @@ data GenesisCreateStakedCmdArgs = GenesisCreateStakedCmdArgs , numBulkPoolCredFiles :: !Word , numBulkPoolsPerFile :: !Word , numStuffedUtxo :: !Word - , mStakePoolRelaySpecFile :: !(Maybe FilePath) -- ^ Relay specification filepath - } deriving Show + , mStakePoolRelaySpecFile :: !(Maybe FilePath) + -- ^ Relay specification filepath + } + deriving Show data GenesisCreateTestNetDataCmdArgs = GenesisCreateTestNetDataCmdArgs - { specShelley :: !(Maybe FilePath) -- ^ Path to the @genesis-shelley@ file to use. If unspecified, a default one will be used. - , specAlonzo :: !(Maybe FilePath) -- ^ Path to the @genesis-alonzo@ file to use. If unspecified, a default one will be used. - , specConway :: !(Maybe FilePath) -- ^ Path to the @genesis-conway@ file to use. If unspecified, a default one will be used. - , numGenesisKeys :: !Word -- ^ The number of genesis keys credentials to create and write to disk. - , numPools :: !Word -- ^ The number of stake pools credentials to create and write to disk. - , stakeDelegators :: !StakeDelegators -- ^ The number of delegators to pools and DReps to create. - , numDRepKeys :: !DRepCredentials -- ^ The number of DRep keys to create. They are registered and get delegated to by stake delegators - , numStuffedUtxo :: !Word -- ^ The number of UTxO accounts to make. They are "stuffed" because the credentials are not written to disk. - , numUtxoKeys :: !Word -- ^ The number of UTxO credentials to create and write to disk. - , totalSupply :: !(Maybe Coin) -- ^ The total number of Lovelace - , delegatedSupply :: !(Maybe Coin) -- ^ The number of Lovelace being delegated - , networkId :: !(Maybe NetworkId) -- ^ The network ID to use. Overrides the network id supplied in the spec file. - , relays :: !(Maybe FilePath) -- ^ Filepath of the specification of relays - , systemStart :: !(Maybe SystemStart) -- ^ The genesis start time. - , outputDir :: !FilePath -- ^ Directory where to write credentials and files. - } deriving Show + { specShelley :: !(Maybe FilePath) + -- ^ Path to the @genesis-shelley@ file to use. If unspecified, a default one will be used. + , specAlonzo :: !(Maybe FilePath) + -- ^ Path to the @genesis-alonzo@ file to use. If unspecified, a default one will be used. + , specConway :: !(Maybe FilePath) + -- ^ Path to the @genesis-conway@ file to use. If unspecified, a default one will be used. + , numGenesisKeys :: !Word + -- ^ The number of genesis keys credentials to create and write to disk. + , numPools :: !Word + -- ^ The number of stake pools credentials to create and write to disk. + , stakeDelegators :: !StakeDelegators + -- ^ The number of delegators to pools and DReps to create. + , numDRepKeys :: !DRepCredentials + -- ^ The number of DRep keys to create. They are registered and get delegated to by stake delegators + , numStuffedUtxo :: !Word + -- ^ The number of UTxO accounts to make. They are "stuffed" because the credentials are not written to disk. + , numUtxoKeys :: !Word + -- ^ The number of UTxO credentials to create and write to disk. + , totalSupply :: !(Maybe Coin) + -- ^ The total number of Lovelace + , delegatedSupply :: !(Maybe Coin) + -- ^ The number of Lovelace being delegated + , networkId :: !(Maybe NetworkId) + -- ^ The network ID to use. Overrides the network id supplied in the spec file. + , relays :: !(Maybe FilePath) + -- ^ Filepath of the specification of relays + , systemStart :: !(Maybe SystemStart) + -- ^ The genesis start time. + , outputDir :: !FilePath + -- ^ Directory where to write credentials and files. + } + deriving Show data GenesisKeyGenGenesisCmdArgs = GenesisKeyGenGenesisCmdArgs { verificationKeyPath :: !(VerificationKeyFile Out) , signingKeyPath :: !(SigningKeyFile Out) - } deriving Show + } + deriving Show data GenesisKeyGenDelegateCmdArgs = GenesisKeyGenDelegateCmdArgs { verificationKeyPath :: !(VerificationKeyFile Out) , signingKeyPath :: !(SigningKeyFile Out) , opCertCounterPath :: !(OpCertCounterFile Out) - } deriving Show + } + deriving Show data GenesisKeyGenUTxOCmdArgs = GenesisKeyGenUTxOCmdArgs { verificationKeyPath :: !(VerificationKeyFile Out) , signingKeyPath :: !(SigningKeyFile Out) - } deriving Show + } + deriving Show data GenesisVerKeyCmdArgs = GenesisVerKeyCmdArgs { verificationKeyPath :: !(VerificationKeyFile Out) , signingKeyPath :: !(SigningKeyFile In) - } deriving Show + } + deriving Show data GenesisTxInCmdArgs = GenesisTxInCmdArgs { verificationKeyPath :: !(VerificationKeyFile In) , network :: !NetworkId , mOutFile :: !(Maybe (File () Out)) - } deriving Show + } + deriving Show data GenesisAddrCmdArgs = GenesisAddrCmdArgs { verificationKeyPath :: !(VerificationKeyFile In) , network :: !NetworkId , mOutFile :: !(Maybe (File () Out)) - } deriving Show + } + deriving Show renderGenesisCmds :: GenesisCmds era -> Text renderGenesisCmds = \case - GenesisCreate {} -> + GenesisCreate{} -> "genesis create" - GenesisCreateCardano {} -> + GenesisCreateCardano{} -> "genesis create-cardano" - GenesisCreateStaked {} -> + GenesisCreateStaked{} -> "genesis create-staked" - GenesisCreateTestNetData {} -> + GenesisCreateTestNetData{} -> "genesis create-testnet-data" - GenesisKeyGenGenesis {} -> + GenesisKeyGenGenesis{} -> "genesis key-gen-genesis" - GenesisKeyGenDelegate {} -> + GenesisKeyGenDelegate{} -> "genesis key-gen-delegate" - GenesisKeyGenUTxO {} -> + GenesisKeyGenUTxO{} -> "genesis key-gen-utxo" - GenesisCmdKeyHash {} -> + GenesisCmdKeyHash{} -> "genesis key-hash" - GenesisVerKey {} -> + GenesisVerKey{} -> "genesis get-ver-key" - GenesisTxIn {} -> + GenesisTxIn{} -> "genesis initial-txin" - GenesisAddr {} -> + GenesisAddr{} -> "genesis initial-addr" - GenesisHashFile {} -> + GenesisHashFile{} -> "genesis hash" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance.hs index f32e032cf7..468853f6cb 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance.hs @@ -3,9 +3,10 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.EraBased.Commands.Governance - ( GovernanceCmds(..) + ( GovernanceCmds (..) , renderGovernanceCmds - ) where + ) +where import Cardano.Api import Cardano.Api.Ledger (Coin) @@ -54,13 +55,13 @@ data GovernanceCmds era renderGovernanceCmds :: GovernanceCmds era -> Text renderGovernanceCmds = \case - GovernanceCreateMirCertificateStakeAddressesCmd {} -> + GovernanceCreateMirCertificateStakeAddressesCmd{} -> "governance create-mir-certificate stake-addresses" - GovernanceCreateMirCertificateTransferToTreasuryCmd {} -> + GovernanceCreateMirCertificateTransferToTreasuryCmd{} -> "governance create-mir-certificate transfer-to-treasury" - GovernanceCreateMirCertificateTransferToReservesCmd {} -> + GovernanceCreateMirCertificateTransferToReservesCmd{} -> "governance create-mir-certificate transfer-to-reserves" - GovernanceGenesisKeyDelegationCertificate {} -> + GovernanceGenesisKeyDelegationCertificate{} -> "governance create-genesis-key-delegation-certificate" GovernanceActionCmds cmds -> renderGovernanceActionCmds cmds diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs index ffb080bca6..135e7dcee3 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs @@ -5,22 +5,22 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} - module Cardano.CLI.EraBased.Commands.Governance.Actions - ( GovernanceActionCmds(..) - , GovernanceActionUpdateCommitteeCmdArgs(..) - , GovernanceActionCreateConstitutionCmdArgs(..) - , GovernanceActionCreateNoConfidenceCmdArgs(..) - , GovernanceActionInfoCmdArgs(..) - , GovernanceActionViewCmdArgs(..) - , GovernanceActionProtocolParametersUpdateCmdArgs(..) - , GovernanceActionTreasuryWithdrawalCmdArgs(..) - , UpdateProtocolParametersConwayOnwards(..) - , UpdateProtocolParametersPreConway(..) - , GovernanceActionHardforkInitCmdArgs(..) - , CostModelsFile(..) + ( GovernanceActionCmds (..) + , GovernanceActionUpdateCommitteeCmdArgs (..) + , GovernanceActionCreateConstitutionCmdArgs (..) + , GovernanceActionCreateNoConfidenceCmdArgs (..) + , GovernanceActionInfoCmdArgs (..) + , GovernanceActionViewCmdArgs (..) + , GovernanceActionProtocolParametersUpdateCmdArgs (..) + , GovernanceActionTreasuryWithdrawalCmdArgs (..) + , UpdateProtocolParametersConwayOnwards (..) + , UpdateProtocolParametersPreConway (..) + , GovernanceActionHardforkInitCmdArgs (..) + , CostModelsFile (..) , renderGovernanceActionCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -33,173 +33,175 @@ import Data.Text (Text) import Data.Word data GovernanceActionCmds era - = GovernanceActionCreateConstitutionCmd !(GovernanceActionCreateConstitutionCmdArgs era) - | GovernanceActionUpdateCommitteeCmd !(GovernanceActionUpdateCommitteeCmdArgs era) - | GovernanceActionCreateNoConfidenceCmd !(GovernanceActionCreateNoConfidenceCmdArgs era) - | GovernanceActionProtocolParametersUpdateCmd !(GovernanceActionProtocolParametersUpdateCmdArgs era) - | GovernanceActionTreasuryWithdrawalCmd !(GovernanceActionTreasuryWithdrawalCmdArgs era) - | GovernanceActionHardforkInitCmd !(GovernanceActionHardforkInitCmdArgs era) - | GovernanceActionInfoCmd !(GovernanceActionInfoCmdArgs era) - | GovernanceActionViewCmd !(GovernanceActionViewCmdArgs era) + = GovernanceActionCreateConstitutionCmd !(GovernanceActionCreateConstitutionCmdArgs era) + | GovernanceActionUpdateCommitteeCmd !(GovernanceActionUpdateCommitteeCmdArgs era) + | GovernanceActionCreateNoConfidenceCmd !(GovernanceActionCreateNoConfidenceCmdArgs era) + | GovernanceActionProtocolParametersUpdateCmd !(GovernanceActionProtocolParametersUpdateCmdArgs era) + | GovernanceActionTreasuryWithdrawalCmd !(GovernanceActionTreasuryWithdrawalCmdArgs era) + | GovernanceActionHardforkInitCmd !(GovernanceActionHardforkInitCmdArgs era) + | GovernanceActionInfoCmd !(GovernanceActionInfoCmdArgs era) + | GovernanceActionViewCmd !(GovernanceActionViewCmdArgs era) deriving Show data GovernanceActionUpdateCommitteeCmdArgs era = GovernanceActionUpdateCommitteeCmdArgs - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , returnAddress :: !StakeIdentifier - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , oldCommitteeVkeySource :: ![VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey] - , newCommitteeVkeySource :: ![(VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey, EpochNo)] - , requiredThreshold :: !Rational - , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) - , outFile :: !(File () Out) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , returnAddress :: !StakeIdentifier + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , oldCommitteeVkeySource :: ![VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey] + , newCommitteeVkeySource :: ![(VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey, EpochNo)] + , requiredThreshold :: !Rational + , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) + , outFile :: !(File () Out) + } + deriving Show data GovernanceActionCreateConstitutionCmdArgs era = GovernanceActionCreateConstitutionCmdArgs - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , stakeCredential :: !StakeIdentifier - , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , constitutionUrl :: !ConstitutionUrl - , constitutionHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , constitutionScript :: !(Maybe ScriptHash) - , outFile :: !(File () Out) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , stakeCredential :: !StakeIdentifier + , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , constitutionUrl :: !ConstitutionUrl + , constitutionHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , constitutionScript :: !(Maybe ScriptHash) + , outFile :: !(File () Out) + } + deriving Show -- | Datatype to carry data for the create-info governance action data GovernanceActionInfoCmdArgs era - = GovernanceActionInfoCmdArgs - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , returnStakeAddress :: !StakeIdentifier - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , outFile :: !(File () Out) - } deriving Show + = GovernanceActionInfoCmdArgs + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , returnStakeAddress :: !StakeIdentifier + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , outFile :: !(File () Out) + } + deriving Show data GovernanceActionCreateNoConfidenceCmdArgs era = GovernanceActionCreateNoConfidenceCmdArgs - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , returnStakeAddress :: !StakeIdentifier - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) - , outFile :: !(File () Out) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , returnStakeAddress :: !StakeIdentifier + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) + , outFile :: !(File () Out) + } + deriving Show data GovernanceActionProtocolParametersUpdateCmdArgs era = GovernanceActionProtocolParametersUpdateCmdArgs - { uppShelleyBasedEra :: !(ShelleyBasedEra era) - , uppPreConway :: !(Maybe (UpdateProtocolParametersPreConway era)) - , uppConwayOnwards :: !(Maybe (UpdateProtocolParametersConwayOnwards era)) - -- | New parameters to be proposed. From Alonzo onwards, the type - -- 'EraBasedProtocolParametersUpdate' also contains cost models. Since all - -- other protocol parameters are read from command line arguments, whereas - -- the cost models are read from a file, we separate the cost models from - -- the rest of the protocol parameters to ease parsing. - , uppNewPParams :: !(EraBasedProtocolParametersUpdate era) - -- | The new cost models proposed. See the comment at 'uppNewPParams' for - -- why this is a separate field. - , uppCostModelsFile :: !(Maybe (CostModelsFile era)) - , uppFilePath :: !(File () Out) - } deriving Show + { uppShelleyBasedEra :: !(ShelleyBasedEra era) + , uppPreConway :: !(Maybe (UpdateProtocolParametersPreConway era)) + , uppConwayOnwards :: !(Maybe (UpdateProtocolParametersConwayOnwards era)) + , uppNewPParams :: !(EraBasedProtocolParametersUpdate era) + -- ^ New parameters to be proposed. From Alonzo onwards, the type + -- 'EraBasedProtocolParametersUpdate' also contains cost models. Since all + -- other protocol parameters are read from command line arguments, whereas + -- the cost models are read from a file, we separate the cost models from + -- the rest of the protocol parameters to ease parsing. + , uppCostModelsFile :: !(Maybe (CostModelsFile era)) + -- ^ The new cost models proposed. See the comment at 'uppNewPParams' for + -- why this is a separate field. + , uppFilePath :: !(File () Out) + } + deriving Show data GovernanceActionTreasuryWithdrawalCmdArgs era = GovernanceActionTreasuryWithdrawalCmdArgs - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , returnAddr :: !StakeIdentifier - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , treasuryWithdrawal :: ![(VerificationKeyOrHashOrFile StakeKey, L.Coin)] - , constitutionScriptHash :: !(Maybe ScriptHash) - , outFile :: !(File () Out) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , returnAddr :: !StakeIdentifier + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , treasuryWithdrawal :: ![(VerificationKeyOrHashOrFile StakeKey, L.Coin)] + , constitutionScriptHash :: !(Maybe ScriptHash) + , outFile :: !(File () Out) + } + deriving Show data GovernanceActionHardforkInitCmdArgs era = GovernanceActionHardforkInitCmdArgs - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , returnStakeAddress :: !StakeIdentifier - , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , protVer :: !L.ProtVer - , outFile :: !(File () Out) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , returnStakeAddress :: !StakeIdentifier + , mPrevGovernanceActionId :: !(Maybe (TxId, Word16)) + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , protVer :: !L.ProtVer + , outFile :: !(File () Out) + } + deriving Show data GovernanceActionViewCmdArgs era = GovernanceActionViewCmdArgs - { eon :: !(ConwayEraOnwards era) - , actionFile :: !(ProposalFile In) - , outFormat :: !ViewOutputFormat - , mOutFile :: !(Maybe (File () Out)) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , actionFile :: !(ProposalFile In) + , outFormat :: !ViewOutputFormat + , mOutFile :: !(Maybe (File () Out)) + } + deriving Show data UpdateProtocolParametersConwayOnwards era = UpdateProtocolParametersConwayOnwards - { eon :: !(ConwayEraOnwards era) - , networkId :: !L.Network - , deposit :: !L.Coin - , returnAddr :: !StakeIdentifier - , proposalUrl :: !ProposalUrl - , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) - , governanceActionId :: !(Maybe (TxId, Word16)) - , constitutionScriptHash :: !(Maybe ScriptHash) - } + { eon :: !(ConwayEraOnwards era) + , networkId :: !L.Network + , deposit :: !L.Coin + , returnAddr :: !StakeIdentifier + , proposalUrl :: !ProposalUrl + , proposalHash :: !(L.SafeHash L.StandardCrypto L.AnchorData) + , governanceActionId :: !(Maybe (TxId, Word16)) + , constitutionScriptHash :: !(Maybe ScriptHash) + } data CostModelsFile era = CostModelsFile - { eon :: !(AlonzoEraOnwards era) - , costModelsFile :: !(File L.CostModels In) - } deriving Show + { eon :: !(AlonzoEraOnwards era) + , costModelsFile :: !(File L.CostModels In) + } + deriving Show deriving instance Show (UpdateProtocolParametersConwayOnwards era) data UpdateProtocolParametersPreConway era = UpdateProtocolParametersPreConway - { eon :: !(ShelleyToBabbageEra era) - , expiryEpoch :: !EpochNo - , genesisVerificationKeys :: ![VerificationKeyFile In] - } - + { eon :: !(ShelleyToBabbageEra era) + , expiryEpoch :: !EpochNo + , genesisVerificationKeys :: ![VerificationKeyFile In] + } deriving instance Show (UpdateProtocolParametersPreConway era) renderGovernanceActionCmds :: GovernanceActionCmds era -> Text -renderGovernanceActionCmds = ("governance action " <>) . \case - GovernanceActionCreateConstitutionCmd {} -> - "create-constitution" - - GovernanceActionProtocolParametersUpdateCmd {} -> - "create-protocol-parameters-update" - - GovernanceActionTreasuryWithdrawalCmd {} -> - "create-treasury-withdrawal" - - GovernanceActionUpdateCommitteeCmd {} -> - "update-committee" - - GovernanceActionCreateNoConfidenceCmd {} -> - "create-no-confidence" - - GovernanceActionHardforkInitCmd {} -> - "create-hardfork" - - GovernanceActionInfoCmd {} -> - "create-info" - - GovernanceActionViewCmd {} -> - "view" +renderGovernanceActionCmds = + ("governance action " <>) . \case + GovernanceActionCreateConstitutionCmd{} -> + "create-constitution" + GovernanceActionProtocolParametersUpdateCmd{} -> + "create-protocol-parameters-update" + GovernanceActionTreasuryWithdrawalCmd{} -> + "create-treasury-withdrawal" + GovernanceActionUpdateCommitteeCmd{} -> + "update-committee" + GovernanceActionCreateNoConfidenceCmd{} -> + "create-no-confidence" + GovernanceActionHardforkInitCmd{} -> + "create-hardfork" + GovernanceActionInfoCmd{} -> + "create-info" + GovernanceActionViewCmd{} -> + "view" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Committee.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Committee.hs index 04e657568e..baefec82aa 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Committee.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Committee.hs @@ -3,14 +3,15 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.EraBased.Commands.Governance.Committee - ( GovernanceCommitteeCmds(..) - , GovernanceCommitteeKeyGenColdCmdArgs(..) - , GovernanceCommitteeKeyGenHotCmdArgs(..) - , GovernanceCommitteeKeyHashCmdArgs(..) - , GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs(..) - , GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs(..) + ( GovernanceCommitteeCmds (..) + , GovernanceCommitteeKeyGenColdCmdArgs (..) + , GovernanceCommitteeKeyGenHotCmdArgs (..) + , GovernanceCommitteeKeyHashCmdArgs (..) + , GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs (..) + , GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs (..) , renderGovernanceCommitteeCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -22,58 +23,69 @@ import Cardano.CLI.Types.Key.VerificationKey import Data.Text (Text) data GovernanceCommitteeCmds era - = GovernanceCommitteeKeyGenColdCmd (GovernanceCommitteeKeyGenColdCmdArgs era) - | GovernanceCommitteeKeyGenHotCmd (GovernanceCommitteeKeyGenHotCmdArgs era) - | GovernanceCommitteeKeyHashCmd (GovernanceCommitteeKeyHashCmdArgs era) - | GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd (GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs era) - | GovernanceCommitteeCreateColdKeyResignationCertificateCmd (GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs era) + = GovernanceCommitteeKeyGenColdCmd + (GovernanceCommitteeKeyGenColdCmdArgs era) + | GovernanceCommitteeKeyGenHotCmd + (GovernanceCommitteeKeyGenHotCmdArgs era) + | GovernanceCommitteeKeyHashCmd + (GovernanceCommitteeKeyHashCmdArgs era) + | GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd + (GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs era) + | GovernanceCommitteeCreateColdKeyResignationCertificateCmd + (GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs era) deriving Show -data GovernanceCommitteeKeyGenColdCmdArgs era = - GovernanceCommitteeKeyGenColdCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeyOutFile :: !(File (VerificationKey ()) Out) - , skeyOutFile :: !(File (SigningKey ()) Out) - } deriving Show +data GovernanceCommitteeKeyGenColdCmdArgs era + = GovernanceCommitteeKeyGenColdCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeyOutFile :: !(File (VerificationKey ()) Out) + , skeyOutFile :: !(File (SigningKey ()) Out) + } + deriving Show -data GovernanceCommitteeKeyGenHotCmdArgs era = - GovernanceCommitteeKeyGenHotCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeyOutFile :: !(File (VerificationKey ()) Out) - , skeyOutFile :: !(File (SigningKey ()) Out) - } deriving Show +data GovernanceCommitteeKeyGenHotCmdArgs era + = GovernanceCommitteeKeyGenHotCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeyOutFile :: !(File (VerificationKey ()) Out) + , skeyOutFile :: !(File (SigningKey ()) Out) + } + deriving Show -data GovernanceCommitteeKeyHashCmdArgs era = - GovernanceCommitteeKeyHashCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeySource :: !AnyVerificationKeySource - } deriving Show +data GovernanceCommitteeKeyHashCmdArgs era + = GovernanceCommitteeKeyHashCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeySource :: !AnyVerificationKeySource + } + deriving Show -data GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs era = - GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeyColdKeySource :: !(VerificationKeySource CommitteeColdKey) - , vkeyHotKeySource :: !(VerificationKeySource CommitteeHotKey) - , outFile :: !(File () Out) - } deriving Show +data GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs era + = GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeyColdKeySource :: !(VerificationKeySource CommitteeColdKey) + , vkeyHotKeySource :: !(VerificationKeySource CommitteeHotKey) + , outFile :: !(File () Out) + } + deriving Show -data GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs era = - GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeyColdKeySource :: !(VerificationKeySource CommitteeColdKey) - , anchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))) - , outFile :: !(File () Out) - } deriving Show +data GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs era + = GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeyColdKeySource :: !(VerificationKeySource CommitteeColdKey) + , anchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))) + , outFile :: !(File () Out) + } + deriving Show renderGovernanceCommitteeCmds :: GovernanceCommitteeCmds era -> Text -renderGovernanceCommitteeCmds = ("governance committee " <>) . \case - GovernanceCommitteeKeyGenColdCmd {} -> - "key-gen-cold" - GovernanceCommitteeKeyGenHotCmd {} -> - "key-gen-hot" - GovernanceCommitteeKeyHashCmd {} -> - "key-hash" - GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd {} -> - "create-hot-key-authorization-certificate" - GovernanceCommitteeCreateColdKeyResignationCertificateCmd {} -> - "create-cold-key-resignation-certificate" +renderGovernanceCommitteeCmds = + ("governance committee " <>) . \case + GovernanceCommitteeKeyGenColdCmd{} -> + "key-gen-cold" + GovernanceCommitteeKeyGenHotCmd{} -> + "key-gen-hot" + GovernanceCommitteeKeyHashCmd{} -> + "key-hash" + GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd{} -> + "create-hot-key-authorization-certificate" + GovernanceCommitteeCreateColdKeyResignationCertificateCmd{} -> + "create-cold-key-resignation-certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/DRep.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/DRep.hs index 7e6fd77818..138601c0c2 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/DRep.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/DRep.hs @@ -5,13 +5,12 @@ module Cardano.CLI.EraBased.Commands.Governance.DRep ( GovernanceDRepCmds (..) , renderGovernanceDRepCmds - - , GovernanceDRepKeyGenCmdArgs(..) - , GovernanceDRepIdCmdArgs(..) - , GovernanceDRepRegistrationCertificateCmdArgs(..) - , GovernanceDRepRetirementCertificateCmdArgs(..) - , GovernanceDRepUpdateCertificateCmdArgs(..) - , GovernanceDRepMetadataHashCmdArgs(..) + , GovernanceDRepKeyGenCmdArgs (..) + , GovernanceDRepIdCmdArgs (..) + , GovernanceDRepRegistrationCertificateCmdArgs (..) + , GovernanceDRepRetirementCertificateCmdArgs (..) + , GovernanceDRepUpdateCertificateCmdArgs (..) + , GovernanceDRepMetadataHashCmdArgs (..) ) where @@ -25,73 +24,74 @@ import Cardano.CLI.Types.Key import Data.Text (Text) data GovernanceDRepCmds era - = GovernanceDRepKeyGenCmd !(GovernanceDRepKeyGenCmdArgs era) - | GovernanceDRepIdCmd !(GovernanceDRepIdCmdArgs era) - | GovernanceDRepRegistrationCertificateCmd !(GovernanceDRepRegistrationCertificateCmdArgs era) - | GovernanceDRepRetirementCertificateCmd !(GovernanceDRepRetirementCertificateCmdArgs era) - | GovernanceDRepUpdateCertificateCmd !(GovernanceDRepUpdateCertificateCmdArgs era) - | GovernanceDRepMetadataHashCmd !(GovernanceDRepMetadataHashCmdArgs era) + = GovernanceDRepKeyGenCmd !(GovernanceDRepKeyGenCmdArgs era) + | GovernanceDRepIdCmd !(GovernanceDRepIdCmdArgs era) + | GovernanceDRepRegistrationCertificateCmd !(GovernanceDRepRegistrationCertificateCmdArgs era) + | GovernanceDRepRetirementCertificateCmd !(GovernanceDRepRetirementCertificateCmdArgs era) + | GovernanceDRepUpdateCertificateCmd !(GovernanceDRepUpdateCertificateCmdArgs era) + | GovernanceDRepMetadataHashCmd !(GovernanceDRepMetadataHashCmdArgs era) -data GovernanceDRepKeyGenCmdArgs era = - GovernanceDRepKeyGenCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeyFile :: !(File (VerificationKey ()) Out) - , skeyFile :: !(File (SigningKey ()) Out) - } +data GovernanceDRepKeyGenCmdArgs era + = GovernanceDRepKeyGenCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeyFile :: !(File (VerificationKey ()) Out) + , skeyFile :: !(File (SigningKey ()) Out) + } -data GovernanceDRepIdCmdArgs era = - GovernanceDRepIdCmdArgs - { eon :: !(ConwayEraOnwards era) - , vkeySource :: !(VerificationKeyOrFile DRepKey) - , idOutputFormat :: !IdOutputFormat - , mOutFile :: !(Maybe (File () Out)) - } +data GovernanceDRepIdCmdArgs era + = GovernanceDRepIdCmdArgs + { eon :: !(ConwayEraOnwards era) + , vkeySource :: !(VerificationKeyOrFile DRepKey) + , idOutputFormat :: !IdOutputFormat + , mOutFile :: !(Maybe (File () Out)) + } -data GovernanceDRepRegistrationCertificateCmdArgs era = - GovernanceDRepRegistrationCertificateCmdArgs - { eon :: !(ConwayEraOnwards era) - , drepHashSource :: !DRepHashSource - , deposit :: !L.Coin - , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))) - , outFile :: !(File () Out) - } +data GovernanceDRepRegistrationCertificateCmdArgs era + = GovernanceDRepRegistrationCertificateCmdArgs + { eon :: !(ConwayEraOnwards era) + , drepHashSource :: !DRepHashSource + , deposit :: !L.Coin + , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))) + , outFile :: !(File () Out) + } -data GovernanceDRepRetirementCertificateCmdArgs era = - GovernanceDRepRetirementCertificateCmdArgs - { eon :: !(ConwayEraOnwards era) - , drepHashSource :: !DRepHashSource - , deposit :: !L.Coin - , outFile :: !(File () Out) - } +data GovernanceDRepRetirementCertificateCmdArgs era + = GovernanceDRepRetirementCertificateCmdArgs + { eon :: !(ConwayEraOnwards era) + , drepHashSource :: !DRepHashSource + , deposit :: !L.Coin + , outFile :: !(File () Out) + } -data GovernanceDRepUpdateCertificateCmdArgs era = - GovernanceDRepUpdateCertificateCmdArgs - { eon :: !(ConwayEraOnwards era) - , drepVkeyHashSource :: !(VerificationKeyOrHashOrFile DRepKey) - , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))) - , outFile :: !(File () Out) - } +data GovernanceDRepUpdateCertificateCmdArgs era + = GovernanceDRepUpdateCertificateCmdArgs + { eon :: !(ConwayEraOnwards era) + , drepVkeyHashSource :: !(VerificationKeyOrHashOrFile DRepKey) + , mAnchor :: !(Maybe (L.Anchor (L.EraCrypto (ShelleyLedgerEra era)))) + , outFile :: !(File () Out) + } -data GovernanceDRepMetadataHashCmdArgs era = - GovernanceDRepMetadataHashCmdArgs - { eon :: !(ConwayEraOnwards era) - , metadataFile :: !(DRepMetadataFile In) - , mOutFile :: !(Maybe (File () Out)) - } +data GovernanceDRepMetadataHashCmdArgs era + = GovernanceDRepMetadataHashCmdArgs + { eon :: !(ConwayEraOnwards era) + , metadataFile :: !(DRepMetadataFile In) + , mOutFile :: !(Maybe (File () Out)) + } -renderGovernanceDRepCmds :: () +renderGovernanceDRepCmds + :: () => GovernanceDRepCmds era -> Text renderGovernanceDRepCmds = \case - GovernanceDRepKeyGenCmd {} -> + GovernanceDRepKeyGenCmd{} -> "governance drep key-gen" - GovernanceDRepIdCmd {} -> + GovernanceDRepIdCmd{} -> "governance drep id" - GovernanceDRepRegistrationCertificateCmd {} -> + GovernanceDRepRegistrationCertificateCmd{} -> "governance drep registration-certificate" - GovernanceDRepRetirementCertificateCmd {} -> + GovernanceDRepRetirementCertificateCmd{} -> "governance drep retirement-certificate" - GovernanceDRepUpdateCertificateCmd {} -> + GovernanceDRepUpdateCertificateCmd{} -> "governance drep update-certificate" - GovernanceDRepMetadataHashCmd {} -> + GovernanceDRepMetadataHashCmd{} -> "governance drep metadata-hash" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Poll.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Poll.hs index bdffc26f00..1b697a96b0 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Poll.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Poll.hs @@ -3,13 +3,13 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.EraBased.Commands.Governance.Poll - ( GovernancePollCmds(..) + ( GovernancePollCmds (..) , renderGovernancePollCmds - - , GovernanceCreatePollCmdArgs(..) - , GovernanceAnswerPollCmdArgs(..) - , GovernanceVerifyPollCmdArgs(..) - ) where + , GovernanceCreatePollCmdArgs (..) + , GovernanceAnswerPollCmdArgs (..) + , GovernanceVerifyPollCmdArgs (..) + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -22,37 +22,41 @@ data GovernancePollCmds era | GovernanceVerifyPoll !(GovernanceVerifyPollCmdArgs era) -- | Create a SPO poll -data GovernanceCreatePollCmdArgs era = - GovernanceCreatePollCmdArgs - { eon :: !(BabbageEraOnwards era) - , prompt :: !Text - , choices :: ![Text] - , nonce :: !(Maybe Word) - , outFile :: !(File GovernancePoll Out) - } deriving (Eq, Show) +data GovernanceCreatePollCmdArgs era + = GovernanceCreatePollCmdArgs + { eon :: !(BabbageEraOnwards era) + , prompt :: !Text + , choices :: ![Text] + , nonce :: !(Maybe Word) + , outFile :: !(File GovernancePoll Out) + } + deriving (Eq, Show) -- | Answer a SPO poll -data GovernanceAnswerPollCmdArgs era = - GovernanceAnswerPollCmdArgs - { eon :: !(BabbageEraOnwards era) - , pollFile :: !(File GovernancePoll In) - , answerIndex :: !(Maybe Word) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Eq, Show) +data GovernanceAnswerPollCmdArgs era + = GovernanceAnswerPollCmdArgs + { eon :: !(BabbageEraOnwards era) + , pollFile :: !(File GovernancePoll In) + , answerIndex :: !(Maybe Word) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Eq, Show) -- | Verify answer to a given SPO poll -data GovernanceVerifyPollCmdArgs era = - GovernanceVerifyPollCmdArgs - { eon :: !(BabbageEraOnwards era) - , pollFile :: !(File GovernancePoll In) - , txFile :: !(File (Tx ()) In) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Eq, Show) - -renderGovernancePollCmds :: () +data GovernanceVerifyPollCmdArgs era + = GovernanceVerifyPollCmdArgs + { eon :: !(BabbageEraOnwards era) + , pollFile :: !(File GovernancePoll In) + , txFile :: !(File (Tx ()) In) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Eq, Show) + +renderGovernancePollCmds + :: () => GovernancePollCmds era -> Text renderGovernancePollCmds = \case - GovernanceCreatePoll {} -> "governance create-poll" - GovernanceAnswerPoll {} -> "governance answer-poll" - GovernanceVerifyPoll {} -> "governance verify-poll" + GovernanceCreatePoll{} -> "governance create-poll" + GovernanceAnswerPoll{} -> "governance answer-poll" + GovernanceVerifyPoll{} -> "governance verify-poll" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Vote.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Vote.hs index 2a86444c6c..a65e335989 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Vote.hs @@ -4,11 +4,13 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.EraBased.Commands.Governance.Vote - ( GovernanceVoteCmds(..) - , GovernanceVoteViewCmdArgs(..) - , GovernanceVoteCreateCmdArgs(..) + ( GovernanceVoteCmds (..) + , GovernanceVoteViewCmdArgs (..) + , GovernanceVoteCreateCmdArgs (..) , renderGovernanceVoteCmds - ) where + ) +where + import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley @@ -26,27 +28,28 @@ data GovernanceVoteCmds era data GovernanceVoteCreateCmdArgs era = GovernanceVoteCreateCmdArgs - { eon :: ConwayEraOnwards era - , voteChoice :: Vote - , governanceAction :: (TxId, Word16) - , votingStakeCredentialSource :: AnyVotingStakeVerificationKeyOrHashOrFile - , mAnchor :: Maybe (VoteUrl, L.SafeHash L.StandardCrypto L.AnchorData) - , outFile :: VoteFile Out - } + { eon :: ConwayEraOnwards era + , voteChoice :: Vote + , governanceAction :: (TxId, Word16) + , votingStakeCredentialSource :: AnyVotingStakeVerificationKeyOrHashOrFile + , mAnchor :: Maybe (VoteUrl, L.SafeHash L.StandardCrypto L.AnchorData) + , outFile :: VoteFile Out + } data GovernanceVoteViewCmdArgs era = GovernanceVoteViewCmdArgs - { eon :: ConwayEraOnwards era - , outFormat :: !ViewOutputFormat - , voteFile :: VoteFile In - , mOutFile :: Maybe (File () Out) - } + { eon :: ConwayEraOnwards era + , outFormat :: !ViewOutputFormat + , voteFile :: VoteFile In + , mOutFile :: Maybe (File () Out) + } -renderGovernanceVoteCmds :: () +renderGovernanceVoteCmds + :: () => GovernanceVoteCmds era -> Text renderGovernanceVoteCmds = \case - GovernanceVoteCreateCmd {} -> + GovernanceVoteCreateCmd{} -> "governance vote create" - GovernanceVoteViewCmd {} -> + GovernanceVoteViewCmd{} -> "governance vote view" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Key.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Key.hs index b2ef3705de..713eb685d3 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Key.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Key.hs @@ -4,16 +4,17 @@ module Cardano.CLI.EraBased.Commands.Key ( KeyCmds (..) - , KeyVerificationKeyCmdArgs(..) - , KeyNonExtendedKeyCmdArgs(..) - , KeyConvertByronKeyCmdArgs(..) - , KeyConvertByronGenesisVKeyCmdArgs(..) - , KeyConvertITNKeyCmdArgs(..) - , KeyConvertITNExtendedKeyCmdArgs(..) - , KeyConvertITNBip32KeyCmdArgs(..) - , KeyConvertCardanoAddressKeyCmdArgs(..) + , KeyVerificationKeyCmdArgs (..) + , KeyNonExtendedKeyCmdArgs (..) + , KeyConvertByronKeyCmdArgs (..) + , KeyConvertByronGenesisVKeyCmdArgs (..) + , KeyConvertITNKeyCmdArgs (..) + , KeyConvertITNExtendedKeyCmdArgs (..) + , KeyConvertITNBip32KeyCmdArgs (..) + , KeyConvertCardanoAddressKeyCmdArgs (..) , renderKeyCmds - ) where + ) +where import Cardano.Api.Shelley @@ -22,89 +23,116 @@ import Cardano.CLI.Types.Common import Data.Text (Text) data KeyCmds era - = KeyVerificationKeyCmd !KeyVerificationKeyCmdArgs - | KeyNonExtendedKeyCmd !KeyNonExtendedKeyCmdArgs - | KeyConvertByronKeyCmd !KeyConvertByronKeyCmdArgs - | KeyConvertByronGenesisVKeyCmd !KeyConvertByronGenesisVKeyCmdArgs - | KeyConvertITNKeyCmd !KeyConvertITNKeyCmdArgs - | KeyConvertITNExtendedKeyCmd !KeyConvertITNExtendedKeyCmdArgs - | KeyConvertITNBip32KeyCmd !KeyConvertITNBip32KeyCmdArgs - | KeyConvertCardanoAddressKeyCmd !KeyConvertCardanoAddressKeyCmdArgs + = KeyVerificationKeyCmd !KeyVerificationKeyCmdArgs + | KeyNonExtendedKeyCmd !KeyNonExtendedKeyCmdArgs + | KeyConvertByronKeyCmd !KeyConvertByronKeyCmdArgs + | KeyConvertByronGenesisVKeyCmd !KeyConvertByronGenesisVKeyCmdArgs + | KeyConvertITNKeyCmd !KeyConvertITNKeyCmdArgs + | KeyConvertITNExtendedKeyCmd !KeyConvertITNExtendedKeyCmdArgs + | KeyConvertITNBip32KeyCmd !KeyConvertITNBip32KeyCmdArgs + | KeyConvertCardanoAddressKeyCmd !KeyConvertCardanoAddressKeyCmdArgs deriving Show -- | Get a verification key from a signing key. This supports all key types data KeyVerificationKeyCmdArgs = KeyVerificationKeyCmdArgs - { skeyFile :: !(SigningKeyFile In) -- ^ Input filepath of the signing key - , vkeyFile :: !(VerificationKeyFile Out) -- ^ Output filepath of the verification key - } deriving Show + { skeyFile :: !(SigningKeyFile In) + -- ^ Input filepath of the signing key + , vkeyFile :: !(VerificationKeyFile Out) + -- ^ Output filepath of the verification key + } + deriving Show -- | Get a non-extended verification key from an extended verification key. This -- supports all extended key types. data KeyNonExtendedKeyCmdArgs = KeyNonExtendedKeyCmdArgs - { extendedVkeyFileIn :: !(VerificationKeyFile In) -- ^ Input filepath of the ed25519-bip32 verification key - , nonExtendedVkeyFileOut :: !(VerificationKeyFile Out) -- ^ Output filepath of the verification key - } deriving Show + { extendedVkeyFileIn :: !(VerificationKeyFile In) + -- ^ Input filepath of the ed25519-bip32 verification key + , nonExtendedVkeyFileOut :: !(VerificationKeyFile Out) + -- ^ Output filepath of the verification key + } + deriving Show -- | Convert a Byron payment, genesis or genesis delegate key (signing or -- verification) to a corresponding Shelley-format key. data KeyConvertByronKeyCmdArgs = KeyConvertByronKeyCmdArgs - { mPassword :: !(Maybe Text) -- ^ Password for signing key (if applicable) - , byronKeyType :: !ByronKeyType -- ^ The byron key type of the input file - , someKeyFileIn :: !(SomeKeyFile In) -- ^ Input file containing the byron key - , someKeyFileOut :: !(File () Out) -- ^ The output file to which the Shelley-format key will be written - } deriving Show + { mPassword :: !(Maybe Text) + -- ^ Password for signing key (if applicable) + , byronKeyType :: !ByronKeyType + -- ^ The byron key type of the input file + , someKeyFileIn :: !(SomeKeyFile In) + -- ^ Input file containing the byron key + , someKeyFileOut :: !(File () Out) + -- ^ The output file to which the Shelley-format key will be written + } + deriving Show -- Convert a Base64-encoded Byron genesis verification key to a Shelley genesis -- verification key data KeyConvertByronGenesisVKeyCmdArgs = KeyConvertByronGenesisVKeyCmdArgs - { vkey :: !VerificationKeyBase64 -- ^ Base64 string for the Byron genesis verification key - , vkeyFileOut :: !(File () Out) -- ^ The output file - } deriving Show + { vkey :: !VerificationKeyBase64 + -- ^ Base64 string for the Byron genesis verification key + , vkeyFileOut :: !(File () Out) + -- ^ The output file + } + deriving Show -- | Convert an Incentivized Testnet (ITN) non-extended (Ed25519) signing or -- verification key to a corresponding Shelley stake key data KeyConvertITNKeyCmdArgs = KeyConvertITNKeyCmdArgs - { itnKeyFile :: !(SomeKeyFile In) -- ^ Filepath of the ITN key (signing or verification) - , outFile :: !(File () Out) -- ^ The output file - } deriving Show + { itnKeyFile :: !(SomeKeyFile In) + -- ^ Filepath of the ITN key (signing or verification) + , outFile :: !(File () Out) + -- ^ The output file + } + deriving Show -- | Convert an Incentivized Testnet (ITN) extended (Ed25519Extended) signing key -- to a corresponding Shelley stake signing key data KeyConvertITNExtendedKeyCmdArgs = KeyConvertITNExtendedKeyCmdArgs - { itnPrivKeyFile :: !(SomeKeyFile In) -- ^ Filepath of the ITN signing key - , outFile :: !(File () Out) -- ^ The output file - } deriving Show + { itnPrivKeyFile :: !(SomeKeyFile In) + -- ^ Filepath of the ITN signing key + , outFile :: !(File () Out) + -- ^ The output file + } + deriving Show -- | Convert an Incentivized Testnet (ITN) BIP32 (Ed25519Bip32) signing key to a -- corresponding Shelley stake signing key data KeyConvertITNBip32KeyCmdArgs = KeyConvertITNBip32KeyCmdArgs - { itnPrivKeyFile :: !(SomeKeyFile In) -- ^ Filepath of the ITN signing key - , outFile :: !(File () Out) -- ^ The output file - } deriving Show + { itnPrivKeyFile :: !(SomeKeyFile In) + -- ^ Filepath of the ITN signing key + , outFile :: !(File () Out) + -- ^ The output file + } + deriving Show -- | Convert a cardano-address extended signing key to a corresponding -- Shelley-format key data KeyConvertCardanoAddressKeyCmdArgs = KeyConvertCardanoAddressKeyCmdArgs - { cardanoAddressKeyType :: !CardanoAddressKeyType -- ^ Address key type of th signing key input file - , skeyFileIn :: !(SigningKeyFile In) -- ^ Input filepath of the signing key - , skeyFileOut :: !(File () Out) -- ^ The output file - } deriving Show + { cardanoAddressKeyType :: !CardanoAddressKeyType + -- ^ Address key type of th signing key input file + , skeyFileIn :: !(SigningKeyFile In) + -- ^ Input filepath of the signing key + , skeyFileOut :: !(File () Out) + -- ^ The output file + } + deriving Show renderKeyCmds :: KeyCmds era -> Text renderKeyCmds = \case - KeyVerificationKeyCmd {} -> + KeyVerificationKeyCmd{} -> "key verification-key" - KeyNonExtendedKeyCmd {} -> + KeyNonExtendedKeyCmd{} -> "key non-extended-key" - KeyConvertByronKeyCmd {} -> + KeyConvertByronKeyCmd{} -> "key convert-byron-key" - KeyConvertByronGenesisVKeyCmd {} -> + KeyConvertByronGenesisVKeyCmd{} -> "key convert-byron-genesis-vkey" - KeyConvertITNKeyCmd {} -> + KeyConvertITNKeyCmd{} -> "key convert-itn-key" - KeyConvertITNExtendedKeyCmd {} -> + KeyConvertITNExtendedKeyCmd{} -> "key convert-itn-extended-key" - KeyConvertITNBip32KeyCmd {} -> + KeyConvertITNBip32KeyCmd{} -> "key convert-itn-bip32-key" - KeyConvertCardanoAddressKeyCmd {} -> + KeyConvertCardanoAddressKeyCmd{} -> "key convert-cardano-address-key" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Node.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Node.hs index cce39fc201..e2d36321eb 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Node.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Node.hs @@ -5,14 +5,14 @@ module Cardano.CLI.EraBased.Commands.Node ( NodeCmds (..) , renderNodeCmds - - , NodeKeyGenColdCmdArgs(..) - , NodeKeyGenKESCmdArgs(..) - , NodeKeyGenVRFCmdArgs(..) - , NodeKeyHashVRFCmdArgs(..) - , NodeNewCounterCmdArgs(..) - , NodeIssueOpCertCmdArgs(..) - ) where + , NodeKeyGenColdCmdArgs (..) + , NodeKeyGenKESCmdArgs (..) + , NodeKeyGenVRFCmdArgs (..) + , NodeKeyHashVRFCmdArgs (..) + , NodeNewCounterCmdArgs (..) + , NodeIssueOpCertCmdArgs (..) + ) +where import Cardano.Api.Shelley @@ -22,73 +22,73 @@ import Cardano.CLI.Types.Key import Data.Text (Text) data NodeCmds era - = NodeKeyGenColdCmd !NodeKeyGenColdCmdArgs - | NodeKeyGenKESCmd !NodeKeyGenKESCmdArgs - | NodeKeyGenVRFCmd !NodeKeyGenVRFCmdArgs - | NodeKeyHashVRFCmd !NodeKeyHashVRFCmdArgs - | NodeNewCounterCmd !NodeNewCounterCmdArgs - | NodeIssueOpCertCmd !NodeIssueOpCertCmdArgs + = NodeKeyGenColdCmd !NodeKeyGenColdCmdArgs + | NodeKeyGenKESCmd !NodeKeyGenKESCmdArgs + | NodeKeyGenVRFCmd !NodeKeyGenVRFCmdArgs + | NodeKeyHashVRFCmd !NodeKeyHashVRFCmdArgs + | NodeNewCounterCmd !NodeNewCounterCmdArgs + | NodeIssueOpCertCmd !NodeIssueOpCertCmdArgs deriving Show -data NodeKeyGenColdCmdArgs = - NodeKeyGenColdCmdArgs - { keyOutputFormat :: !KeyOutputFormat - , vkeyFile :: !(VerificationKeyFile Out) - , skeyFile :: !(SigningKeyFile Out) - , operationalCertificateIssueCounter :: !(OpCertCounterFile Out) - } +data NodeKeyGenColdCmdArgs + = NodeKeyGenColdCmdArgs + { keyOutputFormat :: !KeyOutputFormat + , vkeyFile :: !(VerificationKeyFile Out) + , skeyFile :: !(SigningKeyFile Out) + , operationalCertificateIssueCounter :: !(OpCertCounterFile Out) + } deriving Show -data NodeKeyGenKESCmdArgs = - NodeKeyGenKESCmdArgs - { keyOutputFormat :: !KeyOutputFormat - , vkeyFile :: !(VerificationKeyFile Out) - , skeyFile :: !(SigningKeyFile Out) - } +data NodeKeyGenKESCmdArgs + = NodeKeyGenKESCmdArgs + { keyOutputFormat :: !KeyOutputFormat + , vkeyFile :: !(VerificationKeyFile Out) + , skeyFile :: !(SigningKeyFile Out) + } deriving Show -data NodeKeyGenVRFCmdArgs = - NodeKeyGenVRFCmdArgs - { keyOutputFormat :: !KeyOutputFormat - , vkeyFile :: !(VerificationKeyFile Out) - , skeyFile :: !(SigningKeyFile Out) - } +data NodeKeyGenVRFCmdArgs + = NodeKeyGenVRFCmdArgs + { keyOutputFormat :: !KeyOutputFormat + , vkeyFile :: !(VerificationKeyFile Out) + , skeyFile :: !(SigningKeyFile Out) + } deriving Show -data NodeKeyHashVRFCmdArgs = - NodeKeyHashVRFCmdArgs - { vkeySource :: !(VerificationKeyOrFile VrfKey) - , mOutFile :: !(Maybe (File () Out)) - } +data NodeKeyHashVRFCmdArgs + = NodeKeyHashVRFCmdArgs + { vkeySource :: !(VerificationKeyOrFile VrfKey) + , mOutFile :: !(Maybe (File () Out)) + } deriving Show -data NodeNewCounterCmdArgs = - NodeNewCounterCmdArgs - { coldVkeyFile :: !ColdVerificationKeyOrFile - , counter :: !Word - , mOutFile :: !(OpCertCounterFile InOut) - } +data NodeNewCounterCmdArgs + = NodeNewCounterCmdArgs + { coldVkeyFile :: !ColdVerificationKeyOrFile + , counter :: !Word + , mOutFile :: !(OpCertCounterFile InOut) + } deriving Show -data NodeIssueOpCertCmdArgs = - NodeIssueOpCertCmdArgs - { kesVkeySource :: !(VerificationKeyOrFile KesKey) - -- ^ The hot KES verification key. - , poolSkeyFile :: !(SigningKeyFile In) - -- ^ The cold signing key. - , operationalCertificateCounterFile :: !(OpCertCounterFile InOut) - -- ^ Counter that establishes the precedence of the operational certificate. - , kesPeriod :: !KESPeriod - -- ^ Start of the validity period for this certificate. - , outFile :: !(File () Out) - } +data NodeIssueOpCertCmdArgs + = NodeIssueOpCertCmdArgs + { kesVkeySource :: !(VerificationKeyOrFile KesKey) + -- ^ The hot KES verification key. + , poolSkeyFile :: !(SigningKeyFile In) + -- ^ The cold signing key. + , operationalCertificateCounterFile :: !(OpCertCounterFile InOut) + -- ^ Counter that establishes the precedence of the operational certificate. + , kesPeriod :: !KESPeriod + -- ^ Start of the validity period for this certificate. + , outFile :: !(File () Out) + } deriving Show renderNodeCmds :: NodeCmds era -> Text renderNodeCmds = \case - NodeKeyGenColdCmd {} -> "node key-gen" - NodeKeyGenKESCmd {} -> "node key-gen-KES" - NodeKeyGenVRFCmd {} -> "node key-gen-VRF" - NodeKeyHashVRFCmd {} -> "node key-hash-VRF" - NodeNewCounterCmd {} -> "node new-counter" - NodeIssueOpCertCmd {} -> "node issue-op-cert" + NodeKeyGenColdCmd{} -> "node key-gen" + NodeKeyGenKESCmd{} -> "node key-gen-KES" + NodeKeyGenVRFCmd{} -> "node key-gen-VRF" + NodeKeyHashVRFCmd{} -> "node key-hash-VRF" + NodeNewCounterCmd{} -> "node new-counter" + NodeIssueOpCertCmd{} -> "node issue-op-cert" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs index fd5ce9e107..ad0cedf4c3 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs @@ -5,29 +5,30 @@ module Cardano.CLI.EraBased.Commands.Query ( QueryCmds (..) - , QueryCommitteeMembersStateCmdArgs(..) - , QueryLeadershipScheduleCmdArgs(..) - , QueryProtocolParametersCmdArgs(..) - , QueryConstitutionHashCmdArgs(..) - , QueryTipCmdArgs(..) - , QueryStakePoolsCmdArgs(..) - , QueryStakeDistributionCmdArgs(..) - , QueryStakeAddressInfoCmdArgs(..) - , QueryUTxOCmdArgs(..) - , QueryLedgerStateCmdArgs(..) - , QueryProtocolStateCmdArgs(..) - , QueryStakeSnapshotCmdArgs(..) - , QueryKesPeriodInfoCmdArgs(..) - , QueryPoolStateCmdArgs(..) - , QueryTxMempoolCmdArgs(..) - , QuerySlotNumberCmdArgs(..) - , QueryRefScriptSizeCmdArgs(..) - , QueryNoArgCmdArgs(..) - , QueryDRepStateCmdArgs(..) - , QueryDRepStakeDistributionCmdArgs(..) + , QueryCommitteeMembersStateCmdArgs (..) + , QueryLeadershipScheduleCmdArgs (..) + , QueryProtocolParametersCmdArgs (..) + , QueryConstitutionHashCmdArgs (..) + , QueryTipCmdArgs (..) + , QueryStakePoolsCmdArgs (..) + , QueryStakeDistributionCmdArgs (..) + , QueryStakeAddressInfoCmdArgs (..) + , QueryUTxOCmdArgs (..) + , QueryLedgerStateCmdArgs (..) + , QueryProtocolStateCmdArgs (..) + , QueryStakeSnapshotCmdArgs (..) + , QueryKesPeriodInfoCmdArgs (..) + , QueryPoolStateCmdArgs (..) + , QueryTxMempoolCmdArgs (..) + , QuerySlotNumberCmdArgs (..) + , QueryRefScriptSizeCmdArgs (..) + , QueryNoArgCmdArgs (..) + , QueryDRepStateCmdArgs (..) + , QueryDRepStakeDistributionCmdArgs (..) , renderQueryCmds , IncludeStake (..) - ) where + ) +where import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -41,191 +42,209 @@ import Data.Time.Clock import GHC.Generics data QueryCmds era - = QueryLeadershipScheduleCmd !QueryLeadershipScheduleCmdArgs - | QueryProtocolParametersCmd !QueryProtocolParametersCmdArgs - | QueryConstitutionHashCmd !QueryConstitutionHashCmdArgs - | QueryTipCmd !QueryTipCmdArgs - | QueryStakePoolsCmd !QueryStakePoolsCmdArgs - | QueryStakeDistributionCmd !QueryStakeDistributionCmdArgs - | QueryStakeAddressInfoCmd !QueryStakeAddressInfoCmdArgs - | QueryUTxOCmd !QueryUTxOCmdArgs - | QueryLedgerStateCmd !QueryLedgerStateCmdArgs - | QueryProtocolStateCmd !QueryProtocolStateCmdArgs - | QueryStakeSnapshotCmd !QueryStakeSnapshotCmdArgs - | QueryKesPeriodInfoCmd !QueryKesPeriodInfoCmdArgs - | QueryPoolStateCmd !QueryPoolStateCmdArgs - | QueryTxMempoolCmd !QueryTxMempoolCmdArgs - | QuerySlotNumberCmd !QuerySlotNumberCmdArgs - | QueryRefScriptSizeCmd !QueryRefScriptSizeCmdArgs - | QueryConstitutionCmd !(QueryNoArgCmdArgs era) - | QueryGovStateCmd !(QueryNoArgCmdArgs era) - | QueryDRepStateCmd !(QueryDRepStateCmdArgs era) - | QueryDRepStakeDistributionCmd !(QueryDRepStakeDistributionCmdArgs era) - | QueryCommitteeMembersStateCmd !(QueryCommitteeMembersStateCmdArgs era) + = QueryLeadershipScheduleCmd !QueryLeadershipScheduleCmdArgs + | QueryProtocolParametersCmd !QueryProtocolParametersCmdArgs + | QueryConstitutionHashCmd !QueryConstitutionHashCmdArgs + | QueryTipCmd !QueryTipCmdArgs + | QueryStakePoolsCmd !QueryStakePoolsCmdArgs + | QueryStakeDistributionCmd !QueryStakeDistributionCmdArgs + | QueryStakeAddressInfoCmd !QueryStakeAddressInfoCmdArgs + | QueryUTxOCmd !QueryUTxOCmdArgs + | QueryLedgerStateCmd !QueryLedgerStateCmdArgs + | QueryProtocolStateCmd !QueryProtocolStateCmdArgs + | QueryStakeSnapshotCmd !QueryStakeSnapshotCmdArgs + | QueryKesPeriodInfoCmd !QueryKesPeriodInfoCmdArgs + | QueryPoolStateCmd !QueryPoolStateCmdArgs + | QueryTxMempoolCmd !QueryTxMempoolCmdArgs + | QuerySlotNumberCmd !QuerySlotNumberCmdArgs + | QueryRefScriptSizeCmd !QueryRefScriptSizeCmdArgs + | QueryConstitutionCmd !(QueryNoArgCmdArgs era) + | QueryGovStateCmd !(QueryNoArgCmdArgs era) + | QueryDRepStateCmd !(QueryDRepStateCmdArgs era) + | QueryDRepStakeDistributionCmd !(QueryDRepStakeDistributionCmdArgs era) + | QueryCommitteeMembersStateCmd !(QueryCommitteeMembersStateCmdArgs era) deriving (Generic, Show) data QueryLeadershipScheduleCmdArgs = QueryLeadershipScheduleCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , genesisFp :: !GenesisFile - , poolColdVerKeyFile :: !(VerificationKeyOrHashOrFile StakePoolKey) - , vrkSkeyFp :: !(SigningKeyFile In) - , whichSchedule :: !EpochLeadershipSchedule - , target :: !(Consensus.Target ChainPoint) - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , genesisFp :: !GenesisFile + , poolColdVerKeyFile :: !(VerificationKeyOrHashOrFile StakePoolKey) + , vrkSkeyFp :: !(SigningKeyFile In) + , whichSchedule :: !EpochLeadershipSchedule + , target :: !(Consensus.Target ChainPoint) + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryProtocolParametersCmdArgs = QueryProtocolParametersCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryConstitutionHashCmdArgs = QueryConstitutionHashCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryTipCmdArgs = QueryTipCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryStakePoolsCmdArgs = QueryStakePoolsCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryStakeDistributionCmdArgs = QueryStakeDistributionCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryStakeAddressInfoCmdArgs = QueryStakeAddressInfoCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , addr :: !StakeAddress - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , addr :: !StakeAddress + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryUTxOCmdArgs = QueryUTxOCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , queryFilter :: !QueryUTxOFilter - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , queryFilter :: !QueryUTxOFilter + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryLedgerStateCmdArgs = QueryLedgerStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryProtocolStateCmdArgs = QueryProtocolStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryStakeSnapshotCmdArgs = QueryStakeSnapshotCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryKesPeriodInfoCmdArgs = QueryKesPeriodInfoCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , nodeOpCertFp :: !(File () In) -- ^ Node operational certificate - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , nodeOpCertFp :: !(File () In) + -- ^ Node operational certificate + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryPoolStateCmdArgs = QueryPoolStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryTxMempoolCmdArgs = QueryTxMempoolCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , query :: !TxMempoolQuery - , mOutFile :: !(Maybe (File () Out)) + , networkId :: !NetworkId + , query :: !TxMempoolQuery + , mOutFile :: !(Maybe (File () Out)) } deriving (Generic, Show) data QuerySlotNumberCmdArgs = QuerySlotNumberCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , utcTime :: !UTCTime - } deriving (Generic, Show) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , utcTime :: !UTCTime + } + deriving (Generic, Show) data QueryRefScriptSizeCmdArgs = QueryRefScriptSizeCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , transactionInputs :: !(Set TxIn) - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , transactionInputs :: !(Set TxIn) + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data QueryNoArgCmdArgs era = QueryNoArgCmdArgs - { eon :: !(ConwayEraOnwards era) - , nodeSocketPath :: !SocketPath + { eon :: !(ConwayEraOnwards era) + , nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving Show + , networkId :: !NetworkId + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving Show data QueryDRepStateCmdArgs era = QueryDRepStateCmdArgs - { eon :: !(ConwayEraOnwards era) - , nodeSocketPath :: !SocketPath + { eon :: !(ConwayEraOnwards era) + , nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , drepHashSources :: !(AllOrOnly DRepHashSource) - , includeStake :: !IncludeStake - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving Show + , networkId :: !NetworkId + , drepHashSources :: !(AllOrOnly DRepHashSource) + , includeStake :: !IncludeStake + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving Show -- | Whether to include the stake, as queried by drep-stake-distribution, in -- the output of drep-state. This is (computationally) expensive, but sometimes @@ -233,70 +252,72 @@ data QueryDRepStateCmdArgs era = QueryDRepStateCmdArgs data IncludeStake = WithStake | NoStake deriving Show data QueryDRepStakeDistributionCmdArgs era = QueryDRepStakeDistributionCmdArgs - { eon :: !(ConwayEraOnwards era) - , nodeSocketPath :: !SocketPath + { eon :: !(ConwayEraOnwards era) + , nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , drepHashSources :: !(AllOrOnly DRepHashSource) - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving Show + , networkId :: !NetworkId + , drepHashSources :: !(AllOrOnly DRepHashSource) + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving Show data QueryCommitteeMembersStateCmdArgs era = QueryCommitteeMembersStateCmdArgs - { eon :: !(ConwayEraOnwards era) - , nodeSocketPath :: !SocketPath - , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , committeeColdKeys :: ![VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey] - , committeeHotKeys :: ![VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey] - , memberStatuses :: ![MemberStatus] - , target :: !(Consensus.Target ChainPoint) - , mOutFile :: !(Maybe (File () Out)) - } deriving Show + { eon :: !(ConwayEraOnwards era) + , nodeSocketPath :: !SocketPath + , consensusModeParams :: !ConsensusModeParams + , networkId :: !NetworkId + , committeeColdKeys :: ![VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey] + , committeeHotKeys :: ![VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey] + , memberStatuses :: ![MemberStatus] + , target :: !(Consensus.Target ChainPoint) + , mOutFile :: !(Maybe (File () Out)) + } + deriving Show renderQueryCmds :: QueryCmds era -> Text renderQueryCmds = \case - QueryLeadershipScheduleCmd {} -> + QueryLeadershipScheduleCmd{} -> "query leadership-schedule" - QueryProtocolParametersCmd {} -> + QueryProtocolParametersCmd{} -> "query protocol-parameters " - QueryConstitutionHashCmd {} -> + QueryConstitutionHashCmd{} -> "query constitution-hash " - QueryTipCmd {} -> + QueryTipCmd{} -> "query tip" - QueryStakePoolsCmd {} -> + QueryStakePoolsCmd{} -> "query stake-pools" - QueryStakeDistributionCmd {} -> + QueryStakeDistributionCmd{} -> "query stake-distribution" - QueryStakeAddressInfoCmd {} -> + QueryStakeAddressInfoCmd{} -> "query stake-address-info" - QueryUTxOCmd {} -> + QueryUTxOCmd{} -> "query utxo" - QueryLedgerStateCmd {} -> + QueryLedgerStateCmd{} -> "query ledger-state" - QueryProtocolStateCmd {} -> + QueryProtocolStateCmd{} -> "query protocol-state" - QueryStakeSnapshotCmd {} -> + QueryStakeSnapshotCmd{} -> "query stake-snapshot" - QueryKesPeriodInfoCmd {} -> + QueryKesPeriodInfoCmd{} -> "query kes-period-info" - QueryPoolStateCmd {} -> + QueryPoolStateCmd{} -> "query pool-state" QueryTxMempoolCmd (QueryTxMempoolCmdArgs _ _ _ q _) -> "query tx-mempool" <> renderTxMempoolQuery q - QuerySlotNumberCmd {} -> + QuerySlotNumberCmd{} -> "query slot-number" - QueryRefScriptSizeCmd {} -> + QueryRefScriptSizeCmd{} -> "query ref-script-size" - QueryConstitutionCmd {} -> + QueryConstitutionCmd{} -> "constitution" - QueryGovStateCmd {} -> + QueryGovStateCmd{} -> "gov-state" - QueryDRepStateCmd {} -> + QueryDRepStateCmd{} -> "drep-state" - QueryDRepStakeDistributionCmd {} -> + QueryDRepStakeDistributionCmd{} -> "drep-stake-distribution" - QueryCommitteeMembersStateCmd {} -> + QueryCommitteeMembersStateCmd{} -> "committee-state" renderTxMempoolQuery :: TxMempoolQuery -> Text diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakeAddress.hs index 8b5e085889..fb5ed4b194 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakeAddress.hs @@ -4,7 +4,8 @@ module Cardano.CLI.EraBased.Commands.StakeAddress ( StakeAddressCmds (..) , renderStakeAddressCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley @@ -62,11 +63,11 @@ data StakeAddressCmds era renderStakeAddressCmds :: StakeAddressCmds era -> Text renderStakeAddressCmds = \case - StakeAddressBuildCmd {} -> "stake-address build" - StakeAddressDeregistrationCertificateCmd {} -> "stake-address deregistration-certificate" - StakeAddressKeyGenCmd {} -> "stake-address key-gen" - StakeAddressKeyHashCmd {} -> "stake-address key-hash" - StakeAddressRegistrationCertificateCmd {} -> "stake-address registration-certificate" - StakeAddressStakeAndVoteDelegationCertificateCmd {} -> "stake-address stake-and-vote-delegation-certificate" - StakeAddressStakeDelegationCertificateCmd {} -> "stake-address stake-delegation-certificate" - StakeAddressVoteDelegationCertificateCmd {} -> "stake-address vote-delegation-certificate" + StakeAddressBuildCmd{} -> "stake-address build" + StakeAddressDeregistrationCertificateCmd{} -> "stake-address deregistration-certificate" + StakeAddressKeyGenCmd{} -> "stake-address key-gen" + StakeAddressKeyHashCmd{} -> "stake-address key-hash" + StakeAddressRegistrationCertificateCmd{} -> "stake-address registration-certificate" + StakeAddressStakeAndVoteDelegationCertificateCmd{} -> "stake-address stake-and-vote-delegation-certificate" + StakeAddressStakeDelegationCertificateCmd{} -> "stake-address stake-delegation-certificate" + StakeAddressVoteDelegationCertificateCmd{} -> "stake-address vote-delegation-certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakePool.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakePool.hs index bb6ba472c9..39fd541f8a 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakePool.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/StakePool.hs @@ -5,12 +5,12 @@ module Cardano.CLI.EraBased.Commands.StakePool ( StakePoolCmds (..) , renderStakePoolCmds - - , StakePoolDeregistrationCertificateCmdArgs(..) - , StakePoolIdCmdArgs(..) - , StakePoolMetadataHashCmdArgs(..) - , StakePoolRegistrationCertificateCmdArgs(..) - ) where + , StakePoolDeregistrationCertificateCmdArgs (..) + , StakePoolIdCmdArgs (..) + , StakePoolMetadataHashCmdArgs (..) + , StakePoolRegistrationCertificateCmdArgs (..) + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -24,59 +24,69 @@ import Data.Text (Text) data StakePoolCmds era = StakePoolDeregistrationCertificateCmd !(StakePoolDeregistrationCertificateCmdArgs era) - | StakePoolIdCmd !(StakePoolIdCmdArgs era) - | StakePoolMetadataHashCmd !(StakePoolMetadataHashCmdArgs era) - | StakePoolRegistrationCertificateCmd !(StakePoolRegistrationCertificateCmdArgs era) + | StakePoolIdCmd !(StakePoolIdCmdArgs era) + | StakePoolMetadataHashCmd !(StakePoolMetadataHashCmdArgs era) + | StakePoolRegistrationCertificateCmd !(StakePoolRegistrationCertificateCmdArgs era) deriving Show -data StakePoolDeregistrationCertificateCmdArgs era = - StakePoolDeregistrationCertificateCmdArgs - { sbe :: !(ShelleyBasedEra era) - , poolVerificationKeyOrFile :: !(VerificationKeyOrFile StakePoolKey) - , retireEpoch :: !EpochNo - , outFile :: !(File () Out) - } +data StakePoolDeregistrationCertificateCmdArgs era + = StakePoolDeregistrationCertificateCmdArgs + { sbe :: !(ShelleyBasedEra era) + , poolVerificationKeyOrFile :: !(VerificationKeyOrFile StakePoolKey) + , retireEpoch :: !EpochNo + , outFile :: !(File () Out) + } deriving Show -data StakePoolIdCmdArgs era = - StakePoolIdCmdArgs - { poolVerificationKeyOrFile :: !(VerificationKeyOrFile StakePoolKey) - , outputFormat :: !IdOutputFormat - , mOutFile :: !(Maybe (File () Out)) - } +data StakePoolIdCmdArgs era + = StakePoolIdCmdArgs + { poolVerificationKeyOrFile :: !(VerificationKeyOrFile StakePoolKey) + , outputFormat :: !IdOutputFormat + , mOutFile :: !(Maybe (File () Out)) + } deriving Show -data StakePoolMetadataHashCmdArgs era = - StakePoolMetadataHashCmdArgs - { poolMetadataFile :: !(StakePoolMetadataFile In) - , mOutFile :: !(Maybe (File () Out)) - } +data StakePoolMetadataHashCmdArgs era + = StakePoolMetadataHashCmdArgs + { poolMetadataFile :: !(StakePoolMetadataFile In) + , mOutFile :: !(Maybe (File () Out)) + } deriving Show -data StakePoolRegistrationCertificateCmdArgs era = - StakePoolRegistrationCertificateCmdArgs - { sbe :: !(ShelleyBasedEra era) -- ^ Era in which to register the stake pool. - , poolVerificationKeyOrFile :: !(VerificationKeyOrFile StakePoolKey) -- ^ Stake pool verification key. - , vrfVerificationKeyOrFile :: !(VerificationKeyOrFile VrfKey) -- ^ VRF Verification key. - , poolPledge :: !Coin -- ^ Pool pledge. - , poolCost :: !Coin -- ^ Pool cost. - , poolMargin :: !Rational -- ^ Pool margin. - , rewardStakeVerificationKeyOrFile :: !(VerificationKeyOrFile StakeKey) -- ^ Reward account verification staking key. - , ownerStakeVerificationKeyOrFiles :: ![VerificationKeyOrFile StakeKey] -- ^ Pool owner verification staking key(s). - , relays :: ![StakePoolRelay] -- ^ Stake pool relays. - , mMetadata :: !(Maybe StakePoolMetadataReference) -- ^ Stake pool metadata. - , network :: !NetworkId - , outFile :: !(File () Out) - } +data StakePoolRegistrationCertificateCmdArgs era + = StakePoolRegistrationCertificateCmdArgs + { sbe :: !(ShelleyBasedEra era) + -- ^ Era in which to register the stake pool. + , poolVerificationKeyOrFile :: !(VerificationKeyOrFile StakePoolKey) + -- ^ Stake pool verification key. + , vrfVerificationKeyOrFile :: !(VerificationKeyOrFile VrfKey) + -- ^ VRF Verification key. + , poolPledge :: !Coin + -- ^ Pool pledge. + , poolCost :: !Coin + -- ^ Pool cost. + , poolMargin :: !Rational + -- ^ Pool margin. + , rewardStakeVerificationKeyOrFile :: !(VerificationKeyOrFile StakeKey) + -- ^ Reward account verification staking key. + , ownerStakeVerificationKeyOrFiles :: ![VerificationKeyOrFile StakeKey] + -- ^ Pool owner verification staking key(s). + , relays :: ![StakePoolRelay] + -- ^ Stake pool relays. + , mMetadata :: !(Maybe StakePoolMetadataReference) + -- ^ Stake pool metadata. + , network :: !NetworkId + , outFile :: !(File () Out) + } deriving Show renderStakePoolCmds :: StakePoolCmds era -> Text renderStakePoolCmds = \case - StakePoolDeregistrationCertificateCmd {} -> + StakePoolDeregistrationCertificateCmd{} -> "stake-pool deregistration-certificate" - StakePoolIdCmd {} -> + StakePoolIdCmd{} -> "stake-pool id" - StakePoolMetadataHashCmd {} -> + StakePoolMetadataHashCmd{} -> "stake-pool metadata-hash" - StakePoolRegistrationCertificateCmd {} -> + StakePoolRegistrationCertificateCmd{} -> "stake-pool registration-certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/TextView.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/TextView.hs index 175f361302..6f9deefe0f 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/TextView.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/TextView.hs @@ -4,7 +4,8 @@ module Cardano.CLI.EraBased.Commands.TextView ( TextViewCmds (..) , renderTextViewCmds - ) where + ) +where import Cardano.Api.Shelley diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs index ee0f33d952..0544d0c28e 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs @@ -4,22 +4,22 @@ module Cardano.CLI.EraBased.Commands.Transaction ( TransactionCmds (..) - , TransactionBuildRawCmdArgs(..) - , TransactionBuildCmdArgs(..) - , TransactionBuildEstimateCmdArgs(..) - , TransactionSignCmdArgs(..) - , TransactionWitnessCmdArgs(..) - , TransactionSignWitnessCmdArgs(..) - , TransactionSubmitCmdArgs(..) - , TransactionPolicyIdCmdArgs(..) - , TransactionCalculateMinFeeCmdArgs(..) - , TransactionCalculateMinValueCmdArgs(..) - , TransactionHashScriptDataCmdArgs(..) - , TransactionTxIdCmdArgs(..) - , TransactionViewCmdArgs(..) - + , TransactionBuildRawCmdArgs (..) + , TransactionBuildCmdArgs (..) + , TransactionBuildEstimateCmdArgs (..) + , TransactionSignCmdArgs (..) + , TransactionWitnessCmdArgs (..) + , TransactionSignWitnessCmdArgs (..) + , TransactionSubmitCmdArgs (..) + , TransactionPolicyIdCmdArgs (..) + , TransactionCalculateMinFeeCmdArgs (..) + , TransactionCalculateMinValueCmdArgs (..) + , TransactionHashScriptDataCmdArgs (..) + , TransactionTxIdCmdArgs (..) + , TransactionViewCmdArgs (..) , renderTransactionCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley @@ -30,230 +30,242 @@ import Cardano.CLI.Types.Governance import Data.Text (Text) data TransactionCmds era - = TransactionBuildRawCmd !(TransactionBuildRawCmdArgs era) - | TransactionBuildCmd !(TransactionBuildCmdArgs era) - | TransactionBuildEstimateCmd !(TransactionBuildEstimateCmdArgs era) - | TransactionSignCmd !TransactionSignCmdArgs - | TransactionWitnessCmd !TransactionWitnessCmdArgs - | TransactionSignWitnessCmd !TransactionSignWitnessCmdArgs - | TransactionSubmitCmd !TransactionSubmitCmdArgs - | TransactionPolicyIdCmd !TransactionPolicyIdCmdArgs - | TransactionCalculateMinFeeCmd !TransactionCalculateMinFeeCmdArgs - | TransactionCalculateMinValueCmd !(TransactionCalculateMinValueCmdArgs era) - | TransactionHashScriptDataCmd !TransactionHashScriptDataCmdArgs - | TransactionTxIdCmd !TransactionTxIdCmdArgs - | TransactionViewCmd !TransactionViewCmdArgs + = TransactionBuildRawCmd !(TransactionBuildRawCmdArgs era) + | TransactionBuildCmd !(TransactionBuildCmdArgs era) + | TransactionBuildEstimateCmd !(TransactionBuildEstimateCmdArgs era) + | TransactionSignCmd !TransactionSignCmdArgs + | TransactionWitnessCmd !TransactionWitnessCmdArgs + | TransactionSignWitnessCmd !TransactionSignWitnessCmdArgs + | TransactionSubmitCmd !TransactionSubmitCmdArgs + | TransactionPolicyIdCmd !TransactionPolicyIdCmdArgs + | TransactionCalculateMinFeeCmd !TransactionCalculateMinFeeCmdArgs + | TransactionCalculateMinValueCmd !(TransactionCalculateMinValueCmdArgs era) + | TransactionHashScriptDataCmd !TransactionHashScriptDataCmdArgs + | TransactionTxIdCmd !TransactionTxIdCmdArgs + | TransactionViewCmd !TransactionViewCmdArgs data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs - { eon :: !(ShelleyBasedEra era) - , mScriptValidity :: !(Maybe ScriptValidity) - -- ^ Mark script as expected to pass or fail validation - , txIns :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] - -- ^ Transaction inputs with optional spending scripts - , readOnlyRefIns :: ![TxIn] - -- ^ Read only reference inputs - , txInsCollateral :: ![TxIn] - -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) - -- ^ Return collateral - , mTotalCollateral :: !(Maybe Coin) - -- ^ Total collateral - , requiredSigners :: ![RequiredSigner] - -- ^ Required signers - , txouts :: ![TxOutAnyEra] - , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) - -- ^ Multi-Asset value with script witness - , mValidityLowerBound :: !(Maybe SlotNo) - -- ^ Transaction validity lower bound - , mValidityUpperBound :: !(TxValidityUpperBound era) - -- ^ Transaction validity upper bound - , fee :: !Coin - -- ^ Transaction fee - , certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] - -- ^ Certificates with potential script witness - , withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] - , metadataSchema :: !TxMetadataJsonSchema - , scriptFiles :: ![ScriptFile] - -- ^ Auxiliary scripts - , metadataFiles :: ![MetadataFile] - , mProtocolParamsFile :: !(Maybe ProtocolParamsFile) - , mUpdateProprosalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) - , voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] - , proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] + { eon :: !(ShelleyBasedEra era) + , mScriptValidity :: !(Maybe ScriptValidity) + -- ^ Mark script as expected to pass or fail validation + , txIns :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] + -- ^ Transaction inputs with optional spending scripts + , readOnlyRefIns :: ![TxIn] + -- ^ Read only reference inputs + , txInsCollateral :: ![TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. + , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) + -- ^ Return collateral + , mTotalCollateral :: !(Maybe Coin) + -- ^ Total collateral + , requiredSigners :: ![RequiredSigner] + -- ^ Required signers + , txouts :: ![TxOutAnyEra] + , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) + -- ^ Multi-Asset value with script witness + , mValidityLowerBound :: !(Maybe SlotNo) + -- ^ Transaction validity lower bound + , mValidityUpperBound :: !(TxValidityUpperBound era) + -- ^ Transaction validity upper bound + , fee :: !Coin + -- ^ Transaction fee + , certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Certificates with potential script witness + , withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] + , metadataSchema :: !TxMetadataJsonSchema + , scriptFiles :: ![ScriptFile] + -- ^ Auxiliary scripts + , metadataFiles :: ![MetadataFile] + , mProtocolParamsFile :: !(Maybe ProtocolParamsFile) + , mUpdateProprosalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) + , voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] + , proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] , currentTreasuryValueAndDonation :: !(Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)) - , txBodyOutFile :: !(TxBodyFile Out) - } deriving Show + , txBodyOutFile :: !(TxBodyFile Out) + } + deriving Show -- | Like 'TransactionBuildRaw' but without the fee, and with a change output. data TransactionBuildCmdArgs era = TransactionBuildCmdArgs - { eon :: !(ShelleyBasedEra era) - , nodeSocketPath :: !SocketPath - , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mScriptValidity :: !(Maybe ScriptValidity) - -- ^ Mark script as expected to pass or fail validation - , mOverrideWitnesses :: !(Maybe Word) - -- ^ Override the required number of tx witnesses - , txins :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] - -- ^ Transaction inputs with optional spending scripts + { eon :: !(ShelleyBasedEra era) + , nodeSocketPath :: !SocketPath + , consensusModeParams :: !ConsensusModeParams + , networkId :: !NetworkId + , mScriptValidity :: !(Maybe ScriptValidity) + -- ^ Mark script as expected to pass or fail validation + , mOverrideWitnesses :: !(Maybe Word) + -- ^ Override the required number of tx witnesses + , txins :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] + -- ^ Transaction inputs with optional spending scripts , readOnlyReferenceInputs :: ![TxIn] - -- ^ Read only reference inputs - , requiredSigners :: ![RequiredSigner] - -- ^ Required signers - , txinsc :: ![TxIn] - -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) - -- ^ Return collateral - , mTotalCollateral :: !(Maybe Coin) - -- ^ Total collateral - , txouts :: ![TxOutAnyEra] - -- ^ Normal outputs - , changeAddresses :: !TxOutChangeAddress - -- ^ A change output - , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) - -- ^ Multi-Asset value with script witness - , mValidityLowerBound :: !(Maybe SlotNo) - -- ^ Transaction validity lower bound - , mValidityUpperBound :: !(TxValidityUpperBound era) - -- ^ Transaction validity upper bound - , certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] - -- ^ Certificates with potential script witness - , withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] - -- ^ Withdrawals with potential script witness - , metadataSchema :: !TxMetadataJsonSchema - , scriptFiles :: ![ScriptFile] - -- ^ Auxiliary scripts - , metadataFiles :: ![MetadataFile] - , mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) - , voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] - , proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] - , treasuryDonation :: !(Maybe TxTreasuryDonation) - , buildOutputOptions :: !TxBuildOutputOptions - } deriving Show + -- ^ Read only reference inputs + , requiredSigners :: ![RequiredSigner] + -- ^ Required signers + , txinsc :: ![TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. + , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) + -- ^ Return collateral + , mTotalCollateral :: !(Maybe Coin) + -- ^ Total collateral + , txouts :: ![TxOutAnyEra] + -- ^ Normal outputs + , changeAddresses :: !TxOutChangeAddress + -- ^ A change output + , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) + -- ^ Multi-Asset value with script witness + , mValidityLowerBound :: !(Maybe SlotNo) + -- ^ Transaction validity lower bound + , mValidityUpperBound :: !(TxValidityUpperBound era) + -- ^ Transaction validity upper bound + , certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Certificates with potential script witness + , withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Withdrawals with potential script witness + , metadataSchema :: !TxMetadataJsonSchema + , scriptFiles :: ![ScriptFile] + -- ^ Auxiliary scripts + , metadataFiles :: ![MetadataFile] + , mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) + , voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] + , proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] + , treasuryDonation :: !(Maybe TxTreasuryDonation) + , buildOutputOptions :: !TxBuildOutputOptions + } + deriving Show -- | Like 'TransactionBuildCmd' but does not require explicit access to a running node data TransactionBuildEstimateCmdArgs era = TransactionBuildEstimateCmdArgs - { eon :: !(MaryEraOnwards era) - , mScriptValidity :: !(Maybe ScriptValidity) - -- ^ Mark script as expected to pass or fail validation - , shelleyWitnesses :: !Int - -- ^ Number of shelley witnesses to be added - , mByronWitnesses :: !(Maybe Int) - , protocolParamsFile :: !ProtocolParamsFile - , totalUTxOValue :: !Value - , txins :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] - -- ^ Transaction inputs with optional spending scripts + { eon :: !(MaryEraOnwards era) + , mScriptValidity :: !(Maybe ScriptValidity) + -- ^ Mark script as expected to pass or fail validation + , shelleyWitnesses :: !Int + -- ^ Number of shelley witnesses to be added + , mByronWitnesses :: !(Maybe Int) + , protocolParamsFile :: !ProtocolParamsFile + , totalUTxOValue :: !Value + , txins :: ![(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] + -- ^ Transaction inputs with optional spending scripts , readOnlyReferenceInputs :: ![TxIn] - -- ^ Read only reference inputs - , requiredSigners :: ![RequiredSigner] - -- ^ Required signers - , txinsc :: ![TxIn] - -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) - -- ^ Return collateral - , txouts :: ![TxOutAnyEra] - -- ^ Normal outputs - , changeAddress :: !TxOutChangeAddress - -- ^ A change output - , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) - -- ^ Multi-Asset value with script witness - , mValidityLowerBound :: !(Maybe SlotNo) - -- ^ Transaction validity lower bound - , mValidityUpperBound :: !(TxValidityUpperBound era) - -- ^ Transaction validity upper bound - , certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] - -- ^ Certificates with potential script witness - , withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] - -- ^ Withdrawals with potential script witness + -- ^ Read only reference inputs + , requiredSigners :: ![RequiredSigner] + -- ^ Required signers + , txinsc :: ![TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. + , mReturnCollateral :: !(Maybe TxOutShelleyBasedEra) + -- ^ Return collateral + , txouts :: ![TxOutAnyEra] + -- ^ Normal outputs + , changeAddress :: !TxOutChangeAddress + -- ^ A change output + , mValue :: !(Maybe (Value, [ScriptWitnessFiles WitCtxMint])) + -- ^ Multi-Asset value with script witness + , mValidityLowerBound :: !(Maybe SlotNo) + -- ^ Transaction validity lower bound + , mValidityUpperBound :: !(TxValidityUpperBound era) + -- ^ Transaction validity upper bound + , certificates :: ![(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Certificates with potential script witness + , withdrawals :: ![(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Withdrawals with potential script witness , plutusCollateral :: !(Maybe Coin) - -- ^ Total collateral + -- ^ Total collateral , totalReferenceScriptSize :: !(Maybe ReferenceScriptSize) - -- ^ Size of all reference scripts in bytes - , metadataSchema :: !TxMetadataJsonSchema - , scriptFiles :: ![ScriptFile] - -- ^ Auxiliary scripts - , metadataFiles :: ![MetadataFile] - , mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) - , voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] - , proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Size of all reference scripts in bytes + , metadataSchema :: !TxMetadataJsonSchema + , scriptFiles :: ![ScriptFile] + -- ^ Auxiliary scripts + , metadataFiles :: ![MetadataFile] + , mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) + , voteFiles :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] + , proposalFiles :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] , currentTreasuryValueAndDonation :: !(Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)) - , txBodyOutFile :: !(TxBodyFile Out) + , txBodyOutFile :: !(TxBodyFile Out) } data TransactionSignCmdArgs = TransactionSignCmdArgs - { txOrTxBodyFile :: !InputTxBodyOrTxFile - , witnessSigningData :: ![WitnessSigningData] - , mNetworkId :: !(Maybe NetworkId) - , outTxFile :: !(TxFile Out) - } deriving Show + { txOrTxBodyFile :: !InputTxBodyOrTxFile + , witnessSigningData :: ![WitnessSigningData] + , mNetworkId :: !(Maybe NetworkId) + , outTxFile :: !(TxFile Out) + } + deriving Show data TransactionWitnessCmdArgs = TransactionWitnessCmdArgs - { txBodyFile :: !(TxBodyFile In) - , witnessSigningData :: !WitnessSigningData - , mNetworkId :: !(Maybe NetworkId) - , outFile :: !(File () Out) - } deriving Show + { txBodyFile :: !(TxBodyFile In) + , witnessSigningData :: !WitnessSigningData + , mNetworkId :: !(Maybe NetworkId) + , outFile :: !(File () Out) + } + deriving Show data TransactionSignWitnessCmdArgs = TransactionSignWitnessCmdArgs - { txBodyFile :: !(TxBodyFile In) - , witnessFiles :: ![WitnessFile] - , outFile :: !(File () Out) - } deriving Show + { txBodyFile :: !(TxBodyFile In) + , witnessFiles :: ![WitnessFile] + , outFile :: !(File () Out) + } + deriving Show data TransactionSubmitCmdArgs = TransactionSubmitCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , txFile :: !FilePath - } deriving Show + , networkId :: !NetworkId + , txFile :: !FilePath + } + deriving Show newtype TransactionPolicyIdCmdArgs = TransactionPolicyIdCmdArgs - { scriptFile :: ScriptFile - } deriving Show + { scriptFile :: ScriptFile + } + deriving Show data TransactionCalculateMinFeeCmdArgs = TransactionCalculateMinFeeCmdArgs - { txBodyFile :: !(TxBodyFile In) - , protocolParamsFile :: !ProtocolParamsFile + { txBodyFile :: !(TxBodyFile In) + , protocolParamsFile :: !ProtocolParamsFile , txShelleyWitnessCount :: !TxShelleyWitnessCount - , txByronWitnessCount :: !TxByronWitnessCount - -- | The total size in bytes of the transaction reference scripts. - , referenceScriptSize :: !ReferenceScriptSize - , outputFormat :: !(Maybe OutputFormatJsonOrText) - , outFile :: !(Maybe (File () Out)) - } deriving Show + , txByronWitnessCount :: !TxByronWitnessCount + , referenceScriptSize :: !ReferenceScriptSize + -- ^ The total size in bytes of the transaction reference scripts. + , outputFormat :: !(Maybe OutputFormatJsonOrText) + , outFile :: !(Maybe (File () Out)) + } + deriving Show data TransactionCalculateMinValueCmdArgs era = TransactionCalculateMinValueCmdArgs - { eon :: !(ShelleyBasedEra era) - , protocolParamsFile :: !ProtocolParamsFile - , txOut :: !TxOutShelleyBasedEra - } deriving Show + { eon :: !(ShelleyBasedEra era) + , protocolParamsFile :: !ProtocolParamsFile + , txOut :: !TxOutShelleyBasedEra + } + deriving Show newtype TransactionHashScriptDataCmdArgs = TransactionHashScriptDataCmdArgs - { scriptDataOrFile :: ScriptDataOrFile - } deriving Show + { scriptDataOrFile :: ScriptDataOrFile + } + deriving Show newtype TransactionTxIdCmdArgs = TransactionTxIdCmdArgs { inputTxBodyOrTxFile :: InputTxBodyOrTxFile - } deriving Show + } + deriving Show data TransactionViewCmdArgs = TransactionViewCmdArgs - { outputFormat :: !ViewOutputFormat - , mOutFile :: !(Maybe (File () Out)) + { outputFormat :: !ViewOutputFormat + , mOutFile :: !(Maybe (File () Out)) , inputTxBodyOrTxFile :: !InputTxBodyOrTxFile - } deriving Show + } + deriving Show renderTransactionCmds :: TransactionCmds era -> Text renderTransactionCmds = \case - TransactionBuildCmd {} -> "transaction build" - TransactionBuildEstimateCmd {} -> "transaction build-estimate" - TransactionBuildRawCmd {} -> "transaction build-raw" - TransactionSignCmd {} -> "transaction sign" - TransactionWitnessCmd {} -> "transaction witness" - TransactionSignWitnessCmd {} -> "transaction sign-witness" - TransactionSubmitCmd {} -> "transaction submit" - TransactionPolicyIdCmd {} -> "transaction policyid" - TransactionCalculateMinFeeCmd {} -> "transaction calculate-min-fee" - TransactionCalculateMinValueCmd {} -> "transaction calculate-min-value" - TransactionHashScriptDataCmd {} -> "transaction hash-script-data" - TransactionTxIdCmd {} -> "transaction txid" - TransactionViewCmd {} -> "transaction view" + TransactionBuildCmd{} -> "transaction build" + TransactionBuildEstimateCmd{} -> "transaction build-estimate" + TransactionBuildRawCmd{} -> "transaction build-raw" + TransactionSignCmd{} -> "transaction sign" + TransactionWitnessCmd{} -> "transaction witness" + TransactionSignWitnessCmd{} -> "transaction sign-witness" + TransactionSubmitCmd{} -> "transaction submit" + TransactionPolicyIdCmd{} -> "transaction policyid" + TransactionCalculateMinFeeCmd{} -> "transaction calculate-min-fee" + TransactionCalculateMinValueCmd{} -> "transaction calculate-min-value" + TransactionHashScriptDataCmd{} -> "transaction hash-script-data" + TransactionTxIdCmd{} -> "transaction txid" + TransactionViewCmd{} -> "transaction view" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Address.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Address.hs index da23388d97..6d112b36e9 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Address.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Address.hs @@ -5,7 +5,8 @@ module Cardano.CLI.EraBased.Options.Address ( pAddressCmds - ) where + ) +where import Cardano.Api @@ -16,33 +17,35 @@ import Cardano.CLI.EraBased.Options.Common import Options.Applicative hiding (help, str) import qualified Options.Applicative as Opt -pAddressCmds :: () +pAddressCmds + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (AddressCmds era)) pAddressCmds _ envCli = - subInfoParser "address" - ( Opt.progDesc - $ mconcat + subInfoParser + "address" + ( Opt.progDesc $ + mconcat [ "Payment address commands." ] ) - [ Just - $ subParser "key-gen" - $ Opt.info pAddressKeyGen - $ Opt.progDesc "Create an address key pair." - , Just - $ subParser "key-hash" - $ Opt.info pAddressKeyHash - $ Opt.progDesc "Print the hash of an address key." - , Just - $ subParser "build" - $ Opt.info (pAddressBuild envCli) - $ Opt.progDesc "Build a Shelley payment address, with optional delegation to a stake address." - , Just - $ subParser "info" - $ Opt.info pAddressInfo - $ Opt.progDesc "Print information about an address." + [ Just $ + subParser "key-gen" $ + Opt.info pAddressKeyGen $ + Opt.progDesc "Create an address key pair." + , Just $ + subParser "key-hash" $ + Opt.info pAddressKeyHash $ + Opt.progDesc "Print the hash of an address key." + , Just $ + subParser "build" $ + Opt.info (pAddressBuild envCli) $ + Opt.progDesc "Build a Shelley payment address, with optional delegation to a stake address." + , Just $ + subParser "info" $ + Opt.info pAddressInfo $ + Opt.progDesc "Print information about an address." ] pAddressKeyGen :: Parser (AddressCmds era) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs index b161150f4d..3ae63b6c6a 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Common.hs @@ -64,7 +64,7 @@ defaultShelleyToBabbageEra = EraInEon ShelleyToBabbageEraBabbage command' :: String -> String -> Parser a -> Mod CommandFields a command' c descr p = mconcat - [ command c (info (p <**> helper) $ mconcat [ progDesc descr ]) + [ command c (info (p <**> helper) $ mconcat [progDesc descr]) , metavar c ] @@ -77,130 +77,163 @@ prefixFlag prefix longFlag = Just prefix' -> prefix' <> "-" <> longFlag pNetworkIdDeprecated :: Parser NetworkId -pNetworkIdDeprecated = asum - [ Opt.flag' Mainnet $ mconcat - [ Opt.long "mainnet" - , Opt.help "DEPRECATED. This argument has no effect." - ] - , fmap (Testnet . NetworkMagic) $ Opt.option (bounded "TESTNET_MAGIC") $ mconcat - [ Opt.long "testnet-magic" - , Opt.metavar "NATURAL" - , Opt.help "DEPRECATED. This argument has no effect." +pNetworkIdDeprecated = + asum + [ Opt.flag' Mainnet $ + mconcat + [ Opt.long "mainnet" + , Opt.help "DEPRECATED. This argument has no effect." + ] + , fmap (Testnet . NetworkMagic) $ + Opt.option (bounded "TESTNET_MAGIC") $ + mconcat + [ Opt.long "testnet-magic" + , Opt.metavar "NATURAL" + , Opt.help "DEPRECATED. This argument has no effect." + ] ] - ] pNetworkId :: EnvCli -> Parser NetworkId -pNetworkId envCli = asum $ mconcat - [ [ Opt.flag' Mainnet $ mconcat - [ Opt.long "mainnet" - , Opt.help $ mconcat - [ "Use the mainnet magic id. This overrides the CARDANO_NODE_NETWORK_ID " - , "environment variable" - ] - ] - , fmap (Testnet . NetworkMagic) $ Opt.option (bounded "TESTNET_MAGIC") $ mconcat - [ Opt.long "testnet-magic" - , Opt.metavar "NATURAL" - , Opt.help $ mconcat - [ "Specify a testnet magic id. This overrides the CARDANO_NODE_NETWORK_ID " - , "environment variable" +pNetworkId envCli = + asum $ + mconcat + [ + [ Opt.flag' Mainnet $ + mconcat + [ Opt.long "mainnet" + , Opt.help $ + mconcat + [ "Use the mainnet magic id. This overrides the CARDANO_NODE_NETWORK_ID " + , "environment variable" + ] + ] + , fmap (Testnet . NetworkMagic) $ + Opt.option (bounded "TESTNET_MAGIC") $ + mconcat + [ Opt.long "testnet-magic" + , Opt.metavar "NATURAL" + , Opt.help $ + mconcat + [ "Specify a testnet magic id. This overrides the CARDANO_NODE_NETWORK_ID " + , "environment variable" + ] + ] ] + , -- Default to the network id specified by the environment variable if it is available. + pure <$> maybeToList (envCliNetworkId envCli) ] - ] - , -- Default to the network id specified by the environment variable if it is available. - pure <$> maybeToList (envCliNetworkId envCli) - ] pTarget :: CardanoEra era -> Parser (Consensus.Target ChainPoint) pTarget = inEonForEra (pure Consensus.VolatileTip) pTargetFromConway - where + where pTargetFromConway :: ConwayEraOnwards era -> Parser (Consensus.Target ChainPoint) pTargetFromConway _ = - asum $ mconcat - [ [ Opt.flag' Consensus.VolatileTip $ mconcat - [ Opt.long "volatile-tip" - , Opt.help $ mconcat - [ "Use the volatile tip as a target. (This is the default)" - ] - ] - , Opt.flag' Consensus.ImmutableTip $ mconcat - [ Opt.long "immutable-tip" - , Opt.help $ mconcat - [ "Use the immutable tip as a target." - ] + asum $ + mconcat + [ + [ Opt.flag' Consensus.VolatileTip $ + mconcat + [ Opt.long "volatile-tip" + , Opt.help $ + mconcat + [ "Use the volatile tip as a target. (This is the default)" + ] + ] + , Opt.flag' Consensus.ImmutableTip $ + mconcat + [ Opt.long "immutable-tip" + , Opt.help $ + mconcat + [ "Use the immutable tip as a target." + ] + ] ] + , -- Default to volatile tip if not specified + [pure Consensus.VolatileTip] ] - , -- Default to volatile tip if not specified - [ pure Consensus.VolatileTip ] - ] toUnitIntervalOrErr :: Rational -> L.UnitInterval toUnitIntervalOrErr r = case L.boundRational r of - Nothing -> - error $ mconcat [ "toUnitIntervalOrErr: " - , "rational out of bounds " <> show r - ] - Just n -> n + Nothing -> + error $ + mconcat + [ "toUnitIntervalOrErr: " + , "rational out of bounds " <> show r + ] + Just n -> n pConsensusModeParams :: Parser ConsensusModeParams -pConsensusModeParams = asum - [ pCardanoMode *> pCardanoConsensusMode - , pDefaultConsensusMode - ] - where - pCardanoMode :: Parser () - pCardanoMode = - Opt.flag' () $ mconcat +pConsensusModeParams = + asum + [ pCardanoMode *> pCardanoConsensusMode + , pDefaultConsensusMode + ] + where + pCardanoMode :: Parser () + pCardanoMode = + Opt.flag' () $ + mconcat [ Opt.long "cardano-mode" , Opt.help "For talking to a node running in full Cardano mode (default)." ] - pCardanoConsensusMode :: Parser ConsensusModeParams - pCardanoConsensusMode = CardanoModeParams <$> pEpochSlots + pCardanoConsensusMode :: Parser ConsensusModeParams + pCardanoConsensusMode = CardanoModeParams <$> pEpochSlots - pDefaultConsensusMode :: Parser ConsensusModeParams - pDefaultConsensusMode = - pure . CardanoModeParams $ EpochSlots defaultByronEpochSlots + pDefaultConsensusMode :: Parser ConsensusModeParams + pDefaultConsensusMode = + pure . CardanoModeParams $ EpochSlots defaultByronEpochSlots defaultByronEpochSlots :: Word64 defaultByronEpochSlots = 21600 pEpochSlots :: Parser EpochSlots pEpochSlots = - fmap EpochSlots $ Opt.option (bounded "SLOTS") $ mconcat - [ Opt.long "epoch-slots" - , Opt.metavar "SLOTS" - , Opt.help "The number of slots per epoch for the Byron era." - , Opt.value defaultByronEpochSlots -- Default to the mainnet value. - , Opt.showDefault - ] + fmap EpochSlots $ + Opt.option (bounded "SLOTS") $ + mconcat + [ Opt.long "epoch-slots" + , Opt.metavar "SLOTS" + , Opt.help "The number of slots per epoch for the Byron era." + , Opt.value defaultByronEpochSlots -- Default to the mainnet value. + , Opt.showDefault + ] pSocketPath :: EnvCli -> Parser SocketPath pSocketPath envCli = - asum $ mconcat - [ [ fmap File $ Opt.strOption $ mconcat - [ Opt.long "socket-path" - , Opt.metavar "SOCKET_PATH" - , Opt.help $ mconcat - [ "Path to the node socket. This overrides the CARDANO_NODE_SOCKET_PATH " - , "environment variable. The argument is optional if CARDANO_NODE_SOCKET_PATH " - , "is defined and mandatory otherwise." - ] - , Opt.completer (Opt.bashCompleter "file") + asum $ + mconcat + [ + [ fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "socket-path" + , Opt.metavar "SOCKET_PATH" + , Opt.help $ + mconcat + [ "Path to the node socket. This overrides the CARDANO_NODE_SOCKET_PATH " + , "environment variable. The argument is optional if CARDANO_NODE_SOCKET_PATH " + , "is defined and mandatory otherwise." + ] + , Opt.completer (Opt.bashCompleter "file") + ] ] + , -- Default to the socket path specified by the environment variable if it is available. + pure . File <$> maybeToList (envCliSocketPath envCli) ] - , -- Default to the socket path specified by the environment variable if it is available. - pure . File <$> maybeToList (envCliSocketPath envCli) - ] readerFromParsecParser :: Parsec.Parser a -> Opt.ReadM a readerFromParsecParser p = - Opt.eitherReader (first formatError . Parsec.parse (p <* Parsec.eof) "") - where - formatError err = - Parsec.showErrorMessages "or" "unknown parse error" - "expecting" "unexpected" "end of input" - (Parsec.errorMessages err) + Opt.eitherReader (first formatError . Parsec.parse (p <* Parsec.eof) "") + where + formatError err = + Parsec.showErrorMessages + "or" + "unknown parse error" + "expecting" + "unexpected" + "end of input" + (Parsec.errorMessages err) parseTxIn :: Parsec.Parser TxIn parseTxIn = TxIn <$> parseTxId <*> (Parsec.char '#' *> parseTxIx) @@ -216,100 +249,112 @@ parseTxIx :: Parsec.Parser TxIx parseTxIx = TxIx . fromIntegral <$> decimal decimal :: Parsec.Parser Integer -Parsec.TokenParser { Parsec.decimal = decimal } = Parsec.haskell - +Parsec.TokenParser{Parsec.decimal = decimal} = Parsec.haskell pStakeIdentifier :: Maybe String -> Parser StakeIdentifier -pStakeIdentifier prefix = asum - [ StakeIdentifierVerifier <$> pStakeVerifier prefix - , StakeIdentifierAddress <$> pStakeAddress prefix - ] +pStakeIdentifier prefix = + asum + [ StakeIdentifierVerifier <$> pStakeVerifier prefix + , StakeIdentifierAddress <$> pStakeAddress prefix + ] pStakeVerifier :: Maybe String -> Parser StakeVerifier -pStakeVerifier prefix = asum - [ StakeVerifierKey <$> pStakeVerificationKeyOrHashOrFile prefix - , StakeVerifierScriptFile <$> pScriptFor (prefixFlag prefix "stake-script-file") Nothing "Filepath of the staking script." - ] +pStakeVerifier prefix = + asum + [ StakeVerifierKey <$> pStakeVerificationKeyOrHashOrFile prefix + , StakeVerifierScriptFile + <$> pScriptFor (prefixFlag prefix "stake-script-file") Nothing "Filepath of the staking script." + ] pStakeAddress :: Maybe String -> Parser StakeAddress pStakeAddress prefix = - Opt.option (readerFromParsecParser parseStakeAddress) $ mconcat - [ Opt.long $ prefixFlag prefix "stake-address" - , Opt.metavar "ADDRESS" - , Opt.help "Target stake address (bech32 format)." - ] + Opt.option (readerFromParsecParser parseStakeAddress) $ + mconcat + [ Opt.long $ prefixFlag prefix "stake-address" + , Opt.metavar "ADDRESS" + , Opt.help "Target stake address (bech32 format)." + ] parseStakeAddress :: Parsec.Parser StakeAddress parseStakeAddress = do str' <- lexPlausibleAddressString case deserialiseAddress AsStakeAddress str' of - Nothing -> fail $ "invalid address: " <> Text.unpack str' + Nothing -> fail $ "invalid address: " <> Text.unpack str' Just addr -> pure addr -- | First argument is the optional prefix pStakeVerificationKeyOrFile :: Maybe String -> Parser (VerificationKeyOrFile StakeKey) pStakeVerificationKeyOrFile prefix = - VerificationKeyValue <$> pStakeVerificationKey prefix - <|> VerificationKeyFilePath <$> pStakeVerificationKeyFile prefix + VerificationKeyValue + <$> pStakeVerificationKey prefix + <|> VerificationKeyFilePath + <$> pStakeVerificationKeyFile prefix pScriptFor :: String -> Maybe String -> String -> Parser ScriptFile pScriptFor name Nothing help' = - fmap File $ Opt.strOption $ mconcat - [ Opt.long name - , Opt.metavar "FILE" - , Opt.help help' - , Opt.completer (Opt.bashCompleter "file") - ] - + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long name + , Opt.metavar "FILE" + , Opt.help help' + , Opt.completer (Opt.bashCompleter "file") + ] pScriptFor name (Just deprecated) help' = - pScriptFor name Nothing help' - <|> File <$> Opt.strOption - ( Opt.long deprecated - <> Opt.internal - ) + pScriptFor name Nothing help' + <|> File + <$> Opt.strOption + ( Opt.long deprecated + <> Opt.internal + ) -- | The first argument is the optional prefix. pStakeVerificationKey :: Maybe String -> Parser (VerificationKey StakeKey) pStakeVerificationKey prefix = - Opt.option (readVerificationKey AsStakeKey) $ mconcat - [ Opt.long $ prefixFlag prefix "stake-verification-key" - , Opt.metavar "STRING" - , Opt.help "Stake verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey AsStakeKey) $ + mconcat + [ Opt.long $ prefixFlag prefix "stake-verification-key" + , Opt.metavar "STRING" + , Opt.help "Stake verification key (Bech32 or hex-encoded)." + ] -- | Read a Bech32 or hex-encoded verification key. readVerificationKey - :: forall keyrole. SerialiseAsBech32 (VerificationKey keyrole) + :: forall keyrole + . SerialiseAsBech32 (VerificationKey keyrole) => AsType keyrole -> Opt.ReadM (VerificationKey keyrole) readVerificationKey asType = - Opt.eitherReader deserialiseFromBech32OrHex - where - keyFormats :: NonEmpty (InputFormat (VerificationKey keyrole)) - keyFormats = NE.fromList [InputFormatBech32, InputFormatHex] - - deserialiseFromBech32OrHex - :: String - -> Either String (VerificationKey keyrole) - deserialiseFromBech32OrHex str' = - first (docToString . renderInputDecodeError) $ - deserialiseInput (AsVerificationKey asType) keyFormats (BSC.pack str') + Opt.eitherReader deserialiseFromBech32OrHex + where + keyFormats :: NonEmpty (InputFormat (VerificationKey keyrole)) + keyFormats = NE.fromList [InputFormatBech32, InputFormatHex] + + deserialiseFromBech32OrHex + :: String + -> Either String (VerificationKey keyrole) + deserialiseFromBech32OrHex str' = + first (docToString . renderInputDecodeError) $ + deserialiseInput (AsVerificationKey asType) keyFormats (BSC.pack str') -- | The first argument is the optional prefix. pStakeVerificationKeyFile :: Maybe String -> Parser (VerificationKeyFile In) pStakeVerificationKeyFile prefix = - File <$> asum - [ Opt.strOption $ mconcat - [ Opt.long $ prefixFlag prefix "stake-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the staking verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long $ prefixFlag prefix "staking-verification-key-file" - , Opt.internal + File + <$> asum + [ Opt.strOption $ + mconcat + [ Opt.long $ prefixFlag prefix "stake-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the staking verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long $ prefixFlag prefix "staking-verification-key-file" + , Opt.internal + ] ] - ] subParser :: String -> ParserInfo a -> Parser a subParser availableCommand pInfo = @@ -322,131 +367,149 @@ subInfoParser name i mps = case catMaybes mps of pAnyShelleyBasedEra :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pAnyShelleyBasedEra envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraShelley) - $ mconcat [Opt.long "shelley-era", Opt.help "Specify the Shelley era"] - , Opt.flag' (EraInEon ShelleyBasedEraAllegra) - $ mconcat [Opt.long "allegra-era", Opt.help "Specify the Allegra era"] - , Opt.flag' (EraInEon ShelleyBasedEraMary) - $ mconcat [Opt.long "mary-era", Opt.help "Specify the Mary era"] - , Opt.flag' (EraInEon ShelleyBasedEraAlonzo) - $ mconcat [Opt.long "alonzo-era", Opt.help "Specify the Alonzo era"] - , Opt.flag' (EraInEon ShelleyBasedEraBabbage) - $ mconcat [Opt.long "babbage-era", Opt.help "Specify the Babbage era (default)"] - , Opt.flag' (EraInEon ShelleyBasedEraConway) - $ mconcat [Opt.long "conway-era", Opt.help "Specify the Conway era"] - ] - , maybeToList $ pure <$> envCliAnyShelleyBasedEra envCli - , pure $ pure defaultShelleyBasedEra - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraShelley) $ + mconcat [Opt.long "shelley-era", Opt.help "Specify the Shelley era"] + , Opt.flag' (EraInEon ShelleyBasedEraAllegra) $ + mconcat [Opt.long "allegra-era", Opt.help "Specify the Allegra era"] + , Opt.flag' (EraInEon ShelleyBasedEraMary) $ + mconcat [Opt.long "mary-era", Opt.help "Specify the Mary era"] + , Opt.flag' (EraInEon ShelleyBasedEraAlonzo) $ + mconcat [Opt.long "alonzo-era", Opt.help "Specify the Alonzo era"] + , Opt.flag' (EraInEon ShelleyBasedEraBabbage) $ + mconcat [Opt.long "babbage-era", Opt.help "Specify the Babbage era (default)"] + , Opt.flag' (EraInEon ShelleyBasedEraConway) $ + mconcat [Opt.long "conway-era", Opt.help "Specify the Conway era"] + ] + , maybeToList $ pure <$> envCliAnyShelleyBasedEra envCli + , pure $ pure defaultShelleyBasedEra + ] pAnyShelleyToBabbageEra :: EnvCli -> Parser (EraInEon ShelleyToBabbageEra) pAnyShelleyToBabbageEra envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyToBabbageEraShelley) - $ mconcat [Opt.long "shelley-era", Opt.help "Specify the Shelley era"] - , Opt.flag' (EraInEon ShelleyToBabbageEraAllegra) - $ mconcat [Opt.long "allegra-era", Opt.help "Specify the Allegra era"] - , Opt.flag' (EraInEon ShelleyToBabbageEraMary) - $ mconcat [Opt.long "mary-era", Opt.help "Specify the Mary era"] - , Opt.flag' (EraInEon ShelleyToBabbageEraAlonzo) - $ mconcat [Opt.long "alonzo-era", Opt.help "Specify the Alonzo era"] - , Opt.flag' (EraInEon ShelleyToBabbageEraBabbage) - $ mconcat [Opt.long "babbage-era", Opt.help "Specify the Babbage era (default)"] - ] - , maybeToList $ pure <$> envCliAnyShelleyToBabbageEra envCli - , pure $ pure defaultShelleyToBabbageEra - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyToBabbageEraShelley) $ + mconcat [Opt.long "shelley-era", Opt.help "Specify the Shelley era"] + , Opt.flag' (EraInEon ShelleyToBabbageEraAllegra) $ + mconcat [Opt.long "allegra-era", Opt.help "Specify the Allegra era"] + , Opt.flag' (EraInEon ShelleyToBabbageEraMary) $ + mconcat [Opt.long "mary-era", Opt.help "Specify the Mary era"] + , Opt.flag' (EraInEon ShelleyToBabbageEraAlonzo) $ + mconcat [Opt.long "alonzo-era", Opt.help "Specify the Alonzo era"] + , Opt.flag' (EraInEon ShelleyToBabbageEraBabbage) $ + mconcat [Opt.long "babbage-era", Opt.help "Specify the Babbage era (default)"] + ] + , maybeToList $ pure <$> envCliAnyShelleyToBabbageEra envCli + , pure $ pure defaultShelleyToBabbageEra + ] pShelleyBasedShelley :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pShelleyBasedShelley envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraShelley) - $ mconcat [Opt.long "shelley-era", Opt.help "Specify the Shelley era"] - ] - , maybeToList - $ fmap pure - $ mfilter (== EraInEon ShelleyBasedEraShelley) - $ envCliAnyShelleyBasedEra envCli - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraShelley) $ + mconcat [Opt.long "shelley-era", Opt.help "Specify the Shelley era"] + ] + , maybeToList $ + fmap pure $ + mfilter (== EraInEon ShelleyBasedEraShelley) $ + envCliAnyShelleyBasedEra envCli + ] pShelleyBasedAllegra :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pShelleyBasedAllegra envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraAllegra) - $ mconcat [Opt.long "allegra-era", Opt.help "Specify the Allegra era"] - ] - , maybeToList - $ fmap pure - $ mfilter (== EraInEon ShelleyBasedEraAllegra) - $ envCliAnyShelleyBasedEra envCli - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraAllegra) $ + mconcat [Opt.long "allegra-era", Opt.help "Specify the Allegra era"] + ] + , maybeToList $ + fmap pure $ + mfilter (== EraInEon ShelleyBasedEraAllegra) $ + envCliAnyShelleyBasedEra envCli + ] pShelleyBasedMary :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pShelleyBasedMary envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraMary) - $ mconcat [Opt.long "mary-era", Opt.help "Specify the Mary era"] - ] - , maybeToList - $ fmap pure - $ mfilter (== EraInEon ShelleyBasedEraMary) - $ envCliAnyShelleyBasedEra envCli - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraMary) $ + mconcat [Opt.long "mary-era", Opt.help "Specify the Mary era"] + ] + , maybeToList $ + fmap pure $ + mfilter (== EraInEon ShelleyBasedEraMary) $ + envCliAnyShelleyBasedEra envCli + ] pShelleyBasedAlonzo :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pShelleyBasedAlonzo envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraAlonzo) - $ mconcat [Opt.long "alonzo-era", Opt.help "Specify the Alonzo era"] - ] - , maybeToList - $ fmap pure - $ mfilter (== EraInEon ShelleyBasedEraAlonzo) - $ envCliAnyShelleyBasedEra envCli - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraAlonzo) $ + mconcat [Opt.long "alonzo-era", Opt.help "Specify the Alonzo era"] + ] + , maybeToList $ + fmap pure $ + mfilter (== EraInEon ShelleyBasedEraAlonzo) $ + envCliAnyShelleyBasedEra envCli + ] pShelleyBasedBabbage :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pShelleyBasedBabbage envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraBabbage) - $ mconcat [Opt.long "babbage-era", Opt.help "Specify the Babbage era (default)"] - ] - , maybeToList - $ fmap pure - $ mfilter (== EraInEon ShelleyBasedEraBabbage) - $ envCliAnyShelleyBasedEra envCli - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraBabbage) $ + mconcat [Opt.long "babbage-era", Opt.help "Specify the Babbage era (default)"] + ] + , maybeToList $ + fmap pure $ + mfilter (== EraInEon ShelleyBasedEraBabbage) $ + envCliAnyShelleyBasedEra envCli + ] pShelleyBasedConway :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pShelleyBasedConway envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraConway) - $ mconcat [Opt.long "conway-era", Opt.help "Specify the Conway era"] - ] - , maybeToList - $ fmap pure - $ mfilter (== EraInEon ShelleyBasedEraConway) - $ envCliAnyShelleyBasedEra envCli - ] + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraConway) $ + mconcat [Opt.long "conway-era", Opt.help "Specify the Conway era"] + ] + , maybeToList $ + fmap pure $ + mfilter (== EraInEon ShelleyBasedEraConway) $ + envCliAnyShelleyBasedEra envCli + ] pFileOutDirection :: String -> String -> Parser (File a Out) pFileOutDirection l h = - Opt.strOption $ mconcat - [ Opt.long l - , Opt.metavar "FILE" - , Opt.help h - , Opt.completer (Opt.bashCompleter "file") - ] + Opt.strOption $ + mconcat + [ Opt.long l + , Opt.metavar "FILE" + , Opt.help h + , Opt.completer (Opt.bashCompleter "file") + ] pFileInDirection :: String -> String -> Parser (File a In) pFileInDirection l h = - Opt.strOption $ mconcat - [ Opt.long l - , Opt.metavar "FILE" - , Opt.help h - , Opt.completer (Opt.bashCompleter "file") - ] + Opt.strOption $ + mconcat + [ Opt.long l + , Opt.metavar "FILE" + , Opt.help h + , Opt.completer (Opt.bashCompleter "file") + ] parseLovelace :: Parsec.Parser L.Coin parseLovelace = do @@ -466,110 +529,127 @@ pStakePoolVerificationKeyOrFile prefix = -- | The first argument is the optional prefix. pStakePoolVerificationKey :: Maybe String -> Parser (VerificationKey StakePoolKey) pStakePoolVerificationKey prefix = - Opt.option (readVerificationKey AsStakePoolKey) $ mconcat - [ Opt.long $ prefixFlag prefix "stake-pool-verification-key" - , Opt.metavar "STRING" - , Opt.help "Stake pool verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey AsStakePoolKey) $ + mconcat + [ Opt.long $ prefixFlag prefix "stake-pool-verification-key" + , Opt.metavar "STRING" + , Opt.help "Stake pool verification key (Bech32 or hex-encoded)." + ] -- | The first argument is the optional prefix. pStakePoolVerificationKeyFile :: Maybe String -> Parser (VerificationKeyFile In) pStakePoolVerificationKeyFile prefix = - File <$> asum - [ Opt.strOption $ mconcat - [ Opt.long $ prefixFlag prefix "cold-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the stake pool verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long $ prefixFlag prefix "stake-pool-verification-key-file" - , Opt.internal + File + <$> asum + [ Opt.strOption $ + mconcat + [ Opt.long $ prefixFlag prefix "cold-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the stake pool verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long $ prefixFlag prefix "stake-pool-verification-key-file" + , Opt.internal + ] ] - ] pOutputFile :: Parser (File content Out) pOutputFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "out-file" - , Opt.metavar "FILE" - , Opt.help "The output file." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "out-file" + , Opt.metavar "FILE" + , Opt.help "The output file." + , Opt.completer (Opt.bashCompleter "file") + ] pMIRPot :: Parser L.MIRPot pMIRPot = asum - [ Opt.flag' L.ReservesMIR $ mconcat - [ Opt.long "reserves" - , Opt.help "Use the reserves pot." - ] - , Opt.flag' L.TreasuryMIR $ mconcat - [ Opt.long "treasury" - , Opt.help "Use the treasury pot." - ] + [ Opt.flag' L.ReservesMIR $ + mconcat + [ Opt.long "reserves" + , Opt.help "Use the reserves pot." + ] + , Opt.flag' L.TreasuryMIR $ + mconcat + [ Opt.long "treasury" + , Opt.help "Use the treasury pot." + ] ] pRewardAmt :: Parser L.Coin pRewardAmt = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "reward" - , Opt.metavar "LOVELACE" - , Opt.help "The reward for the relevant reward account." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "reward" + , Opt.metavar "LOVELACE" + , Opt.help "The reward for the relevant reward account." + ] pTransferAmt :: Parser L.Coin pTransferAmt = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "transfer" - , Opt.metavar "LOVELACE" - , Opt.help "The amount to transfer." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "transfer" + , Opt.metavar "LOVELACE" + , Opt.help "The amount to transfer." + ] -rHexHash :: () +rHexHash + :: () => SerialiseAsRawBytes (Hash a) => AsType a - -> Maybe String -- ^ Optional prefix to the error message + -> Maybe String + -- ^ Optional prefix to the error message -> ReadM (Hash a) rHexHash a mErrPrefix = Opt.eitherReader $ first (\e -> errPrefix <> (docToString $ prettyError e)) . deserialiseFromRawBytesHex (AsHash a) . BSC.pack - where - errPrefix = maybe "" (": " <>) mErrPrefix + where + errPrefix = maybe "" (": " <>) mErrPrefix rBech32KeyHash :: SerialiseAsBech32 (Hash a) => AsType a -> ReadM (Hash a) rBech32KeyHash a = Opt.eitherReader $ first (docToString . prettyError) - . deserialiseFromBech32 (AsHash a) - . Text.pack + . deserialiseFromBech32 (AsHash a) + . Text.pack pGenesisDelegateVerificationKey :: Parser (VerificationKey GenesisDelegateKey) pGenesisDelegateVerificationKey = - Opt.option deserialiseFromHex $ mconcat - [ Opt.long "genesis-delegate-verification-key" - , Opt.metavar "STRING" - , Opt.help "Genesis delegate verification key (hex-encoded)." - ] - where - deserialiseFromHex = - rVerificationKey AsGenesisDelegateKey (Just "Invalid genesis delegate verification key") + Opt.option deserialiseFromHex $ + mconcat + [ Opt.long "genesis-delegate-verification-key" + , Opt.metavar "STRING" + , Opt.help "Genesis delegate verification key (hex-encoded)." + ] + where + deserialiseFromHex = + rVerificationKey AsGenesisDelegateKey (Just "Invalid genesis delegate verification key") -- | Reader for verification keys -rVerificationKey :: () +rVerificationKey + :: () => SerialiseAsRawBytes (VerificationKey a) - => AsType a -- ^ Singleton value identifying the kind of verification keys - -> Maybe String -- ^ Optional prefix to the error message + => AsType a + -- ^ Singleton value identifying the kind of verification keys + -> Maybe String + -- ^ Optional prefix to the error message -> ReadM (VerificationKey a) rVerificationKey a mErrPrefix = - Opt.eitherReader $ first - (\e -> errPrefix <> (docToString $ prettyError e)) - . deserialiseFromRawBytesHex (AsVerificationKey a) - . BSC.pack - where - errPrefix = maybe "" (": " <>) mErrPrefix + Opt.eitherReader $ + first + (\e -> errPrefix <> (docToString $ prettyError e)) + . deserialiseFromRawBytesHex (AsVerificationKey a) + . BSC.pack + where + errPrefix = maybe "" (": " <>) mErrPrefix -- | The first argument is the optional prefix. pColdVerificationKeyOrFile :: Maybe String -> Parser ColdVerificationKeyOrFile @@ -582,89 +662,104 @@ pColdVerificationKeyOrFile prefix = pColdVerificationKeyFile :: Parser (VerificationKeyFile direction) pColdVerificationKeyFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "cold-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the cold verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "verification-key-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "cold-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the cold verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "verification-key-file" + , Opt.internal + ] ] - ] -- TODO CIP-1694 parameterise this by signing key role pColdSigningKeyFile :: Parser (File (SigningKey keyrole) direction) pColdSigningKeyFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "cold-signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the cold signing key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "signing-key-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "cold-signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the cold signing key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "signing-key-file" + , Opt.internal + ] ] - ] -- TODO CIP-1694 parameterise this by verification key role pVerificationKeyFileOut :: Parser (File (VerificationKey keyrole) Out) pVerificationKeyFileOut = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Output filepath of the verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Output filepath of the verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pSigningKeyFileOut :: Parser (File (SigningKey keyrole) Out) pSigningKeyFileOut = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Output filepath of the signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Output filepath of the signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pOperatorCertIssueCounterFile :: Parser (File OpCertCounter direction) pOperatorCertIssueCounterFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "operational-certificate-issue-counter-file" - , Opt.metavar "FILE" - , Opt.help "The file with the issue counter for the operational certificate." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "operational-certificate-issue-counter" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "operational-certificate-issue-counter-file" + , Opt.metavar "FILE" + , Opt.help "The file with the issue counter for the operational certificate." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "operational-certificate-issue-counter" + , Opt.internal + ] ] - ] --- -pAddCommitteeColdVerificationKeySource :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey) +pAddCommitteeColdVerificationKeySource + :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey) pAddCommitteeColdVerificationKeySource = asum [ VkhfshKeyHashFile . VerificationKeyOrFile <$> pAddCommitteeColdVerificationKeyOrFile , VkhfshKeyHashFile . VerificationKeyHash <$> pAddCommitteeColdVerificationKeyHash - , VkhfshScriptHash <$> - pScriptHash + , VkhfshScriptHash + <$> pScriptHash "add-cc-cold-script-hash" "Cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." ] pAddCommitteeColdVerificationKeyHash :: Parser (Hash CommitteeColdKey) pAddCommitteeColdVerificationKeyHash = - Opt.option deserialiseColdCCKeyHashFromHex $ mconcat - [ Opt.long "add-cc-cold-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee key hash (hex-encoded)." - ] + Opt.option deserialiseColdCCKeyHashFromHex $ + mconcat + [ Opt.long "add-cc-cold-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee key hash (hex-encoded)." + ] pAddCommitteeColdVerificationKeyOrFile :: Parser (VerificationKeyOrFile CommitteeColdKey) pAddCommitteeColdVerificationKeyOrFile = @@ -675,54 +770,62 @@ pAddCommitteeColdVerificationKeyOrFile = pAddCommitteeColdVerificationKey :: Parser (VerificationKey CommitteeColdKey) pAddCommitteeColdVerificationKey = - Opt.option deserialiseFromHex $ mconcat - [ Opt.long "add-cc-cold-verification-key" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee cold key (hex-encoded)." - ] - where - deserialiseFromHex = - rVerificationKey AsCommitteeColdKey (Just "Invalid Constitutional Committee cold key") + Opt.option deserialiseFromHex $ + mconcat + [ Opt.long "add-cc-cold-verification-key" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee cold key (hex-encoded)." + ] + where + deserialiseFromHex = + rVerificationKey AsCommitteeColdKey (Just "Invalid Constitutional Committee cold key") pAddCommitteeColdVerificationKeyFile :: Parser (File (VerificationKey keyrole) In) pAddCommitteeColdVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "add-cc-cold-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the Constitutional Committee cold key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "add-cc-cold-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the Constitutional Committee cold key." + , Opt.completer (Opt.bashCompleter "file") + ] --- -pRemoveCommitteeColdVerificationKeySource :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey) +pRemoveCommitteeColdVerificationKeySource + :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey) pRemoveCommitteeColdVerificationKeySource = asum [ VkhfshKeyHashFile . VerificationKeyOrFile <$> pRemoveCommitteeColdVerificationKeyOrFile , VkhfshKeyHashFile . VerificationKeyHash <$> pRemoveCommitteeColdVerificationKeyHash - , VkhfshScriptHash <$> - pScriptHash + , VkhfshScriptHash + <$> pScriptHash "remove-cc-cold-script-hash" "Cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." ] pScriptHash - :: String -- ^ long option name - -> String -- ^ help text + :: String + -- ^ long option name + -> String + -- ^ help text -> Parser ScriptHash pScriptHash longOptionName helpText = - Opt.option scriptHashReader $ mconcat - [ Opt.long longOptionName - , Opt.metavar "HASH" - , Opt.help helpText - ] + Opt.option scriptHashReader $ + mconcat + [ Opt.long longOptionName + , Opt.metavar "HASH" + , Opt.help helpText + ] pRemoveCommitteeColdVerificationKeyHash :: Parser (Hash CommitteeColdKey) pRemoveCommitteeColdVerificationKeyHash = - Opt.option deserialiseColdCCKeyHashFromHex $ mconcat - [ Opt.long "remove-cc-cold-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee key hash (hex-encoded)." - ] + Opt.option deserialiseColdCCKeyHashFromHex $ + mconcat + [ Opt.long "remove-cc-cold-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee key hash (hex-encoded)." + ] pRemoveCommitteeColdVerificationKeyOrFile :: Parser (VerificationKeyOrFile CommitteeColdKey) pRemoveCommitteeColdVerificationKeyOrFile = @@ -733,11 +836,12 @@ pRemoveCommitteeColdVerificationKeyOrFile = pRemoveCommitteeColdVerificationKey :: Parser (VerificationKey CommitteeColdKey) pRemoveCommitteeColdVerificationKey = - Opt.option deserialiseColdCCKeyFromHex $ mconcat - [ Opt.long "remove-cc-cold-verification-key" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee cold key (hex-encoded)." - ] + Opt.option deserialiseColdCCKeyFromHex $ + mconcat + [ Opt.long "remove-cc-cold-verification-key" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee cold key (hex-encoded)." + ] deserialiseColdCCKeyFromHex :: ReadM (VerificationKey CommitteeColdKey) deserialiseColdCCKeyFromHex = @@ -749,12 +853,14 @@ deserialiseColdCCKeyHashFromHex = pRemoveCommitteeColdVerificationKeyFile :: Parser (File (VerificationKey keyrole) In) pRemoveCommitteeColdVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "remove-cc-cold-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the Constitutional Committee cold key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "remove-cc-cold-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the Constitutional Committee cold key." + , Opt.completer (Opt.bashCompleter "file") + ] --- @@ -774,54 +880,64 @@ pCommitteeColdVerificationKeyOrFile = pCommitteeColdVerificationKey :: Parser (VerificationKey CommitteeColdKey) pCommitteeColdVerificationKey = - Opt.option deserialiseColdCCKeyFromHex $ mconcat - [ Opt.long "cold-verification-key" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee cold key (hex-encoded)." - ] + Opt.option deserialiseColdCCKeyFromHex $ + mconcat + [ Opt.long "cold-verification-key" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee cold key (hex-encoded)." + ] pCommitteeColdVerificationKeyHash :: Parser (Hash CommitteeColdKey) pCommitteeColdVerificationKeyHash = - Opt.option deserialiseColdCCKeyHashFromHex $ mconcat - [ Opt.long "cold-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee key hash (hex-encoded)." - ] + Opt.option deserialiseColdCCKeyHashFromHex $ + mconcat + [ Opt.long "cold-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee key hash (hex-encoded)." + ] pCommitteeColdVerificationKeyFile :: Parser (File (VerificationKey keyrole) In) pCommitteeColdVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "cold-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the Constitutional Committee cold key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "cold-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the Constitutional Committee cold key." + , Opt.completer (Opt.bashCompleter "file") + ] pVerificationKeyFileIn :: Parser (VerificationKeyFile In) pVerificationKeyFileIn = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pAnyVerificationKeyFileIn :: String -> Parser (VerificationKeyFile In) pAnyVerificationKeyFileIn helpText = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "verification-key-file" - , Opt.metavar "FILE" - , Opt.help $ "Input filepath of the " <> helpText <> "." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "verification-key-file" + , Opt.metavar "FILE" + , Opt.help $ "Input filepath of the " <> helpText <> "." + , Opt.completer (Opt.bashCompleter "file") + ] pAnyVerificationKeyText :: String -> Parser AnyVerificationKeyText pAnyVerificationKeyText helpText = - fmap (AnyVerificationKeyText . Text.pack) $ Opt.strOption $ mconcat - [ Opt.long "verification-key" - , Opt.metavar "STRING" - , Opt.help $ helpText <> " (Bech32-encoded)" - ] + fmap (AnyVerificationKeyText . Text.pack) $ + Opt.strOption $ + mconcat + [ Opt.long "verification-key" + , Opt.metavar "STRING" + , Opt.help $ helpText <> " (Bech32-encoded)" + ] pAnyVerificationKeySource :: String -> Parser AnyVerificationKeySource pAnyVerificationKeySource helpText = @@ -842,19 +958,21 @@ pCommitteeHotVerificationKeyOrFile = pCommitteeHotVerificationKeyHash :: Parser (Hash CommitteeHotKey) pCommitteeHotVerificationKeyHash = - Opt.option deserialiseHotCCKeyHashFromHex $ mconcat - [ Opt.long "hot-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee key hash (hex-encoded)." - ] + Opt.option deserialiseHotCCKeyHashFromHex $ + mconcat + [ Opt.long "hot-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee key hash (hex-encoded)." + ] pCommitteeHotVerificationKey :: String -> Parser (VerificationKey CommitteeHotKey) pCommitteeHotVerificationKey longFlag = - Opt.option deserialiseHotCCKeyFromHex $ mconcat - [ Opt.long longFlag - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee hot key (hex-encoded)." - ] + Opt.option deserialiseHotCCKeyFromHex $ + mconcat + [ Opt.long longFlag + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee hot key (hex-encoded)." + ] deserialiseHotCCKeyFromHex :: ReadM (VerificationKey CommitteeHotKey) deserialiseHotCCKeyFromHex = @@ -866,21 +984,24 @@ deserialiseHotCCKeyHashFromHex = pCommitteeHotVerificationKeyFile :: String -> Parser (VerificationKeyFile In) pCommitteeHotVerificationKeyFile longFlag = - fmap File $ Opt.strOption $ mconcat - [ Opt.long longFlag - , Opt.metavar "FILE" - , Opt.help "Filepath of the Constitutional Committee hot key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long longFlag + , Opt.metavar "FILE" + , Opt.help "Filepath of the Constitutional Committee hot key." + , Opt.completer (Opt.bashCompleter "file") + ] -- | The first argument is the optional prefix. pCommitteeHotKeyHash :: Maybe String -> Parser (Hash CommitteeHotKey) pCommitteeHotKeyHash prefix = - Opt.option deserialiseHotCCKeyHashFromHex $ mconcat - [ Opt.long $ prefixFlag prefix "hot-key-hash" - , Opt.metavar "STRING" - , Opt.help "Constitutional Committee key hash (hex-encoded)." - ] + Opt.option deserialiseHotCCKeyHashFromHex $ + mconcat + [ Opt.long $ prefixFlag prefix "hot-key-hash" + , Opt.metavar "STRING" + , Opt.help "Constitutional Committee key hash (hex-encoded)." + ] pCommitteeHotKeyOrHashOrFile :: Parser (VerificationKeyOrHashOrFile CommitteeHotKey) pCommitteeHotKeyOrHashOrFile = @@ -890,20 +1011,24 @@ pCommitteeHotKeyOrHashOrFile = , VerificationKeyHash <$> pCommitteeHotKeyHash Nothing ] -pCommitteeHotVerificationKeyOrHashOrVerificationFile :: Parser (VerificationKeyOrHashOrFile CommitteeHotKey) +pCommitteeHotVerificationKeyOrHashOrVerificationFile + :: Parser (VerificationKeyOrHashOrFile CommitteeHotKey) pCommitteeHotVerificationKeyOrHashOrVerificationFile = asum - [ VerificationKeyOrFile . VerificationKeyValue <$> pCommitteeHotVerificationKey "cc-hot-verification-key", - VerificationKeyOrFile . VerificationKeyFilePath <$> pCommitteeHotVerificationKeyFile "cc-hot-verification-key-file", - VerificationKeyHash <$> pCommitteeHotKeyHash (Just "cc") + [ VerificationKeyOrFile . VerificationKeyValue + <$> pCommitteeHotVerificationKey "cc-hot-verification-key" + , VerificationKeyOrFile . VerificationKeyFilePath + <$> pCommitteeHotVerificationKeyFile "cc-hot-verification-key-file" + , VerificationKeyHash <$> pCommitteeHotKeyHash (Just "cc") ] -pCommitteeHotVerificationKeyOrHashOrVerificationFileOrScriptHash :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey) +pCommitteeHotVerificationKeyOrHashOrVerificationFileOrScriptHash + :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey) pCommitteeHotVerificationKeyOrHashOrVerificationFileOrScriptHash = asum [ VkhfshKeyHashFile <$> pCommitteeHotVerificationKeyOrHashOrVerificationFile - , VkhfshScriptHash <$> - pScriptHash + , VkhfshScriptHash + <$> pScriptHash "cc-hot-script-hash" "Cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." ] @@ -920,55 +1045,61 @@ pConstitutionUrl = pConstitutionHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData) pConstitutionHash = - Opt.option readSafeHash $ mconcat - [ Opt.long "constitution-hash" - , Opt.metavar "HASH" - , Opt.help "Hash of the constitution data (obtain it with \"cardano-cli hash anchor-data ...\")." - ] + Opt.option readSafeHash $ + mconcat + [ Opt.long "constitution-hash" + , Opt.metavar "HASH" + , Opt.help "Hash of the constitution data (obtain it with \"cardano-cli hash anchor-data ...\")." + ] pUrl :: String -> String -> Parser L.Url pUrl l h = - let toUrl urlText = fromMaybe (error "Url longer than 64 bytes") - $ L.textToUrl (Text.length urlText) urlText - in fmap toUrl . Opt.strOption - $ mconcat [ Opt.long l - , Opt.metavar "TEXT" - , Opt.help h - ] + let toUrl urlText = + fromMaybe (error "Url longer than 64 bytes") $ + L.textToUrl (Text.length urlText) urlText + in fmap toUrl . Opt.strOption $ + mconcat + [ Opt.long l + , Opt.metavar "TEXT" + , Opt.help h + ] pGovActionDeposit :: Parser L.Coin pGovActionDeposit = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "governance-action-deposit" - , Opt.metavar "NATURAL" - , Opt.help "Deposit required to submit a governance action." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "governance-action-deposit" + , Opt.metavar "NATURAL" + , Opt.help "Deposit required to submit a governance action." + ] pNewGovActionDeposit :: Parser L.Coin pNewGovActionDeposit = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "new-governance-action-deposit" - , Opt.metavar "NATURAL" - , Opt.help "Proposed new value of the deposit required to submit a governance action." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "new-governance-action-deposit" + , Opt.metavar "NATURAL" + , Opt.help "Proposed new value of the deposit required to submit a governance action." + ] -- | First argument is the optional prefix pStakeVerificationKeyOrHashOrFile :: Maybe String -> Parser (VerificationKeyOrHashOrFile StakeKey) -pStakeVerificationKeyOrHashOrFile prefix = asum - [ VerificationKeyOrFile <$> pStakeVerificationKeyOrFile prefix - , VerificationKeyHash <$> pStakeVerificationKeyHash prefix - ] +pStakeVerificationKeyOrHashOrFile prefix = + asum + [ VerificationKeyOrFile <$> pStakeVerificationKeyOrFile prefix + , VerificationKeyHash <$> pStakeVerificationKeyHash prefix + ] -- | First argument is the optional prefix pStakeVerificationKeyHash :: Maybe String -> Parser (Hash StakeKey) pStakeVerificationKeyHash prefix = - Opt.option (rHexHash AsStakeKey Nothing) $ mconcat + Opt.option (rHexHash AsStakeKey Nothing) $ + mconcat [ Opt.long $ prefixFlag prefix "stake-key-hash" , Opt.metavar "HASH" , Opt.help "Stake verification key hash (hex-encoded)." ] - -- | The first argument is the optional prefix. pStakePoolVerificationKeyOrHashOrFile :: Maybe String -> Parser (VerificationKeyOrHashOrFile StakePoolKey) @@ -983,139 +1114,165 @@ pStakePoolVerificationKeyOrHashOrFile prefix = pCBORInFile :: Parser FilePath pCBORInFile = asum - [ Opt.strOption $ mconcat - [ Opt.long "in-file" - , Opt.metavar "FILE" - , Opt.help "CBOR input file." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "file" - , Opt.internal - ] + [ Opt.strOption $ + mconcat + [ Opt.long "in-file" + , Opt.metavar "FILE" + , Opt.help "CBOR input file." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "file" + , Opt.internal + ] ] -------------------------------------------------------------------------------- pPollQuestion :: Parser Text pPollQuestion = - Opt.strOption $ mconcat - [ Opt.long "question" - , Opt.metavar "STRING" - , Opt.help "The question for the poll." - ] + Opt.strOption $ + mconcat + [ Opt.long "question" + , Opt.metavar "STRING" + , Opt.help "The question for the poll." + ] pPollAnswer :: Parser Text pPollAnswer = - Opt.strOption $ mconcat - [ Opt.long "answer" - , Opt.metavar "STRING" - , Opt.help "A possible choice for the poll. The option is repeatable." - ] + Opt.strOption $ + mconcat + [ Opt.long "answer" + , Opt.metavar "STRING" + , Opt.help "A possible choice for the poll. The option is repeatable." + ] pPollAnswerIndex :: Parser Word pPollAnswerIndex = - Opt.option auto $ mconcat - [ Opt.long "answer" - , Opt.metavar "INT" - , Opt.help "The index of the chosen answer in the poll. Optional. Asked interactively if omitted." - ] + Opt.option auto $ + mconcat + [ Opt.long "answer" + , Opt.metavar "INT" + , Opt.help "The index of the chosen answer in the poll. Optional. Asked interactively if omitted." + ] pPollFile :: Parser (File GovernancePoll In) pPollFile = - Opt.strOption $ mconcat - [ Opt.long "poll-file" - , Opt.metavar "FILE" - , Opt.help "Filepath to the ongoing poll." - , Opt.completer (Opt.bashCompleter "file") - ] + Opt.strOption $ + mconcat + [ Opt.long "poll-file" + , Opt.metavar "FILE" + , Opt.help "Filepath to the ongoing poll." + , Opt.completer (Opt.bashCompleter "file") + ] pPollTxFile :: Parser (TxFile In) pPollTxFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "tx-file" - , Opt.metavar "FILE" - , Opt.help "Filepath to the JSON TxBody or JSON Tx carrying a valid poll answer." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "tx-file" + , Opt.metavar "FILE" + , Opt.help "Filepath to the JSON TxBody or JSON Tx carrying a valid poll answer." + , Opt.completer (Opt.bashCompleter "file") + ] pPollNonce :: Parser Word pPollNonce = - Opt.option auto $ mconcat - [ Opt.long "nonce" - , Opt.metavar "UINT" - , Opt.help "An (optional) nonce for non-replayability." - ] + Opt.option auto $ + mconcat + [ Opt.long "nonce" + , Opt.metavar "UINT" + , Opt.help "An (optional) nonce for non-replayability." + ] -------------------------------------------------------------------------------- -pScriptWitnessFiles :: forall witctx. - WitCtx witctx - -> BalanceTxExecUnits -- ^ Use the @execution-units@ flag. - -> String -- ^ Script flag prefix - -> Maybe String - -> String - -> Parser (ScriptWitnessFiles witctx) +pScriptWitnessFiles + :: forall witctx + . WitCtx witctx + -> BalanceTxExecUnits + -- ^ Use the @execution-units@ flag. + -> String + -- ^ Script flag prefix + -> Maybe String + -> String + -> Parser (ScriptWitnessFiles witctx) pScriptWitnessFiles witctx autoBalanceExecUnits scriptFlagPrefix scriptFlagPrefixDeprecated help = - toScriptWitnessFiles - <$> pScriptFor (scriptFlagPrefix ++ "-script-file") - ((++ "-script-file") <$> scriptFlagPrefixDeprecated) - ("The file containing the script to witness " ++ help) - <*> optional ((,,) <$> pScriptDatumOrFile scriptFlagPrefix witctx - <*> pScriptRedeemerOrFile scriptFlagPrefix - <*> (case autoBalanceExecUnits of - AutoBalance -> pure (ExecutionUnits 0 0) - ManualBalance -> pExecutionUnits scriptFlagPrefix) - ) - where - toScriptWitnessFiles :: ScriptFile - -> Maybe (ScriptDatumOrFile witctx, - ScriptRedeemerOrFile, - ExecutionUnits) - -> ScriptWitnessFiles witctx - toScriptWitnessFiles sf Nothing = SimpleScriptWitnessFile sf - toScriptWitnessFiles sf (Just (d,r, e)) = PlutusScriptWitnessFiles sf d r e - + toScriptWitnessFiles + <$> pScriptFor + (scriptFlagPrefix ++ "-script-file") + ((++ "-script-file") <$> scriptFlagPrefixDeprecated) + ("The file containing the script to witness " ++ help) + <*> optional + ( (,,) + <$> pScriptDatumOrFile scriptFlagPrefix witctx + <*> pScriptRedeemerOrFile scriptFlagPrefix + <*> ( case autoBalanceExecUnits of + AutoBalance -> pure (ExecutionUnits 0 0) + ManualBalance -> pExecutionUnits scriptFlagPrefix + ) + ) + where + toScriptWitnessFiles + :: ScriptFile + -> Maybe + ( ScriptDatumOrFile witctx + , ScriptRedeemerOrFile + , ExecutionUnits + ) + -> ScriptWitnessFiles witctx + toScriptWitnessFiles sf Nothing = SimpleScriptWitnessFile sf + toScriptWitnessFiles sf (Just (d, r, e)) = PlutusScriptWitnessFiles sf d r e pExecutionUnits :: String -> Parser ExecutionUnits pExecutionUnits scriptFlagPrefix = - fmap (uncurry ExecutionUnits) $ Opt.option Opt.auto $ mconcat - [ Opt.long (scriptFlagPrefix ++ "-execution-units") - , Opt.metavar "(INT, INT)" - , Opt.help "The time and space units needed by the script." - ] + fmap (uncurry ExecutionUnits) $ + Opt.option Opt.auto $ + mconcat + [ Opt.long (scriptFlagPrefix ++ "-execution-units") + , Opt.metavar "(INT, INT)" + , Opt.help "The time and space units needed by the script." + ] pScriptRedeemerOrFile :: String -> Parser ScriptDataOrFile pScriptRedeemerOrFile scriptFlagPrefix = - pScriptDataOrFile (scriptFlagPrefix ++ "-redeemer") + pScriptDataOrFile + (scriptFlagPrefix ++ "-redeemer") "The script redeemer value." "The script redeemer file." - pScriptDatumOrFile :: String -> WitCtx witctx -> Parser (ScriptDatumOrFile witctx) pScriptDatumOrFile scriptFlagPrefix witctx = case witctx of - WitCtxTxIn -> asum [ ScriptDatumOrFileForTxIn <$> - pScriptDataOrFile - (scriptFlagPrefix ++ "-datum") - "The script datum." - "The script datum file." - , pInlineDatumPresent - ] - WitCtxMint -> pure NoScriptDatumOrFileForMint + WitCtxTxIn -> + asum + [ ScriptDatumOrFileForTxIn + <$> pScriptDataOrFile + (scriptFlagPrefix ++ "-datum") + "The script datum." + "The script datum file." + , pInlineDatumPresent + ] + WitCtxMint -> pure NoScriptDatumOrFileForMint WitCtxStake -> pure NoScriptDatumOrFileForStake where pInlineDatumPresent :: Parser (ScriptDatumOrFile WitCtxTxIn) - pInlineDatumPresent = - flag' InlineDatumPresentAtTxIn $ mconcat - [ long (scriptFlagPrefix ++ "-inline-datum-present") - , Opt.help "Inline datum present at transaction input." - ] + pInlineDatumPresent = + flag' InlineDatumPresentAtTxIn $ + mconcat + [ long (scriptFlagPrefix ++ "-inline-datum-present") + , Opt.help "Inline datum present at transaction input." + ] pScriptDataOrFile - :: String -- ^ data flag prefix - -> String -- ^ value help text - -> String -- ^ file help text + :: String + -- ^ data flag prefix + -> String + -- ^ value help text + -> String + -- ^ file help text -> Parser ScriptDataOrFile pScriptDataOrFile dataFlagPrefix helpTextForValue helpTextForFile = asum @@ -1123,92 +1280,110 @@ pScriptDataOrFile dataFlagPrefix helpTextForValue helpTextForFile = , pScriptDataFile , pScriptDataValue ] - where - pScriptDataCborFile = fmap ScriptDataCborFile . Opt.strOption $ mconcat - [ Opt.long (dataFlagPrefix ++ "-cbor-file") - , Opt.metavar "CBOR_FILE" - , Opt.help $ mconcat - [ helpTextForFile - , " The file has to be in CBOR format." + where + pScriptDataCborFile = + fmap ScriptDataCborFile . Opt.strOption $ + mconcat + [ Opt.long (dataFlagPrefix ++ "-cbor-file") + , Opt.metavar "CBOR_FILE" + , Opt.help $ + mconcat + [ helpTextForFile + , " The file has to be in CBOR format." + ] ] - ] - pScriptDataFile = fmap ScriptDataJsonFile . Opt.strOption $ mconcat - [ Opt.long (dataFlagPrefix ++ "-file") - , Opt.metavar "JSON_FILE" - , Opt.help $ mconcat - [ helpTextForFile - , " The file must follow the detailed 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 detailed JSON schema for script data." + ] ] - ] - 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." + 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 :: ReadM HashableScriptData - readerScriptData = do - v <- Opt.str - sDataValue <- liftWith ("readerScriptData: " <>) $ + readerScriptData :: ReadM HashableScriptData + readerScriptData = do + v <- Opt.str + sDataValue <- + liftWith ("readerScriptData: " <>) $ Aeson.eitherDecode v - liftWith (docToString . prettyError) $ - scriptDataJsonToHashable ScriptDataJsonNoSchema sDataValue - where liftWith f = either (fail . f) pure + liftWith (docToString . prettyError) $ + scriptDataJsonToHashable ScriptDataJsonNoSchema sDataValue + where + liftWith f = either (fail . f) pure pVoteFiles :: ShelleyBasedEra era -> BalanceTxExecUnits -> Parser [(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))] -pVoteFiles sbe bExUnits = caseShelleyToBabbageOrConwayEraOnwards - (const $ pure []) - (const . many $ pVoteFile bExUnits) - sbe +pVoteFiles sbe bExUnits = + caseShelleyToBabbageOrConwayEraOnwards + (const $ pure []) + (const . many $ pVoteFile bExUnits) + sbe pVoteFile :: BalanceTxExecUnits -> Parser (VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake)) pVoteFile balExUnits = - (,) <$> pFileInDirection "vote-file" "Filepath of the vote." - <*> optional (pVoteScriptOrReferenceScriptWitness balExUnits) - + (,) + <$> pFileInDirection "vote-file" "Filepath of the vote." + <*> optional (pVoteScriptOrReferenceScriptWitness balExUnits) where - pVoteScriptOrReferenceScriptWitness - :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) - pVoteScriptOrReferenceScriptWitness bExUnits = - pScriptWitnessFiles - WitCtxStake - bExUnits - "vote" - Nothing - "a vote" - -pProposalFiles :: ShelleyBasedEra era -> BalanceTxExecUnits -> Parser [(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] -pProposalFiles sbe balExUnits = caseShelleyToBabbageOrConwayEraOnwards - (const $ pure []) - (const $ many (pProposalFile balExUnits)) - sbe - -pProposalFile :: BalanceTxExecUnits -> Parser (ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake)) -pProposalFile balExUnits = - (,) <$> pFileInDirection "proposal-file" "Filepath of the proposal." - <*> optional (pProposingScriptOrReferenceScriptWitness balExUnits) + pVoteScriptOrReferenceScriptWitness + :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) + pVoteScriptOrReferenceScriptWitness bExUnits = + pScriptWitnessFiles + WitCtxStake + bExUnits + "vote" + Nothing + "a vote" + +pProposalFiles + :: ShelleyBasedEra era + -> BalanceTxExecUnits + -> Parser [(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))] +pProposalFiles sbe balExUnits = + caseShelleyToBabbageOrConwayEraOnwards + (const $ pure []) + (const $ many (pProposalFile balExUnits)) + sbe +pProposalFile + :: BalanceTxExecUnits -> Parser (ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake)) +pProposalFile balExUnits = + (,) + <$> pFileInDirection "proposal-file" "Filepath of the proposal." + <*> optional (pProposingScriptOrReferenceScriptWitness balExUnits) where - pProposingScriptOrReferenceScriptWitness - :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) - pProposingScriptOrReferenceScriptWitness bExUnits = - pScriptWitnessFiles - WitCtxStake - bExUnits - "proposal" - Nothing - "a proposal" - -pCurrentTreasuryValueAndDonation :: ShelleyBasedEra era -> Parser (Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)) + pProposingScriptOrReferenceScriptWitness + :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) + pProposingScriptOrReferenceScriptWitness bExUnits = + pScriptWitnessFiles + WitCtxStake + bExUnits + "proposal" + Nothing + "a proposal" + +pCurrentTreasuryValueAndDonation + :: ShelleyBasedEra era -> Parser (Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)) pCurrentTreasuryValueAndDonation sbe = caseShelleyToBabbageOrConwayEraOnwards (const $ pure Nothing) @@ -1217,11 +1392,14 @@ pCurrentTreasuryValueAndDonation sbe = pCurrentTreasuryValue' :: Parser TxCurrentTreasuryValue pCurrentTreasuryValue' = - TxCurrentTreasuryValue <$> (Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "current-treasury-value" - , Opt.metavar "LOVELACE" - , Opt.help "The current treasury value." - ]) + TxCurrentTreasuryValue + <$> ( Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "current-treasury-value" + , Opt.metavar "LOVELACE" + , Opt.help "The current treasury value." + ] + ) pTreasuryDonation :: ShelleyBasedEra era -> Parser (Maybe TxTreasuryDonation) pTreasuryDonation = @@ -1231,11 +1409,14 @@ pTreasuryDonation = pTreasuryDonation' :: Parser TxTreasuryDonation pTreasuryDonation' = - TxTreasuryDonation <$> (Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "treasury-donation" - , Opt.metavar "LOVELACE" - , Opt.help "The donation to the treasury to perform." - ]) + TxTreasuryDonation + <$> ( Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "treasury-donation" + , Opt.metavar "LOVELACE" + , Opt.help "The donation to the treasury to perform." + ] + ) -------------------------------------------------------------------------------- @@ -1243,11 +1424,10 @@ pPaymentVerifier :: Parser PaymentVerifier pPaymentVerifier = asum [ PaymentVerifierKey <$> pPaymentVerificationKeyTextOrFile - , PaymentVerifierScriptFile <$> - pScriptFor "payment-script-file" Nothing "Filepath of the payment script." + , PaymentVerifierScriptFile + <$> pScriptFor "payment-script-file" Nothing "Filepath of the payment script." ] - pPaymentVerificationKeyTextOrFile :: Parser VerificationKeyTextOrFile pPaymentVerificationKeyTextOrFile = asum @@ -1257,108 +1437,125 @@ pPaymentVerificationKeyTextOrFile = pPaymentVerificationKeyText :: Parser Text pPaymentVerificationKeyText = - fmap Text.pack $ Opt.strOption $ mconcat - [ Opt.long "payment-verification-key" - , Opt.metavar "STRING" - , Opt.help "Payment verification key (Bech32-encoded)" - ] + fmap Text.pack $ + Opt.strOption $ + mconcat + [ Opt.long "payment-verification-key" + , Opt.metavar "STRING" + , Opt.help "Payment verification key (Bech32-encoded)" + ] pPaymentVerificationKeyFile :: Parser (VerificationKeyFile In) pPaymentVerificationKeyFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "payment-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the payment verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "verification-key-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "payment-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the payment verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "verification-key-file" + , Opt.internal + ] ] - ] pScript :: Parser ScriptFile pScript = pScriptFor "script-file" Nothing "Filepath of the script." pReferenceTxIn :: String -> String -> Parser TxIn pReferenceTxIn prefix scriptType = - 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." + 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) $ 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." + 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." + ] ] - ] -------------------------------------------------------------------------------- pAddressKeyType :: Parser AddressKeyType pAddressKeyType = asum - [ Opt.flag' AddressKeyShelley $ mconcat - [ Opt.long "normal-key" - , Opt.help "Use a normal Shelley-era key (default)." - ] - , Opt.flag' AddressKeyShelleyExtended $ mconcat - [ Opt.long "extended-key" - , Opt.help "Use an extended ed25519 Shelley-era key." - ] - , Opt.flag' AddressKeyByron $ mconcat - [ Opt.long "byron-key" - , Opt.help "Use a Byron-era key." - ] + [ Opt.flag' AddressKeyShelley $ + mconcat + [ Opt.long "normal-key" + , Opt.help "Use a normal Shelley-era key (default)." + ] + , Opt.flag' AddressKeyShelleyExtended $ + mconcat + [ Opt.long "extended-key" + , Opt.help "Use an extended ed25519 Shelley-era key." + ] + , Opt.flag' AddressKeyByron $ + mconcat + [ Opt.long "byron-key" + , Opt.help "Use a Byron-era key." + ] , pure AddressKeyShelley ] pProtocolParamsFile :: Parser ProtocolParamsFile pProtocolParamsFile = - fmap ProtocolParamsFile $ Opt.strOption $ mconcat - [ Opt.long "protocol-params-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the JSON-encoded protocol parameters file" - , Opt.completer (Opt.bashCompleter "file") - ] + fmap ProtocolParamsFile $ + Opt.strOption $ + mconcat + [ Opt.long "protocol-params-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the JSON-encoded protocol parameters file" + , Opt.completer (Opt.bashCompleter "file") + ] pTxBuildOutputOptions :: Parser TxBuildOutputOptions pTxBuildOutputOptions = (OutputTxBodyOnly <$> pTxBodyFileOut) <|> pCalculatePlutusScriptCost - where - pCalculatePlutusScriptCost :: Parser TxBuildOutputOptions - pCalculatePlutusScriptCost = - OutputScriptCostOnly <$> Opt.strOption - ( Opt.long "calculate-plutus-script-cost" <> - Opt.metavar "FILE" <> - Opt.help "(File () Out) filepath of the script cost information." <> - Opt.completer (Opt.bashCompleter "file") - ) + where + pCalculatePlutusScriptCost :: Parser TxBuildOutputOptions + pCalculatePlutusScriptCost = + OutputScriptCostOnly + <$> Opt.strOption + ( Opt.long "calculate-plutus-script-cost" + <> Opt.metavar "FILE" + <> Opt.help "(File () Out) filepath of the script cost information." + <> Opt.completer (Opt.bashCompleter "file") + ) pCertificateFile :: BalanceTxExecUnits -> Parser (CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake)) pCertificateFile balanceExecUnits = (,) - <$> ( fmap CertificateFile $ asum - [ Opt.strOption $ mconcat - [ Opt.long "certificate-file" - , Opt.metavar "FILE" - , Opt.help helpText - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption (Opt.long "certificate" <> Opt.internal) - ] + <$> ( fmap CertificateFile $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "certificate-file" + , Opt.metavar "FILE" + , Opt.help helpText + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption (Opt.long "certificate" <> Opt.internal) + ] ) <*> optional (pCertifyingScriptOrReferenceScriptWit balanceExecUnits) where @@ -1366,38 +1563,44 @@ pCertificateFile balanceExecUnits = :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxStake) pCertifyingScriptOrReferenceScriptWit bExecUnits = pScriptWitnessFiles - WitCtxStake - balanceExecUnits - "certificate" Nothing - "the use of the certificate." <|> - pPlutusStakeReferenceScriptWitnessFiles "certificate-" bExecUnits - - helpText = mconcat - [ "Filepath of the certificate. This encompasses all " - , "types of certificates (stake pool certificates, " - , "stake key certificates etc). Optionally specify a script witness." - ] + WitCtxStake + balanceExecUnits + "certificate" + Nothing + "the use of the certificate." + <|> pPlutusStakeReferenceScriptWitnessFiles "certificate-" bExecUnits + + 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 (StakePoolMetadataFile In) pPoolMetadataFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "pool-metadata-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the pool metadata." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "pool-metadata-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the pool metadata." + , Opt.completer (Opt.bashCompleter "file") + ] pTxMetadataJsonSchema :: Parser TxMetadataJsonSchema pTxMetadataJsonSchema = asum - [ Opt.flag' () - ( Opt.long "json-metadata-no-schema" - <> Opt.help "Use the \"no schema\" conversion from JSON to tx metadata (default)." + [ Opt.flag' + () + ( Opt.long "json-metadata-no-schema" + <> Opt.help "Use the \"no schema\" conversion from JSON to tx metadata (default)." ) $> TxMetadataJsonNoSchema - , Opt.flag' () - ( Opt.long "json-metadata-detailed-schema" - <> Opt.help "Use the \"detailed schema\" conversion from JSON to tx metadata." + , Opt.flag' + () + ( Opt.long "json-metadata-detailed-schema" + <> Opt.help "Use the \"detailed schema\" conversion from JSON to tx metadata." ) $> TxMetadataJsonDetailedSchema , -- Default to the no-schema conversion. @@ -1411,56 +1614,65 @@ convertTime = pMetadataFile :: Parser MetadataFile pMetadataFile = asum - [ fmap MetadataFileJSON - $ asum - [ Opt.strOption $ mconcat + [ fmap MetadataFileJSON $ + asum + [ Opt.strOption $ + mconcat [ Opt.long "metadata-json-file" , Opt.metavar "FILE" , Opt.help "Filepath of the metadata file, in JSON format." , Opt.completer (Opt.bashCompleter "file") ] - , Opt.strOption $ mconcat + , Opt.strOption $ + mconcat [ Opt.long "metadata-file" -- backward compat name , Opt.internal ] + ] + , fmap MetadataFileCBOR $ + Opt.strOption $ + mconcat + [ Opt.long "metadata-cbor-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the metadata, in raw CBOR format." + , Opt.completer (Opt.bashCompleter "file") ] - , fmap MetadataFileCBOR $ Opt.strOption $ mconcat - [ Opt.long "metadata-cbor-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the metadata, in raw CBOR format." - , Opt.completer (Opt.bashCompleter "file") - ] ] pWithdrawal :: BalanceTxExecUnits - -> Parser (StakeAddress, - L.Coin, - Maybe (ScriptWitnessFiles WitCtxStake)) + -> Parser + ( StakeAddress + , L.Coin + , Maybe (ScriptWitnessFiles WitCtxStake) + ) pWithdrawal balance = - (\(stakeAddr,lovelace) maybeScriptFp -> (stakeAddr, lovelace, maybeScriptFp)) - <$> Opt.option (readerFromParsecParser parseWithdrawal) - ( Opt.long "withdrawal" - <> Opt.metavar "WITHDRAWAL" - <> Opt.help helpText - ) - <*> optional pWithdrawalScriptOrReferenceScriptWit + (\(stakeAddr, lovelace) maybeScriptFp -> (stakeAddr, lovelace, maybeScriptFp)) + <$> Opt.option + (readerFromParsecParser parseWithdrawal) + ( Opt.long "withdrawal" + <> Opt.metavar "WITHDRAWAL" + <> Opt.help helpText + ) + <*> optional pWithdrawalScriptOrReferenceScriptWit where pWithdrawalScriptOrReferenceScriptWit :: Parser (ScriptWitnessFiles WitCtxStake) pWithdrawalScriptOrReferenceScriptWit = - pScriptWitnessFiles - WitCtxStake - balance - "withdrawal" Nothing - "the withdrawal of rewards." <|> - pPlutusStakeReferenceScriptWitnessFiles "withdrawal-" balance - - 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." - ] + pScriptWitnessFiles + WitCtxStake + balance + "withdrawal" + Nothing + "the withdrawal of rewards." + <|> pPlutusStakeReferenceScriptWitnessFiles "withdrawal-" balance + + 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, L.Coin) parseWithdrawal = @@ -1468,7 +1680,8 @@ pWithdrawal balance = pPlutusStakeReferenceScriptWitnessFiles :: String - -> BalanceTxExecUnits -- ^ Use the @execution-units@ flag. + -> BalanceTxExecUnits + -- ^ Use the @execution-units@ flag. -> Parser (ScriptWitnessFiles WitCtxStake) pPlutusStakeReferenceScriptWitnessFiles prefix autoBalanceExecUnits = PlutusReferenceScriptWitnessFiles @@ -1476,85 +1689,101 @@ pPlutusStakeReferenceScriptWitnessFiles prefix autoBalanceExecUnits = <*> pPlutusScriptLanguage prefix <*> pure NoScriptDatumOrFileForStake <*> pScriptRedeemerOrFile (prefix ++ "reference-tx-in") - <*> (case autoBalanceExecUnits of - AutoBalance -> pure (ExecutionUnits 0 0) - ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in") + <*> ( case autoBalanceExecUnits of + AutoBalance -> pure (ExecutionUnits 0 0) + ManualBalance -> pExecutionUnits $ prefix ++ "reference-tx-in" + ) <*> pure Nothing pPlutusScriptLanguage :: String -> Parser AnyScriptLanguage pPlutusScriptLanguage prefix = plutusP PlutusScriptV2 "v2" <|> plutusP PlutusScriptV3 "v3" - where - plutusP :: PlutusScriptVersion lang -> String -> Parser AnyScriptLanguage - plutusP plutusVersion versionString = - Opt.flag' (AnyScriptLanguage $ PlutusScriptLanguage plutusVersion) - ( Opt.long (prefix <> "plutus-script-" <> versionString) - <> Opt.help ("Specify a plutus script " <> versionString <> " reference script.") + where + plutusP :: PlutusScriptVersion lang -> String -> Parser AnyScriptLanguage + plutusP plutusVersion versionString = + Opt.flag' + (AnyScriptLanguage $ PlutusScriptLanguage plutusVersion) + ( Opt.long (prefix <> "plutus-script-" <> versionString) + <> Opt.help ("Specify a plutus script " <> versionString <> " reference script.") ) pUpdateProposalFile :: Parser UpdateProposalFile pUpdateProposalFile = - fmap UpdateProposalFile - $ asum - [ Opt.strOption $ mconcat - [ Opt.long "update-proposal-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the update proposal." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "update-proposal" - , Opt.internal - ] - ] + fmap UpdateProposalFile $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "update-proposal-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the update proposal." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "update-proposal" + , Opt.internal + ] + ] pRequiredSigner :: Parser RequiredSigner pRequiredSigner = - RequiredSignerSkeyFile <$> sKeyFile - <|> RequiredSignerHash <$> sPayKeyHash + RequiredSignerSkeyFile + <$> sKeyFile + <|> RequiredSignerHash + <$> sPayKeyHash where sKeyFile :: Parser (SigningKeyFile In) - sKeyFile = fmap File $ 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") - ] + sKeyFile = + fmap File $ + 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)) $ mconcat - [ Opt.long "required-signer-hash" - , Opt.metavar "HASH" - , Opt.help $ mconcat - [ "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 In) pVrfSigningKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "vrf-signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the VRF signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "vrf-signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the VRF signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pWhichLeadershipSchedule :: Parser EpochLeadershipSchedule pWhichLeadershipSchedule = pCurrent <|> pNext - where - pCurrent :: Parser EpochLeadershipSchedule - pCurrent = - Opt.flag' CurrentEpoch $ mconcat + where + pCurrent :: Parser EpochLeadershipSchedule + pCurrent = + Opt.flag' CurrentEpoch $ + mconcat [ Opt.long "current" , Opt.help "Get the leadership schedule for the current epoch." ] - pNext :: Parser EpochLeadershipSchedule - pNext = - Opt.flag' NextEpoch $ mconcat + pNext :: Parser EpochLeadershipSchedule + pNext = + Opt.flag' NextEpoch $ + mconcat [ Opt.long "next" , Opt.help "Get the leadership schedule for the following epoch." ] @@ -1562,85 +1791,99 @@ pWhichLeadershipSchedule = pCurrent <|> pNext pWitnessSigningData :: Parser WitnessSigningData pWitnessSigningData = KeyWitnessSigningData - <$> ( fmap File $ Opt.strOption $ mconcat - [ Opt.long "signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the signing key (one or more)." - , Opt.completer (Opt.bashCompleter "file") - ] + <$> ( fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the signing key (one or more)." + , Opt.completer (Opt.bashCompleter "file") + ] ) <*> optional pByronAddress pSigningKeyFileIn :: Parser (SigningKeyFile In) pSigningKeyFileIn = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pKesPeriod :: Parser KESPeriod pKesPeriod = - fmap KESPeriod $ Opt.option (bounded "KES_PERIOD") $ mconcat - [ Opt.long "kes-period" - , Opt.metavar "NATURAL" - , Opt.help "The start of the KES key validity period." - ] + fmap KESPeriod $ + Opt.option (bounded "KES_PERIOD") $ + mconcat + [ Opt.long "kes-period" + , Opt.metavar "NATURAL" + , Opt.help "The start of the KES key validity period." + ] pEpochNo :: String -> Parser EpochNo pEpochNo h = - fmap EpochNo $ Opt.option (bounded "EPOCH") $ mconcat - [ Opt.long "epoch" - , Opt.metavar "NATURAL" - , Opt.help h - ] - + fmap EpochNo $ + Opt.option (bounded "EPOCH") $ + mconcat + [ Opt.long "epoch" + , Opt.metavar "NATURAL" + , Opt.help h + ] pEpochNoUpdateProp :: Parser EpochNo pEpochNoUpdateProp = pEpochNo "The epoch number in which the update proposal is valid." pGenesisFile :: String -> Parser GenesisFile pGenesisFile desc = - fmap GenesisFile $ Opt.strOption $ mconcat - [ Opt.long "genesis" - , Opt.metavar "FILE" - , Opt.help desc - , Opt.completer (Opt.bashCompleter "file") - ] + fmap GenesisFile $ + Opt.strOption $ + mconcat + [ Opt.long "genesis" + , Opt.metavar "FILE" + , Opt.help desc + , Opt.completer (Opt.bashCompleter "file") + ] pOperationalCertificateFile :: Parser (File () direction) pOperationalCertificateFile = - Opt.strOption $ mconcat - [ Opt.long "op-cert-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the node's operational certificate." - , Opt.completer (Opt.bashCompleter "file") - ] + Opt.strOption $ + mconcat + [ Opt.long "op-cert-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the node's operational certificate." + , Opt.completer (Opt.bashCompleter "file") + ] pKeyOutputFormat :: Parser KeyOutputFormat pKeyOutputFormat = - Opt.option readKeyOutputFormat $ mconcat - [ Opt.long "key-output-format" - , Opt.metavar "STRING" - , Opt.help $ mconcat - [ "Optional key output format. Accepted output formats are \"text-envelope\" " - , "and \"bech32\" (default is \"text-envelope\")." - ] - , Opt.value KeyOutputFormatTextEnvelope - ] + Opt.option readKeyOutputFormat $ + mconcat + [ Opt.long "key-output-format" + , Opt.metavar "STRING" + , Opt.help $ + mconcat + [ "Optional key output format. Accepted output formats are \"text-envelope\" " + , "and \"bech32\" (default is \"text-envelope\")." + ] + , Opt.value KeyOutputFormatTextEnvelope + ] pPoolIdOutputFormat :: Parser IdOutputFormat pPoolIdOutputFormat = - Opt.option readIdOutputFormat $ mconcat - [ Opt.long "output-format" - , Opt.metavar "STRING" - , Opt.help $ mconcat - [ "Optional pool id output format. Accepted output formats are \"hex\" " - , "and \"bech32\" (default is \"bech32\")." - ] - , Opt.value IdOutputFormatBech32 - ] + Opt.option readIdOutputFormat $ + mconcat + [ Opt.long "output-format" + , Opt.metavar "STRING" + , Opt.help $ + mconcat + [ "Optional pool id output format. Accepted output formats are \"hex\" " + , "and \"bech32\" (default is \"bech32\")." + ] + , Opt.value IdOutputFormatBech32 + ] -- | @pOutputFormatJsonOrText kind@ is a parser to specify in which format -- to view some data (json or text). @kind@ is the kind of data considered. @@ -1650,16 +1893,22 @@ pOutputFormatJsonOrText kind = [ make OutputFormatJson "JSON" "json" (Just " Default format when writing to a file") , make OutputFormatText "TEXT" "text" (Just " Default format when writing to stdout") ] - where - make format desc flag_ extraHelp = - -- Not using Opt.flag, because there is no default. We can't have - -- a default and preserve the historical behavior (that differed whether - -- an output file was specified or not). - Opt.flag' format $ mconcat - [ Opt.help $ - "Format " <> kind <> " query output to " <> desc <> "." - <> fromMaybe "" extraHelp - , Opt.long ("output-" <> flag_)] + where + make format desc flag_ extraHelp = + -- Not using Opt.flag, because there is no default. We can't have + -- a default and preserve the historical behavior (that differed whether + -- an output file was specified or not). + Opt.flag' format $ + mconcat + [ Opt.help $ + "Format " + <> kind + <> " query output to " + <> desc + <> "." + <> fromMaybe "" extraHelp + , Opt.long ("output-" <> flag_) + ] pTxViewOutputFormat :: Parser ViewOutputFormat pTxViewOutputFormat = pViewOutputFormat "transaction" @@ -1678,33 +1927,44 @@ pViewOutputFormat kind = [ make ViewOutputFormatJson "JSON" "json" Nothing , make ViewOutputFormatYaml "YAML" "yaml" (Just " Defaults to JSON if unspecified.") ] - where - make format desc flag_ extraHelp = - Opt.flag ViewOutputFormatJson format $ mconcat - [ Opt.help $ - "Format " <> kind <> " view output to " <> desc <> "." - <> fromMaybe "" extraHelp - , Opt.long ("output-" <> flag_)] + where + make format desc flag_ extraHelp = + Opt.flag ViewOutputFormatJson format $ + mconcat + [ Opt.help $ + "Format " + <> kind + <> " view output to " + <> desc + <> "." + <> fromMaybe "" extraHelp + , Opt.long ("output-" <> flag_) + ] pMaybeOutputFile :: Parser (Maybe (File content Out)) pMaybeOutputFile = - optional $ fmap File $ Opt.strOption $ mconcat - [ Opt.long "out-file" - , Opt.metavar "FILE" - , Opt.help "Optional output file. Default is to write to stdout." - , Opt.completer (Opt.bashCompleter "file") - ] + optional $ + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "out-file" + , Opt.metavar "FILE" + , Opt.help "Optional output file. Default is to write to stdout." + , Opt.completer (Opt.bashCompleter "file") + ] pVerificationKey - :: forall keyrole. SerialiseAsBech32 (VerificationKey keyrole) + :: forall keyrole + . SerialiseAsBech32 (VerificationKey keyrole) => AsType keyrole -> Parser (VerificationKey keyrole) pVerificationKey asType = - Opt.option (readVerificationKey asType) $ mconcat - [ Opt.long "verification-key" - , Opt.metavar "STRING" - , Opt.help "Verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey asType) $ + mconcat + [ Opt.long "verification-key" + , Opt.metavar "STRING" + , Opt.help "Verification key (Bech32 or hex-encoded)." + ] pVerificationKeyOrFileIn :: SerialiseAsBech32 (VerificationKey keyrole) @@ -1718,44 +1978,50 @@ pVerificationKeyOrFileIn asType = pExtendedVerificationKeyFileIn :: Parser (VerificationKeyFile In) pExtendedVerificationKeyFileIn = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "extended-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the ed25519-bip32 verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "extended-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the ed25519-bip32 verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pGenesisVerificationKeyFile :: Parser (VerificationKeyFile In) pGenesisVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "genesis-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the genesis verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "genesis-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the genesis verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pGenesisVerificationKeyHash :: Parser (Hash GenesisKey) pGenesisVerificationKeyHash = - Opt.option deserialiseFromHex $ mconcat - [ Opt.long "genesis-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "Genesis verification key hash (hex-encoded)." - ] - where - deserialiseFromHex :: ReadM (Hash GenesisKey) - deserialiseFromHex = - rHexHash AsGenesisKey (Just "Invalid genesis verification key hash") + Opt.option deserialiseFromHex $ + mconcat + [ Opt.long "genesis-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "Genesis verification key hash (hex-encoded)." + ] + where + deserialiseFromHex :: ReadM (Hash GenesisKey) + deserialiseFromHex = + rHexHash AsGenesisKey (Just "Invalid genesis verification key hash") pGenesisVerificationKey :: Parser (VerificationKey GenesisKey) pGenesisVerificationKey = - Opt.option deserialiseFromHex $ mconcat - [ Opt.long "genesis-verification-key" - , Opt.metavar "STRING" - , Opt.help "Genesis verification key (hex-encoded)." - ] - where - deserialiseFromHex = - rVerificationKey AsGenesisKey (Just "Invalid genesis verification key") + Opt.option deserialiseFromHex $ + mconcat + [ Opt.long "genesis-verification-key" + , Opt.metavar "STRING" + , Opt.help "Genesis verification key (hex-encoded)." + ] + where + deserialiseFromHex = + rVerificationKey AsGenesisKey (Just "Invalid genesis verification key") pGenesisVerificationKeyOrFile :: Parser (VerificationKeyOrFile GenesisKey) pGenesisVerificationKeyOrFile = @@ -1773,24 +2039,27 @@ pGenesisVerificationKeyOrHashOrFile = pGenesisDelegateVerificationKeyFile :: Parser (VerificationKeyFile In) pGenesisDelegateVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "genesis-delegate-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the genesis delegate verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "genesis-delegate-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the genesis delegate verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pGenesisDelegateVerificationKeyHash :: Parser (Hash GenesisDelegateKey) pGenesisDelegateVerificationKeyHash = - Opt.option deserialiseFromHex $ mconcat - [ Opt.long "genesis-delegate-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "Genesis delegate verification key hash (hex-encoded)." - ] - where - deserialiseFromHex :: ReadM (Hash GenesisDelegateKey) - deserialiseFromHex = - rHexHash AsGenesisDelegateKey (Just "Invalid genesis delegate verification key hash") + Opt.option deserialiseFromHex $ + mconcat + [ Opt.long "genesis-delegate-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "Genesis delegate verification key hash (hex-encoded)." + ] + where + deserialiseFromHex :: ReadM (Hash GenesisDelegateKey) + deserialiseFromHex = + rHexHash AsGenesisDelegateKey (Just "Invalid genesis delegate verification key hash") pGenesisDelegateVerificationKeyOrFile :: Parser (VerificationKeyOrFile GenesisDelegateKey) @@ -1817,68 +2086,75 @@ pKesVerificationKeyOrFile = pKesVerificationKey :: Parser (VerificationKey KesKey) pKesVerificationKey = - Opt.option (Opt.eitherReader deserialiseVerKey) $ mconcat - [ Opt.long "kes-verification-key" - , Opt.metavar "STRING" - , Opt.help "A Bech32 or hex-encoded hot KES verification key." - ] - where - asType :: AsType (VerificationKey KesKey) - asType = AsVerificationKey AsKesKey - - deserialiseVerKey :: String -> Either String (VerificationKey KesKey) - deserialiseVerKey str = - case deserialiseFromBech32 asType (Text.pack str) of - Right res -> Right res - - -- The input was valid Bech32, but some other error occurred. - Left err@(Bech32UnexpectedPrefix _ _) -> Left (docToString $ prettyError err) - Left err@(Bech32DataPartToBytesError _) -> Left (docToString $ prettyError err) - Left err@(Bech32DeserialiseFromBytesError _) -> Left (docToString $ prettyError err) - Left err@(Bech32WrongPrefix _ _) -> Left (docToString $ prettyError err) - - -- The input was not valid Bech32. Attempt to deserialise it as hex. - Left (Bech32DecodingError _) -> - first - (\e -> docToString $ "Invalid stake pool verification key: " <> prettyError e) $ - deserialiseFromRawBytesHex asType (BSC.pack str) + Opt.option (Opt.eitherReader deserialiseVerKey) $ + mconcat + [ Opt.long "kes-verification-key" + , Opt.metavar "STRING" + , Opt.help "A Bech32 or hex-encoded hot KES verification key." + ] + where + asType :: AsType (VerificationKey KesKey) + asType = AsVerificationKey AsKesKey + + deserialiseVerKey :: String -> Either String (VerificationKey KesKey) + deserialiseVerKey str = + case deserialiseFromBech32 asType (Text.pack str) of + Right res -> Right res + -- The input was valid Bech32, but some other error occurred. + Left err@(Bech32UnexpectedPrefix _ _) -> Left (docToString $ prettyError err) + Left err@(Bech32DataPartToBytesError _) -> Left (docToString $ prettyError err) + Left err@(Bech32DeserialiseFromBytesError _) -> Left (docToString $ prettyError err) + Left err@(Bech32WrongPrefix _ _) -> Left (docToString $ prettyError err) + -- The input was not valid Bech32. Attempt to deserialise it as hex. + Left (Bech32DecodingError _) -> + first + (\e -> docToString $ "Invalid stake pool verification key: " <> prettyError e) + $ deserialiseFromRawBytesHex asType (BSC.pack str) pKesVerificationKeyFile :: Parser (VerificationKeyFile In) pKesVerificationKeyFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "kes-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the hot KES verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "hot-kes-verification-key-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "kes-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the hot KES verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "hot-kes-verification-key-file" + , Opt.internal + ] ] - ] pTxSubmitFile :: Parser FilePath pTxSubmitFile = - Opt.strOption $ mconcat - [ Opt.long "tx-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the transaction you intend to submit." - , Opt.completer (Opt.bashCompleter "file") - ] + Opt.strOption $ + mconcat + [ Opt.long "tx-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the transaction you intend to submit." + , Opt.completer (Opt.bashCompleter "file") + ] -pTxIn :: BalanceTxExecUnits - -> Parser (TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn)) +pTxIn + :: BalanceTxExecUnits + -> Parser (TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn)) pTxIn balance = - (,) <$> Opt.option (readerFromParsecParser parseTxIn) - ( Opt.long "tx-in" - <> Opt.metavar "TX-IN" - <> Opt.help "TxId#TxIx" - ) - <*> optional (pPlutusReferenceScriptWitness balance <|> - pSimpleReferenceSpendingScriptWitess <|> - pEmbeddedPlutusScriptWitness - ) + (,) + <$> Opt.option + (readerFromParsecParser parseTxIn) + ( Opt.long "tx-in" + <> Opt.metavar "TX-IN" + <> Opt.help "TxId#TxIx" + ) + <*> optional + ( pPlutusReferenceScriptWitness balance + <|> pSimpleReferenceSpendingScriptWitess + <|> pEmbeddedPlutusScriptWitness + ) where pSimpleReferenceSpendingScriptWitess :: Parser (ScriptWitnessFiles WitCtxTxIn) pSimpleReferenceSpendingScriptWitess = @@ -1888,9 +2164,9 @@ pTxIn balance = createSimpleReferenceScriptWitnessFiles :: TxIn -> ScriptWitnessFiles WitCtxTxIn - createSimpleReferenceScriptWitnessFiles refTxIn = + createSimpleReferenceScriptWitnessFiles refTxIn = let simpleLang = AnyScriptLanguage SimpleScriptLanguage - in SimpleReferenceScriptWitnessFiles refTxIn simpleLang Nothing + in SimpleReferenceScriptWitnessFiles refTxIn simpleLang Nothing pPlutusReferenceScriptWitness :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxTxIn) pPlutusReferenceScriptWitness autoBalanceExecUnits = @@ -1899,9 +2175,10 @@ pTxIn balance = <*> pPlutusScriptLanguage "spending-" <*> pScriptDatumOrFile "spending-reference-tx-in" WitCtxTxIn <*> pScriptRedeemerOrFile "spending-reference-tx-in" - <*> (case autoBalanceExecUnits of + <*> ( case autoBalanceExecUnits of AutoBalance -> pure (ExecutionUnits 0 0) - ManualBalance -> pExecutionUnits "spending-reference-tx-in") + ManualBalance -> pExecutionUnits "spending-reference-tx-in" + ) where createPlutusReferenceScriptWitnessFiles :: TxIn @@ -1918,177 +2195,198 @@ pTxIn balance = pScriptWitnessFiles WitCtxTxIn balance - "tx-in" (Just "txin") + "tx-in" + (Just "txin") "the spending of the transaction input." pTxInCollateral :: Parser TxIn pTxInCollateral = - Opt.option (readerFromParsecParser parseTxIn) - ( Opt.long "tx-in-collateral" - <> Opt.metavar "TX-IN" - <> Opt.help "TxId#TxIx" - ) + Opt.option + (readerFromParsecParser parseTxIn) + ( Opt.long "tx-in-collateral" + <> Opt.metavar "TX-IN" + <> Opt.help "TxId#TxIx" + ) pReturnCollateral :: Parser TxOutShelleyBasedEra pReturnCollateral = - Opt.option (readerFromParsecParser parseTxOutShelleyBasedEra) - ( 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." + Opt.option + (readerFromParsecParser parseTxOutShelleyBasedEra) + ( 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 L.Coin pTotalCollateral = - Opt.option (L.Coin <$> 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\"." - ] - ] + Opt.option (L.Coin <$> 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 $ mconcat - [ 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." + ] pNumberOfShelleyKeyWitnesses :: Parser Int -pNumberOfShelleyKeyWitnesses = Opt.option Opt.auto $ mconcat - [ Opt.long "shelley-key-witnesses" - , Opt.metavar "INT" - , Opt.help "Specify the number of Shelley key witnesses the transaction requires." - ] +pNumberOfShelleyKeyWitnesses = + Opt.option Opt.auto $ + mconcat + [ Opt.long "shelley-key-witnesses" + , Opt.metavar "INT" + , Opt.help "Specify the number of Shelley key witnesses the transaction requires." + ] pNumberOfByronKeyWitnesses :: Parser Int -pNumberOfByronKeyWitnesses = Opt.option Opt.auto $ mconcat - [ Opt.long "byron-key-witnesses" - , Opt.metavar "Int" - , Opt.help "Specify the number of Byron key witnesses the transaction requires." - ] +pNumberOfByronKeyWitnesses = + Opt.option Opt.auto $ + mconcat + [ Opt.long "byron-key-witnesses" + , Opt.metavar "Int" + , Opt.help "Specify the number of Byron key witnesses the transaction requires." + ] pTotalUTxOValue :: Parser Value pTotalUTxOValue = - Opt.option (readerFromParsecParser parseValue) $ mconcat - [ Opt.long "total-utxo-value" - , Opt.metavar "VALUE" - , Opt.help "The total value of the UTxO that exists at the tx inputs being spent." - ] - + Opt.option (readerFromParsecParser parseValue) $ + mconcat + [ Opt.long "total-utxo-value" + , Opt.metavar "VALUE" + , Opt.help "The total value of the UTxO that exists at the tx inputs being spent." + ] pTxOut :: Parser TxOutAnyEra pTxOut = - Opt.option (readerFromParsecParser parseTxOutAnyEra) - ( Opt.long "tx-out" - <> 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 \ - \the multi-asset syntax (including simply Lovelace)." - ) + Opt.option + (readerFromParsecParser parseTxOutAnyEra) + ( Opt.long "tx-out" + <> 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 \ + \the multi-asset syntax (including simply Lovelace)." + ) <*> pTxOutDatum <*> pRefScriptFp pTxOutShelleyBased :: Parser TxOutShelleyBasedEra pTxOutShelleyBased = - Opt.option (readerFromParsecParser parseTxOutShelleyBasedEra) - ( Opt.long "tx-out" - <> 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 \ - \the multi-asset syntax (including simply Lovelace)." - ) + Opt.option + (readerFromParsecParser parseTxOutShelleyBasedEra) + ( Opt.long "tx-out" + <> 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 \ + \the multi-asset syntax (including simply Lovelace)." + ) <*> pTxOutDatum <*> pRefScriptFp pTxOutDatum :: Parser TxOutDatumAnyEra pTxOutDatum = - pTxOutDatumByHashOnly - <|> pTxOutDatumByHashOf - <|> pTxOutDatumByValue - <|> pTxOutInlineDatumByValue - <|> pure TxOutDatumByNone - where - pTxOutDatumByHashOnly = - 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)." + pTxOutDatumByHashOnly + <|> pTxOutDatumByHashOf + <|> pTxOutDatumByValue + <|> pTxOutInlineDatumByValue + <|> pure TxOutDatumByNone + where + pTxOutDatumByHashOnly = + 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 <$> - pScriptDataOrFile - "tx-out-datum-hash" - "The script datum hash for this tx output, by hashing the script datum given here." - "The script datum hash for this tx output, by hashing the script datum in the file." - - pTxOutDatumByValue = - TxOutDatumByValue <$> - pScriptDataOrFile - "tx-out-datum-embed" - "The script datum to embed in the tx for this output, given here." - "The script datum to embed in the tx for this output, in the given file." - - pTxOutInlineDatumByValue = - TxOutInlineDatumByValue <$> - pScriptDataOrFile - "tx-out-inline-datum" - "The script datum to embed in the tx output as an inline datum, given here." - "The script datum to embed in the tx output as an inline datum, in the given file." - + pTxOutDatumByHashOf = + TxOutDatumByHashOf + <$> pScriptDataOrFile + "tx-out-datum-hash" + "The script datum hash for this tx output, by hashing the script datum given here." + "The script datum hash for this tx output, by hashing the script datum in the file." + + pTxOutDatumByValue = + TxOutDatumByValue + <$> pScriptDataOrFile + "tx-out-datum-embed" + "The script datum to embed in the tx for this output, given here." + "The script datum to embed in the tx for this output, in the given file." + + pTxOutInlineDatumByValue = + TxOutInlineDatumByValue + <$> pScriptDataOrFile + "tx-out-inline-datum" + "The script datum to embed in the tx output as an inline datum, given here." + "The script datum to embed in the tx output as an inline datum, in the given file." pRefScriptFp :: Parser ReferenceScriptAnyEra pRefScriptFp = - ReferenceScriptAnyEra <$> Opt.strOption - ( Opt.long "tx-out-reference-script-file" - <> Opt.metavar "FILE" - <> Opt.help "Reference script input file." - <> Opt.completer (Opt.bashCompleter "file") - ) <|> pure ReferenceScriptAnyEraNone + ReferenceScriptAnyEra + <$> Opt.strOption + ( Opt.long "tx-out-reference-script-file" + <> Opt.metavar "FILE" + <> Opt.help "Reference script input file." + <> Opt.completer (Opt.bashCompleter "file") + ) + <|> pure ReferenceScriptAnyEraNone pMintMultiAsset :: BalanceTxExecUnits -> Parser (Value, [ScriptWitnessFiles WitCtxMint]) pMintMultiAsset balanceExecUnits = - (,) <$> Opt.option - (readerFromParsecParser parseValue) - ( Opt.long "mint" - <> Opt.metavar "VALUE" - <> Opt.help helpText - ) - <*> some (pMintingScriptOrReferenceScriptWit balanceExecUnits <|> - pSimpleReferenceMintingScriptWitness <|> - pPlutusMintReferenceScriptWitnessFiles balanceExecUnits - ) + (,) + <$> Opt.option + (readerFromParsecParser parseValue) + ( Opt.long "mint" + <> Opt.metavar "VALUE" + <> Opt.help helpText + ) + <*> some + ( pMintingScriptOrReferenceScriptWit balanceExecUnits + <|> pSimpleReferenceMintingScriptWitness + <|> pPlutusMintReferenceScriptWitnessFiles balanceExecUnits + ) where pMintingScriptOrReferenceScriptWit :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint) pMintingScriptOrReferenceScriptWit bExecUnits = - pScriptWitnessFiles - WitCtxMint - bExecUnits - "mint" (Just "minting") - "the minting of assets for a particular policy Id." + pScriptWitnessFiles + WitCtxMint + bExecUnits + "mint" + (Just "minting") + "the minting of assets for a particular policy Id." pSimpleReferenceMintingScriptWitness :: Parser (ScriptWitnessFiles WitCtxMint) pSimpleReferenceMintingScriptWitness = @@ -2102,171 +2400,205 @@ pMintMultiAsset balanceExecUnits = -> ScriptWitnessFiles WitCtxMint createSimpleMintingReferenceScriptWitnessFiles refTxIn pid = let simpleLang = AnyScriptLanguage SimpleScriptLanguage - in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (Just pid) + in SimpleReferenceScriptWitnessFiles refTxIn simpleLang (Just pid) pPlutusMintReferenceScriptWitnessFiles - :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint) + :: BalanceTxExecUnits -> Parser (ScriptWitnessFiles WitCtxMint) pPlutusMintReferenceScriptWitnessFiles autoBalanceExecUnits = - PlutusReferenceScriptWitnessFiles - <$> pReferenceTxIn "mint-" "plutus" - <*> pPlutusScriptLanguage "mint-" - <*> pure NoScriptDatumOrFileForMint - <*> pScriptRedeemerOrFile "mint-reference-tx-in" - <*> (case autoBalanceExecUnits of - AutoBalance -> pure (ExecutionUnits 0 0) - ManualBalance -> pExecutionUnits "mint-reference-tx-in") - <*> (Just <$> pPolicyId) - - helpText = mconcat - [ "Mint multi-asset value(s) with the multi-asset cli syntax. " - , "You must specify a script witness." - ] + PlutusReferenceScriptWitnessFiles + <$> pReferenceTxIn "mint-" "plutus" + <*> pPlutusScriptLanguage "mint-" + <*> pure NoScriptDatumOrFileForMint + <*> pScriptRedeemerOrFile "mint-reference-tx-in" + <*> ( case autoBalanceExecUnits of + AutoBalance -> pure (ExecutionUnits 0 0) + ManualBalance -> pExecutionUnits "mint-reference-tx-in" + ) + <*> (Just <$> pPolicyId) + + helpText = + mconcat + [ "Mint multi-asset value(s) with the multi-asset cli syntax. " + , "You must specify a script witness." + ] pPolicyId :: Parser PolicyId pPolicyId = - Opt.option (readerFromParsecParser policyId) $ mconcat - [ Opt.long "policy-id" - , Opt.metavar "HASH" - , Opt.help "Policy id of minting script." - ] - + Opt.option (readerFromParsecParser policyId) $ + mconcat + [ Opt.long "policy-id" + , Opt.metavar "HASH" + , Opt.help "Policy id of minting script." + ] pInvalidBefore :: Parser SlotNo -pInvalidBefore = fmap SlotNo $ asum - [ Opt.option (bounded "SLOT") $ mconcat - [ Opt.long "invalid-before" - , Opt.metavar "SLOT" - , Opt.help "Time that transaction is valid from (in slots)." - ] - , Opt.option (bounded "SLOT") $ 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 - ] - ] +pInvalidBefore = + fmap SlotNo $ + asum + [ Opt.option (bounded "SLOT") $ + mconcat + [ Opt.long "invalid-before" + , Opt.metavar "SLOT" + , Opt.help "Time that transaction is valid from (in slots)." + ] + , Opt.option (bounded "SLOT") $ + 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 + ] + ] pLegacyInvalidHereafter :: Parser SlotNo pLegacyInvalidHereafter = - fmap SlotNo $ asum - [ Opt.option (bounded "SLOT") $ mconcat - [ Opt.long "invalid-hereafter" - , Opt.metavar "SLOT" - , Opt.help "Time that transaction is valid until (in slots)." - ] - , Opt.option (bounded "SLOT") $ 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 (bounded "SLOT") $ mconcat - [ 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 (bounded "SLOT") $ + mconcat + [ Opt.long "invalid-hereafter" + , Opt.metavar "SLOT" + , Opt.help "Time that transaction is valid until (in slots)." + ] + , Opt.option (bounded "SLOT") $ + 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 (bounded "SLOT") $ + mconcat + [ Opt.long "ttl" + , Opt.metavar "SLOT" + , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)." + , Opt.internal + ] ] - ] -pInvalidHereafter :: () +pInvalidHereafter + :: () => ShelleyBasedEra era -> Parser (TxValidityUpperBound era) pInvalidHereafter eon = - fmap (TxValidityUpperBound eon) $ asum - [ fmap (Just . SlotNo) $ Opt.option (bounded "SLOT") $ mconcat - [ Opt.long "invalid-hereafter" - , Opt.metavar "SLOT" - , Opt.help "Time that transaction is valid until (in slots)." - ] - , fmap (Just . SlotNo) $ Opt.option (bounded "SLOT") $ 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 - ] - , fmap (Just . SlotNo) $ Opt.option (bounded "SLOT") $ mconcat - [ Opt.long "ttl" - , Opt.metavar "SLOT" - , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)." - , Opt.internal - ] - , pure Nothing - ] - + fmap (TxValidityUpperBound eon) $ + asum + [ fmap (Just . SlotNo) $ + Opt.option (bounded "SLOT") $ + mconcat + [ Opt.long "invalid-hereafter" + , Opt.metavar "SLOT" + , Opt.help "Time that transaction is valid until (in slots)." + ] + , fmap (Just . SlotNo) $ + Opt.option (bounded "SLOT") $ + 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 + ] + , fmap (Just . SlotNo) $ + Opt.option (bounded "SLOT") $ + mconcat + [ Opt.long "ttl" + , Opt.metavar "SLOT" + , Opt.help "Time to live (in slots) (deprecated; use --invalid-hereafter instead)." + , Opt.internal + ] + , pure Nothing + ] pTxFee :: Parser L.Coin pTxFee = - fmap (L.Coin . (fromIntegral :: Natural -> Integer)) $ Opt.option Opt.auto $ mconcat - [ Opt.long "fee" - , Opt.metavar "LOVELACE" - , Opt.help "The fee amount in Lovelace." - ] + fmap (L.Coin . (fromIntegral :: Natural -> Integer)) $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "fee" + , Opt.metavar "LOVELACE" + , Opt.help "The fee amount in Lovelace." + ] pWitnessFile :: Parser WitnessFile pWitnessFile = - fmap WitnessFile $ Opt.strOption $ mconcat - [ Opt.long "witness-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the witness" - , Opt.completer (Opt.bashCompleter "file") - ] + fmap WitnessFile $ + Opt.strOption $ + mconcat + [ Opt.long "witness-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the witness" + , Opt.completer (Opt.bashCompleter "file") + ] pTxBodyFileIn :: Parser (TxBodyFile In) pTxBodyFileIn = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "tx-body-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the JSON TxBody." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "tx-body-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the JSON TxBody." + , Opt.completer (Opt.bashCompleter "file") + ] pTxBodyFileOut :: Parser (TxBodyFile Out) pTxBodyFileOut = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "out-file" - , Opt.metavar "FILE" - , Opt.help "Output filepath of the JSON TxBody." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "tx-body-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "out-file" + , Opt.metavar "FILE" + , Opt.help "Output filepath of the JSON TxBody." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "tx-body-file" + , Opt.internal + ] ] - ] pTxFileIn :: Parser (TxFile In) pTxFileIn = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "tx-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the JSON Tx." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "tx-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the JSON Tx." + , Opt.completer (Opt.bashCompleter "file") + ] pTxFileOut :: Parser (TxFile Out) pTxFileOut = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "out-file" - , Opt.metavar "FILE" - , Opt.help "Output filepath of the JSON Tx." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "tx-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "out-file" + , Opt.metavar "FILE" + , Opt.help "Output filepath of the JSON Tx." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "tx-file" + , Opt.internal + ] ] - ] pInputTxOrTxBodyFile :: Parser InputTxBodyOrTxFile pInputTxOrTxBodyFile = @@ -2277,36 +2609,44 @@ pInputTxOrTxBodyFile = pTxInCountDeprecated :: Parser TxInCount pTxInCountDeprecated = - fmap TxInCount $ Opt.option Opt.auto $ mconcat - [ Opt.long "tx-in-count" - , Opt.metavar "NATURAL" - , Opt.help "DEPRECATED. This argument has no effect." - ] + fmap TxInCount $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "tx-in-count" + , Opt.metavar "NATURAL" + , Opt.help "DEPRECATED. This argument has no effect." + ] pTxOutCountDeprecated :: Parser TxOutCount pTxOutCountDeprecated = - fmap TxOutCount $ Opt.option Opt.auto $ mconcat - [ Opt.long "tx-out-count" - , Opt.metavar "NATURAL" - , Opt.help "DEPRECATED. This argument has no effect." - ] + fmap TxOutCount $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "tx-out-count" + , Opt.metavar "NATURAL" + , Opt.help "DEPRECATED. This argument has no effect." + ] pTxShelleyWitnessCount :: Parser TxShelleyWitnessCount pTxShelleyWitnessCount = - fmap TxShelleyWitnessCount $ Opt.option Opt.auto $ mconcat - [ Opt.long "witness-count" - , Opt.metavar "NATURAL" - , Opt.help "The number of Shelley key witnesses." - ] + fmap TxShelleyWitnessCount $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "witness-count" + , Opt.metavar "NATURAL" + , Opt.help "The number of Shelley key witnesses." + ] pTxByronWitnessCount :: Parser TxByronWitnessCount pTxByronWitnessCount = - fmap TxByronWitnessCount $ Opt.option Opt.auto $ mconcat - [ Opt.long "byron-witness-count" - , Opt.metavar "NATURAL" - , Opt.help "The number of Byron key witnesses (default is 0)." - , Opt.value 0 - ] + fmap TxByronWitnessCount $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "byron-witness-count" + , Opt.metavar "NATURAL" + , Opt.help "The number of Byron key witnesses (default is 0)." + , Opt.value 0 + ] pQueryUTxOFilter :: Parser QueryUTxOFilter pQueryUTxOFilter = @@ -2315,30 +2655,33 @@ pQueryUTxOFilter = , pQueryUTxOByAddress , pQueryUTxOByTxIn ] - where - pQueryUTxOWhole = - Opt.flag' QueryUTxOWhole $ mconcat + where + pQueryUTxOWhole = + Opt.flag' QueryUTxOWhole $ + mconcat [ Opt.long "whole-utxo" , Opt.help "Return the whole UTxO (only appropriate on small testnets)." ] - pQueryUTxOByAddress :: Parser QueryUTxOFilter - pQueryUTxOByAddress = QueryUTxOByAddress . Set.fromList <$> some pByAddress + pQueryUTxOByAddress :: Parser QueryUTxOFilter + pQueryUTxOByAddress = QueryUTxOByAddress . Set.fromList <$> some pByAddress - pByAddress :: Parser AddressAny - pByAddress = - Opt.option (readerFromParsecParser parseAddressAny) $ mconcat + pByAddress :: Parser AddressAny + pByAddress = + Opt.option (readerFromParsecParser parseAddressAny) $ + mconcat [ Opt.long "address" , Opt.metavar "ADDRESS" , Opt.help "Filter by Cardano address(es) (Bech32-encoded)." ] - pQueryUTxOByTxIn :: Parser QueryUTxOFilter - pQueryUTxOByTxIn = QueryUTxOByTxIn . Set.fromList <$> some pByTxIn + pQueryUTxOByTxIn :: Parser QueryUTxOFilter + pQueryUTxOByTxIn = QueryUTxOByTxIn . Set.fromList <$> some pByTxIn - pByTxIn :: Parser TxIn - pByTxIn = - Opt.option (readerFromParsecParser parseTxIn) $ mconcat + pByTxIn :: Parser TxIn + pByTxIn = + Opt.option (readerFromParsecParser parseTxIn) $ + mconcat [ Opt.long "tx-in" , Opt.metavar "TX-IN" , Opt.help "Filter by transaction input (TxId#TxIx)." @@ -2346,7 +2689,8 @@ pQueryUTxOFilter = pFilterByStakeAddress :: Parser StakeAddress pFilterByStakeAddress = - Opt.option (readerFromParsecParser parseStakeAddress) $ mconcat + Opt.option (readerFromParsecParser parseStakeAddress) $ + mconcat [ Opt.long "address" , Opt.metavar "ADDRESS" , Opt.help "Filter by Cardano stake address (Bech32-encoded)." @@ -2354,64 +2698,72 @@ pFilterByStakeAddress = pByronAddress :: Parser (Address ByronAddr) pByronAddress = - Opt.option (Opt.eitherReader deserialise) $ mconcat - [ Opt.long "address" - , Opt.metavar "STRING" - , Opt.help "Byron address (Base58-encoded)." - ] - where - deserialise :: String -> Either String (Address ByronAddr) - deserialise = - maybe (Left "Invalid Byron address.") Right - . deserialiseAddress AsByronAddress - . Text.pack + Opt.option (Opt.eitherReader deserialise) $ + mconcat + [ Opt.long "address" + , Opt.metavar "STRING" + , Opt.help "Byron address (Base58-encoded)." + ] + where + deserialise :: String -> Either String (Address ByronAddr) + deserialise = + maybe (Left "Invalid Byron address.") Right + . deserialiseAddress AsByronAddress + . Text.pack pAddress :: Parser Text pAddress = - fmap Text.pack $ Opt.strOption $ mconcat - [ Opt.long "address" - , Opt.metavar "ADDRESS" - , Opt.help "A Cardano address" - ] + fmap Text.pack $ + Opt.strOption $ + mconcat + [ Opt.long "address" + , Opt.metavar "ADDRESS" + , Opt.help "A Cardano address" + ] -- | First argument is the prefix for the option's flag to use pStakePoolVerificationKeyHash :: Maybe String -> Parser (Hash StakePoolKey) pStakePoolVerificationKeyHash prefix = - Opt.option (rBech32KeyHash AsStakePoolKey <|> rHexHash AsStakePoolKey Nothing) $ mconcat + Opt.option (rBech32KeyHash AsStakePoolKey <|> rHexHash AsStakePoolKey Nothing) $ + mconcat [ Opt.long $ prefixFlag prefix "stake-pool-id" , Opt.metavar "STAKE_POOL_ID" , Opt.help - "Stake pool ID/verification key hash (either Bech32-encoded or hex-encoded)." + "Stake pool ID/verification key hash (either Bech32-encoded or hex-encoded)." ] pVrfVerificationKeyFile :: Parser (VerificationKeyFile In) pVrfVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "vrf-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the VRF verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "vrf-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the VRF verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pVrfVerificationKeyHash :: Parser (Hash VrfKey) pVrfVerificationKeyHash = - Opt.option deserialiseFromHex $ mconcat - [ Opt.long "vrf-verification-key-hash" - , Opt.metavar "STRING" - , Opt.help "VRF verification key hash (hex-encoded)." - ] - where - deserialiseFromHex :: ReadM (Hash VrfKey) - deserialiseFromHex = - rHexHash AsVrfKey (Just "Invalid VRF verification key hash") + Opt.option deserialiseFromHex $ + mconcat + [ Opt.long "vrf-verification-key-hash" + , Opt.metavar "STRING" + , Opt.help "VRF verification key hash (hex-encoded)." + ] + where + deserialiseFromHex :: ReadM (Hash VrfKey) + deserialiseFromHex = + rHexHash AsVrfKey (Just "Invalid VRF verification key hash") pVrfVerificationKey :: Parser (VerificationKey VrfKey) pVrfVerificationKey = - Opt.option (readVerificationKey AsVrfKey) $ mconcat - [ Opt.long "vrf-verification-key" - , Opt.metavar "STRING" - , Opt.help "VRF verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey AsVrfKey) $ + mconcat + [ Opt.long "vrf-verification-key" + , Opt.metavar "STRING" + , Opt.help "VRF verification key (Bech32 or hex-encoded)." + ] pVrfVerificationKeyOrFile :: Parser (VerificationKeyOrFile VrfKey) pVrfVerificationKeyOrFile = @@ -2427,29 +2779,32 @@ pVrfVerificationKeyOrHashOrFile = , VerificationKeyHash <$> pVrfVerificationKeyHash ] - pRewardAcctVerificationKeyFile :: Parser (VerificationKeyFile In) pRewardAcctVerificationKeyFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "pool-reward-account-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the reward account stake verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "reward-account-verification-key-file" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "pool-reward-account-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the reward account stake verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "reward-account-verification-key-file" + , Opt.internal + ] ] - ] pRewardAcctVerificationKey :: Parser (VerificationKey StakeKey) pRewardAcctVerificationKey = - Opt.option (readVerificationKey AsStakeKey) $ mconcat - [ Opt.long "pool-reward-account-verification-key" - , Opt.metavar "STRING" - , Opt.help "Reward account stake verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey AsStakeKey) $ + mconcat + [ Opt.long "pool-reward-account-verification-key" + , Opt.metavar "STRING" + , Opt.help "Reward account stake verification key (Bech32 or hex-encoded)." + ] pRewardAcctVerificationKeyOrFile :: Parser (VerificationKeyOrFile StakeKey) pRewardAcctVerificationKeyOrFile = @@ -2460,26 +2815,30 @@ pRewardAcctVerificationKeyOrFile = pPoolOwnerVerificationKeyFile :: Parser (VerificationKeyFile In) pPoolOwnerVerificationKeyFile = - fmap File $ asum - [ Opt.strOption $ mconcat - [ Opt.long "pool-owner-stake-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the pool owner stake verification key." - , Opt.completer (Opt.bashCompleter "file") - ] - , Opt.strOption $ mconcat - [ Opt.long "pool-owner-staking-verification-key" - , Opt.internal + fmap File $ + asum + [ Opt.strOption $ + mconcat + [ Opt.long "pool-owner-stake-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the pool owner stake verification key." + , Opt.completer (Opt.bashCompleter "file") + ] + , Opt.strOption $ + mconcat + [ Opt.long "pool-owner-staking-verification-key" + , Opt.internal + ] ] - ] pPoolOwnerVerificationKey :: Parser (VerificationKey StakeKey) pPoolOwnerVerificationKey = - Opt.option (readVerificationKey AsStakeKey) $ mconcat - [ Opt.long "pool-owner-verification-key" - , Opt.metavar "STRING" - , Opt.help "Pool owner stake verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey AsStakeKey) $ + mconcat + [ Opt.long "pool-owner-verification-key" + , Opt.metavar "STRING" + , Opt.help "Pool owner stake verification key (Bech32 or hex-encoded)." + ] pPoolOwnerVerificationKeyOrFile :: Parser (VerificationKeyOrFile StakeKey) pPoolOwnerVerificationKeyOrFile = @@ -2490,32 +2849,34 @@ pPoolOwnerVerificationKeyOrFile = pPoolPledge :: Parser L.Coin pPoolPledge = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "pool-pledge" - , Opt.metavar "LOVELACE" - , Opt.help "The stake pool's pledge." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "pool-pledge" + , Opt.metavar "LOVELACE" + , Opt.help "The stake pool's pledge." + ] pPoolCost :: Parser L.Coin pPoolCost = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "pool-cost" - , Opt.metavar "LOVELACE" - , Opt.help "The stake pool's cost." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "pool-cost" + , Opt.metavar "LOVELACE" + , Opt.help "The stake pool's cost." + ] pRational :: String -> String -> Parser Rational pRational opt h = - Opt.option readRationalUnitInterval $ mconcat - [ Opt.long opt - , Opt.metavar "RATIONAL" - , Opt.help h - ] + Opt.option readRationalUnitInterval $ + mconcat + [ Opt.long opt + , Opt.metavar "RATIONAL" + , Opt.help h + ] pPoolMargin :: Parser Rational pPoolMargin = pRational "pool-margin" "The stake pool's margin." - pPoolRelay :: Parser StakePoolRelay pPoolRelay = asum @@ -2527,10 +2888,11 @@ pPoolRelay = pMultiHostName :: Parser StakePoolRelay pMultiHostName = StakePoolRelayDnsSrvRecord <$> pDNSName - where - pDNSName :: Parser ByteString - pDNSName = - Opt.option (Opt.eitherReader eDNSName) $ mconcat + where + pDNSName :: Parser ByteString + pDNSName = + Opt.option (Opt.eitherReader eDNSName) $ + mconcat [ Opt.long "multi-host-pool-relay" , Opt.metavar "STRING" , Opt.help "The stake pool relay's DNS name that corresponds to an SRV DNS record" @@ -2539,16 +2901,19 @@ pMultiHostName = pSingleHostName :: Parser StakePoolRelay pSingleHostName = StakePoolRelayDnsARecord <$> pDNSName <*> optional pPort - 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" + 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" + ] ] - ] pSingleHostAddress :: Parser StakePoolRelay pSingleHostAddress = @@ -2556,42 +2921,45 @@ pSingleHostAddress = <$> optional pIpV4 <*> optional pIpV6 <*> pPort - where - singleHostAddress :: Maybe IP.IPv4 -> Maybe IP.IPv6 -> PortNumber -> StakePoolRelay - singleHostAddress ipv4 ipv6 port = - case (ipv4, ipv6) of - (Nothing, Nothing) -> - error "Please enter either an IPv4 or IPv6 address for the pool relay" - (Just i4, Nothing) -> - StakePoolRelayIp (Just i4) Nothing (Just port) - (Nothing, Just i6) -> - StakePoolRelayIp Nothing (Just i6) (Just port) - (Just i4, Just i6) -> - StakePoolRelayIp (Just i4) (Just i6) (Just port) + where + singleHostAddress :: Maybe IP.IPv4 -> Maybe IP.IPv6 -> PortNumber -> StakePoolRelay + singleHostAddress ipv4 ipv6 port = + case (ipv4, ipv6) of + (Nothing, Nothing) -> + error "Please enter either an IPv4 or IPv6 address for the pool relay" + (Just i4, Nothing) -> + StakePoolRelayIp (Just i4) Nothing (Just port) + (Nothing, Just i6) -> + StakePoolRelayIp Nothing (Just i6) (Just port) + (Just i4, Just i6) -> + StakePoolRelayIp (Just i4) (Just i6) (Just port) pIpV4 :: Parser IP.IPv4 pIpV4 = - Opt.option (Opt.maybeReader readMaybe :: Opt.ReadM IP.IPv4) $ mconcat - [ Opt.long "pool-relay-ipv4" - , Opt.metavar "STRING" - , Opt.help "The stake pool relay's IPv4 address" - ] + Opt.option (Opt.maybeReader readMaybe :: Opt.ReadM IP.IPv4) $ + mconcat + [ Opt.long "pool-relay-ipv4" + , Opt.metavar "STRING" + , Opt.help "The stake pool relay's IPv4 address" + ] pIpV6 :: Parser IP.IPv6 pIpV6 = - Opt.option (Opt.maybeReader readMaybe :: Opt.ReadM IP.IPv6) $ mconcat - [ Opt.long "pool-relay-ipv6" - , Opt.metavar "STRING" - , Opt.help "The stake pool relay's IPv6 address" - ] + Opt.option (Opt.maybeReader readMaybe :: Opt.ReadM IP.IPv6) $ + mconcat + [ Opt.long "pool-relay-ipv6" + , Opt.metavar "STRING" + , Opt.help "The stake pool relay's IPv6 address" + ] pPort :: Parser PortNumber pPort = - Opt.option (fromInteger <$> Opt.eitherReader readEither) $ mconcat - [ Opt.long "pool-relay-port" - , Opt.metavar "INT" - , Opt.help "The stake pool relay's port" - ] + Opt.option (fromInteger <$> Opt.eitherReader readEither) $ + mconcat + [ Opt.long "pool-relay-port" + , Opt.metavar "INT" + , Opt.help "The stake pool relay's port" + ] pStakePoolMetadataReference :: Parser (Maybe StakePoolMetadataReference) pStakePoolMetadataReference = @@ -2602,23 +2970,25 @@ pStakePoolMetadataReference = pStakePoolMetadataUrl :: Parser Text pStakePoolMetadataUrl = - Opt.option (readURIOfMaxLength 64) $ mconcat - [ Opt.long "metadata-url" - , Opt.metavar "URL" - , Opt.help "Pool metadata URL (maximum length of 64 characters)." - ] + Opt.option (readURIOfMaxLength 64) $ + mconcat + [ Opt.long "metadata-url" + , Opt.metavar "URL" + , Opt.help "Pool metadata URL (maximum length of 64 characters)." + ] pStakePoolMetadataHash :: Parser (Hash StakePoolMetadata) pStakePoolMetadataHash = - Opt.option deserializeFromHex $ mconcat - [ Opt.long "metadata-hash" - , Opt.metavar "HASH" - , Opt.help "Pool metadata hash." - ] - where - deserializeFromHex :: ReadM (Hash StakePoolMetadata) - deserializeFromHex = - rHexHash AsStakePoolMetadata Nothing + Opt.option deserializeFromHex $ + mconcat + [ Opt.long "metadata-hash" + , Opt.metavar "HASH" + , Opt.help "Pool metadata hash." + ] + where + deserializeFromHex :: ReadM (Hash StakePoolMetadata) + deserializeFromHex = + rHexHash AsStakePoolMetadata Nothing pStakePoolRegistrationParserRequirements :: EnvCli -> Parser StakePoolRegistrationParserRequirements @@ -2666,391 +3036,455 @@ pProtocolParametersUpdate = pCostModels :: Parser FilePath pCostModels = - Opt.strOption $ mconcat - [ Opt.long "cost-model-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the JSON formatted cost model" - , Opt.completer (Opt.bashCompleter "file") - ] + Opt.strOption $ + mconcat + [ Opt.long "cost-model-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the JSON formatted cost model" + , Opt.completer (Opt.bashCompleter "file") + ] pMinFeePerByteFactor :: Parser L.Coin pMinFeePerByteFactor = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "min-fee-linear" - , Opt.metavar "LOVELACE" - , Opt.help "The linear factor per byte for the minimum fee calculation." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "min-fee-linear" + , Opt.metavar "LOVELACE" + , Opt.help "The linear factor per byte for the minimum fee calculation." + ] pMinFeeConstantFactor :: Parser L.Coin pMinFeeConstantFactor = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "min-fee-constant" - , Opt.metavar "LOVELACE" - , Opt.help "The constant factor for the minimum fee calculation." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "min-fee-constant" + , Opt.metavar "LOVELACE" + , Opt.help "The constant factor for the minimum fee calculation." + ] pMinUTxOValue :: Parser L.Coin pMinUTxOValue = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "min-utxo-value" - , Opt.metavar "NATURAL" - , Opt.help "The minimum allowed UTxO value (Shelley to Mary eras)." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "min-utxo-value" + , Opt.metavar "NATURAL" + , Opt.help "The minimum allowed UTxO value (Shelley to Mary eras)." + ] pMinPoolCost :: Parser L.Coin pMinPoolCost = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "min-pool-cost" - , Opt.metavar "NATURAL" - , Opt.help "The minimum allowed cost parameter for stake pools." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "min-pool-cost" + , Opt.metavar "NATURAL" + , Opt.help "The minimum allowed cost parameter for stake pools." + ] pMaxBodySize :: Parser Word32 pMaxBodySize = - Opt.option Opt.auto $ mconcat - [ Opt.long "max-block-body-size" - , Opt.metavar "WORD32" - , Opt.help "Maximal block body size." - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "max-block-body-size" + , Opt.metavar "WORD32" + , Opt.help "Maximal block body size." + ] pMaxTransactionSize :: Parser Word32 pMaxTransactionSize = - Opt.option Opt.auto $ mconcat - [ Opt.long "max-tx-size" - , Opt.metavar "WORD32" - , Opt.help "Maximum transaction size." - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "max-tx-size" + , Opt.metavar "WORD32" + , Opt.help "Maximum transaction size." + ] pMaxBlockHeaderSize :: Parser Word16 pMaxBlockHeaderSize = - Opt.option Opt.auto $ mconcat - [ Opt.long "max-block-header-size" - , Opt.metavar "WORD16" - , Opt.help "Maximum block header size." - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "max-block-header-size" + , Opt.metavar "WORD16" + , Opt.help "Maximum block header size." + ] pKeyRegistDeposit :: Parser L.Coin pKeyRegistDeposit = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "key-reg-deposit-amt" - , Opt.metavar "NATURAL" - , Opt.help "Key registration deposit amount." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "key-reg-deposit-amt" + , Opt.metavar "NATURAL" + , Opt.help "Key registration deposit amount." + ] pDrepDeposit :: Parser L.Coin pDrepDeposit = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "deposit-amt" - , Opt.metavar "LOVELACE" - , Opt.help "DRep deposit amount (same at registration and retirement)." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "deposit-amt" + , Opt.metavar "LOVELACE" + , Opt.help "DRep deposit amount (same at registration and retirement)." + ] pPoolDeposit :: Parser L.Coin pPoolDeposit = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "pool-reg-deposit" - , Opt.metavar "NATURAL" - , Opt.help "The amount of a pool registration deposit." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "pool-reg-deposit" + , Opt.metavar "NATURAL" + , Opt.help "The amount of a pool registration deposit." + ] pEpochBoundRetirement :: Parser L.EpochInterval pEpochBoundRetirement = - fmap L.EpochInterval $ asum - [ Opt.option (bounded "EPOCH_INTERVAL") $ mconcat - [ Opt.long "pool-retirement-epoch-interval" - , Opt.metavar "WORD32" - , Opt.help "Epoch interval of pool retirement." - ] - , Opt.option (bounded "EPOCH_BOUNDARY") $ mconcat - [ Opt.long "pool-retirement-epoch-boundary" - , Opt.internal - ] - ] + fmap L.EpochInterval $ + asum + [ Opt.option (bounded "EPOCH_INTERVAL") $ + mconcat + [ Opt.long "pool-retirement-epoch-interval" + , Opt.metavar "WORD32" + , Opt.help "Epoch interval of pool retirement." + ] + , Opt.option (bounded "EPOCH_BOUNDARY") $ + mconcat + [ Opt.long "pool-retirement-epoch-boundary" + , Opt.internal + ] + ] pNumberOfPools :: Parser Natural pNumberOfPools = - Opt.option Opt.auto $ mconcat - [ Opt.long "number-of-pools" - , Opt.metavar "NATURAL" - , Opt.help "Desired number of pools." - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "number-of-pools" + , Opt.metavar "NATURAL" + , Opt.help "Desired number of pools." + ] pPoolInfluence :: Parser Rational pPoolInfluence = - Opt.option readRational $ mconcat - [ Opt.long "pool-influence" - , Opt.metavar "RATIONAL" - , Opt.help "Pool influence." - ] + Opt.option readRational $ + mconcat + [ Opt.long "pool-influence" + , Opt.metavar "RATIONAL" + , Opt.help "Pool influence." + ] pTreasuryExpansion :: Parser Rational pTreasuryExpansion = - Opt.option readRationalUnitInterval $ mconcat - [ Opt.long "treasury-expansion" - , Opt.metavar "RATIONAL" - , Opt.help "Treasury expansion." - ] + Opt.option readRationalUnitInterval $ + mconcat + [ Opt.long "treasury-expansion" + , Opt.metavar "RATIONAL" + , Opt.help "Treasury expansion." + ] pMonetaryExpansion :: Parser Rational pMonetaryExpansion = - Opt.option readRationalUnitInterval $ mconcat - [ Opt.long "monetary-expansion" - , Opt.metavar "RATIONAL" - , Opt.help "Monetary expansion." - ] + Opt.option readRationalUnitInterval $ + mconcat + [ Opt.long "monetary-expansion" + , Opt.metavar "RATIONAL" + , Opt.help "Monetary expansion." + ] pDecentralParam :: Parser Rational pDecentralParam = - Opt.option readRationalUnitInterval $ mconcat - [ Opt.long "decentralization-parameter" - , Opt.metavar "RATIONAL" - , Opt.help "Decentralization parameter." - ] + Opt.option readRationalUnitInterval $ + mconcat + [ Opt.long "decentralization-parameter" + , Opt.metavar "RATIONAL" + , Opt.help "Decentralization parameter." + ] pExtraEntropy :: Parser (Maybe PraosNonce) pExtraEntropy = asum - [ Opt.option (Just <$> readerFromParsecParser parsePraosNonce) $ mconcat - [ Opt.long "extra-entropy" - , Opt.metavar "HEX" - , Opt.help "Praos extra entropy seed, as a hex byte string." - ] - , Opt.flag' Nothing $ mconcat - [ Opt.long "reset-extra-entropy" - , Opt.help "Reset the Praos extra entropy to none." - ] + [ Opt.option (Just <$> readerFromParsecParser parsePraosNonce) $ + mconcat + [ Opt.long "extra-entropy" + , Opt.metavar "HEX" + , Opt.help "Praos extra entropy seed, as a hex byte string." + ] + , Opt.flag' Nothing $ + mconcat + [ Opt.long "reset-extra-entropy" + , Opt.help "Reset the Praos extra entropy to none." + ] ] - where - parsePraosNonce :: Parsec.Parser PraosNonce - parsePraosNonce = makePraosNonce <$> parseEntropyBytes + where + parsePraosNonce :: Parsec.Parser PraosNonce + parsePraosNonce = makePraosNonce <$> parseEntropyBytes - parseEntropyBytes :: Parsec.Parser ByteString - parseEntropyBytes = either fail return - . B16.decode . BSC.pack - =<< some Parsec.hexDigit + parseEntropyBytes :: Parsec.Parser ByteString + parseEntropyBytes = + either fail return + . B16.decode + . BSC.pack + =<< some Parsec.hexDigit pUTxOCostPerByte :: Parser L.Coin pUTxOCostPerByte = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "utxo-cost-per-byte" - , Opt.metavar "LOVELACE" - , Opt.help "Cost in lovelace per unit of UTxO storage (from Babbage era)." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "utxo-cost-per-byte" + , Opt.metavar "LOVELACE" + , Opt.help "Cost in lovelace per unit of UTxO storage (from Babbage era)." + ] pExecutionUnitPrices :: Parser ExecutionUnitPrices -pExecutionUnitPrices = ExecutionUnitPrices - <$> Opt.option readRational +pExecutionUnitPrices = + ExecutionUnitPrices + <$> Opt.option + readRational ( 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.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.option + readRational ( 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')" + [ 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 + uncurry ExecutionUnits + <$> Opt.option + Opt.auto ( 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)." + [ 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 + uncurry ExecutionUnits + <$> Opt.option + Opt.auto ( 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)." + [ 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 $ 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)." - ] - ] + 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 $ 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)." - ] - ] + 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 $ 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)." - ] - ] + 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)." + ] + ] pProtocolVersion :: Parser (Natural, Natural) pProtocolVersion = - (,) <$> pProtocolMajorVersion <*> pProtocolMinorVersion - where - pProtocolMajorVersion = - Opt.option Opt.auto $ mconcat + (,) <$> pProtocolMajorVersion <*> pProtocolMinorVersion + where + pProtocolMajorVersion = + Opt.option Opt.auto $ + mconcat [ Opt.long "protocol-major-version" , Opt.metavar "NATURAL" , Opt.help "Major protocol version. An increase indicates a hard fork." ] - pProtocolMinorVersion = - Opt.option Opt.auto $ mconcat + pProtocolMinorVersion = + 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)." - ] + , Opt.help $ + mconcat + [ "Minor protocol version. An increase indicates a soft fork" + , " (old software canvalidate but not produce new blocks)." + ] ] pPoolVotingThresholds :: Parser L.PoolVotingThresholds pPoolVotingThresholds = - L.PoolVotingThresholds - <$> pMotionNoConfidence - <*> pCommitteeNormal - <*> pCommitteeNoConfidence - <*> pHardForkInitiation - <*> pPPSecurityGroup - where - pMotionNoConfidence = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + L.PoolVotingThresholds + <$> pMotionNoConfidence + <*> pCommitteeNormal + <*> pCommitteeNoConfidence + <*> pHardForkInitiation + <*> pPPSecurityGroup + where + pMotionNoConfidence = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "pool-voting-threshold-motion-no-confidence" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for stake pool votes on motions no confidence." ] - pCommitteeNormal = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pCommitteeNormal = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "pool-voting-threshold-committee-normal" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for stake pool votes on normal committee updates." ] - pCommitteeNoConfidence = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pCommitteeNoConfidence = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "pool-voting-threshold-committee-no-confidence" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for stake pool votes on committee updates when the committee is in a state of no confidence." + , Opt.help + "Acceptance threshold for stake pool votes on committee updates when the committee is in a state of no confidence." ] - pHardForkInitiation = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pHardForkInitiation = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "pool-voting-threshold-hard-fork-initiation" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for stake pool votes on hard fork initiations." ] - pPPSecurityGroup = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pPPSecurityGroup = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "pool-voting-threshold-pp-security-group" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for stake pool votes on protocol parameters for parameters in the 'security' group." + , Opt.help + "Acceptance threshold for stake pool votes on protocol parameters for parameters in the 'security' group." ] pDRepVotingThresholds :: Parser L.DRepVotingThresholds pDRepVotingThresholds = - L.DRepVotingThresholds - <$> pMotionNoConfidence - <*> pCommitteeNormal - <*> pCommitteeNoConfidence - <*> pUpdateToConstitution - <*> pHardForkInitiation - <*> pPPNetworkGroup - <*> pPPEconomicGroup - <*> pPPTechnicalGroup - <*> pPPGovGroup - <*> pTreasuryWithdrawal - where - pMotionNoConfidence = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + L.DRepVotingThresholds + <$> pMotionNoConfidence + <*> pCommitteeNormal + <*> pCommitteeNoConfidence + <*> pUpdateToConstitution + <*> pHardForkInitiation + <*> pPPNetworkGroup + <*> pPPEconomicGroup + <*> pPPTechnicalGroup + <*> pPPGovGroup + <*> pTreasuryWithdrawal + where + pMotionNoConfidence = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-motion-no-confidence" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for DRep votes on motions of no confidence." ] - pCommitteeNormal = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pCommitteeNormal = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-committee-normal" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for DRep votes on normal committee updates." ] - pCommitteeNoConfidence = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pCommitteeNoConfidence = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-committee-no-confidence" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for DRep votes on committee updates when the committee is in a state of no confidence." + , Opt.help + "Acceptance threshold for DRep votes on committee updates when the committee is in a state of no confidence." ] - pUpdateToConstitution = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pUpdateToConstitution = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-update-to-constitution" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for DRep votes on constitution updates." ] - pHardForkInitiation = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pHardForkInitiation = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-hard-fork-initiation" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for DRep votes on hard fork initiations." ] - pPPNetworkGroup = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pPPNetworkGroup = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-pp-network-group" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'network' group." + , Opt.help + "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'network' group." ] - pPPEconomicGroup = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pPPEconomicGroup = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-pp-economic-group" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'economic' group." + , Opt.help + "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'economic' group." ] - pPPTechnicalGroup = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pPPTechnicalGroup = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-pp-technical-group" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'technical' group." + , Opt.help + "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'technical' group." ] - pPPGovGroup = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pPPGovGroup = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-pp-governance-group" , Opt.metavar "RATIONAL" - , Opt.help "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'governance' group." + , Opt.help + "Acceptance threshold for DRep votes on protocol parameters for parameters in the 'governance' group." ] - pTreasuryWithdrawal = - Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ mconcat + pTreasuryWithdrawal = + Opt.option (toUnitIntervalOrErr <$> readRationalUnitInterval) $ + mconcat [ Opt.long "drep-voting-threshold-treasury-withdrawal" , Opt.metavar "RATIONAL" , Opt.help "Acceptance threshold for DRep votes on treasury withdrawals." @@ -3058,91 +3492,99 @@ pDRepVotingThresholds = pMinCommitteeSize :: Parser Natural pMinCommitteeSize = - Opt.option Opt.auto $ mconcat - [ Opt.long "min-committee-size" - , Opt.metavar "INT" - , Opt.help "Minimal size of the constitutional committee." - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "min-committee-size" + , Opt.metavar "INT" + , Opt.help "Minimal size of the constitutional committee." + ] pCommitteeTermLength :: Parser L.EpochInterval pCommitteeTermLength = - fmap L.EpochInterval $ Opt.option (bounded "EPOCH_INTERVAL") $ mconcat - [ Opt.long "committee-term-length" - , Opt.metavar "WORD32" - , Opt.help "Maximal term length for members of the constitutional committee, in epochs." - ] + fmap L.EpochInterval $ + Opt.option (bounded "EPOCH_INTERVAL") $ + mconcat + [ Opt.long "committee-term-length" + , Opt.metavar "WORD32" + , Opt.help "Maximal term length for members of the constitutional committee, in epochs." + ] pGovActionLifetime :: Parser L.EpochInterval pGovActionLifetime = - fmap L.EpochInterval $ Opt.option (bounded "EPOCH_INTERVAL") $ mconcat - [ Opt.long "governance-action-lifetime" - , Opt.metavar "WORD32" - , Opt.help "Maximal lifetime of governance actions, in epochs." - ] + fmap L.EpochInterval $ + Opt.option (bounded "EPOCH_INTERVAL") $ + mconcat + [ Opt.long "governance-action-lifetime" + , Opt.metavar "WORD32" + , Opt.help "Maximal lifetime of governance actions, in epochs." + ] pDRepDeposit :: Parser L.Coin pDRepDeposit = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "drep-deposit" - , Opt.metavar "LOVELACE" - , Opt.help "DRep deposit amount." - ] + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "drep-deposit" + , Opt.metavar "LOVELACE" + , Opt.help "DRep deposit amount." + ] pDRepActivity :: Parser L.EpochInterval pDRepActivity = - fmap L.EpochInterval $ Opt.option (bounded "EPOCH_INTERVAL") $ mconcat - [ Opt.long "drep-activity" - , Opt.metavar "WORD32" - , Opt.help "DRep activity period, in epochs." - ] + fmap L.EpochInterval $ + Opt.option (bounded "EPOCH_INTERVAL") $ + mconcat + [ Opt.long "drep-activity" + , Opt.metavar "WORD32" + , Opt.help "DRep activity period, in epochs." + ] parseTxOutShelleyBasedEra :: Parsec.Parser (TxOutDatumAnyEra -> ReferenceScriptAnyEra -> TxOutShelleyBasedEra) parseTxOutShelleyBasedEra = do - addr <- parseShelleyAddress - Parsec.spaces - -- Accept the old style of separating the address and value in a - -- transaction output: - Parsec.option () (Parsec.char '+' >> Parsec.spaces) - val <- parseValue - return (TxOutShelleyBasedEra addr val) + addr <- parseShelleyAddress + Parsec.spaces + -- Accept the old style of separating the address and value in a + -- transaction output: + Parsec.option () (Parsec.char '+' >> Parsec.spaces) + val <- parseValue + return (TxOutShelleyBasedEra addr val) parseShelleyAddress :: Parsec.Parser (Address ShelleyAddr) parseShelleyAddress = do - str <- lexPlausibleAddressString - case deserialiseAddress AsShelleyAddress str of - Nothing -> fail $ "invalid address: " <> Text.unpack str - Just addr -> pure addr - + str <- lexPlausibleAddressString + case deserialiseAddress AsShelleyAddress str of + Nothing -> fail $ "invalid address: " <> Text.unpack str + Just addr -> pure addr parseTxOutAnyEra :: Parsec.Parser (TxOutDatumAnyEra -> ReferenceScriptAnyEra -> TxOutAnyEra) parseTxOutAnyEra = do - addr <- parseAddressAny - Parsec.spaces - -- Accept the old style of separating the address and value in a - -- transaction output: - Parsec.option () (Parsec.char '+' >> Parsec.spaces) - val <- parseValue - return (TxOutAnyEra addr val) + addr <- parseAddressAny + Parsec.spaces + -- Accept the old style of separating the address and value in a + -- transaction output: + Parsec.option () (Parsec.char '+' >> Parsec.spaces) + val <- parseValue + return (TxOutAnyEra addr val) -------------------------------------------------------------------------------- pVoteChoice :: Parser Vote pVoteChoice = asum - [ flag' Yes $ long "yes" - , flag' No $ long "no" - , flag' Abstain $ long "abstain" - ] + [ flag' Yes $ long "yes" + , flag' No $ long "no" + , flag' Abstain $ long "abstain" + ] pVoterType :: Parser VType pVoterType = asum - [ flag' VCC $ mconcat [long "constitutional-committee-member", Opt.help "Member of the constiutional committee"] - , flag' VDR $ mconcat [long "drep", Opt.help "Delegated representative"] - , flag' VSP $ mconcat [long "spo", Opt.help "Stake pool operator"] - ] + [ flag' VCC $ + mconcat [long "constitutional-committee-member", Opt.help "Member of the constiutional committee"] + , flag' VDR $ mconcat [long "drep", Opt.help "Delegated representative"] + , flag' VSP $ mconcat [long "spo", Opt.help "Stake pool operator"] + ] -- TODO: Conway era include "normal" stake keys pVotingCredential :: Parser (VerificationKeyOrFile StakePoolKey) @@ -3158,44 +3600,49 @@ pVoteDelegationTarget = pAlwaysAbstain :: Parser () pAlwaysAbstain = - Opt.flag' () $ mconcat - [ Opt.long "always-abstain" - , Opt.help "Abstain from voting on all proposals." - ] + Opt.flag' () $ + mconcat + [ Opt.long "always-abstain" + , Opt.help "Abstain from voting on all proposals." + ] pVoteAnchor :: Parser (VoteUrl, L.SafeHash L.StandardCrypto L.AnchorData) -pVoteAnchor = (,) - <$> (VoteUrl <$> pUrl "anchor-url" "Vote anchor URL") - <*> pVoteAnchorDataHash +pVoteAnchor = + (,) + <$> (VoteUrl <$> pUrl "anchor-url" "Vote anchor URL") + <*> pVoteAnchorDataHash pVoteAnchorDataHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData) pVoteAnchorDataHash = - Opt.option readSafeHash $ mconcat - [ Opt.long "anchor-data-hash" - , Opt.metavar "HASH" - , Opt.help "Hash of the vote anchor data (obtain it with \"cardano-cli hash anchor-data ...\")." - ] + Opt.option readSafeHash $ + mconcat + [ Opt.long "anchor-data-hash" + , Opt.metavar "HASH" + , Opt.help "Hash of the vote anchor data (obtain it with \"cardano-cli hash anchor-data ...\")." + ] pAlwaysNoConfidence :: Parser () pAlwaysNoConfidence = - Opt.flag' () $ mconcat - [ Opt.long "always-no-confidence" - , Opt.help "Always vote no confidence" - ] + Opt.flag' () $ + mconcat + [ Opt.long "always-no-confidence" + , Opt.help "Always vote no confidence" + ] pDrepRefund :: Parser (DRepHashSource, L.Coin) pDrepRefund = - (,) <$> pDRepHashSource - <*> pDepositRefund + (,) + <$> pDRepHashSource + <*> pDepositRefund pDepositRefund :: Parser L.Coin pDepositRefund = - Opt.option (readerFromParsecParser parseLovelace) $ mconcat - [ Opt.long "deposit-refund" - , Opt.metavar "LOVELACE" - , Opt.help "Deposit refund amount." - ] - + Opt.option (readerFromParsecParser parseLovelace) $ + mconcat + [ Opt.long "deposit-refund" + , Opt.metavar "LOVELACE" + , Opt.help "Deposit refund amount." + ] pDRepHashSource :: Parser DRepHashSource pDRepHashSource = @@ -3224,13 +3671,14 @@ pDRepVerificationKeyOrHashOrFile = , VerificationKeyHash <$> pDRepVerificationKeyHash ] -pDRepVerificationKeyOrHashOrFileOrScriptHash :: Parser (VerificationKeyOrHashOrFileOrScriptHash DRepKey) +pDRepVerificationKeyOrHashOrFileOrScriptHash + :: Parser (VerificationKeyOrHashOrFileOrScriptHash DRepKey) pDRepVerificationKeyOrHashOrFileOrScriptHash = asum [ VkhfshKeyHashFile . VerificationKeyOrFile <$> pDRepVerificationKeyOrFile , VkhfshKeyHashFile . VerificationKeyHash <$> pDRepVerificationKeyHash - , VkhfshScriptHash <$> - pScriptHash + , VkhfshScriptHash + <$> pScriptHash "drep-script-hash" "Cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." ] @@ -3238,15 +3686,19 @@ pDRepVerificationKeyOrHashOrFileOrScriptHash = pAllOrOnlyDRepHashSource :: Parser (AllOrOnly DRepHashSource) pAllOrOnlyDRepHashSource = pAll <|> pOnly - where pOnly = Only <$> some pDRepHashSource - pAll = Opt.flag' All $ mconcat - [ Opt.long "all-dreps" - , Opt.help "Query for all DReps." - ] + where + pOnly = Only <$> some pDRepHashSource + pAll = + Opt.flag' All $ + mconcat + [ Opt.long "all-dreps" + , Opt.help "Query for all DReps." + ] pDRepVerificationKeyHash :: Parser (Hash DRepKey) pDRepVerificationKeyHash = - Opt.option (rBech32KeyHash AsDRepKey <|> rHexHash AsDRepKey Nothing) $ mconcat + Opt.option (rBech32KeyHash AsDRepKey <|> rHexHash AsDRepKey Nothing) $ + mconcat [ Opt.long "drep-key-hash" , Opt.metavar "HASH" , Opt.help "DRep verification key hash (either Bech32-encoded or hex-encoded)." @@ -3254,11 +3706,12 @@ pDRepVerificationKeyHash = pDRepVerificationKey :: Parser (VerificationKey DRepKey) pDRepVerificationKey = - Opt.option (readVerificationKey AsDRepKey) $ mconcat - [ Opt.long "drep-verification-key" - , Opt.metavar "STRING" - , Opt.help "DRep verification key (Bech32 or hex-encoded)." - ] + Opt.option (readVerificationKey AsDRepKey) $ + mconcat + [ Opt.long "drep-verification-key" + , Opt.metavar "STRING" + , Opt.help "DRep verification key (Bech32 or hex-encoded)." + ] pDRepVerificationKeyOrFile :: Parser (VerificationKeyOrFile DRepKey) pDRepVerificationKeyOrFile = @@ -3269,12 +3722,13 @@ pDRepVerificationKeyOrFile = pDRepVerificationKeyFile :: Parser (VerificationKeyFile In) pDRepVerificationKeyFile = - fmap File . Opt.strOption $ mconcat - [ Opt.long "drep-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the DRep verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File . Opt.strOption $ + mconcat + [ Opt.long "drep-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the DRep verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pAnchorUrl :: Parser ProposalUrl pAnchorUrl = @@ -3283,68 +3737,83 @@ pAnchorUrl = pAnchorDataHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData) pAnchorDataHash = - Opt.option readSafeHash $ mconcat - [ Opt.long "anchor-data-hash" - , Opt.metavar "HASH" - , Opt.help "Proposal anchor data hash (obtain it with \"cardano-cli hash anchor-data ...\")" - ] + Opt.option readSafeHash $ + mconcat + [ Opt.long "anchor-data-hash" + , Opt.metavar "HASH" + , Opt.help "Proposal anchor data hash (obtain it with \"cardano-cli hash anchor-data ...\")" + ] pPreviousGovernanceAction :: Parser (Maybe (TxId, Word16)) -pPreviousGovernanceAction = optional $ - (,) <$> pTxId "prev-governance-action-tx-id" "Txid of the previous governance action." +pPreviousGovernanceAction = + optional $ + (,) + <$> pTxId "prev-governance-action-tx-id" "Txid of the previous governance action." <*> pWord16 "prev-governance-action-index" "Action index of the previous governance action." pGovernanceActionId :: Parser (TxId, Word16) pGovernanceActionId = - (,) <$> pTxId "governance-action-tx-id" "Txid of the governance action." - <*> pWord16 "governance-action-index" "Tx's governance action index." + (,) + <$> pTxId "governance-action-tx-id" "Txid of the governance action." + <*> pWord16 "governance-action-index" "Tx's governance action index." pWord16 :: String -> String -> Parser Word16 pWord16 l h = - Opt.option auto $ mconcat - [ Opt.long l - , Opt.metavar "WORD16" - , Opt.help h - ] + Opt.option auto $ + mconcat + [ Opt.long l + , Opt.metavar "WORD16" + , Opt.help h + ] pTxId :: String -> String -> Parser TxId pTxId l h = - Opt.option (readerFromParsecParser parseTxId) $ mconcat - [ Opt.long l - , Opt.metavar "TXID" - , Opt.help h - ] + Opt.option (readerFromParsecParser parseTxId) $ + mconcat + [ Opt.long l + , Opt.metavar "TXID" + , Opt.help h + ] pNetworkIdForTestnetData :: EnvCli -> Parser NetworkId -pNetworkIdForTestnetData envCli = asum $ mconcat - [ [ fmap (Testnet . NetworkMagic) $ Opt.option (bounded "TESTNET_MAGIC") $ mconcat - [ Opt.long "testnet-magic" - , Opt.metavar "NATURAL" - , Opt.help $ mconcat - [ "Specify a testnet magic id for the cluster. " - , "This overrides both the network magic from the " - , "spec file and CARDANO_NODE_NETWORK_ID environment variable." +pNetworkIdForTestnetData envCli = + asum $ + mconcat + [ + [ fmap (Testnet . NetworkMagic) $ + Opt.option (bounded "TESTNET_MAGIC") $ + mconcat + [ Opt.long "testnet-magic" + , Opt.metavar "NATURAL" + , Opt.help $ + mconcat + [ "Specify a testnet magic id for the cluster. " + , "This overrides both the network magic from the " + , "spec file and CARDANO_NODE_NETWORK_ID environment variable." + ] + ] ] + , -- Default to the network id specified by the environment variable if it is available. + pure <$> maybeToList (envCliNetworkId envCli) ] - ] - , -- Default to the network id specified by the environment variable if it is available. - pure <$> maybeToList (envCliNetworkId envCli) - ] pReferenceScriptSize :: Parser ReferenceScriptSize pReferenceScriptSize = - fmap ReferenceScriptSize $ Opt.option Opt.auto $ mconcat - [ Opt.long "reference-script-size" - , Opt.metavar "NATURAL" - , Opt.help "Total size in bytes of transaction reference scripts (default is 0)." - , Opt.value 0 - ] + fmap ReferenceScriptSize $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "reference-script-size" + , Opt.metavar "NATURAL" + , Opt.help "Total size in bytes of transaction reference scripts (default is 0)." + , Opt.value 0 + ] -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- -pFeatured :: () +pFeatured + :: () => Eon eon => ToCardanoEra peon => peon era diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs index a6e45fa67b..e0fcb7ee0b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs @@ -6,7 +6,8 @@ module Cardano.CLI.EraBased.Options.Genesis ( pGenesisCmds - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) import Cardano.Api.Ledger (Coin (..)) @@ -26,99 +27,104 @@ import qualified Options.Applicative as Opt {- HLINT ignore "Use <$>" -} {- HLINT ignore "Move brackets to avoid $" -} -pGenesisCmds :: () +pGenesisCmds + :: () => EnvCli -> Maybe (Parser (GenesisCmds era)) pGenesisCmds envCli = - subInfoParser "genesis" - ( Opt.progDesc - $ mconcat + subInfoParser + "genesis" + ( Opt.progDesc $ + mconcat [ "Genesis block commands." ] ) - [ Just - $ subParser "key-gen-genesis" - $ Opt.info pGenesisKeyGen - $ Opt.progDesc "Create a Shelley genesis key pair" - , Just - $ subParser "key-gen-delegate" - $ Opt.info pGenesisDelegateKeyGen - $ Opt.progDesc "Create a Shelley genesis delegate key pair" - , Just - $ subParser "key-gen-utxo" - $ Opt.info pGenesisUTxOKeyGen - $ Opt.progDesc "Create a Shelley genesis UTxO key pair" - , Just - $ subParser "key-hash" - $ Opt.info pGenesisKeyHash - $ Opt.progDesc "Print the identifier (hash) of a public key" - , Just - $ subParser "get-ver-key" - $ Opt.info pGenesisVerKey - $ Opt.progDesc "Derive the verification key from a signing key" - , Just - $ subParser "initial-addr" - $ Opt.info (pGenesisAddr envCli) - $ Opt.progDesc "Get the address for an initial UTxO based on the verification key" - , Just - $ subParser "initial-txin" - $ Opt.info (pGenesisTxIn envCli) - $ Opt.progDesc "Get the TxIn for an initial UTxO based on the verification key" - , Just - $ subParser "create-cardano" - $ Opt.info (pGenesisCreateCardano envCli) - $ Opt.progDesc - $ mconcat - [ "Create a Byron and Shelley genesis file from a genesis " - , "template and genesis/delegation/spending keys." - ] - , Just - $ subParser "create" - $ Opt.info (pGenesisCreate envCli) - $ Opt.progDesc - $ mconcat - [ "Create a Shelley genesis file from a genesis " - , "template and genesis/delegation/spending keys." - ] - , Just - $ subParser "create-staked" - $ Opt.info (pGenesisCreateStaked envCli) - $ Opt.progDesc - $ mconcat - [ "Create a staked Shelley genesis file from a genesis " - , "template and genesis/delegation/spending keys." - ] - , Just - $ subParser "create-testnet-data" - $ Opt.info (pGenesisCreateTestNetData envCli) - $ Opt.progDesc - $ mconcat - [ "Create data to use for starting a testnet." - ] - , Just - $ subParser "hash" - $ Opt.info pGenesisHash - $ Opt.progDesc "Compute the hash of a genesis file" + [ Just $ + subParser "key-gen-genesis" $ + Opt.info pGenesisKeyGen $ + Opt.progDesc "Create a Shelley genesis key pair" + , Just $ + subParser "key-gen-delegate" $ + Opt.info pGenesisDelegateKeyGen $ + Opt.progDesc "Create a Shelley genesis delegate key pair" + , Just $ + subParser "key-gen-utxo" $ + Opt.info pGenesisUTxOKeyGen $ + Opt.progDesc "Create a Shelley genesis UTxO key pair" + , Just $ + subParser "key-hash" $ + Opt.info pGenesisKeyHash $ + Opt.progDesc "Print the identifier (hash) of a public key" + , Just $ + subParser "get-ver-key" $ + Opt.info pGenesisVerKey $ + Opt.progDesc "Derive the verification key from a signing key" + , Just $ + subParser "initial-addr" $ + Opt.info (pGenesisAddr envCli) $ + Opt.progDesc "Get the address for an initial UTxO based on the verification key" + , Just $ + subParser "initial-txin" $ + Opt.info (pGenesisTxIn envCli) $ + Opt.progDesc "Get the TxIn for an initial UTxO based on the verification key" + , Just $ + subParser "create-cardano" $ + Opt.info (pGenesisCreateCardano envCli) $ + Opt.progDesc $ + mconcat + [ "Create a Byron and Shelley genesis file from a genesis " + , "template and genesis/delegation/spending keys." + ] + , Just $ + subParser "create" $ + Opt.info (pGenesisCreate envCli) $ + Opt.progDesc $ + mconcat + [ "Create a Shelley genesis file from a genesis " + , "template and genesis/delegation/spending keys." + ] + , Just $ + subParser "create-staked" $ + Opt.info (pGenesisCreateStaked envCli) $ + Opt.progDesc $ + mconcat + [ "Create a staked Shelley genesis file from a genesis " + , "template and genesis/delegation/spending keys." + ] + , Just $ + subParser "create-testnet-data" $ + Opt.info (pGenesisCreateTestNetData envCli) $ + Opt.progDesc $ + mconcat + [ "Create data to use for starting a testnet." + ] + , Just $ + subParser "hash" $ + Opt.info pGenesisHash $ + Opt.progDesc "Compute the hash of a genesis file" ] pGenesisKeyGen :: Parser (GenesisCmds era) pGenesisKeyGen = - fmap GenesisKeyGenGenesis $ GenesisKeyGenGenesisCmdArgs - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut + fmap GenesisKeyGenGenesis $ + GenesisKeyGenGenesisCmdArgs + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut pGenesisDelegateKeyGen :: Parser (GenesisCmds era) pGenesisDelegateKeyGen = - fmap GenesisKeyGenDelegate $ GenesisKeyGenDelegateCmdArgs - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut - <*> pOperatorCertIssueCounterFile + fmap GenesisKeyGenDelegate $ + GenesisKeyGenDelegateCmdArgs + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut + <*> pOperatorCertIssueCounterFile pGenesisUTxOKeyGen :: Parser (GenesisCmds era) pGenesisUTxOKeyGen = - fmap GenesisKeyGenUTxO $ GenesisKeyGenUTxOCmdArgs - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut + fmap GenesisKeyGenUTxO $ + GenesisKeyGenUTxOCmdArgs + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut pGenesisKeyHash :: Parser (GenesisCmds era) pGenesisKeyHash = @@ -127,82 +133,89 @@ pGenesisKeyHash = pGenesisVerKey :: Parser (GenesisCmds era) pGenesisVerKey = - fmap GenesisVerKey $ GenesisVerKeyCmdArgs - <$> pVerificationKeyFileOut - <*> pSigningKeyFileIn + fmap GenesisVerKey $ + GenesisVerKeyCmdArgs + <$> pVerificationKeyFileOut + <*> pSigningKeyFileIn pGenesisAddr :: EnvCli -> Parser (GenesisCmds era) pGenesisAddr envCli = - fmap GenesisAddr $ GenesisAddrCmdArgs - <$> pVerificationKeyFileIn - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap GenesisAddr $ + GenesisAddrCmdArgs + <$> pVerificationKeyFileIn + <*> pNetworkId envCli + <*> pMaybeOutputFile pGenesisTxIn :: EnvCli -> Parser (GenesisCmds era) pGenesisTxIn envCli = - fmap GenesisTxIn $ GenesisTxInCmdArgs - <$> pVerificationKeyFileIn - <*> pNetworkId envCli - <*> pMaybeOutputFile + fmap GenesisTxIn $ + GenesisTxInCmdArgs + <$> pVerificationKeyFileIn + <*> pNetworkId envCli + <*> pMaybeOutputFile pGenesisCreateCardano :: EnvCli -> Parser (GenesisCmds era) pGenesisCreateCardano envCli = - fmap GenesisCreateCardano $ GenesisCreateCardanoCmdArgs - <$> pGenesisDir - <*> pGenesisNumGenesisKeys - <*> pGenesisNumUTxOKeys - <*> pMaybeSystemStart - <*> pInitialSupplyNonDelegated - <*> (BlockCount <$> pSecurityParam) - <*> pSlotLength - <*> pSlotCoefficient - <*> pNetworkId envCli - <*> parseFilePath - "byron-template" - "JSON file with genesis defaults for each byron." - <*> parseFilePath - "shelley-template" - "JSON file with genesis defaults for each shelley." - <*> parseFilePath - "alonzo-template" - "JSON file with genesis defaults for alonzo." - <*> parseFilePath - "conway-template" - "JSON file with genesis defaults for conway." - <*> pNodeConfigTemplate + fmap GenesisCreateCardano $ + GenesisCreateCardanoCmdArgs + <$> pGenesisDir + <*> pGenesisNumGenesisKeys + <*> pGenesisNumUTxOKeys + <*> pMaybeSystemStart + <*> pInitialSupplyNonDelegated + <*> (BlockCount <$> pSecurityParam) + <*> pSlotLength + <*> pSlotCoefficient + <*> pNetworkId envCli + <*> parseFilePath + "byron-template" + "JSON file with genesis defaults for each byron." + <*> parseFilePath + "shelley-template" + "JSON file with genesis defaults for each shelley." + <*> parseFilePath + "alonzo-template" + "JSON file with genesis defaults for alonzo." + <*> parseFilePath + "conway-template" + "JSON file with genesis defaults for conway." + <*> pNodeConfigTemplate pGenesisCreate :: EnvCli -> Parser (GenesisCmds era) pGenesisCreate envCli = - fmap GenesisCreate $ GenesisCreateCmdArgs - <$> pKeyOutputFormat - <*> pGenesisDir - <*> pGenesisNumGenesisKeys - <*> pGenesisNumUTxOKeys - <*> pMaybeSystemStart - <*> pInitialSupplyNonDelegated - <*> pNetworkId envCli + fmap GenesisCreate $ + GenesisCreateCmdArgs + <$> pKeyOutputFormat + <*> pGenesisDir + <*> pGenesisNumGenesisKeys + <*> pGenesisNumUTxOKeys + <*> pMaybeSystemStart + <*> pInitialSupplyNonDelegated + <*> pNetworkId envCli pGenesisCreateStaked :: EnvCli -> Parser (GenesisCmds era) pGenesisCreateStaked envCli = - fmap GenesisCreateStaked $ GenesisCreateStakedCmdArgs - <$> pKeyOutputFormat - <*> pGenesisDir - <*> pGenesisNumGenesisKeys - <*> pGenesisNumUTxOKeys - <*> pGenesisNumPools - <*> pGenesisNumStDelegs - <*> pMaybeSystemStart - <*> pInitialSupplyNonDelegated - <*> pInitialSupplyDelegated - <*> pNetworkId envCli - <*> pBulkPoolCredFiles - <*> pBulkPoolsPerFile - <*> pStuffedUtxoCount - <*> Opt.optional pRelayJsonFp - where - pRelayJsonFp :: Parser FilePath - pRelayJsonFp = - Opt.strOption $ mconcat + fmap GenesisCreateStaked $ + GenesisCreateStakedCmdArgs + <$> pKeyOutputFormat + <*> pGenesisDir + <*> pGenesisNumGenesisKeys + <*> pGenesisNumUTxOKeys + <*> pGenesisNumPools + <*> pGenesisNumStDelegs + <*> pMaybeSystemStart + <*> pInitialSupplyNonDelegated + <*> pInitialSupplyDelegated + <*> pNetworkId envCli + <*> pBulkPoolCredFiles + <*> pBulkPoolsPerFile + <*> pStuffedUtxoCount + <*> Opt.optional pRelayJsonFp + where + pRelayJsonFp :: Parser FilePath + pRelayJsonFp = + Opt.strOption $ + mconcat [ Opt.long "relay-specification-file" , Opt.metavar "FILE" , Opt.help "JSON file that specifies the relays of each stake pool." @@ -211,117 +224,146 @@ pGenesisCreateStaked envCli = pGenesisCreateTestNetData :: EnvCli -> Parser (GenesisCmds era) pGenesisCreateTestNetData envCli = - fmap GenesisCreateTestNetData $ GenesisCreateTestNetDataCmdArgs - <$> (optional $ pSpecFile "shelley") - <*> (optional $ pSpecFile "alonzo") - <*> (optional $ pSpecFile "conway") - <*> pNumGenesisKeys - <*> pNumPools - <*> pNumStakeDelegs - <*> pNumDReps - <*> pNumStuffedUtxoCount - <*> pNumUtxoKeys - <*> pSupply - <*> pSupplyDelegated - <*> (optional $ pNetworkIdForTestnetData envCli) - <*> Opt.optional pRelays - <*> pMaybeSystemStart - <*> pOutputDir - where - pSpecFile era = Opt.strOption $ mconcat - [ Opt.long $ "spec-" <> era - , Opt.metavar "FILE" - , Opt.help $ "The " <> era <> " specification file to use as input. A default one is generated if omitted." - ] - pNumGenesisKeys = Opt.option Opt.auto $ mconcat - [ Opt.long "genesis-keys" - , Opt.metavar "INT" - , Opt.help "The number of genesis keys to make (default is 3)." - , Opt.value 3 - ] - pNumPools :: Parser Word - pNumPools = - Opt.option Opt.auto $ mconcat + fmap GenesisCreateTestNetData $ + GenesisCreateTestNetDataCmdArgs + <$> (optional $ pSpecFile "shelley") + <*> (optional $ pSpecFile "alonzo") + <*> (optional $ pSpecFile "conway") + <*> pNumGenesisKeys + <*> pNumPools + <*> pNumStakeDelegs + <*> pNumDReps + <*> pNumStuffedUtxoCount + <*> pNumUtxoKeys + <*> pSupply + <*> pSupplyDelegated + <*> (optional $ pNetworkIdForTestnetData envCli) + <*> Opt.optional pRelays + <*> pMaybeSystemStart + <*> pOutputDir + where + pSpecFile era = + Opt.strOption $ + mconcat + [ Opt.long $ "spec-" <> era + , Opt.metavar "FILE" + , Opt.help $ + "The " <> era <> " specification file to use as input. A default one is generated if omitted." + ] + pNumGenesisKeys = + Opt.option Opt.auto $ + mconcat + [ Opt.long "genesis-keys" + , Opt.metavar "INT" + , Opt.help "The number of genesis keys to make (default is 3)." + , Opt.value 3 + ] + pNumPools :: Parser Word + pNumPools = + Opt.option Opt.auto $ + mconcat [ Opt.long "pools" , Opt.metavar "INT" , Opt.help "The number of stake pool credential sets to make (default is 0)." , Opt.value 0 ] - pNumDReps :: Parser DRepCredentials - pNumDReps = - pDReps OnDisk "drep-keys" "Credentials are written to disk." + pNumDReps :: Parser DRepCredentials + pNumDReps = + pDReps OnDisk "drep-keys" "Credentials are written to disk." <|> pDReps Transient "transient-drep-keys" "The credentials are NOT written to disk." - where - pDReps :: CredentialGenerationMode -> String -> String -> Parser DRepCredentials - pDReps mode modeOptionName modeExplanation = - DRepCredentials mode <$> - (Opt.option Opt.auto $ mconcat - [ Opt.long modeOptionName - , Opt.help $ "The number of DRep credentials to make (default is 0). " <> modeExplanation - , Opt.metavar "INT", Opt.value 0 - ]) - pNumStakeDelegs :: Parser StakeDelegators - pNumStakeDelegs = - pStakeDelegators OnDisk "stake-delegators" "Credentials are written to disk." + where + pDReps :: CredentialGenerationMode -> String -> String -> Parser DRepCredentials + pDReps mode modeOptionName modeExplanation = + DRepCredentials mode + <$> ( Opt.option Opt.auto $ + mconcat + [ Opt.long modeOptionName + , Opt.help $ "The number of DRep credentials to make (default is 0). " <> modeExplanation + , Opt.metavar "INT" + , Opt.value 0 + ] + ) + pNumStakeDelegs :: Parser StakeDelegators + pNumStakeDelegs = + pStakeDelegators OnDisk "stake-delegators" "Credentials are written to disk." <|> pStakeDelegators Transient "transient-stake-delegators" "The credentials are NOT written to disk." - where - pStakeDelegators :: CredentialGenerationMode -> String -> String -> Parser StakeDelegators - pStakeDelegators mode modeOptionName modeExplanation = - StakeDelegators mode <$> - (Opt.option Opt.auto $ mconcat - [ Opt.long modeOptionName - , Opt.help $ "The number of stake delegator credential sets to make (default is 0). " <> modeExplanation - , Opt.metavar "INT", Opt.value 0 - ]) - pNumStuffedUtxoCount :: Parser Word - pNumStuffedUtxoCount = - Opt.option Opt.auto $ mconcat + where + pStakeDelegators :: CredentialGenerationMode -> String -> String -> Parser StakeDelegators + pStakeDelegators mode modeOptionName modeExplanation = + StakeDelegators mode + <$> ( Opt.option Opt.auto $ + mconcat + [ Opt.long modeOptionName + , Opt.help $ + "The number of stake delegator credential sets to make (default is 0). " <> modeExplanation + , Opt.metavar "INT" + , Opt.value 0 + ] + ) + pNumStuffedUtxoCount :: Parser Word + pNumStuffedUtxoCount = + Opt.option Opt.auto $ + mconcat [ Opt.long "stuffed-utxo" , Opt.metavar "INT" , Opt.help "The number of fake UTxO entries to generate (default is 0)." , Opt.value 0 ] - pNumUtxoKeys :: Parser Word - pNumUtxoKeys = - Opt.option Opt.auto $ mconcat + pNumUtxoKeys :: Parser Word + pNumUtxoKeys = + Opt.option Opt.auto $ + mconcat [ Opt.long "utxo-keys" , Opt.metavar "INT" , Opt.help "The number of UTxO keys to make (default is 0)." , Opt.value 0 ] - pSupply :: Parser (Maybe Coin) - pSupply = - Opt.optional $ fmap Coin $ Opt.option Opt.auto $ mconcat - [ Opt.long "total-supply" - , Opt.metavar "LOVELACE" - , Opt.help $ mconcat [ "The maximum possible amount of Lovelace, which is evenly distributed across stake holders. Defaults to 1 million Ada (i.e. 10^12 Lovelace)." - , " If --delegated-supply is specified, a part of this amount will be delegated." - ] - , Opt.value 1_000_000_000_000 - ] - pSupplyDelegated :: Parser (Maybe Coin) - pSupplyDelegated = - Opt.optional $ fmap Coin $ Opt.option Opt.auto $ mconcat - [ Opt.long "delegated-supply" - , Opt.metavar "LOVELACE" - , Opt.help $ mconcat [ "The amount of the total supply which is evenly delegated. Defaults to 500 000 Ada (i.e. (10^12) / 2 Lovelace)." - , " Cannot be more than the amount specified with --total-supply." - ] - , Opt.value 500_000_000_000 - ] - pRelays :: Parser FilePath - pRelays = - Opt.strOption $ mconcat + pSupply :: Parser (Maybe Coin) + pSupply = + Opt.optional $ + fmap Coin $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "total-supply" + , Opt.metavar "LOVELACE" + , Opt.help $ + mconcat + [ "The maximum possible amount of Lovelace, which is evenly distributed across stake holders. Defaults to 1 million Ada (i.e. 10^12 Lovelace)." + , " If --delegated-supply is specified, a part of this amount will be delegated." + ] + , Opt.value 1_000_000_000_000 + ] + pSupplyDelegated :: Parser (Maybe Coin) + pSupplyDelegated = + Opt.optional $ + fmap Coin $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "delegated-supply" + , Opt.metavar "LOVELACE" + , Opt.help $ + mconcat + [ "The amount of the total supply which is evenly delegated. Defaults to 500 000 Ada (i.e. (10^12) / 2 Lovelace)." + , " Cannot be more than the amount specified with --total-supply." + ] + , Opt.value 500_000_000_000 + ] + pRelays :: Parser FilePath + pRelays = + Opt.strOption $ + mconcat [ Opt.long "relays" , Opt.metavar "FILE" , Opt.help "JSON file specifying the relays of each stake pool." , Opt.completer (Opt.bashCompleter "file") ] - pOutputDir = Opt.strOption $ mconcat - [ Opt.long "out-dir" - , Opt.metavar "DIR" - , Opt.help "The directory where to generate the data. Created if not existing." - ] + pOutputDir = + Opt.strOption $ + mconcat + [ Opt.long "out-dir" + , Opt.metavar "DIR" + , Opt.help "The directory where to generate the data. Created if not existing." + ] pGenesisHash :: Parser (GenesisCmds era) pGenesisHash = @@ -329,128 +371,151 @@ pGenesisHash = pGenesisDir :: Parser GenesisDir pGenesisDir = - fmap GenesisDir $ Opt.strOption $ mconcat - [ Opt.long "genesis-dir" - , Opt.metavar "DIR" - , Opt.help "The genesis directory containing the genesis template and required genesis/delegation/spending keys." - ] + fmap GenesisDir $ + Opt.strOption $ + mconcat + [ Opt.long "genesis-dir" + , Opt.metavar "DIR" + , Opt.help + "The genesis directory containing the genesis template and required genesis/delegation/spending keys." + ] pMaybeSystemStart :: Parser (Maybe SystemStart) pMaybeSystemStart = - Opt.optional $ fmap (SystemStart . convertTime) $ Opt.strOption $ mconcat - [ Opt.long "start-time" - , Opt.metavar "UTC-TIME" - , Opt.help "The genesis start time in YYYY-MM-DDThh:mm:ssZ format. If unspecified, will be the current time +30 seconds." - ] + Opt.optional $ + fmap (SystemStart . convertTime) $ + Opt.strOption $ + mconcat + [ Opt.long "start-time" + , Opt.metavar "UTC-TIME" + , Opt.help + "The genesis start time in YYYY-MM-DDThh:mm:ssZ format. If unspecified, will be the current time +30 seconds." + ] pGenesisNumGenesisKeys :: Parser Word pGenesisNumGenesisKeys = - Opt.option Opt.auto $ mconcat - [ Opt.long "gen-genesis-keys" - , Opt.metavar "INT" - , Opt.help "The number of genesis keys to make [default is 3]." - , Opt.value 3 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "gen-genesis-keys" + , Opt.metavar "INT" + , Opt.help "The number of genesis keys to make [default is 3]." + , Opt.value 3 + ] pNodeConfigTemplate :: Parser (Maybe FilePath) pNodeConfigTemplate = optional $ parseFilePath "node-config-template" "the node config template" pGenesisNumUTxOKeys :: Parser Word pGenesisNumUTxOKeys = - Opt.option Opt.auto $ mconcat - [ Opt.long "gen-utxo-keys" - , Opt.metavar "INT" - , Opt.help "The number of UTxO keys to make [default is 0]." - , Opt.value 0 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "gen-utxo-keys" + , Opt.metavar "INT" + , Opt.help "The number of UTxO keys to make [default is 0]." + , Opt.value 0 + ] pGenesisNumPools :: Parser Word pGenesisNumPools = - Opt.option Opt.auto $ mconcat - [ Opt.long "gen-pools" - , Opt.metavar "INT" - , Opt.help "The number of stake pool credential sets to make [default is 0]." - , Opt.value 0 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "gen-pools" + , Opt.metavar "INT" + , Opt.help "The number of stake pool credential sets to make [default is 0]." + , Opt.value 0 + ] pGenesisNumStDelegs :: Parser Word pGenesisNumStDelegs = - Opt.option Opt.auto $ mconcat - [ Opt.long "gen-stake-delegs" - , Opt.metavar "INT" - , Opt.help "The number of stake delegator credential sets to make [default is 0]." - , Opt.value 0 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "gen-stake-delegs" + , Opt.metavar "INT" + , Opt.help "The number of stake delegator credential sets to make [default is 0]." + , Opt.value 0 + ] pStuffedUtxoCount :: Parser Word pStuffedUtxoCount = - Opt.option Opt.auto $ mconcat - [ Opt.long "num-stuffed-utxo" - , Opt.metavar "INT" - , Opt.help "The number of fake UTxO entries to generate [default is 0]." - , Opt.value 0 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "num-stuffed-utxo" + , Opt.metavar "INT" + , Opt.help "The number of fake UTxO entries to generate [default is 0]." + , Opt.value 0 + ] pInitialSupplyNonDelegated :: Parser (Maybe Coin) pInitialSupplyNonDelegated = - Opt.optional $ fmap Coin $ Opt.option Opt.auto $ mconcat - [ Opt.long "supply" - , Opt.metavar "LOVELACE" - , Opt.help "The initial coin supply in Lovelace which will be evenly distributed across initial, non-delegating stake holders." - ] + Opt.optional $ + fmap Coin $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "supply" + , Opt.metavar "LOVELACE" + , Opt.help + "The initial coin supply in Lovelace which will be evenly distributed across initial, non-delegating stake holders." + ] pInitialSupplyDelegated :: Parser Coin pInitialSupplyDelegated = - fmap (Coin . fromMaybe 0) $ Opt.optional $ Opt.option Opt.auto $ mconcat - [ Opt.long "supply-delegated" - , Opt.metavar "LOVELACE" - , Opt.help "The initial coin supply in Lovelace which will be evenly distributed across initial, delegating stake holders." - , Opt.value 0 - ] + fmap (Coin . fromMaybe 0) $ + Opt.optional $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "supply-delegated" + , Opt.metavar "LOVELACE" + , Opt.help + "The initial coin supply in Lovelace which will be evenly distributed across initial, delegating stake holders." + , Opt.value 0 + ] pSecurityParam :: Parser Word64 pSecurityParam = - Opt.option Opt.auto $ mconcat - [ Opt.long "security-param" - , Opt.metavar "INT" - , Opt.help "Security parameter for genesis file [default is 108]." - , Opt.value 108 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "security-param" + , Opt.metavar "INT" + , Opt.help "Security parameter for genesis file [default is 108]." + , Opt.value 108 + ] pSlotLength :: Parser Word pSlotLength = - Opt.option Opt.auto $ mconcat - [ Opt.long "slot-length" - , Opt.metavar "INT" - , Opt.help "slot length (ms) parameter for genesis file [default is 1000]." - , Opt.value 1_000 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "slot-length" + , Opt.metavar "INT" + , Opt.help "slot length (ms) parameter for genesis file [default is 1000]." + , Opt.value 1_000 + ] pSlotCoefficient :: Parser Rational pSlotCoefficient = - Opt.option readRationalUnitInterval $ mconcat - [ Opt.long "slot-coefficient" - , Opt.metavar "RATIONAL" - , Opt.help "Slot Coefficient for genesis file [default is .05]." - , Opt.value 0.05 - ] + Opt.option readRationalUnitInterval $ + mconcat + [ Opt.long "slot-coefficient" + , Opt.metavar "RATIONAL" + , Opt.help "Slot Coefficient for genesis file [default is .05]." + , Opt.value 0.05 + ] pBulkPoolCredFiles :: Parser Word pBulkPoolCredFiles = - Opt.option Opt.auto $ mconcat - [ Opt.long "bulk-pool-cred-files" - , Opt.metavar "INT" - , Opt.help "Generate bulk pool credential files [default is 0]." - , Opt.value 0 - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "bulk-pool-cred-files" + , Opt.metavar "INT" + , Opt.help "Generate bulk pool credential files [default is 0]." + , Opt.value 0 + ] pBulkPoolsPerFile :: Parser Word pBulkPoolsPerFile = - Opt.option Opt.auto $ mconcat - [ Opt.long "bulk-pools-per-file" - , Opt.metavar "INT" - , Opt.help "Each bulk pool to contain this many pool credential sets [default is 0]." - , Opt.value 0 - ] - - + Opt.option Opt.auto $ + mconcat + [ Opt.long "bulk-pools-per-file" + , Opt.metavar "INT" + , Opt.help "Each bulk pool to contain this many pool credential sets [default is 0]." + , Opt.value 0 + ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance.hs index d835c30be5..782492cf16 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance.hs @@ -2,10 +2,11 @@ {-# LANGUAGE GADTs #-} module Cardano.CLI.EraBased.Options.Governance - ( GovernanceCmds(..) + ( GovernanceCmds (..) , renderGovernanceCmds , pGovernanceCmds - ) where + ) +where import Cardano.Api @@ -21,50 +22,54 @@ import Data.Foldable import Options.Applicative import qualified Options.Applicative as Opt -pGovernanceCmds :: () +pGovernanceCmds + :: () => CardanoEra era -> Maybe (Parser (GovernanceCmds era)) pGovernanceCmds era = - subInfoParser "governance" - ( Opt.progDesc - $ mconcat + subInfoParser + "governance" + ( Opt.progDesc $ + mconcat [ "Governance commands." ] ) [ pCreateMirCertificatesCmds era , pGovernanceGenesisKeyDelegationCertificate era - , fmap GovernanceActionCmds <$> pGovernanceActionCmds era - , fmap GovernanceCommitteeCmds <$> pGovernanceCommitteeCmds era - , fmap GovernanceDRepCmds <$> pGovernanceDRepCmds era - , fmap GovernancePollCmds <$> pGovernancePollCmds era - , fmap GovernanceVoteCmds <$> pGovernanceVoteCmds era + , fmap GovernanceActionCmds <$> pGovernanceActionCmds era + , fmap GovernanceCommitteeCmds <$> pGovernanceCommitteeCmds era + , fmap GovernanceDRepCmds <$> pGovernanceDRepCmds era + , fmap GovernancePollCmds <$> pGovernancePollCmds era + , fmap GovernanceVoteCmds <$> pGovernanceVoteCmds era ] pCreateMirCertificatesCmds :: CardanoEra era -> Maybe (Parser (GovernanceCmds era)) pCreateMirCertificatesCmds era = do w <- forEraMaybeEon era - pure - $ subParser "create-mir-certificate" - $ Opt.info (pMIRPayStakeAddresses w <|> mirCertParsers w) - $ Opt.progDesc "Create an MIR (Move Instantaneous Rewards) certificate" + pure $ + subParser "create-mir-certificate" $ + Opt.info (pMIRPayStakeAddresses w <|> mirCertParsers w) $ + Opt.progDesc "Create an MIR (Move Instantaneous Rewards) certificate" -mirCertParsers :: () +mirCertParsers + :: () => ShelleyToBabbageEra era -> Parser (GovernanceCmds era) mirCertParsers w = asum - [ subParser "stake-addresses" - $ Opt.info (pMIRPayStakeAddresses w) - $ Opt.progDesc "Create an MIR certificate to pay stake addresses" - , subParser "transfer-to-treasury" - $ Opt.info (pGovernanceCreateMirCertificateTransferToTreasuryCmd w) - $ Opt.progDesc "Create an MIR certificate to transfer from the reserves pot to the treasury pot" - , subParser "transfer-to-rewards" - $ Opt.info (pGovernanceCreateMirCertificateTransferToReservesCmd w) - $ Opt.progDesc "Create an MIR certificate to transfer from the treasury pot to the reserves pot" + [ subParser "stake-addresses" $ + Opt.info (pMIRPayStakeAddresses w) $ + Opt.progDesc "Create an MIR certificate to pay stake addresses" + , subParser "transfer-to-treasury" $ + Opt.info (pGovernanceCreateMirCertificateTransferToTreasuryCmd w) $ + Opt.progDesc "Create an MIR certificate to transfer from the reserves pot to the treasury pot" + , subParser "transfer-to-rewards" $ + Opt.info (pGovernanceCreateMirCertificateTransferToReservesCmd w) $ + Opt.progDesc "Create an MIR certificate to transfer from the treasury pot to the reserves pot" ] -pMIRPayStakeAddresses :: () +pMIRPayStakeAddresses + :: () => ShelleyToBabbageEra era -> Parser (GovernanceCmds era) pMIRPayStakeAddresses w = @@ -74,7 +79,8 @@ pMIRPayStakeAddresses w = <*> some pRewardAmt <*> pOutputFile -pGovernanceCreateMirCertificateTransferToTreasuryCmd :: () +pGovernanceCreateMirCertificateTransferToTreasuryCmd + :: () => ShelleyToBabbageEra era -> Parser (GovernanceCmds era) pGovernanceCreateMirCertificateTransferToTreasuryCmd w = @@ -82,7 +88,8 @@ pGovernanceCreateMirCertificateTransferToTreasuryCmd w = <$> pTransferAmt <*> pOutputFile -pGovernanceCreateMirCertificateTransferToReservesCmd :: () +pGovernanceCreateMirCertificateTransferToReservesCmd + :: () => ShelleyToBabbageEra era -> Parser (GovernanceCmds era) pGovernanceCreateMirCertificateTransferToReservesCmd w = @@ -90,18 +97,20 @@ pGovernanceCreateMirCertificateTransferToReservesCmd w = <$> pTransferAmt <*> pOutputFile -pGovernanceGenesisKeyDelegationCertificate :: () +pGovernanceGenesisKeyDelegationCertificate + :: () => CardanoEra era -> Maybe (Parser (GovernanceCmds era)) pGovernanceGenesisKeyDelegationCertificate era = do w <- forEraMaybeEon era - pure - $ subParser "create-genesis-key-delegation-certificate" - $ Opt.info (parser w) - $ Opt.progDesc "Create a genesis key delegation certificate" - where - parser w = GovernanceGenesisKeyDelegationCertificate w - <$> pGenesisVerificationKeyOrHashOrFile - <*> pGenesisDelegateVerificationKeyOrHashOrFile - <*> pVrfVerificationKeyOrHashOrFile - <*> pOutputFile + pure $ + subParser "create-genesis-key-delegation-certificate" $ + Opt.info (parser w) $ + Opt.progDesc "Create a genesis key delegation certificate" + where + parser w = + GovernanceGenesisKeyDelegationCertificate w + <$> pGenesisVerificationKeyOrHashOrFile + <*> pGenesisDelegateVerificationKeyOrHashOrFile + <*> pVrfVerificationKeyOrHashOrFile + <*> pOutputFile diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs index 198864e895..7ee4982d5e 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs @@ -4,7 +4,8 @@ module Cardano.CLI.EraBased.Options.Governance.Actions ( pGovernanceActionCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -20,13 +21,15 @@ import GHC.Natural (Natural) import Options.Applicative import qualified Options.Applicative as Opt -pGovernanceActionCmds :: () +pGovernanceActionCmds + :: () => CardanoEra era -> Maybe (Parser (Cmd.GovernanceActionCmds era)) pGovernanceActionCmds era = - subInfoParser "action" - ( Opt.progDesc - $ mconcat + subInfoParser + "action" + ( Opt.progDesc $ + mconcat [ "Governance action commands." ] ) @@ -48,12 +51,12 @@ pGovernanceActionViewCmd era = do return $ subParser "view" $ Opt.info - ( fmap Cmd.GovernanceActionViewCmd - $ Cmd.GovernanceActionViewCmdArgs eon - <$> pFileInDirection "action-file" "Path to action file." - <*> pGovernanceActionViewOutputFormat - <*> pMaybeOutputFile - ) + ( fmap Cmd.GovernanceActionViewCmd $ + Cmd.GovernanceActionViewCmdArgs eon + <$> pFileInDirection "action-file" "Path to action file." + <*> pGovernanceActionViewOutputFormat + <*> pMaybeOutputFile + ) $ Opt.progDesc "View a governance action." pGovernanceActionNewInfoCmd @@ -64,18 +67,17 @@ pGovernanceActionNewInfoCmd era = do pure $ subParser "create-info" $ Opt.info - ( fmap Cmd.GovernanceActionInfoCmd $ - Cmd.GovernanceActionInfoCmdArgs eon - <$> pNetwork - <*> pGovActionDeposit - <*> pStakeIdentifier (Just "deposit-return") - <*> pAnchorUrl - <*> pAnchorDataHash - <*> pFileOutDirection "out-file" "Path to action file to be used later on with build or build-raw " - ) + ( fmap Cmd.GovernanceActionInfoCmd $ + Cmd.GovernanceActionInfoCmdArgs eon + <$> pNetwork + <*> pGovActionDeposit + <*> pStakeIdentifier (Just "deposit-return") + <*> pAnchorUrl + <*> pAnchorDataHash + <*> pFileOutDirection "out-file" "Path to action file to be used later on with build or build-raw " + ) $ Opt.progDesc "Create an info action." - pGovernanceActionNewConstitutionCmd :: CardanoEra era -> Maybe (Parser (Cmd.GovernanceActionCmds era)) @@ -84,19 +86,19 @@ pGovernanceActionNewConstitutionCmd era = do pure $ subParser "create-constitution" $ Opt.info - ( fmap Cmd.GovernanceActionCreateConstitutionCmd $ - Cmd.GovernanceActionCreateConstitutionCmdArgs eon - <$> pNetwork - <*> pGovActionDeposit - <*> pStakeIdentifier (Just "deposit-return") - <*> pPreviousGovernanceAction - <*> pAnchorUrl - <*> pAnchorDataHash - <*> pConstitutionUrl - <*> pConstitutionHash - <*> optional pConstitutionScriptHash - <*> pFileOutDirection "out-file" "Output filepath of the constitution." - ) + ( fmap Cmd.GovernanceActionCreateConstitutionCmd $ + Cmd.GovernanceActionCreateConstitutionCmdArgs eon + <$> pNetwork + <*> pGovActionDeposit + <*> pStakeIdentifier (Just "deposit-return") + <*> pPreviousGovernanceAction + <*> pAnchorUrl + <*> pAnchorDataHash + <*> pConstitutionUrl + <*> pConstitutionHash + <*> optional pConstitutionScriptHash + <*> pFileOutDirection "out-file" "Output filepath of the constitution." + ) $ Opt.progDesc "Create a constitution." pGovernanceActionUpdateCommitteeCmd @@ -107,12 +109,13 @@ pGovernanceActionUpdateCommitteeCmd era = do pure $ subParser "update-committee" $ Opt.info - ( Cmd.GovernanceActionUpdateCommitteeCmd - <$> pUpdateCommitteeCmd eon - ) + ( Cmd.GovernanceActionUpdateCommitteeCmd + <$> pUpdateCommitteeCmd eon + ) $ Opt.progDesc "Create or update a new committee proposal." -pUpdateCommitteeCmd :: () +pUpdateCommitteeCmd + :: () => ConwayEraOnwards era -> Parser (Cmd.GovernanceActionUpdateCommitteeCmdArgs era) pUpdateCommitteeCmd eon = @@ -124,14 +127,14 @@ pUpdateCommitteeCmd eon = <*> pAnchorDataHash <*> many pRemoveCommitteeColdVerificationKeySource <*> many - ( (,) - <$> pAddCommitteeColdVerificationKeySource - <*> pEpochNo "Committee member expiry epoch") + ( (,) + <$> pAddCommitteeColdVerificationKeySource + <*> pEpochNo "Committee member expiry epoch" + ) <*> pRational "threshold" "Threshold of YES votes that are necessary for approving a governance action." <*> pPreviousGovernanceAction <*> pOutputFile - pGovernanceActionNoConfidenceCmd :: CardanoEra era -> Maybe (Parser (Cmd.GovernanceActionCmds era)) @@ -140,25 +143,27 @@ pGovernanceActionNoConfidenceCmd era = do pure $ subParser "create-no-confidence" $ Opt.info - ( fmap Cmd.GovernanceActionCreateNoConfidenceCmd $ - Cmd.GovernanceActionCreateNoConfidenceCmdArgs eon - <$> pNetwork - <*> pGovActionDeposit - <*> pStakeIdentifier (Just "deposit-return") - <*> pAnchorUrl - <*> pAnchorDataHash - <*> pPreviousGovernanceAction - <*> pFileOutDirection "out-file" "Output filepath of the no confidence proposal." - ) + ( fmap Cmd.GovernanceActionCreateNoConfidenceCmd $ + Cmd.GovernanceActionCreateNoConfidenceCmdArgs eon + <$> pNetwork + <*> pGovActionDeposit + <*> pStakeIdentifier (Just "deposit-return") + <*> pAnchorUrl + <*> pAnchorDataHash + <*> pPreviousGovernanceAction + <*> pFileOutDirection "out-file" "Output filepath of the no confidence proposal." + ) $ Opt.progDesc "Create a no confidence proposal." -pUpdateProtocolParametersPreConway :: ShelleyToBabbageEra era -> Parser (Cmd.UpdateProtocolParametersPreConway era) +pUpdateProtocolParametersPreConway + :: ShelleyToBabbageEra era -> Parser (Cmd.UpdateProtocolParametersPreConway era) pUpdateProtocolParametersPreConway shelleyToBab = Cmd.UpdateProtocolParametersPreConway shelleyToBab <$> pEpochNoUpdateProp <*> pProtocolParametersUpdateGenesisKeys -pUpdateProtocolParametersPostConway :: ConwayEraOnwards era -> Parser (Cmd.UpdateProtocolParametersConwayOnwards era) +pUpdateProtocolParametersPostConway + :: ConwayEraOnwards era -> Parser (Cmd.UpdateProtocolParametersConwayOnwards era) pUpdateProtocolParametersPostConway conwayOnwards = Cmd.UpdateProtocolParametersConwayOnwards conwayOnwards <$> pNetwork @@ -169,35 +174,37 @@ pUpdateProtocolParametersPostConway conwayOnwards = <*> pPreviousGovernanceAction <*> optional pConstitutionScriptHash - -pUpdateProtocolParametersCmd :: ShelleyBasedEra era -> Parser (Cmd.GovernanceActionProtocolParametersUpdateCmdArgs era) +pUpdateProtocolParametersCmd + :: ShelleyBasedEra era -> Parser (Cmd.GovernanceActionProtocolParametersUpdateCmdArgs era) pUpdateProtocolParametersCmd = caseShelleyToBabbageOrConwayEraOnwards - (\shelleyToBab -> + ( \shelleyToBab -> let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBab - in subParser "create-protocol-parameters-update" - $ Opt.info - ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs (shelleyToBabbageEraToShelleyBasedEra shelleyToBab) - <$> fmap Just (pUpdateProtocolParametersPreConway shelleyToBab) - <*> pure Nothing - <*> dpGovActionProtocolParametersUpdate sbe - <*> pCostModelsFile sbe - <*> pOutputFile - ) - $ Opt.progDesc "Create a protocol parameters update.") - (\conwayOnwards -> + in subParser "create-protocol-parameters-update" + $ Opt.info + ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs + (shelleyToBabbageEraToShelleyBasedEra shelleyToBab) + <$> fmap Just (pUpdateProtocolParametersPreConway shelleyToBab) + <*> pure Nothing + <*> dpGovActionProtocolParametersUpdate sbe + <*> pCostModelsFile sbe + <*> pOutputFile + ) + $ Opt.progDesc "Create a protocol parameters update." + ) + ( \conwayOnwards -> let sbe = conwayEraOnwardsToShelleyBasedEra conwayOnwards - in subParser "create-protocol-parameters-update" - $ Opt.info - ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs - (conwayEraOnwardsToShelleyBasedEra conwayOnwards) Nothing - <$> fmap Just (pUpdateProtocolParametersPostConway conwayOnwards) - <*> dpGovActionProtocolParametersUpdate sbe - <*> pCostModelsFile sbe - <*> pOutputFile - ) - $ Opt.progDesc "Create a protocol parameters update." - + in subParser "create-protocol-parameters-update" + $ Opt.info + ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs + (conwayEraOnwardsToShelleyBasedEra conwayOnwards) + Nothing + <$> fmap Just (pUpdateProtocolParametersPostConway conwayOnwards) + <*> dpGovActionProtocolParametersUpdate sbe + <*> pCostModelsFile sbe + <*> pOutputFile + ) + $ Opt.progDesc "Create a protocol parameters update." ) -- | Cost models only makes sense in eras from Alonzo onwards. For earlier @@ -207,36 +214,41 @@ pCostModelsFile = caseShelleyToMaryOrAlonzoEraOnwards (const $ pure Nothing) ( \alonzoOnwards -> - fmap (Cmd.CostModelsFile alonzoOnwards . File) - <$> optional pCostModels + fmap (Cmd.CostModelsFile alonzoOnwards . File) + <$> optional pCostModels ) -pGovernanceActionProtocolParametersUpdateCmd :: () +pGovernanceActionProtocolParametersUpdateCmd + :: () => CardanoEra era -> Maybe (Parser (Cmd.GovernanceActionCmds era)) pGovernanceActionProtocolParametersUpdateCmd era = do w <- forEraMaybeEon era - pure $ Cmd.GovernanceActionProtocolParametersUpdateCmd - <$> pUpdateProtocolParametersCmd w + pure $ + Cmd.GovernanceActionProtocolParametersUpdateCmd + <$> pUpdateProtocolParametersCmd w pMinFeeRefScriptCostPerByte :: Parser L.NonNegativeInterval pMinFeeRefScriptCostPerByte = - Opt.option (toNonNegativeIntervalOrErr <$> readRational) $ mconcat - [ Opt.long "ref-script-cost-per-byte" - , Opt.metavar "RATIONAL" - , Opt.help "Reference script cost per byte for the minimum fee calculation." - ] + Opt.option (toNonNegativeIntervalOrErr <$> readRational) $ + mconcat + [ Opt.long "ref-script-cost-per-byte" + , Opt.metavar "RATIONAL" + , Opt.help "Reference script cost per byte for the minimum fee calculation." + ] convertToLedger :: (a -> b) -> Parser (Maybe a) -> Parser (L.StrictMaybe b) convertToLedger conv = fmap (L.maybeToStrictMaybe . fmap conv) toNonNegativeIntervalOrErr :: Rational -> L.NonNegativeInterval toNonNegativeIntervalOrErr r = case L.boundRational r of - Nothing -> - error $ mconcat [ "toNonNegativeIntervalOrErr: " - , "rational out of bounds " <> show r - ] - Just n -> n + Nothing -> + error $ + mconcat + [ "toNonNegativeIntervalOrErr: " + , "rational out of bounds " <> show r + ] + Just n -> n mkProtocolVersionOrErr :: (Natural, Natural) -> L.ProtVer mkProtocolVersionOrErr (majorProtVer, minorProtVer) = @@ -262,7 +274,6 @@ pCommonProtocolParameters = <*> convertToLedger toUnitIntervalOrErr (optional pMonetaryExpansion) <*> convertToLedger id (optional pMinPoolCost) - pDeprecatedAfterMaryPParams :: Parser (DeprecatedAfterMaryPParams ledgerera) pDeprecatedAfterMaryPParams = DeprecatedAfterMaryPParams @@ -282,15 +293,15 @@ pShelleyToAlonzoPParams = pAlonzoOnwardsPParams :: Parser (AlonzoOnwardsPParams ledgerera) pAlonzoOnwardsPParams = AlonzoOnwardsPParams L.SNothing -- The cost models are read separately from a file, so we use 'SNothing' as the place holder here - <$> convertToLedger (either (\e -> error $ "pAlonzoOnwardsPParams: " <> show e) id . toAlonzoPrices) - (optional pExecutionUnitPrices) + <$> convertToLedger + (either (\e -> error $ "pAlonzoOnwardsPParams: " <> show e) id . toAlonzoPrices) + (optional pExecutionUnitPrices) <*> convertToLedger toAlonzoExUnits (optional pMaxTxExecutionUnits) <*> convertToLedger toAlonzoExUnits (optional pMaxBlockExecutionUnits) <*> convertToLedger id (optional pMaxValueSize) <*> convertToLedger id (optional pCollateralPercent) <*> convertToLedger id (optional pMaxCollateralInputs) - pIntroducedInBabbagePParams :: Parser (IntroducedInBabbagePParams ledgerera) pIntroducedInBabbagePParams = IntroducedInBabbagePParams @@ -353,59 +364,68 @@ dpGovActionProtocolParametersUpdate = \case <*> pIntroducedInBabbagePParams <*> pIntroducedInConwayPParams -pGovernanceActionTreasuryWithdrawalCmd :: CardanoEra era -> Maybe (Parser (Cmd.GovernanceActionCmds era)) +pGovernanceActionTreasuryWithdrawalCmd + :: CardanoEra era -> Maybe (Parser (Cmd.GovernanceActionCmds era)) pGovernanceActionTreasuryWithdrawalCmd era = do eon <- forEraMaybeEon era pure $ subParser "create-treasury-withdrawal" $ Opt.info - ( fmap Cmd.GovernanceActionTreasuryWithdrawalCmd $ - Cmd.GovernanceActionTreasuryWithdrawalCmdArgs eon - <$> pNetwork - <*> pGovActionDeposit - <*> pStakeIdentifier (Just "deposit-return") - <*> pAnchorUrl - <*> pAnchorDataHash - <*> many ((,) <$> pStakeVerificationKeyOrHashOrFile (Just "funds-receiving") <*> pTransferAmt) - <*> optional pConstitutionScriptHash - <*> pFileOutDirection "out-file" "Output filepath of the treasury withdrawal." - ) + ( fmap Cmd.GovernanceActionTreasuryWithdrawalCmd $ + Cmd.GovernanceActionTreasuryWithdrawalCmdArgs eon + <$> pNetwork + <*> pGovActionDeposit + <*> pStakeIdentifier (Just "deposit-return") + <*> pAnchorUrl + <*> pAnchorDataHash + <*> many ((,) <$> pStakeVerificationKeyOrHashOrFile (Just "funds-receiving") <*> pTransferAmt) + <*> optional pConstitutionScriptHash + <*> pFileOutDirection "out-file" "Output filepath of the treasury withdrawal." + ) $ Opt.progDesc "Create a treasury withdrawal." pNetwork :: Parser L.Network -pNetwork = asum $ mconcat - [ [ Opt.flag' L.Mainnet $ mconcat - [ Opt.long "mainnet" - , Opt.help "Use the mainnet magic id." - ] - , Opt.flag' L.Testnet $ mconcat - [ Opt.long "testnet" - , Opt.help "Use the testnet magic id." +pNetwork = + asum $ + mconcat + [ + [ Opt.flag' L.Mainnet $ + mconcat + [ Opt.long "mainnet" + , Opt.help "Use the mainnet magic id." + ] + , Opt.flag' L.Testnet $ + mconcat + [ Opt.long "testnet" + , Opt.help "Use the testnet magic id." + ] + ] ] - ] - ] pNewProtVer :: Parser (Natural, Natural) pNewProtVer = (,) <$> pProtMajor <*> pProtMinor - where - pProtMajor :: Parser Natural - pProtMajor = - Opt.option Opt.auto $ mconcat - [ Opt.long "protocol-major-version" - , Opt.metavar "MAJOR" - , Opt.help $ mconcat - ["Specify the major protocol version to fork into. It must be the next natural number " + where + pProtMajor :: Parser Natural + pProtMajor = + Opt.option Opt.auto $ + mconcat + [ Opt.long "protocol-major-version" + , Opt.metavar "MAJOR" + , Opt.help $ + mconcat + [ "Specify the major protocol version to fork into. It must be the next natural number " , "after the current version and must be supported by the node." ] - ] + ] - pProtMinor :: Parser Natural - pProtMinor = - Opt.option Opt.auto $ mconcat - [ Opt.long "protocol-minor-version" - , Opt.metavar "MINOR" - , Opt.help "Minor protocol version. Must be zero when the major protocol version is increased." - ] + pProtMinor :: Parser Natural + pProtMinor = + Opt.option Opt.auto $ + mconcat + [ Opt.long "protocol-minor-version" + , Opt.metavar "MINOR" + , Opt.help "Minor protocol version. Must be zero when the major protocol version is increased." + ] pPV :: Parser L.ProtVer pPV = mkProtocolVersionOrErr <$> pNewProtVer @@ -418,15 +438,15 @@ pGovernanceActionHardforkInitCmd era = do pure $ subParser "create-hardfork" $ Opt.info - ( fmap Cmd.GovernanceActionHardforkInitCmd $ - Cmd.GovernanceActionHardforkInitCmdArgs eon - <$> pNetwork - <*> pGovActionDeposit - <*> pStakeIdentifier (Just "deposit-return") - <*> pPreviousGovernanceAction - <*> pAnchorUrl - <*> pAnchorDataHash - <*> pPV - <*> pFileOutDirection "out-file" "Output filepath of the hardfork proposal." - ) + ( fmap Cmd.GovernanceActionHardforkInitCmd $ + Cmd.GovernanceActionHardforkInitCmdArgs eon + <$> pNetwork + <*> pGovActionDeposit + <*> pStakeIdentifier (Just "deposit-return") + <*> pPreviousGovernanceAction + <*> pAnchorUrl + <*> pAnchorDataHash + <*> pPV + <*> pFileOutDirection "out-file" "Output filepath of the hardfork proposal." + ) $ Opt.progDesc "Create a hardfork initiation proposal." diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Committee.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Committee.hs index 4e05a49587..8b17c5a3fa 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Committee.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Committee.hs @@ -3,7 +3,8 @@ module Cardano.CLI.EraBased.Options.Governance.Committee ( pGovernanceCommitteeCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -17,13 +18,15 @@ import Data.Foldable (asum) import Options.Applicative (Parser) import qualified Options.Applicative as Opt -pGovernanceCommitteeCmds :: () +pGovernanceCommitteeCmds + :: () => CardanoEra era -> Maybe (Parser (GovernanceCommitteeCmds era)) pGovernanceCommitteeCmds era = - subInfoParser "committee" - ( Opt.progDesc - $ mconcat + subInfoParser + "committee" + ( Opt.progDesc $ + mconcat [ "Committee member commands." ] ) @@ -34,51 +37,56 @@ pGovernanceCommitteeCmds era = , pGovernanceCommitteeCreateColdKeyResignationCertificateCmd era ] -pGovernanceCommitteeKeyGenColdCmd :: () +pGovernanceCommitteeKeyGenColdCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceCommitteeCmds era)) pGovernanceCommitteeKeyGenColdCmd era = do w <- forEraMaybeEon era - pure - $ subParser "key-gen-cold" - $ Opt.info (pCmd w) - $ Opt.progDesc - $ mconcat - [ "Create a cold key pair for a Constitutional Committee Member" - ] - where - pCmd :: () - => ConwayEraOnwards era - -> Parser (GovernanceCommitteeCmds era) - pCmd w = - fmap GovernanceCommitteeKeyGenColdCmd $ - GovernanceCommitteeKeyGenColdCmdArgs w - <$> pColdVerificationKeyFile - <*> pColdSigningKeyFile + pure $ + subParser "key-gen-cold" $ + Opt.info (pCmd w) $ + Opt.progDesc $ + mconcat + [ "Create a cold key pair for a Constitutional Committee Member" + ] + where + pCmd + :: () + => ConwayEraOnwards era + -> Parser (GovernanceCommitteeCmds era) + pCmd w = + fmap GovernanceCommitteeKeyGenColdCmd $ + GovernanceCommitteeKeyGenColdCmdArgs w + <$> pColdVerificationKeyFile + <*> pColdSigningKeyFile -pGovernanceCommitteeKeyGenHotCmd :: () +pGovernanceCommitteeKeyGenHotCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceCommitteeCmds era)) pGovernanceCommitteeKeyGenHotCmd era = do w <- forEraMaybeEon era - pure - $ subParser "key-gen-hot" - $ Opt.info (pCmd w) - $ Opt.progDesc - $ mconcat - [ "Create a hot key pair for a Constitutional Committee Member" - ] - where - pCmd :: () - => ConwayEraOnwards era - -> Parser (GovernanceCommitteeCmds era) - pCmd w = - fmap GovernanceCommitteeKeyGenHotCmd $ - GovernanceCommitteeKeyGenHotCmdArgs w - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut + pure $ + subParser "key-gen-hot" $ + Opt.info (pCmd w) $ + Opt.progDesc $ + mconcat + [ "Create a hot key pair for a Constitutional Committee Member" + ] + where + pCmd + :: () + => ConwayEraOnwards era + -> Parser (GovernanceCommitteeCmds era) + pCmd w = + fmap GovernanceCommitteeKeyGenHotCmd $ + GovernanceCommitteeKeyGenHotCmdArgs w + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut -pGovernanceCommitteeKeyHashCmd :: () +pGovernanceCommitteeKeyHashCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceCommitteeCmds era)) pGovernanceCommitteeKeyHashCmd era = do @@ -86,16 +94,17 @@ pGovernanceCommitteeKeyHashCmd era = do pure $ subParser "key-hash" $ Opt.info - ( fmap GovernanceCommitteeKeyHashCmd $ - GovernanceCommitteeKeyHashCmdArgs w - <$> pAnyVerificationKeySource "Constitutional Committee Member key (hot or cold)" - ) + ( fmap GovernanceCommitteeKeyHashCmd $ + GovernanceCommitteeKeyHashCmdArgs w + <$> pAnyVerificationKeySource "Constitutional Committee Member key (hot or cold)" + ) $ Opt.progDesc $ mconcat - [ "Print the identifier (hash) of a public key" - ] + [ "Print the identifier (hash) of a public key" + ] -pGovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd :: () +pGovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceCommitteeCmds era)) pGovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd era = do @@ -103,42 +112,46 @@ pGovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd era = do pure $ subParser "create-hot-key-authorization-certificate" $ Opt.info - ( fmap GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd $ - GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs w - <$> pColdCredential - <*> pHotCredential - <*> pOutputFile - ) + ( fmap GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmd $ + GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs w + <$> pColdCredential + <*> pHotCredential + <*> pOutputFile + ) $ Opt.progDesc $ mconcat - [ "Create hot key authorization certificate for a Constitutional Committee Member" - ] + [ "Create hot key authorization certificate for a Constitutional Committee Member" + ] -pGovernanceCommitteeCreateColdKeyResignationCertificateCmd :: () +pGovernanceCommitteeCreateColdKeyResignationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceCommitteeCmds era)) pGovernanceCommitteeCreateColdKeyResignationCertificateCmd era = do w <- forEraMaybeEon era - pure - $ subParser "create-cold-key-resignation-certificate" - $ Opt.info (conwayEraOnwardsConstraints w $ mkParser w) - $ Opt.progDesc - $ mconcat - [ "Create cold key resignation certificate for a Constitutional Committee Member" - ] + pure $ + subParser "create-cold-key-resignation-certificate" $ + Opt.info (conwayEraOnwardsConstraints w $ mkParser w) $ + Opt.progDesc $ + mconcat + [ "Create cold key resignation certificate for a Constitutional Committee Member" + ] where mkParser w = - GovernanceCommitteeCreateColdKeyResignationCertificateCmd <$> - (GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs w <$> - pColdCredential <*> pAnchor <*> pOutputFile) + GovernanceCommitteeCreateColdKeyResignationCertificateCmd + <$> ( GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs w + <$> pColdCredential + <*> pAnchor + <*> pOutputFile + ) pColdCredential :: Parser (VerificationKeySource CommitteeColdKey) pColdCredential = asum [ VksKeyHashFile . VerificationKeyOrFile <$> pCommitteeColdVerificationKeyOrFile , VksKeyHashFile . VerificationKeyHash <$> pCommitteeColdVerificationKeyHash - , VksScriptHash <$> - pScriptHash + , VksScriptHash + <$> pScriptHash "cold-script-hash" "Committee cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." , VksScript <$> pScriptFor "cold-script-file" Nothing "Cold Native or Plutus script file" @@ -149,8 +162,8 @@ pHotCredential = asum [ VksKeyHashFile . VerificationKeyOrFile <$> pCommitteeHotVerificationKeyOrFile , VksKeyHashFile . VerificationKeyHash <$> pCommitteeHotVerificationKeyHash - , VksScriptHash <$> - pScriptHash + , VksScriptHash + <$> pScriptHash "hot-script-hash" "Committee hot Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." , VksScript <$> pScriptFor "hot-script-file" Nothing "Hot Native or Plutus script file" @@ -168,10 +181,11 @@ pAnchorUrl = AnchorUrl <$> pUrl "resignation-metadata-url" "Constitutional Committee cold key resignation certificate URL" -pSafeHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData) +pSafeHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData) pSafeHash = - Opt.option readSafeHash $ mconcat - [ Opt.long "resignation-metadata-hash" - , Opt.metavar "HASH" - , Opt.help "Constitutional Committee cold key resignation certificate metadata hash" - ] + Opt.option readSafeHash $ + mconcat + [ Opt.long "resignation-metadata-hash" + , Opt.metavar "HASH" + , Opt.help "Constitutional Committee cold key resignation certificate metadata hash" + ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/DRep.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/DRep.hs index 63bf5752ac..0c8db91543 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/DRep.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/DRep.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} - {-# OPTIONS_GHC -Wno-unused-imports #-} module Cardano.CLI.EraBased.Options.Governance.DRep ( pGovernanceDRepCmds - , pUpdateCertificateCmd) where + , pUpdateCertificateCmd + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -25,13 +26,15 @@ import Data.String import Options.Applicative (Parser) import qualified Options.Applicative as Opt -pGovernanceDRepCmds :: () +pGovernanceDRepCmds + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pGovernanceDRepCmds era = - subInfoParser "drep" - ( Opt.progDesc - $ mconcat + subInfoParser + "drep" + ( Opt.progDesc $ + mconcat [ "DRep member commands." ] ) @@ -43,7 +46,8 @@ pGovernanceDRepCmds era = , pGovernanceDrepMetadataHashCmd era ] -pGovernanceDRepKeyGenCmd :: () +pGovernanceDRepKeyGenCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pGovernanceDRepKeyGenCmd era = do @@ -51,14 +55,15 @@ pGovernanceDRepKeyGenCmd era = do pure $ subParser "key-gen" $ Opt.info - ( fmap GovernanceDRepKeyGenCmd $ - GovernanceDRepKeyGenCmdArgs w - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut - ) + ( fmap GovernanceDRepKeyGenCmd $ + GovernanceDRepKeyGenCmdArgs w + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut + ) $ Opt.progDesc "Generate Delegated Representative verification and signing keys." -pGovernanceDRepKeyIdCmd :: () +pGovernanceDRepKeyIdCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pGovernanceDRepKeyIdCmd era = do @@ -66,37 +71,40 @@ pGovernanceDRepKeyIdCmd era = do pure $ subParser "id" $ Opt.info - ( fmap GovernanceDRepIdCmd $ - GovernanceDRepIdCmdArgs w - <$> pDRepVerificationKeyOrFile - <*> pDRepIdOutputFormat - <*> optional pOutputFile - ) + ( fmap GovernanceDRepIdCmd $ + GovernanceDRepIdCmdArgs w + <$> pDRepVerificationKeyOrFile + <*> pDRepIdOutputFormat + <*> optional pOutputFile + ) $ Opt.progDesc "Generate a drep id." pDRepIdOutputFormat :: Parser IdOutputFormat pDRepIdOutputFormat = - Opt.option readIdOutputFormat $ mconcat - [ Opt.long "output-format" - , Opt.metavar "STRING" - , Opt.help $ mconcat - [ "Optional drep id output format. Accepted output formats are \"hex\" " - , "and \"bech32\" (default is \"bech32\")." + Opt.option readIdOutputFormat $ + mconcat + [ Opt.long "output-format" + , Opt.metavar "STRING" + , Opt.help $ + mconcat + [ "Optional drep id output format. Accepted output formats are \"hex\" " + , "and \"bech32\" (default is \"bech32\")." + ] + , Opt.value IdOutputFormatBech32 ] - , Opt.value IdOutputFormatBech32 - ] -- Registration Certificate related -pRegistrationCertificateCmd :: () +pRegistrationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pRegistrationCertificateCmd era = do w <- forEraMaybeEon era - pure - $ subParser "registration-certificate" - $ Opt.info (conwayEraOnwardsConstraints w $ mkParser w) - $ Opt.progDesc "Create a registration certificate." + pure $ + subParser "registration-certificate" $ + Opt.info (conwayEraOnwardsConstraints w $ mkParser w) $ + Opt.progDesc "Create a registration certificate." where mkParser w = fmap GovernanceDRepRegistrationCertificateCmd $ @@ -120,13 +128,15 @@ pDrepMetadataUrl = pDrepMetadataHash :: Parser (L.SafeHash L.StandardCrypto L.AnchorData) pDrepMetadataHash = - Opt.option readSafeHash $ mconcat - [ Opt.long "drep-metadata-hash" - , Opt.metavar "HASH" - , Opt.help "DRep anchor data hash." - ] + Opt.option readSafeHash $ + mconcat + [ Opt.long "drep-metadata-hash" + , Opt.metavar "HASH" + , Opt.help "DRep anchor data hash." + ] -pRetirementCertificateCmd :: () +pRetirementCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pRetirementCertificateCmd era = do @@ -142,7 +152,8 @@ pRetirementCertificateCmd era = do ) $ Opt.progDesc "Create a DRep retirement certificate." -pUpdateCertificateCmd :: () +pUpdateCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pUpdateCertificateCmd era = do @@ -159,7 +170,8 @@ pUpdateCertificateCmd era = do ) $ Opt.progDesc "Create a DRep update certificate." -pGovernanceDrepMetadataHashCmd :: () +pGovernanceDrepMetadataHashCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceDRepCmds era)) pGovernanceDrepMetadataHashCmd era = do @@ -167,11 +179,11 @@ pGovernanceDrepMetadataHashCmd era = do pure $ subParser "metadata-hash" $ Opt.info - ( fmap GovernanceDRepMetadataHashCmd $ - GovernanceDRepMetadataHashCmdArgs w - <$> pFileInDirection "drep-metadata-file" "JSON Metadata file to hash." - <*> pMaybeOutputFile - ) + ( fmap GovernanceDRepMetadataHashCmd $ + GovernanceDRepMetadataHashCmdArgs w + <$> pFileInDirection "drep-metadata-file" "JSON Metadata file to hash." + <*> pMaybeOutputFile + ) $ Opt.progDesc "Calculate the hash of a metadata file." -------------------------------------------------------------------------------- @@ -182,10 +194,10 @@ data AnyEraDecider era where instance Eon AnyEraDecider where inEonForEra no yes = \case - ByronEra -> no - ShelleyEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraShelley - AllegraEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraAllegra - MaryEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraMary - AlonzoEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraAlonzo - BabbageEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraBabbage - ConwayEra -> yes $ AnyEraDeciderConwayOnwards ConwayEraOnwardsConway + ByronEra -> no + ShelleyEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraShelley + AllegraEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraAllegra + MaryEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraMary + AlonzoEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraAlonzo + BabbageEra -> yes $ AnyEraDeciderShelleyToBabbage ShelleyToBabbageEraBabbage + ConwayEra -> yes $ AnyEraDeciderConwayOnwards ConwayEraOnwardsConway diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Poll.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Poll.hs index 909c8bb69b..7566b893dd 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Poll.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Poll.hs @@ -1,5 +1,5 @@ module Cardano.CLI.EraBased.Options.Governance.Poll - ( pGovernancePollCmds, + ( pGovernancePollCmds ) where @@ -14,60 +14,64 @@ import Data.Foldable import Options.Applicative hiding (help, str) import qualified Options.Applicative as Opt -pGovernancePollCmds :: () +pGovernancePollCmds + :: () => CardanoEra era -> Maybe (Parser (Cmd.GovernancePollCmds era)) pGovernancePollCmds era = case parsers of [] -> Nothing _ -> Just $ asum parsers - where - parsers = - catMaybes - [ subParser "create-poll" - <$> ( Opt.info - <$> pGovernanceCreatePoll era - <*> pure (Opt.progDesc "Create an SPO poll") - ), - subParser "answer-poll" - <$> ( Opt.info - <$> pGovernanceAnswerPoll era - <*> pure (Opt.progDesc "Answer an SPO poll") - ), - subParser "verify-poll" - <$> ( Opt.info - <$> pGovernanceVerifyPoll era - <*> pure (Opt.progDesc "Verify an answer to a given SPO poll") - ) - ] + where + parsers = + catMaybes + [ subParser "create-poll" + <$> ( Opt.info + <$> pGovernanceCreatePoll era + <*> pure (Opt.progDesc "Create an SPO poll") + ) + , subParser "answer-poll" + <$> ( Opt.info + <$> pGovernanceAnswerPoll era + <*> pure (Opt.progDesc "Answer an SPO poll") + ) + , subParser "verify-poll" + <$> ( Opt.info + <$> pGovernanceVerifyPoll era + <*> pure (Opt.progDesc "Verify an answer to a given SPO poll") + ) + ] pGovernanceCreatePoll :: CardanoEra era -> Maybe (Parser (Cmd.GovernancePollCmds era)) pGovernanceCreatePoll era = do w <- forEraMaybeEon era when ("BabbageEraOnwardsConway" `isInfixOf` show w) Nothing - pure $ fmap Cmd.GovernanceCreatePoll $ - Cmd.GovernanceCreatePollCmdArgs w - <$> pPollQuestion - <*> some pPollAnswer - <*> optional pPollNonce - <*> pOutputFile + pure $ + fmap Cmd.GovernanceCreatePoll $ + Cmd.GovernanceCreatePollCmdArgs w + <$> pPollQuestion + <*> some pPollAnswer + <*> optional pPollNonce + <*> pOutputFile pGovernanceAnswerPoll :: CardanoEra era -> Maybe (Parser (Cmd.GovernancePollCmds era)) pGovernanceAnswerPoll era = do w <- forEraMaybeEon era when ("BabbageEraOnwardsConway" `isInfixOf` show w) Nothing - pure $ fmap Cmd.GovernanceAnswerPoll $ - Cmd.GovernanceAnswerPollCmdArgs w - <$> pPollFile - <*> optional pPollAnswerIndex - <*> optional pOutputFile + pure $ + fmap Cmd.GovernanceAnswerPoll $ + Cmd.GovernanceAnswerPollCmdArgs w + <$> pPollFile + <*> optional pPollAnswerIndex + <*> optional pOutputFile pGovernanceVerifyPoll :: CardanoEra era -> Maybe (Parser (Cmd.GovernancePollCmds era)) pGovernanceVerifyPoll era = do w <- forEraMaybeEon era when ("BabbageEraOnwardsConway" `isInfixOf` show w) Nothing - pure $ fmap Cmd.GovernanceVerifyPoll $ - Cmd.GovernanceVerifyPollCmdArgs w - <$> pPollFile - <*> pPollTxFile - <*> optional pOutputFile + pure $ + fmap Cmd.GovernanceVerifyPoll $ + Cmd.GovernanceVerifyPollCmdArgs w + <$> pPollFile + <*> pPollTxFile + <*> optional pOutputFile diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Vote.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Vote.hs index b68c25c8fd..f896d36fd0 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Vote.hs @@ -3,7 +3,8 @@ module Cardano.CLI.EraBased.Options.Governance.Vote ( pGovernanceVoteCmds - ) where + ) +where import Cardano.Api @@ -16,17 +17,20 @@ import Data.Foldable import Options.Applicative (Parser) import qualified Options.Applicative as Opt -pGovernanceVoteCmds :: () +pGovernanceVoteCmds + :: () => CardanoEra era -> Maybe (Parser (GovernanceVoteCmds era)) pGovernanceVoteCmds era = - subInfoParser "vote" + subInfoParser + "vote" (Opt.progDesc "Vote commands.") - [ pGovernanceVoteCreateCmd era, - pGovernanceVoteViewCmd era + [ pGovernanceVoteCreateCmd era + , pGovernanceVoteViewCmd era ] -pGovernanceVoteCreateCmd :: () +pGovernanceVoteCreateCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceVoteCmds era)) pGovernanceVoteCreateCmd era = do @@ -34,29 +38,33 @@ pGovernanceVoteCreateCmd era = do pure $ subParser "create" $ Opt.info - ( GovernanceVoteCreateCmd - <$> pGovernanceVoteCreateCmdArgs w - ) + ( GovernanceVoteCreateCmd + <$> pGovernanceVoteCreateCmdArgs w + ) $ Opt.progDesc "Vote creation." -pGovernanceVoteCreateCmdArgs :: () +pGovernanceVoteCreateCmdArgs + :: () => ConwayEraOnwards era -> Parser (GovernanceVoteCreateCmdArgs era) pGovernanceVoteCreateCmdArgs cOnwards = GovernanceVoteCreateCmdArgs cOnwards - <$> pVoteChoice - <*> pGovernanceActionId - <*> pAnyVotingStakeVerificationKeyOrHashOrFile - <*> optional pVoteAnchor - <*> pFileOutDirection "out-file" "Output filepath of the vote." + <$> pVoteChoice + <*> pGovernanceActionId + <*> pAnyVotingStakeVerificationKeyOrHashOrFile + <*> optional pVoteAnchor + <*> pFileOutDirection "out-file" "Output filepath of the vote." pAnyVotingStakeVerificationKeyOrHashOrFile :: Parser AnyVotingStakeVerificationKeyOrHashOrFile pAnyVotingStakeVerificationKeyOrHashOrFile = - asum [ AnyDRepVerificationKeyOrHashOrFileOrScriptHash <$> pDRepVerificationKeyOrHashOrFileOrScriptHash - , AnyStakePoolVerificationKeyOrHashOrFile <$> pStakePoolVerificationKeyOrHashOrFile Nothing - , AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash <$> pCommitteeHotVerificationKeyOrHashOrVerificationFileOrScriptHash - ] + asum + [ AnyDRepVerificationKeyOrHashOrFileOrScriptHash <$> pDRepVerificationKeyOrHashOrFileOrScriptHash + , AnyStakePoolVerificationKeyOrHashOrFile <$> pStakePoolVerificationKeyOrHashOrFile Nothing + , AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash + <$> pCommitteeHotVerificationKeyOrHashOrVerificationFileOrScriptHash + ] -pGovernanceVoteViewCmd :: () +pGovernanceVoteViewCmd + :: () => CardanoEra era -> Maybe (Parser (GovernanceVoteCmds era)) pGovernanceVoteViewCmd era = do @@ -64,7 +72,7 @@ pGovernanceVoteViewCmd era = do pure $ subParser "view" $ Opt.info - (GovernanceVoteViewCmd <$> pGovernanceVoteViewCmdArgs w) + (GovernanceVoteViewCmd <$> pGovernanceVoteViewCmdArgs w) $ Opt.progDesc "Vote viewing." pGovernanceVoteViewCmdArgs :: ConwayEraOnwards era -> Parser (GovernanceVoteViewCmdArgs era) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Key.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Key.hs index 9f5831b1e1..09b1d25c5d 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Key.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Key.hs @@ -5,7 +5,8 @@ module Cardano.CLI.EraBased.Options.Key ( pKeyCmds - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) @@ -23,82 +24,83 @@ import qualified Options.Applicative as Opt pKeyCmds :: Maybe (Parser (KeyCmds era)) pKeyCmds = - subInfoParser "key" - ( Opt.progDesc - $ mconcat + subInfoParser + "key" + ( Opt.progDesc $ + mconcat [ "Key utility commands." ] ) - [ Just - $ subParser "verification-key" - $ Opt.info pKeyVerificationKeyCmd - $ Opt.progDesc - $ mconcat - [ "Get a verification key from a signing key. This " - , " supports all key types." - ] - , Just - $ subParser "non-extended-key" - $ Opt.info pKeyNonExtendedKeyCmd - $ Opt.progDesc - $ mconcat - [ "Get a non-extended verification key from an " - , "extended verification key. This supports all " - , "extended key types." - ] - , Just - $ subParser "convert-byron-key" - $ Opt.info pKeyConvertByronKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert a Byron payment, genesis or genesis " - , "delegate key (signing or verification) to a " - , "corresponding Shelley-format key." - ] - , Just - $ subParser "convert-byron-genesis-vkey" - $ Opt.info pKeyConvertByronGenesisKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert a Base64-encoded Byron genesis " - , "verification key to a Shelley genesis " - , "verification key" - ] - , Just - $ subParser "convert-itn-key" - $ Opt.info pKeyConvertITNKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert an Incentivized Testnet (ITN) non-extended " - , "(Ed25519) signing or verification key to a " - , "corresponding Shelley stake key" - ] - , Just - $ subParser "convert-itn-extended-key" - $ Opt.info pKeyConvertITNExtendedKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert an Incentivized Testnet (ITN) extended " - , "(Ed25519Extended) signing key to a corresponding " - , "Shelley stake signing key" - ] - , Just - $ subParser "convert-itn-bip32-key" - $ Opt.info pKeyConvertITNBip32KeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert an Incentivized Testnet (ITN) BIP32 " - , "(Ed25519Bip32) signing key to a corresponding " - , "Shelley stake signing key" - ] - , Just - $ subParser "convert-cardano-address-key" - $ Opt.info pKeyConvertCardanoAddressKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert a cardano-address extended signing key " - , "to a corresponding Shelley-format key." - ] + [ Just $ + subParser "verification-key" $ + Opt.info pKeyVerificationKeyCmd $ + Opt.progDesc $ + mconcat + [ "Get a verification key from a signing key. This " + , " supports all key types." + ] + , Just $ + subParser "non-extended-key" $ + Opt.info pKeyNonExtendedKeyCmd $ + Opt.progDesc $ + mconcat + [ "Get a non-extended verification key from an " + , "extended verification key. This supports all " + , "extended key types." + ] + , Just $ + subParser "convert-byron-key" $ + Opt.info pKeyConvertByronKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert a Byron payment, genesis or genesis " + , "delegate key (signing or verification) to a " + , "corresponding Shelley-format key." + ] + , Just $ + subParser "convert-byron-genesis-vkey" $ + Opt.info pKeyConvertByronGenesisKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert a Base64-encoded Byron genesis " + , "verification key to a Shelley genesis " + , "verification key" + ] + , Just $ + subParser "convert-itn-key" $ + Opt.info pKeyConvertITNKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert an Incentivized Testnet (ITN) non-extended " + , "(Ed25519) signing or verification key to a " + , "corresponding Shelley stake key" + ] + , Just $ + subParser "convert-itn-extended-key" $ + Opt.info pKeyConvertITNExtendedKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert an Incentivized Testnet (ITN) extended " + , "(Ed25519Extended) signing key to a corresponding " + , "Shelley stake signing key" + ] + , Just $ + subParser "convert-itn-bip32-key" $ + Opt.info pKeyConvertITNBip32KeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert an Incentivized Testnet (ITN) BIP32 " + , "(Ed25519Bip32) signing key to a corresponding " + , "Shelley stake signing key" + ] + , Just $ + subParser "convert-cardano-address-key" $ + Opt.info pKeyConvertCardanoAddressKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert a cardano-address extended signing key " + , "to a corresponding Shelley-format key." + ] ] pKeyVerificationKeyCmd :: Parser (KeyCmds era) @@ -126,65 +128,76 @@ pKeyConvertByronKeyCmd = pPassword :: Parser Text pPassword = - Opt.strOption $ mconcat - [ Opt.long "password" - , Opt.metavar "TEXT" - , Opt.help "Password for signing key (if applicable)." - ] + Opt.strOption $ + mconcat + [ Opt.long "password" + , Opt.metavar "TEXT" + , Opt.help "Password for signing key (if applicable)." + ] pByronKeyType :: Parser ByronKeyType pByronKeyType = asum - [ Opt.flag' (ByronPaymentKey NonLegacyByronKeyFormat) $ mconcat - [ Opt.long "byron-payment-key-type" - , Opt.help "Use a Byron-era payment key." - ] - , Opt.flag' (ByronPaymentKey LegacyByronKeyFormat) $ mconcat - [ Opt.long "legacy-byron-payment-key-type" - , Opt.help "Use a Byron-era payment key, in legacy SL format." - ] - , Opt.flag' (ByronGenesisKey NonLegacyByronKeyFormat) $ mconcat - [ Opt.long "byron-genesis-key-type" - , Opt.help "Use a Byron-era genesis key." - ] - , Opt.flag' (ByronGenesisKey LegacyByronKeyFormat) $ mconcat - [ Opt.long "legacy-byron-genesis-key-type" - , Opt.help "Use a Byron-era genesis key, in legacy SL format." - ] - , Opt.flag' (ByronDelegateKey NonLegacyByronKeyFormat) $ mconcat - [ Opt.long "byron-genesis-delegate-key-type" - , Opt.help "Use a Byron-era genesis delegate key." - ] - , Opt.flag' (ByronDelegateKey LegacyByronKeyFormat) $ mconcat - [ Opt.long "legacy-byron-genesis-delegate-key-type" - , Opt.help "Use a Byron-era genesis delegate key, in legacy SL format." - ] + [ Opt.flag' (ByronPaymentKey NonLegacyByronKeyFormat) $ + mconcat + [ Opt.long "byron-payment-key-type" + , Opt.help "Use a Byron-era payment key." + ] + , Opt.flag' (ByronPaymentKey LegacyByronKeyFormat) $ + mconcat + [ Opt.long "legacy-byron-payment-key-type" + , Opt.help "Use a Byron-era payment key, in legacy SL format." + ] + , Opt.flag' (ByronGenesisKey NonLegacyByronKeyFormat) $ + mconcat + [ Opt.long "byron-genesis-key-type" + , Opt.help "Use a Byron-era genesis key." + ] + , Opt.flag' (ByronGenesisKey LegacyByronKeyFormat) $ + mconcat + [ Opt.long "legacy-byron-genesis-key-type" + , Opt.help "Use a Byron-era genesis key, in legacy SL format." + ] + , Opt.flag' (ByronDelegateKey NonLegacyByronKeyFormat) $ + mconcat + [ Opt.long "byron-genesis-delegate-key-type" + , Opt.help "Use a Byron-era genesis delegate key." + ] + , Opt.flag' (ByronDelegateKey LegacyByronKeyFormat) $ + mconcat + [ Opt.long "legacy-byron-genesis-delegate-key-type" + , Opt.help "Use a Byron-era genesis delegate key, in legacy SL format." + ] ] pByronKeyFile :: Parser (SomeKeyFile In) pByronKeyFile = asum - [ ASigningKeyFile <$> pByronSigningKeyFile + [ ASigningKeyFile <$> pByronSigningKeyFile , AVerificationKeyFile <$> pByronVerificationKeyFile ] pByronSigningKeyFile :: Parser (SigningKeyFile In) pByronSigningKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "byron-signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the Byron-format signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "byron-signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the Byron-format signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pByronVerificationKeyFile :: Parser (VerificationKeyFile In) pByronVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "byron-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the Byron-format verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "byron-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the Byron-format verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pKeyConvertByronGenesisKeyCmd :: Parser (KeyCmds era) pKeyConvertByronGenesisKeyCmd = @@ -195,11 +208,13 @@ pKeyConvertByronGenesisKeyCmd = pByronGenesisVKeyBase64 :: Parser VerificationKeyBase64 pByronGenesisVKeyBase64 = - fmap VerificationKeyBase64 $ Opt.strOption $ mconcat - [ Opt.long "byron-genesis-verification-key" - , Opt.metavar "BASE64" - , Opt.help "Base64 string for the Byron genesis verification key." - ] + fmap VerificationKeyBase64 $ + Opt.strOption $ + mconcat + [ Opt.long "byron-genesis-verification-key" + , Opt.metavar "BASE64" + , Opt.help "Base64 string for the Byron genesis verification key." + ] pKeyConvertITNKeyCmd :: Parser (KeyCmds era) pKeyConvertITNKeyCmd = @@ -231,21 +246,25 @@ pITNKeyFIle = pITNSigningKeyFile :: Parser (SomeKeyFile direction) pITNSigningKeyFile = - fmap (ASigningKeyFile . File) $ Opt.strOption $ mconcat - [ Opt.long "itn-signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the ITN signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap (ASigningKeyFile . File) $ + Opt.strOption $ + mconcat + [ Opt.long "itn-signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the ITN signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pITNVerificationKeyFile :: Parser (SomeKeyFile direction) pITNVerificationKeyFile = - fmap (AVerificationKeyFile . File) $ Opt.strOption $ mconcat - [ Opt.long "itn-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the ITN verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap (AVerificationKeyFile . File) $ + Opt.strOption $ + mconcat + [ Opt.long "itn-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the ITN verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pKeyConvertCardanoAddressKeyCmd :: Parser (KeyCmds era) pKeyConvertCardanoAddressKeyCmd = @@ -258,32 +277,39 @@ pKeyConvertCardanoAddressKeyCmd = pCardanoAddressKeyType :: Parser CardanoAddressKeyType pCardanoAddressKeyType = asum - [ Opt.flag' CardanoAddressCommitteeColdKey $ mconcat - [ Opt.long "cc-cold-key" - , Opt.help "Use a committee cold key." - ] - , Opt.flag' CardanoAddressCommitteeHotKey $ mconcat - [ Opt.long "cc-hot-key" - , Opt.help "Use a committee hot key." - ] - , Opt.flag' CardanoAddressDRepKey $ mconcat - [ Opt.long "drep-key" - , Opt.help "Use a DRep key." - ] - , Opt.flag' CardanoAddressShelleyPaymentKey $ mconcat - [ Opt.long "shelley-payment-key" - , Opt.help "Use a Shelley-era extended payment key." - ] - , Opt.flag' CardanoAddressShelleyStakeKey $ mconcat - [ Opt.long "shelley-stake-key" - , Opt.help "Use a Shelley-era extended stake key." - ] - , Opt.flag' CardanoAddressIcarusPaymentKey $ mconcat - [ Opt.long "icarus-payment-key" - , Opt.help "Use a Byron-era extended payment key formatted in the Icarus style." - ] - , Opt.flag' CardanoAddressByronPaymentKey $ mconcat - [ Opt.long "byron-payment-key" - , Opt.help "Use a Byron-era extended payment key formatted in the deprecated Byron style." - ] + [ Opt.flag' CardanoAddressCommitteeColdKey $ + mconcat + [ Opt.long "cc-cold-key" + , Opt.help "Use a committee cold key." + ] + , Opt.flag' CardanoAddressCommitteeHotKey $ + mconcat + [ Opt.long "cc-hot-key" + , Opt.help "Use a committee hot key." + ] + , Opt.flag' CardanoAddressDRepKey $ + mconcat + [ Opt.long "drep-key" + , Opt.help "Use a DRep key." + ] + , Opt.flag' CardanoAddressShelleyPaymentKey $ + mconcat + [ Opt.long "shelley-payment-key" + , Opt.help "Use a Shelley-era extended payment key." + ] + , Opt.flag' CardanoAddressShelleyStakeKey $ + mconcat + [ Opt.long "shelley-stake-key" + , Opt.help "Use a Shelley-era extended stake key." + ] + , Opt.flag' CardanoAddressIcarusPaymentKey $ + mconcat + [ Opt.long "icarus-payment-key" + , Opt.help "Use a Byron-era extended payment key formatted in the Icarus style." + ] + , Opt.flag' CardanoAddressByronPaymentKey $ + mconcat + [ Opt.long "byron-payment-key" + , Opt.help "Use a Byron-era extended payment key formatted in the deprecated Byron style." + ] ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs index ed7b3e5509..26d87265fd 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Node.hs @@ -5,7 +5,8 @@ module Cardano.CLI.EraBased.Options.Node ( pNodeCmds - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) @@ -21,53 +22,55 @@ import qualified Options.Applicative as Opt pNodeCmds :: Maybe (Parser (NodeCmds era)) pNodeCmds = - subInfoParser "node" - ( Opt.progDesc - $ mconcat + subInfoParser + "node" + ( Opt.progDesc $ + mconcat [ "Node operation commands." ] ) - [ Just - $ 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" - ] - , Just - $ subParser "key-gen-KES" - $ Opt.info pKeyGenKES - $ Opt.progDesc - $ mconcat - [ "Create a key pair for a node KES operational key" - ] - , Just - $ subParser "key-gen-VRF" - $ Opt.info pKeyGenVRF - $ Opt.progDesc - $ mconcat - [ "Create a key pair for a node VRF operational key" - ] - , Just - $ subParser "key-hash-VRF". Opt.info pKeyHashVRF - $ Opt.progDesc - $ mconcat - [ "Print hash of a node's operational VRF key." - ] - , Just - $ subParser "new-counter" - $ Opt.info pNewCounter - $ Opt.progDesc - $ mconcat - [ "Create a new certificate issue counter" - ] - , Just - $ subParser "issue-op-cert" - $ Opt.info pIssueOpCert - $ Opt.progDesc - $ mconcat - [ "Issue a node operational certificate" - ] + [ Just $ + 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" + ] + , Just $ + subParser "key-gen-KES" $ + Opt.info pKeyGenKES $ + Opt.progDesc $ + mconcat + [ "Create a key pair for a node KES operational key" + ] + , Just $ + subParser "key-gen-VRF" $ + Opt.info pKeyGenVRF $ + Opt.progDesc $ + mconcat + [ "Create a key pair for a node VRF operational key" + ] + , Just $ + subParser "key-hash-VRF" . Opt.info pKeyHashVRF $ + Opt.progDesc $ + mconcat + [ "Print hash of a node's operational VRF key." + ] + , Just $ + subParser "new-counter" $ + Opt.info pNewCounter $ + Opt.progDesc $ + mconcat + [ "Create a new certificate issue counter" + ] + , Just $ + subParser "issue-op-cert" $ + Opt.info pIssueOpCert $ + Opt.progDesc $ + mconcat + [ "Issue a node operational certificate" + ] ] pKeyGenOperator :: Parser (NodeCmds era) @@ -98,7 +101,7 @@ pKeyGenVRF = pKeyHashVRF :: Parser (NodeCmds era) pKeyHashVRF = fmap Cmd.NodeKeyHashVRFCmd $ - Cmd.NodeKeyHashVRFCmdArgs + Cmd.NodeKeyHashVRFCmdArgs <$> pVerificationKeyOrFileIn AsVrfKey <*> pMaybeOutputFile @@ -112,11 +115,12 @@ pNewCounter = pCounterValue :: Parser Word pCounterValue = - Opt.option Opt.auto $ mconcat - [ Opt.long "counter-value" - , Opt.metavar "INT" - , Opt.help "The next certificate issue counter value to use." - ] + Opt.option Opt.auto $ + mconcat + [ Opt.long "counter-value" + , Opt.metavar "INT" + , Opt.help "The next certificate issue counter value to use." + ] pIssueOpCert :: Parser (NodeCmds era) pIssueOpCert = diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs index 4727fae1d6..fbee7339fc 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Query.hs @@ -5,7 +5,8 @@ module Cardano.CLI.EraBased.Options.Query ( pQueryCmds - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) import qualified Cardano.Api as MemberStatus (MemberStatus (..)) @@ -25,91 +26,99 @@ import qualified Options.Applicative as Opt {- HLINT ignore "Use <$>" -} {- HLINT ignore "Move brackets to avoid $" -} -pQueryCmds :: () +pQueryCmds + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (QueryCmds era)) pQueryCmds era envCli = - subInfoParser "query" - ( Opt.progDesc - $ mconcat + subInfoParser + "query" + ( Opt.progDesc $ + mconcat [ "Node query commands. Will query the local node whose Unix domain socket is " , "obtained from the CARDANO_NODE_SOCKET_PATH environment variable." ] ) - [ Just - $ subParser "protocol-parameters" - $ Opt.info (pQueryProtocolParametersCmd envCli) - $ Opt.progDesc "Get the node's current protocol parameters" - , Just - $ subParser "tip" - $ Opt.info (pQueryTipCmd era envCli) - $ Opt.progDesc "Get the node's current tip (slot no, hash, block no)" - , Just - $ subParser "stake-pools" - $ Opt.info (pQueryStakePoolsCmd era envCli) - $ Opt.progDesc "Get the node's current set of stake pool ids" - , Just - $ subParser "stake-distribution" - $ Opt.info (pQueryStakeDistributionCmd era envCli) - $ Opt.progDesc "Get the node's current aggregated stake distribution" - , Just - $ subParser "stake-address-info" - $ Opt.info (pQueryStakeAddressInfoCmd era envCli) - $ Opt.progDesc $ mconcat - [ "Get the current delegations and reward accounts filtered by stake address." - ] - , Just - $ subParser "utxo" - $ Opt.info (pQueryUTxOCmd era envCli) - $ Opt.progDesc $ mconcat - [ "Get a portion of the current UTxO: by tx in, by address or the whole." - ] - , Just - $ subParser "ledger-state" - $ Opt.info (pQueryLedgerStateCmd era envCli) - $ Opt.progDesc $ mconcat - [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)" - ] - , Just - $ subParser "protocol-state" - $ Opt.info (pQueryProtocolStateCmd era envCli) - $ Opt.progDesc $ mconcat - [ "Dump the current protocol state of the node (Ledger.ChainDepState -- advanced command)" - ] - , Just - $ subParser "stake-snapshot" - $ Opt.info (pQueryStakeSnapshotCmd era envCli) - $ Opt.progDesc $ mconcat - [ "Obtain the three stake snapshots for a pool, plus the total active stake (advanced command)" - ] - , Just - $ hiddenSubParser "pool-params" - $ Opt.info (pQueryPoolStateCmd era envCli) - $ Opt.progDesc $ mconcat - [ "DEPRECATED. Use query pool-state instead. Dump the pool parameters " - , "(Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)" - ] - , Just - $ subParser "leadership-schedule" - $ Opt.info (pLeadershipScheduleCmd era envCli) - $ Opt.progDesc "Get the slots the node is expected to mint a block in (advanced command)" - , Just - $ subParser "kes-period-info" - $ Opt.info (pKesPeriodInfoCmd era envCli) - $ Opt.progDesc "Get information about the current KES period and your node's operational certificate." - , Just - $ subParser "pool-state" - $ Opt.info (pQueryPoolStateCmd era envCli) - $ Opt.progDesc "Dump the pool state" - , Just - $ subParser "tx-mempool" - $ Opt.info (pQueryTxMempoolCmd envCli) - $ Opt.progDesc "Local Mempool info" - , Just - $ subParser "slot-number" - $ Opt.info (pQuerySlotNumberCmd era envCli) - $ Opt.progDesc "Query slot number for UTC timestamp" + [ Just $ + subParser "protocol-parameters" $ + Opt.info (pQueryProtocolParametersCmd envCli) $ + Opt.progDesc "Get the node's current protocol parameters" + , Just $ + subParser "tip" $ + Opt.info (pQueryTipCmd era envCli) $ + Opt.progDesc "Get the node's current tip (slot no, hash, block no)" + , Just $ + subParser "stake-pools" $ + Opt.info (pQueryStakePoolsCmd era envCli) $ + Opt.progDesc "Get the node's current set of stake pool ids" + , Just $ + subParser "stake-distribution" $ + Opt.info (pQueryStakeDistributionCmd era envCli) $ + Opt.progDesc "Get the node's current aggregated stake distribution" + , Just $ + subParser "stake-address-info" $ + Opt.info (pQueryStakeAddressInfoCmd era envCli) $ + Opt.progDesc $ + mconcat + [ "Get the current delegations and reward accounts filtered by stake address." + ] + , Just $ + subParser "utxo" $ + Opt.info (pQueryUTxOCmd era envCli) $ + Opt.progDesc $ + mconcat + [ "Get a portion of the current UTxO: by tx in, by address or the whole." + ] + , Just $ + subParser "ledger-state" $ + Opt.info (pQueryLedgerStateCmd era envCli) $ + Opt.progDesc $ + mconcat + [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)" + ] + , Just $ + subParser "protocol-state" $ + Opt.info (pQueryProtocolStateCmd era envCli) $ + Opt.progDesc $ + mconcat + [ "Dump the current protocol state of the node (Ledger.ChainDepState -- advanced command)" + ] + , Just $ + subParser "stake-snapshot" $ + Opt.info (pQueryStakeSnapshotCmd era envCli) $ + Opt.progDesc $ + mconcat + [ "Obtain the three stake snapshots for a pool, plus the total active stake (advanced command)" + ] + , Just $ + hiddenSubParser "pool-params" $ + Opt.info (pQueryPoolStateCmd era envCli) $ + Opt.progDesc $ + mconcat + [ "DEPRECATED. Use query pool-state instead. Dump the pool parameters " + , "(Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)" + ] + , Just $ + subParser "leadership-schedule" $ + Opt.info (pLeadershipScheduleCmd era envCli) $ + Opt.progDesc "Get the slots the node is expected to mint a block in (advanced command)" + , Just $ + subParser "kes-period-info" $ + Opt.info (pKesPeriodInfoCmd era envCli) $ + Opt.progDesc "Get information about the current KES period and your node's operational certificate." + , Just $ + subParser "pool-state" $ + Opt.info (pQueryPoolStateCmd era envCli) $ + Opt.progDesc "Dump the pool state" + , Just $ + subParser "tx-mempool" $ + Opt.info (pQueryTxMempoolCmd envCli) $ + Opt.progDesc "Local Mempool info" + , Just $ + subParser "slot-number" $ + Opt.info (pQuerySlotNumberCmd era envCli) $ + Opt.progDesc "Query slot number for UTC timestamp" , Just . subParser "ref-script-size" . Opt.info (pQueryRefScriptSizeCmd era envCli) @@ -207,13 +216,16 @@ pQueryProtocolStateCmd era envCli = pAllStakePoolsOrSome :: Parser (AllOrOnly (Hash StakePoolKey)) pAllStakePoolsOrSome = pAll <|> pOnly - where pAll :: Parser (AllOrOnly (Hash StakePoolKey)) - pAll = Opt.flag' All $ mconcat - [ Opt.long "all-stake-pools" - , Opt.help "Query for all stake pools" - ] - pOnly :: Parser (AllOrOnly (Hash StakePoolKey)) - pOnly = Only <$> some (pStakePoolVerificationKeyHash Nothing) + where + pAll :: Parser (AllOrOnly (Hash StakePoolKey)) + pAll = + Opt.flag' All $ + mconcat + [ Opt.long "all-stake-pools" + , Opt.help "Query for all stake pools" + ] + pOnly :: Parser (AllOrOnly (Hash StakePoolKey)) + pOnly = Only <$> some (pStakePoolVerificationKeyHash Nothing) pQueryStakeSnapshotCmd :: CardanoEra era -> EnvCli -> Parser (QueryCmds era) pQueryStakeSnapshotCmd era envCli = @@ -246,19 +258,21 @@ pQueryTxMempoolCmd envCli = <*> pNetworkId envCli <*> pTxMempoolQuery <*> pMaybeOutputFile - where - pTxMempoolQuery :: Parser TxMempoolQuery - pTxMempoolQuery = asum - [ subParser "info" - $ Opt.info (pure TxMempoolQueryInfo) - $ Opt.progDesc "Ask the node about the current mempool's capacity and sizes" - , subParser "next-tx" - $ Opt.info (pure TxMempoolQueryNextTx) - $ Opt.progDesc "Requests the next transaction from the mempool's current list" - , subParser "tx-exists" - $ Opt.info (TxMempoolQueryTxExists <$> argument Opt.str (metavar "TX_ID")) - $ Opt.progDesc "Query if a particular transaction exists in the mempool" + where + pTxMempoolQuery :: Parser TxMempoolQuery + pTxMempoolQuery = + asum + [ subParser "info" $ + Opt.info (pure TxMempoolQueryInfo) $ + Opt.progDesc "Ask the node about the current mempool's capacity and sizes" + , subParser "next-tx" $ + Opt.info (pure TxMempoolQueryNextTx) $ + Opt.progDesc "Requests the next transaction from the mempool's current list" + , subParser "tx-exists" $ + Opt.info (TxMempoolQueryTxExists <$> argument Opt.str (metavar "TX_ID")) $ + Opt.progDesc "Query if a particular transaction exists in the mempool" ] + pLeadershipScheduleCmd :: CardanoEra era -> EnvCli -> Parser (QueryCmds era) pLeadershipScheduleCmd era envCli = fmap QueryLeadershipScheduleCmd $ @@ -294,9 +308,10 @@ pQuerySlotNumberCmd era envCli = <*> pNetworkId envCli <*> pTarget era <*> pUtcTimestamp - where - pUtcTimestamp = - convertTime <$> (Opt.strArgument . mconcat) + where + pUtcTimestamp = + convertTime + <$> (Opt.strArgument . mconcat) [ Opt.metavar "TIMESTAMP" , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" ] @@ -312,86 +327,97 @@ pQueryRefScriptSizeCmd era envCli = <*> pTarget era <*> (optional $ pOutputFormatJsonOrText "reference inputs") <*> pMaybeOutputFile - where - pByTxIn :: Parser TxIn - pByTxIn = - Opt.option (readerFromParsecParser parseTxIn) $ mconcat + where + pByTxIn :: Parser TxIn + pByTxIn = + Opt.option (readerFromParsecParser parseTxIn) $ + mconcat [ Opt.long "tx-in" , Opt.metavar "TX-IN" , Opt.help "Transaction input (TxId#TxIx)." ] -pQueryGetConstitutionCmd :: () +pQueryGetConstitutionCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (QueryCmds era)) pQueryGetConstitutionCmd era envCli = do w <- forEraMaybeEon era - pure - $ subParser "constitution" - $ Opt.info (QueryConstitutionCmd <$> pQueryNoArgCmdArgs w era envCli) - $ Opt.progDesc "Get the constitution" + pure $ + subParser "constitution" $ + Opt.info (QueryConstitutionCmd <$> pQueryNoArgCmdArgs w era envCli) $ + Opt.progDesc "Get the constitution" -pQueryGetGovStateCmd :: () +pQueryGetGovStateCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (QueryCmds era)) pQueryGetGovStateCmd era envCli = do w <- forEraMaybeEon era - pure - $ subParser "gov-state" - $ Opt.info (QueryGovStateCmd <$> pQueryNoArgCmdArgs w era envCli) - $ Opt.progDesc "Get the governance state" + pure $ + subParser "gov-state" $ + Opt.info (QueryGovStateCmd <$> pQueryNoArgCmdArgs w era envCli) $ + Opt.progDesc "Get the governance state" -- TODO Conway: DRep State and DRep Stake Distribution parsers use DRep keys to obtain DRep credentials. This only -- makes use of 'KeyHashObj' constructor of 'Credential kr c'. Should we also support here 'ScriptHashObj'? -- What about 'DRep c' - this means that only 'KeyHash' constructor is in use here: should also -- 'DRepAlwaysAbstain' and 'DRepAlwaysNoConfidence' be supported here? -pQueryDRepStateCmd :: () +pQueryDRepStateCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (QueryCmds era)) pQueryDRepStateCmd era envCli = do w <- forEraMaybeEon era - pure - $ subParser "drep-state" - $ Opt.info (QueryDRepStateCmd <$> pQueryDRepStateCmdArgs w) - $ Opt.progDesc "Get the DRep state." - where - pQueryDRepStateCmdArgs :: ConwayEraOnwards era -> Parser (QueryDRepStateCmdArgs era) - pQueryDRepStateCmdArgs w = - QueryDRepStateCmdArgs w - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pAllOrOnlyDRepHashSource - <*> Opt.flag NoStake WithStake (mconcat - [ Opt.long "include-stake" - , Opt.help $ mconcat - [ "Also return the stake associated with each DRep. " - , "The result is the same as with \"drep-stake-distribution\"; " - , "this is a convenience option to obtain all information concerning a DRep at once. " - , "This is a potentially expensive query, so it's OFF by default." - ] - ] - ) - <*> pTarget era - <*> optional pOutputFile - -pQueryDRepStakeDistributionCmd :: () + pure $ + subParser "drep-state" $ + Opt.info (QueryDRepStateCmd <$> pQueryDRepStateCmdArgs w) $ + Opt.progDesc "Get the DRep state." + where + pQueryDRepStateCmdArgs :: ConwayEraOnwards era -> Parser (QueryDRepStateCmdArgs era) + pQueryDRepStateCmdArgs w = + QueryDRepStateCmdArgs w + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pAllOrOnlyDRepHashSource + <*> Opt.flag + NoStake + WithStake + ( mconcat + [ Opt.long "include-stake" + , Opt.help $ + mconcat + [ "Also return the stake associated with each DRep. " + , "The result is the same as with \"drep-stake-distribution\"; " + , "this is a convenience option to obtain all information concerning a DRep at once. " + , "This is a potentially expensive query, so it's OFF by default." + ] + ] + ) + <*> pTarget era + <*> optional pOutputFile + +pQueryDRepStakeDistributionCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (QueryCmds era)) pQueryDRepStakeDistributionCmd era envCli = do w <- forEraMaybeEon era - pure - $ subParser "drep-stake-distribution" - $ Opt.info (QueryDRepStakeDistributionCmd <$> pQueryDRepStakeDistributionCmdArgs w) - $ Opt.progDesc "Get the DRep stake distribution." - where - pQueryDRepStakeDistributionCmdArgs :: ConwayEraOnwards era -> Parser (QueryDRepStakeDistributionCmdArgs era) - pQueryDRepStakeDistributionCmdArgs w = QueryDRepStakeDistributionCmdArgs w + pure $ + subParser "drep-stake-distribution" $ + Opt.info (QueryDRepStakeDistributionCmd <$> pQueryDRepStakeDistributionCmdArgs w) $ + Opt.progDesc "Get the DRep stake distribution." + where + pQueryDRepStakeDistributionCmdArgs + :: ConwayEraOnwards era -> Parser (QueryDRepStakeDistributionCmdArgs era) + pQueryDRepStakeDistributionCmdArgs w = + QueryDRepStakeDistributionCmdArgs w <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli @@ -399,19 +425,22 @@ pQueryDRepStakeDistributionCmd era envCli = do <*> pTarget era <*> optional pOutputFile -pQueryGetCommitteeStateCmd :: () +pQueryGetCommitteeStateCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (QueryCmds era)) pQueryGetCommitteeStateCmd era envCli = do w <- forEraMaybeEon era - pure - $ subParser "committee-state" - $ Opt.info (QueryCommitteeMembersStateCmd <$> pQueryCommitteeMembersStateArgs w) - $ Opt.progDesc "Get the committee state" - where - pQueryCommitteeMembersStateArgs :: ConwayEraOnwards era -> Parser (QueryCommitteeMembersStateCmdArgs era) - pQueryCommitteeMembersStateArgs w = QueryCommitteeMembersStateCmdArgs w + pure $ + subParser "committee-state" $ + Opt.info (QueryCommitteeMembersStateCmd <$> pQueryCommitteeMembersStateArgs w) $ + Opt.progDesc "Get the committee state" + where + pQueryCommitteeMembersStateArgs + :: ConwayEraOnwards era -> Parser (QueryCommitteeMembersStateCmdArgs era) + pQueryCommitteeMembersStateArgs w = + QueryCommitteeMembersStateCmdArgs w <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli @@ -421,44 +450,50 @@ pQueryGetCommitteeStateCmd era envCli = do <*> pTarget era <*> optional pOutputFile - pCommitteeColdVerificationKeyOrHashOrFileOrScriptHash :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey) - pCommitteeColdVerificationKeyOrHashOrFileOrScriptHash = - asum - [ VkhfshKeyHashFile <$> pCommitteeColdVerificationKeyOrHashOrFile - , VkhfshScriptHash <$> - pScriptHash - "cold-script-hash" - "Cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." - ] + pCommitteeColdVerificationKeyOrHashOrFileOrScriptHash + :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeColdKey) + pCommitteeColdVerificationKeyOrHashOrFileOrScriptHash = + asum + [ VkhfshKeyHashFile <$> pCommitteeColdVerificationKeyOrHashOrFile + , VkhfshScriptHash + <$> pScriptHash + "cold-script-hash" + "Cold Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." + ] - pCommitteeHotKeyOrHashOrFileOrScriptHash :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey) - pCommitteeHotKeyOrHashOrFileOrScriptHash = - asum - [ VkhfshKeyHashFile <$> pCommitteeHotKeyOrHashOrFile - , VkhfshScriptHash <$> - pScriptHash - "hot-script-hash" - "Hot Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." - ] + pCommitteeHotKeyOrHashOrFileOrScriptHash + :: Parser (VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey) + pCommitteeHotKeyOrHashOrFileOrScriptHash = + asum + [ VkhfshKeyHashFile <$> pCommitteeHotKeyOrHashOrFile + , VkhfshScriptHash + <$> pScriptHash + "hot-script-hash" + "Hot Native or Plutus script file hash (hex-encoded). Obtain it with \"cardano-cli hash script ...\"." + ] - pMemberStatus :: Parser MemberStatus - pMemberStatus = - asum - [ Opt.flag' MemberStatus.Active $ mconcat + pMemberStatus :: Parser MemberStatus + pMemberStatus = + asum + [ Opt.flag' MemberStatus.Active $ + mconcat [ Opt.long "active" , Opt.help "Active committee members (members whose vote will count during ratification)" ] - , Opt.flag' MemberStatus.Expired $ mconcat + , Opt.flag' MemberStatus.Expired $ + mconcat [ Opt.long "expired" , Opt.help "Expired committee members" ] - , Opt.flag' MemberStatus.Unrecognized $ mconcat + , Opt.flag' MemberStatus.Unrecognized $ + mconcat [ Opt.long "unrecognized" , Opt.help "Unrecognized committe members: a hot credential for an unknown cold credential" ] - ] + ] -pQueryNoArgCmdArgs :: () +pQueryNoArgCmdArgs + :: () => ConwayEraOnwards era -> CardanoEra era -> EnvCli diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs index eee0a37309..8757b5fd75 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/StakeAddress.hs @@ -3,7 +3,8 @@ module Cardano.CLI.EraBased.Options.StakeAddress ( pStakeAddressCmds - ) where + ) +where import Cardano.Api @@ -14,15 +15,16 @@ import Cardano.CLI.EraBased.Options.Common import Options.Applicative import qualified Options.Applicative as Opt - -pStakeAddressCmds :: () +pStakeAddressCmds + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressCmds era envCli = - subInfoParser "stake-address" - ( Opt.progDesc - $ mconcat + subInfoParser + "stake-address" + ( Opt.progDesc $ + mconcat [ "Stake address commands." ] ) @@ -36,7 +38,8 @@ pStakeAddressCmds era envCli = , pStakeAddressVoteDelegationCertificateCmd era ] -pStakeAddressKeyGenCmd :: () +pStakeAddressKeyGenCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressKeyGenCmd era = do @@ -44,14 +47,15 @@ pStakeAddressKeyGenCmd era = do pure $ subParser "key-gen" $ Opt.info - ( StakeAddressKeyGenCmd w - <$> pKeyOutputFormat - <*> pVerificationKeyFileOut - <*> pSigningKeyFileOut - ) + ( StakeAddressKeyGenCmd w + <$> pKeyOutputFormat + <*> pVerificationKeyFileOut + <*> pSigningKeyFileOut + ) $ Opt.progDesc "Create a stake address key pair" -pStakeAddressKeyHashCmd :: () +pStakeAddressKeyHashCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressKeyHashCmd era = do @@ -59,13 +63,14 @@ pStakeAddressKeyHashCmd era = do pure $ subParser "key-hash" $ Opt.info - ( StakeAddressKeyHashCmd w - <$> pStakeVerificationKeyOrFile Nothing - <*> pMaybeOutputFile - ) + ( StakeAddressKeyHashCmd w + <$> pStakeVerificationKeyOrFile Nothing + <*> pMaybeOutputFile + ) $ Opt.progDesc "Print the hash of a stake address key" -pStakeAddressBuildCmd :: () +pStakeAddressBuildCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (StakeAddressCmds era)) @@ -74,68 +79,75 @@ pStakeAddressBuildCmd era envCli = do pure $ subParser "build" $ Opt.info - ( StakeAddressBuildCmd w - <$> pStakeVerifier Nothing - <*> pNetworkId envCli - <*> pMaybeOutputFile - ) + ( StakeAddressBuildCmd w + <$> pStakeVerifier Nothing + <*> pNetworkId envCli + <*> pMaybeOutputFile + ) $ Opt.progDesc "Build a stake address" -pStakeAddressRegistrationCertificateCmd :: () +pStakeAddressRegistrationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressRegistrationCertificateCmd era = do forEraInEonMaybe era $ \sbe -> caseShelleyToBabbageOrConwayEraOnwards - (const $ subParser "registration-certificate" - $ Opt.info - ( StakeAddressRegistrationCertificateCmd sbe - <$> pStakeIdentifier Nothing - <*> pure Nothing - <*> pOutputFile - ) - desc + ( const $ + subParser "registration-certificate" $ + Opt.info + ( StakeAddressRegistrationCertificateCmd sbe + <$> pStakeIdentifier Nothing + <*> pure Nothing + <*> pOutputFile + ) + desc ) - (const $ subParser "registration-certificate" - $ Opt.info - ( StakeAddressRegistrationCertificateCmd sbe - <$> pStakeIdentifier Nothing - <*> fmap Just pKeyRegistDeposit - <*> pOutputFile - ) - desc + ( const $ + subParser "registration-certificate" $ + Opt.info + ( StakeAddressRegistrationCertificateCmd sbe + <$> pStakeIdentifier Nothing + <*> fmap Just pKeyRegistDeposit + <*> pOutputFile + ) + desc ) sbe - where - desc = Opt.progDesc "Create a stake address registration certificate" + where + desc = Opt.progDesc "Create a stake address registration certificate" -pStakeAddressDeregistrationCertificateCmd :: () +pStakeAddressDeregistrationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressDeregistrationCertificateCmd era = do forEraInEonMaybe era $ \sbe -> caseShelleyToBabbageOrConwayEraOnwards - (\shelleyToBabbage -> subParser "deregistration-certificate" - $ Opt.info - ( StakeAddressDeregistrationCertificateCmd (shelleyToBabbageEraToShelleyBasedEra shelleyToBabbage) - <$> pStakeIdentifier Nothing - <*> pure Nothing - <*> pOutputFile - ) - $ Opt.progDesc "Create a stake address deregistration certificate" + ( \shelleyToBabbage -> + subParser "deregistration-certificate" + $ Opt.info + ( StakeAddressDeregistrationCertificateCmd (shelleyToBabbageEraToShelleyBasedEra shelleyToBabbage) + <$> pStakeIdentifier Nothing + <*> pure Nothing + <*> pOutputFile + ) + $ Opt.progDesc "Create a stake address deregistration certificate" ) - (\conwayOnwards -> subParser "deregistration-certificate" - $ Opt.info - ( StakeAddressDeregistrationCertificateCmd (conwayEraOnwardsToShelleyBasedEra conwayOnwards) - <$> pStakeIdentifier Nothing - <*> fmap Just pKeyRegistDeposit - <*> pOutputFile - ) - $ Opt.progDesc "Create a stake address deregistration certificate" + ( \conwayOnwards -> + subParser "deregistration-certificate" + $ Opt.info + ( StakeAddressDeregistrationCertificateCmd (conwayEraOnwardsToShelleyBasedEra conwayOnwards) + <$> pStakeIdentifier Nothing + <*> fmap Just pKeyRegistDeposit + <*> pOutputFile + ) + $ Opt.progDesc "Create a stake address deregistration certificate" ) sbe -pStakeAddressStakeDelegationCertificateCmd :: () +pStakeAddressStakeDelegationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressStakeDelegationCertificateCmd era = do @@ -143,18 +155,19 @@ pStakeAddressStakeDelegationCertificateCmd era = do pure $ subParser "stake-delegation-certificate" $ Opt.info - ( StakeAddressStakeDelegationCertificateCmd w - <$> pStakeIdentifier Nothing - <*> pStakePoolVerificationKeyOrHashOrFile Nothing - <*> pOutputFile - ) + ( StakeAddressStakeDelegationCertificateCmd w + <$> pStakeIdentifier Nothing + <*> pStakePoolVerificationKeyOrHashOrFile Nothing + <*> pOutputFile + ) $ Opt.progDesc $ mconcat - [ "Create a stake address stake delegation certificate, which when submitted in a transaction " - , "delegates stake to a stake pool." - ] + [ "Create a stake address stake delegation certificate, which when submitted in a transaction " + , "delegates stake to a stake pool." + ] -pStakeAddressStakeAndVoteDelegationCertificateCmd :: () +pStakeAddressStakeAndVoteDelegationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressStakeAndVoteDelegationCertificateCmd era = do @@ -162,19 +175,20 @@ pStakeAddressStakeAndVoteDelegationCertificateCmd era = do pure $ subParser "stake-and-vote-delegation-certificate" $ Opt.info - ( StakeAddressStakeAndVoteDelegationCertificateCmd w - <$> pStakeIdentifier Nothing - <*> pStakePoolVerificationKeyOrHashOrFile Nothing - <*> pVoteDelegationTarget - <*> pOutputFile - ) + ( StakeAddressStakeAndVoteDelegationCertificateCmd w + <$> pStakeIdentifier Nothing + <*> pStakePoolVerificationKeyOrHashOrFile Nothing + <*> pVoteDelegationTarget + <*> pOutputFile + ) $ Opt.progDesc $ mconcat - [ "Create a stake address stake and vote delegation certificate, which when submitted in a transaction " - , "delegates stake to a stake pool and a DRep." - ] + [ "Create a stake address stake and vote delegation certificate, which when submitted in a transaction " + , "delegates stake to a stake pool and a DRep." + ] -pStakeAddressVoteDelegationCertificateCmd :: () +pStakeAddressVoteDelegationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (StakeAddressCmds era)) pStakeAddressVoteDelegationCertificateCmd era = do @@ -182,13 +196,13 @@ pStakeAddressVoteDelegationCertificateCmd era = do pure $ subParser "vote-delegation-certificate" $ Opt.info - ( StakeAddressVoteDelegationCertificateCmd w - <$> pStakeIdentifier Nothing - <*> pVoteDelegationTarget - <*> pOutputFile - ) + ( StakeAddressVoteDelegationCertificateCmd w + <$> pStakeIdentifier Nothing + <*> pVoteDelegationTarget + <*> pOutputFile + ) $ Opt.progDesc $ mconcat - [ "Create a stake address vote delegation certificate, which when submitted in a transaction " - , "delegates stake to a DRep." - ] + [ "Create a stake address vote delegation certificate, which when submitted in a transaction " + , "delegates stake to a DRep." + ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/StakePool.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/StakePool.hs index 61685b59b8..86ac74f65c 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/StakePool.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/StakePool.hs @@ -8,7 +8,8 @@ module Cardano.CLI.EraBased.Options.StakePool ( pStakePoolCmds - ) where + ) +where import Cardano.Api @@ -19,30 +20,33 @@ import Cardano.CLI.EraBased.Options.Common import Options.Applicative hiding (help, str) import qualified Options.Applicative as Opt -pStakePoolCmds :: () +pStakePoolCmds + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (Cmd.StakePoolCmds era)) pStakePoolCmds era envCli = - subInfoParser "stake-pool" - ( Opt.progDesc - $ mconcat + subInfoParser + "stake-pool" + ( Opt.progDesc $ + mconcat [ "Stake pool commands." ] ) [ pStakePoolRegistrationCertificateCmd era envCli , pStakePoolDeregistrationCertificateCmd era - , Just - $ subParser "id" - $ Opt.info pStakePoolId - $ Opt.progDesc "Build pool id from the offline key" - , Just - $ subParser "metadata-hash" - $ Opt.info pStakePoolMetadataHashCmd - $ Opt.progDesc "Print the hash of pool metadata." + , Just $ + subParser "id" $ + Opt.info pStakePoolId $ + Opt.progDesc "Build pool id from the offline key" + , Just $ + subParser "metadata-hash" $ + Opt.info pStakePoolMetadataHashCmd $ + Opt.progDesc "Print the hash of pool metadata." ] -pStakePoolId :: () +pStakePoolId + :: () => Parser (Cmd.StakePoolCmds era) pStakePoolId = fmap Cmd.StakePoolIdCmd $ @@ -51,7 +55,8 @@ pStakePoolId = <*> pPoolIdOutputFormat <*> pMaybeOutputFile -pStakePoolMetadataHashCmd :: () +pStakePoolMetadataHashCmd + :: () => Parser (Cmd.StakePoolCmds era) pStakePoolMetadataHashCmd = fmap Cmd.StakePoolMetadataHashCmd $ @@ -59,7 +64,8 @@ pStakePoolMetadataHashCmd = <$> pPoolMetadataFile <*> pMaybeOutputFile -pStakePoolRegistrationCertificateCmd :: () +pStakePoolRegistrationCertificateCmd + :: () => CardanoEra era -> EnvCli -> Maybe (Parser (Cmd.StakePoolCmds era)) @@ -68,23 +74,24 @@ pStakePoolRegistrationCertificateCmd era envCli = do pure $ subParser "registration-certificate" $ Opt.info - ( fmap Cmd.StakePoolRegistrationCertificateCmd $ - Cmd.StakePoolRegistrationCertificateCmdArgs w - <$> pStakePoolVerificationKeyOrFile Nothing - <*> pVrfVerificationKeyOrFile - <*> pPoolPledge - <*> pPoolCost - <*> pPoolMargin - <*> pRewardAcctVerificationKeyOrFile - <*> some pPoolOwnerVerificationKeyOrFile - <*> many pPoolRelay - <*> pStakePoolMetadataReference - <*> pNetworkId envCli - <*> pOutputFile - ) + ( fmap Cmd.StakePoolRegistrationCertificateCmd $ + Cmd.StakePoolRegistrationCertificateCmdArgs w + <$> pStakePoolVerificationKeyOrFile Nothing + <*> pVrfVerificationKeyOrFile + <*> pPoolPledge + <*> pPoolCost + <*> pPoolMargin + <*> pRewardAcctVerificationKeyOrFile + <*> some pPoolOwnerVerificationKeyOrFile + <*> many pPoolRelay + <*> pStakePoolMetadataReference + <*> pNetworkId envCli + <*> pOutputFile + ) $ Opt.progDesc "Create a stake pool registration certificate" -pStakePoolDeregistrationCertificateCmd :: () +pStakePoolDeregistrationCertificateCmd + :: () => CardanoEra era -> Maybe (Parser (Cmd.StakePoolCmds era)) pStakePoolDeregistrationCertificateCmd era = do @@ -92,10 +99,10 @@ pStakePoolDeregistrationCertificateCmd era = do pure $ subParser "deregistration-certificate" $ Opt.info - ( fmap Cmd.StakePoolDeregistrationCertificateCmd $ - Cmd.StakePoolDeregistrationCertificateCmdArgs w - <$> pStakePoolVerificationKeyOrFile Nothing - <*> pEpochNo "The epoch number." - <*> pOutputFile - ) + ( fmap Cmd.StakePoolDeregistrationCertificateCmd $ + Cmd.StakePoolDeregistrationCertificateCmdArgs w + <$> pStakePoolVerificationKeyOrFile Nothing + <*> pEpochNo "The epoch number." + <*> pOutputFile + ) $ Opt.progDesc "Create a stake pool deregistration certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/TextView.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/TextView.hs index 386ad63819..c230cc3f91 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/TextView.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/TextView.hs @@ -5,7 +5,8 @@ module Cardano.CLI.EraBased.Options.TextView ( pTextViewCmds - ) where + ) +where import Cardano.CLI.EraBased.Commands.TextView import Cardano.CLI.EraBased.Options.Common @@ -18,15 +19,16 @@ import qualified Options.Applicative as Opt pTextViewCmds :: Maybe (Parser (TextViewCmds era)) pTextViewCmds = - subInfoParser "text-view" - ( Opt.progDesc - $ mconcat + subInfoParser + "text-view" + ( Opt.progDesc $ + mconcat [ "Commands for dealing with Shelley TextView files. Transactions, addresses etc " , "are stored on disk as TextView files." ] ) - [ Just - $ subParser "decode-cbor" - $ Opt.info (TextViewInfo <$> pCBORInFile <*> pMaybeOutputFile) - $ Opt.progDesc "Print a TextView file as decoded CBOR." + [ Just $ + subParser "decode-cbor" $ + Opt.info (TextViewInfo <$> pCBORInFile <*> pMaybeOutputFile) $ + Opt.progDesc "Print a TextView file as decoded CBOR." ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs index be4fb8816d..a5d8a7c7d3 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Options/Transaction.hs @@ -6,7 +6,8 @@ module Cardano.CLI.EraBased.Options.Transaction ( pTransactionCmds - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) @@ -24,230 +25,250 @@ import Prettyprinter (line) {- HLINT ignore "Use <$>" -} {- HLINT ignore "Move brackets to avoid $" -} -pTransactionCmds :: () +pTransactionCmds + :: () => ShelleyBasedEra era -> EnvCli -> Maybe (Parser (TransactionCmds era)) pTransactionCmds era envCli = - subInfoParser "transaction" - ( Opt.progDesc - $ mconcat + subInfoParser + "transaction" + ( Opt.progDesc $ + mconcat [ "Transaction commands." ] ) - [ Just - $ subParser "build-raw" - $ Opt.info (pTransactionBuildRaw era) - $ Opt.progDescDoc - $ Just $ mconcat - [ pretty @String "Build a transaction (low-level, inconvenient)" - , line - , line - , H.yellow $ mconcat - [ "Please note the order of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] - ] + [ Just $ + subParser "build-raw" $ + Opt.info (pTransactionBuildRaw era) $ + Opt.progDescDoc $ + Just $ + mconcat + [ pretty @String "Build a transaction (low-level, inconvenient)" + , line + , line + , H.yellow $ + mconcat + [ "Please note the order of some cmd options is crucial. If used incorrectly may produce " + , "undesired tx body. See nested [] notation above for details." + ] + ] , pTransactionBuildCmd era envCli , forShelleyBasedEraInEon era Nothing (`pTransactionBuildEstimateCmd` envCli) - , Just - $ subParser "sign" - $ Opt.info (pTransactionSign envCli) - $ Opt.progDesc "Sign a transaction" - , Just - $ subParser "witness" - $ Opt.info (pTransactionCreateWitness envCli) - $ Opt.progDesc "Create a transaction witness" - , Just - $ subParser "assemble" - $ Opt.info pTransactionAssembleTxBodyWit - $ Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" + , Just $ + subParser "sign" $ + Opt.info (pTransactionSign envCli) $ + Opt.progDesc "Sign a transaction" + , Just $ + subParser "witness" $ + Opt.info (pTransactionCreateWitness envCli) $ + Opt.progDesc "Create a transaction witness" + , Just $ + subParser "assemble" $ + Opt.info pTransactionAssembleTxBodyWit $ + Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" , Just pSignWitnessBackwardCompatible - , Just - $ subParser "submit" - $ Opt.info (pTransactionSubmit envCli) - $ Opt.progDesc - $ mconcat - [ "Submit a transaction to the local node whose Unix domain socket " - , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." - ] - , Just - $ subParser "policyid" - $ Opt.info pTransactionPolicyId - $ Opt.progDesc "Calculate the PolicyId from the monetary policy script." - , Just - $ subParser "calculate-min-fee" - $ Opt.info pTransactionCalculateMinFee - $ Opt.progDesc "Calculate the minimum fee for a transaction." - , Just $ subParser "calculate-min-required-utxo" - $ Opt.info (pTransactionCalculateMinReqUTxO era) - $ Opt.progDesc "Calculate the minimum required UTxO for a transaction output." + , Just $ + subParser "submit" $ + Opt.info (pTransactionSubmit envCli) $ + Opt.progDesc $ + mconcat + [ "Submit a transaction to the local node whose Unix domain socket " + , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." + ] + , Just $ + subParser "policyid" $ + Opt.info pTransactionPolicyId $ + Opt.progDesc "Calculate the PolicyId from the monetary policy script." + , Just $ + subParser "calculate-min-fee" $ + Opt.info pTransactionCalculateMinFee $ + Opt.progDesc "Calculate the minimum fee for a transaction." + , Just $ + subParser "calculate-min-required-utxo" $ + Opt.info (pTransactionCalculateMinReqUTxO era) $ + Opt.progDesc "Calculate the minimum required UTxO for a transaction output." , Just $ pCalculateMinRequiredUtxoBackwardCompatible era - , Just - $ subParser "hash-script-data" - $ Opt.info pTxHashScriptData - $ Opt.progDesc "Calculate the hash of script data." - , Just - $ subParser "txid" - $ Opt.info pTransactionId - $ Opt.progDesc "Print a transaction identifier." - , Just - $ subParser "view" - $ Opt.info pTransactionView - $ Opt.progDesc "Print a transaction." + , Just $ + subParser "hash-script-data" $ + Opt.info pTxHashScriptData $ + Opt.progDesc "Calculate the hash of script data." + , Just $ + subParser "txid" $ + Opt.info pTransactionId $ + Opt.progDesc "Print a transaction identifier." + , Just $ + subParser "view" $ + Opt.info pTransactionView $ + Opt.progDesc "Print a transaction." ] -- Backwards compatible parsers calcMinValueInfo :: ShelleyBasedEra era -> ParserInfo (TransactionCmds era) calcMinValueInfo era = - Opt.info (pTransactionCalculateMinReqUTxO era) - $ Opt.progDesc "DEPRECATED: Use 'calculate-min-required-utxo' instead." + Opt.info (pTransactionCalculateMinReqUTxO era) $ + Opt.progDesc "DEPRECATED: Use 'calculate-min-required-utxo' instead." pCalculateMinRequiredUtxoBackwardCompatible :: ShelleyBasedEra era -> Parser (TransactionCmds era) pCalculateMinRequiredUtxoBackwardCompatible era = - Opt.subparser - $ Opt.command "calculate-min-value" (calcMinValueInfo era) <> Opt.internal + Opt.subparser $ + Opt.command "calculate-min-value" (calcMinValueInfo era) <> Opt.internal assembleInfo :: ParserInfo (TransactionCmds era) assembleInfo = - Opt.info pTransactionAssembleTxBodyWit - $ Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" + Opt.info pTransactionAssembleTxBodyWit $ + Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" pSignWitnessBackwardCompatible :: Parser (TransactionCmds era) pSignWitnessBackwardCompatible = - Opt.subparser - $ Opt.command "sign-witness" assembleInfo <> Opt.internal + Opt.subparser $ + Opt.command "sign-witness" assembleInfo <> Opt.internal pScriptValidity :: Parser ScriptValidity -pScriptValidity = asum - [ Opt.flag' ScriptValid $ mconcat - [ Opt.long "script-valid" - , Opt.help "Assertion that the script is valid. (default)" - ] - , Opt.flag' ScriptInvalid $ mconcat - [ Opt.long "script-invalid" - , Opt.help $ mconcat - [ "Assertion that the script is invalid. " - , "If a transaction is submitted with such a script, " - , "the script will fail and the collateral will be taken." - ] +pScriptValidity = + asum + [ Opt.flag' ScriptValid $ + mconcat + [ Opt.long "script-valid" + , Opt.help "Assertion that the script is valid. (default)" + ] + , Opt.flag' ScriptInvalid $ + mconcat + [ Opt.long "script-invalid" + , Opt.help $ + mconcat + [ "Assertion that the script is invalid. " + , "If a transaction is submitted with such a script, " + , "the script will fail and the collateral will be taken." + ] + ] ] - ] pTransactionBuildCmd :: ShelleyBasedEra era -> EnvCli -> Maybe (Parser (TransactionCmds era)) pTransactionBuildCmd era envCli = do - pure - $ subParser "build" - $ Opt.info (pCmd era) - $ Opt.progDescDoc - $ Just $ mconcat - [ pretty @String "Build a balanced transaction (automatically calculates fees)" - , line - , line - , H.yellow $ mconcat - [ "Please note " - , H.underline "the order" - , " of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] - ] - where - pCmd :: ShelleyBasedEra era -> Parser (TransactionCmds era) - pCmd sbe = - fmap TransactionBuildCmd $ - TransactionBuildCmdArgs sbe - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> optional pScriptValidity - <*> optional pWitnessOverride - <*> some (pTxIn AutoBalance) - <*> many pReadOnlyReferenceTxIn - <*> many pRequiredSigner - <*> many pTxInCollateral - <*> optional pReturnCollateral - <*> optional pTotalCollateral - <*> many pTxOut - <*> pChangeAddress - <*> optional (pMintMultiAsset AutoBalance) - <*> optional pInvalidBefore - <*> pInvalidHereafter sbe - <*> many (pCertificateFile AutoBalance) - <*> many (pWithdrawal AutoBalance) - <*> pTxMetadataJsonSchema - <*> many (pScriptFor - "auxiliary-script-file" - Nothing - "Filepath of auxiliary script(s)") - <*> many pMetadataFile - <*> pFeatured (toCardanoEra sbe) (optional pUpdateProposalFile) - <*> pVoteFiles sbe AutoBalance - <*> pProposalFiles sbe AutoBalance - <*> pTreasuryDonation sbe - <*> pTxBuildOutputOptions + pure $ + subParser "build" $ + Opt.info (pCmd era) $ + Opt.progDescDoc $ + Just $ + mconcat + [ pretty @String "Build a balanced transaction (automatically calculates fees)" + , line + , line + , H.yellow $ + mconcat + [ "Please note " + , H.underline "the order" + , " of some cmd options is crucial. If used incorrectly may produce " + , "undesired tx body. See nested [] notation above for details." + ] + ] + where + pCmd :: ShelleyBasedEra era -> Parser (TransactionCmds era) + pCmd sbe = + fmap TransactionBuildCmd $ + TransactionBuildCmdArgs sbe + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> optional pScriptValidity + <*> optional pWitnessOverride + <*> some (pTxIn AutoBalance) + <*> many pReadOnlyReferenceTxIn + <*> many pRequiredSigner + <*> many pTxInCollateral + <*> optional pReturnCollateral + <*> optional pTotalCollateral + <*> many pTxOut + <*> pChangeAddress + <*> optional (pMintMultiAsset AutoBalance) + <*> optional pInvalidBefore + <*> pInvalidHereafter sbe + <*> many (pCertificateFile AutoBalance) + <*> many (pWithdrawal AutoBalance) + <*> pTxMetadataJsonSchema + <*> many + ( pScriptFor + "auxiliary-script-file" + Nothing + "Filepath of auxiliary script(s)" + ) + <*> many pMetadataFile + <*> pFeatured (toCardanoEra sbe) (optional pUpdateProposalFile) + <*> pVoteFiles sbe AutoBalance + <*> pProposalFiles sbe AutoBalance + <*> pTreasuryDonation sbe + <*> pTxBuildOutputOptions -- | Estimate the transaction fees without access to a live node. pTransactionBuildEstimateCmd :: MaryEraOnwards era -> EnvCli -> Maybe (Parser (TransactionCmds era)) pTransactionBuildEstimateCmd era _envCli = do - pure - $ subParser "build-estimate" - $ Opt.info (pCmd era) - $ Opt.progDescDoc - $ Just $ mconcat - [ pretty @String "Build a balanced transaction without access to a live node (automatically estimates fees)" - , line - , line - , H.yellow $ mconcat - [ "Please note " - , H.underline "the order" - , " of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] - ] - where - pCmd :: MaryEraOnwards era -> Parser (TransactionCmds era) - pCmd w = do - let sbe = maryEraOnwardsToShelleyBasedEra w - fmap TransactionBuildEstimateCmd $ - TransactionBuildEstimateCmdArgs w - <$> optional pScriptValidity - <*> pNumberOfShelleyKeyWitnesses - <*> optional pNumberOfByronKeyWitnesses - <*> pProtocolParamsFile - <*> pTotalUTxOValue - <*> some (pTxIn ManualBalance) - <*> many pReadOnlyReferenceTxIn - <*> many pRequiredSigner - <*> many pTxInCollateral - <*> optional pReturnCollateral - <*> many pTxOut - <*> pChangeAddress - <*> optional (pMintMultiAsset ManualBalance) - <*> optional pInvalidBefore - <*> pInvalidHereafter sbe - <*> many (pCertificateFile ManualBalance) - <*> many (pWithdrawal ManualBalance) - <*> optional pTotalCollateral - <*> optional pReferenceScriptSize - <*> pTxMetadataJsonSchema - <*> many (pScriptFor - "auxiliary-script-file" - Nothing - "Filepath of auxiliary script(s)") - <*> many pMetadataFile - <*> pFeatured (toCardanoEra sbe) (optional pUpdateProposalFile) - <*> pVoteFiles sbe ManualBalance - <*> pProposalFiles sbe ManualBalance - <*> pCurrentTreasuryValueAndDonation sbe - <*> pTxBodyFileOut + pure $ + subParser "build-estimate" $ + Opt.info (pCmd era) $ + Opt.progDescDoc $ + Just $ + mconcat + [ pretty @String + "Build a balanced transaction without access to a live node (automatically estimates fees)" + , line + , line + , H.yellow $ + mconcat + [ "Please note " + , H.underline "the order" + , " of some cmd options is crucial. If used incorrectly may produce " + , "undesired tx body. See nested [] notation above for details." + ] + ] + where + pCmd :: MaryEraOnwards era -> Parser (TransactionCmds era) + pCmd w = do + let sbe = maryEraOnwardsToShelleyBasedEra w + fmap TransactionBuildEstimateCmd $ + TransactionBuildEstimateCmdArgs w + <$> optional pScriptValidity + <*> pNumberOfShelleyKeyWitnesses + <*> optional pNumberOfByronKeyWitnesses + <*> pProtocolParamsFile + <*> pTotalUTxOValue + <*> some (pTxIn ManualBalance) + <*> many pReadOnlyReferenceTxIn + <*> many pRequiredSigner + <*> many pTxInCollateral + <*> optional pReturnCollateral + <*> many pTxOut + <*> pChangeAddress + <*> optional (pMintMultiAsset ManualBalance) + <*> optional pInvalidBefore + <*> pInvalidHereafter sbe + <*> many (pCertificateFile ManualBalance) + <*> many (pWithdrawal ManualBalance) + <*> optional pTotalCollateral + <*> optional pReferenceScriptSize + <*> pTxMetadataJsonSchema + <*> many + ( pScriptFor + "auxiliary-script-file" + Nothing + "Filepath of auxiliary script(s)" + ) + <*> many pMetadataFile + <*> pFeatured (toCardanoEra sbe) (optional pUpdateProposalFile) + <*> pVoteFiles sbe ManualBalance + <*> pProposalFiles sbe ManualBalance + <*> pCurrentTreasuryValueAndDonation sbe + <*> pTxBodyFileOut pChangeAddress :: Parser TxOutChangeAddress pChangeAddress = - fmap TxOutChangeAddress $ Opt.option (readerFromParsecParser parseAddressAny) $ mconcat - [ Opt.long "change-address" - , Opt.metavar "ADDRESS" - , Opt.help "Address where ADA in excess of the tx fee will go to." - ] + fmap TxOutChangeAddress $ + Opt.option (readerFromParsecParser parseAddressAny) $ + mconcat + [ Opt.long "change-address" + , Opt.metavar "ADDRESS" + , Opt.help "Address where ADA in excess of the tx fee will go to." + ] pTransactionBuildRaw :: ShelleyBasedEra era -> Parser (TransactionCmds era) pTransactionBuildRaw era = @@ -265,7 +286,7 @@ pTransactionBuildRaw era = <*> optional pInvalidBefore <*> pInvalidHereafter era <*> pTxFee - <*> many (pCertificateFile ManualBalance ) + <*> many (pCertificateFile ManualBalance) <*> many (pWithdrawal ManualBalance) <*> pTxMetadataJsonSchema <*> many (pScriptFor "auxiliary-script-file" Nothing "Filepath of auxiliary script(s)") @@ -277,7 +298,7 @@ pTransactionBuildRaw era = <*> pCurrentTreasuryValueAndDonation era <*> pTxBodyFileOut -pTransactionSign :: EnvCli -> Parser (TransactionCmds era) +pTransactionSign :: EnvCli -> Parser (TransactionCmds era) pTransactionSign envCli = fmap TransactionSignCmd $ TransactionSignCmdArgs @@ -330,9 +351,9 @@ pTransactionCalculateMinFee = <*> (optional $ pOutputFormatJsonOrText "calculate-min-fee") <*> optional pOutputFile -- Deprecated options: - <* optional pNetworkIdDeprecated - <* optional pTxInCountDeprecated - <* optional pTxOutCountDeprecated + <* optional pNetworkIdDeprecated + <* optional pTxInCountDeprecated + <* optional pTxOutCountDeprecated pTransactionCalculateMinReqUTxO :: ShelleyBasedEra era -> Parser (TransactionCmds era) pTransactionCalculateMinReqUTxO era = @@ -346,11 +367,11 @@ pTxHashScriptData = fmap TransactionHashScriptDataCmd $ TransactionHashScriptDataCmdArgs <$> pScriptDataOrFile - "script-data" - "The script data." - "The script data file." + "script-data" + "The script data." + "The script data file." -pTransactionId :: Parser (TransactionCmds era) +pTransactionId :: Parser (TransactionCmds era) pTransactionId = fmap TransactionTxIdCmd $ TransactionTxIdCmdArgs diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run.hs index b3157cdfce..d3e9762b43 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run.hs @@ -5,7 +5,8 @@ module Cardano.CLI.EraBased.Run ( runAnyEraCommand , runCmds , runGovernanceCmds - ) where + ) +where import Cardano.Api @@ -24,14 +25,16 @@ import Cardano.CLI.Types.Errors.CmdError import Data.Function ((&)) -runAnyEraCommand :: () +runAnyEraCommand + :: () => AnyEraCommand -> ExceptT CmdError IO () runAnyEraCommand = \case AnyEraCommandOf sbe cmd -> shelleyBasedEraConstraints sbe $ runCmds cmd -runCmds :: () +runCmds + :: () => Cmds era -> ExceptT CmdError IO () runCmds = \case diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Address.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Address.hs index a48aa69465..6850d92e21 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Address.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Address.hs @@ -12,7 +12,8 @@ module Cardano.CLI.EraBased.Run.Address , runAddressKeyHashCmd , buildShelleyAddress , generateAndWriteKeyFiles - ) where + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -32,7 +33,8 @@ import qualified Data.ByteString.Char8 as BS import Data.Function import qualified Data.Text.IO as Text -runAddressCmds :: () +runAddressCmds + :: () => AddressCmds era -> ExceptT AddressCmdError IO () runAddressCmds = \case @@ -52,11 +54,12 @@ runAddressKeyGenCmd -> SigningKeyFile Out -> ExceptT AddressCmdError IO () runAddressKeyGenCmd fmt kt vkf skf = case kt of - AddressKeyShelley -> void $ generateAndWriteKeyFiles fmt AsPaymentKey vkf skf + AddressKeyShelley -> void $ generateAndWriteKeyFiles fmt AsPaymentKey vkf skf AddressKeyShelleyExtended -> void $ generateAndWriteKeyFiles fmt AsPaymentExtendedKey vkf skf - AddressKeyByron -> generateAndWriteByronKeyFiles AsByronKey vkf skf + AddressKeyByron -> generateAndWriteByronKeyFiles AsByronKey vkf skf -generateAndWriteByronKeyFiles :: () +generateAndWriteByronKeyFiles + :: () => Key keyrole => HasTypeProxy keyrole => AsType keyrole @@ -66,7 +69,8 @@ generateAndWriteByronKeyFiles :: () generateAndWriteByronKeyFiles asType vkf skf = do uncurry (writeByronPaymentKeyFiles vkf skf) =<< liftIO (generateKeyPair asType) -generateAndWriteKeyFiles :: () +generateAndWriteKeyFiles + :: () => Key keyrole => HasTypeProxy keyrole => SerialiseAsBech32 (SigningKey keyrole) @@ -95,86 +99,88 @@ writePaymentKeyFiles fmt vkeyPath skeyPath vkey skey = do firstExceptT AddressCmdWriteFileError $ do case fmt of KeyOutputFormatTextEnvelope -> - newExceptT - $ writeLazyByteStringFile skeyPath - $ textEnvelopeToJSON (Just skeyDesc) skey + newExceptT $ + writeLazyByteStringFile skeyPath $ + textEnvelopeToJSON (Just skeyDesc) skey KeyOutputFormatBech32 -> - newExceptT - $ writeTextFile skeyPath - $ serialiseToBech32 skey + newExceptT $ + writeTextFile skeyPath $ + serialiseToBech32 skey case fmt of KeyOutputFormatTextEnvelope -> - newExceptT - $ writeLazyByteStringFile vkeyPath - $ textEnvelopeToJSON (Just Key.paymentVkeyDesc) vkey + newExceptT $ + writeLazyByteStringFile vkeyPath $ + textEnvelopeToJSON (Just Key.paymentVkeyDesc) vkey KeyOutputFormatBech32 -> - newExceptT - $ writeTextFile vkeyPath - $ serialiseToBech32 vkey - - where - skeyDesc :: TextEnvelopeDescr - skeyDesc = "Payment Signing Key" + newExceptT $ + writeTextFile vkeyPath $ + serialiseToBech32 vkey + where + skeyDesc :: TextEnvelopeDescr + skeyDesc = "Payment Signing Key" writeByronPaymentKeyFiles - :: Key keyrole - => VerificationKeyFile Out - -> SigningKeyFile Out - -> VerificationKey keyrole - -> SigningKey keyrole - -> ExceptT AddressCmdError IO () + :: Key keyrole + => VerificationKeyFile Out + -> SigningKeyFile Out + -> VerificationKey keyrole + -> SigningKey keyrole + -> ExceptT AddressCmdError IO () writeByronPaymentKeyFiles vkeyPath skeyPath vkey skey = do firstExceptT AddressCmdWriteFileError $ do -- No bech32 encoding for Byron keys newExceptT $ writeLazyByteStringFile skeyPath $ textEnvelopeToJSON (Just skeyDesc) skey newExceptT $ writeLazyByteStringFile vkeyPath $ textEnvelopeToJSON (Just Key.paymentVkeyDesc) vkey - where - skeyDesc :: TextEnvelopeDescr - skeyDesc = "Payment Signing Key" + where + skeyDesc :: TextEnvelopeDescr + skeyDesc = "Payment Signing Key" -runAddressKeyHashCmd :: VerificationKeyTextOrFile - -> Maybe (File () Out) - -> ExceptT AddressCmdError IO () +runAddressKeyHashCmd + :: VerificationKeyTextOrFile + -> Maybe (File () Out) + -> ExceptT AddressCmdError IO () runAddressKeyHashCmd vkeyTextOrFile mOutputFp = do - vkey <- firstExceptT AddressCmdVerificationKeyTextOrFileError $ - newExceptT $ readVerificationKeyTextOrFileAnyOf vkeyTextOrFile + vkey <- + firstExceptT AddressCmdVerificationKeyTextOrFileError $ + newExceptT $ + readVerificationKeyTextOrFileAnyOf vkeyTextOrFile - let hexKeyHash = mapSomeAddressVerificationKey - (serialiseToRawBytesHex . verificationKeyHash) vkey + let hexKeyHash = + mapSomeAddressVerificationKey + (serialiseToRawBytesHex . verificationKeyHash) + vkey case mOutputFp of Just (File fpath) -> liftIO $ BS.writeFile fpath hexKeyHash Nothing -> liftIO $ BS.putStrLn hexKeyHash - -runAddressBuildCmd :: PaymentVerifier - -> Maybe StakeIdentifier - -> NetworkId - -> Maybe (File () Out) - -> ExceptT AddressCmdError IO () +runAddressBuildCmd + :: PaymentVerifier + -> Maybe StakeIdentifier + -> NetworkId + -> Maybe (File () Out) + -> ExceptT AddressCmdError IO () runAddressBuildCmd paymentVerifier mbStakeVerifier nw mOutFp = do outText <- case paymentVerifier of PaymentVerifierKey payVkeyTextOrFile -> do - payVKey <- firstExceptT AddressCmdVerificationKeyTextOrFileError $ - newExceptT $ readVerificationKeyTextOrFileAnyOf payVkeyTextOrFile + payVKey <- + firstExceptT AddressCmdVerificationKeyTextOrFileError $ + newExceptT $ + readVerificationKeyTextOrFileAnyOf payVkeyTextOrFile addr <- case payVKey of AByronVerificationKey vk -> return (AddressByron (makeByronAddress nw vk)) - APaymentVerificationKey vk -> AddressShelley <$> buildShelleyAddress vk mbStakeVerifier nw - APaymentExtendedVerificationKey vk -> AddressShelley <$> buildShelleyAddress (castVerificationKey vk) mbStakeVerifier nw - AGenesisUTxOVerificationKey vk -> AddressShelley <$> buildShelleyAddress (castVerificationKey vk) mbStakeVerifier nw nonPaymentKey -> left $ AddressCmdExpectedPaymentVerificationKey nonPaymentKey return $ serialiseAddress (addr :: AddressAny) - PaymentVerifierScriptFile (File fp) -> do ScriptInAnyLang _lang script <- firstExceptT AddressCmdReadScriptFileError $ @@ -188,7 +194,7 @@ runAddressBuildCmd paymentVerifier mbStakeVerifier nw mOutFp = do case mOutFp of Just (File fpath) -> liftIO $ Text.writeFile fpath outText - Nothing -> liftIO $ Text.putStr outText + Nothing -> liftIO $ Text.putStr outText makeStakeAddressRef :: StakeIdentifier @@ -198,10 +204,10 @@ makeStakeAddressRef stakeIdentifier = StakeIdentifierVerifier stakeVerifier -> case stakeVerifier of StakeVerifierKey stkVkeyOrFile -> do - stakeVKeyHash <- modifyError AddressCmdReadKeyFileError $ - readVerificationKeyOrHashOrFile AsStakeKey stkVkeyOrFile + stakeVKeyHash <- + modifyError AddressCmdReadKeyFileError $ + readVerificationKeyOrHashOrFile AsStakeKey stkVkeyOrFile return . StakeAddressByValue $ StakeCredentialByKey stakeVKeyHash - StakeVerifierScriptFile (File fp) -> do ScriptInAnyLang _lang script <- firstExceptT AddressCmdReadScriptFileError $ @@ -210,7 +216,7 @@ makeStakeAddressRef stakeIdentifier = let stakeCred = StakeCredentialByScript (hashScript script) return (StakeAddressByValue stakeCred) StakeIdentifierAddress stakeAddr -> - pure $ StakeAddressByValue $ stakeAddressCredential stakeAddr + pure $ StakeAddressByValue $ stakeAddressCredential stakeAddr buildShelleyAddress :: VerificationKey PaymentKey @@ -218,4 +224,5 @@ buildShelleyAddress -> NetworkId -> ExceptT AddressCmdError IO (Address ShelleyAddr) buildShelleyAddress vkey mbStakeVerifier nw = - makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash vkey)) <$> maybe (return NoStakeAddress) makeStakeAddressRef mbStakeVerifier \ No newline at end of file + makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash vkey)) + <$> maybe (return NoStakeAddress) makeStakeAddressRef mbStakeVerifier diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Address/Info.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Address/Info.hs index fe71b29d72..ba3623c02b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Address/Info.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Address/Info.hs @@ -3,7 +3,8 @@ module Cardano.CLI.EraBased.Run.Address.Info ( runAddressInfoCmd - ) where + ) +where import Cardano.Api @@ -35,32 +36,31 @@ instance ToJSON AddressInfo where runAddressInfoCmd :: Text -> Maybe (File () Out) -> ExceptT AddressInfoError IO () runAddressInfoCmd addrTxt mOutputFp = do - addrInfo <- case (Left <$> deserialiseAddress AsAddressAny addrTxt) - <|> (Right <$> deserialiseAddress AsStakeAddress addrTxt) of - - Nothing -> - left $ ShelleyAddressInvalid addrTxt - - Just (Left (AddressByron payaddr)) -> - pure $ AddressInfo - { aiType = "payment" - , aiEra = "byron" - , aiEncoding = "base58" - , aiAddress = addrTxt - , aiBase16 = serialiseToRawBytesHexText payaddr - } - - Just (Left (AddressShelley payaddr)) -> - pure $ AddressInfo - { aiType = "payment" - , aiEra = "shelley" - , aiEncoding = "bech32" - , aiAddress = addrTxt - , aiBase16 = serialiseToRawBytesHexText payaddr - } - - Just (Right addr) -> - pure $ AddressInfo + addrInfo <- case (Left <$> deserialiseAddress AsAddressAny addrTxt) + <|> (Right <$> deserialiseAddress AsStakeAddress addrTxt) of + Nothing -> + left $ ShelleyAddressInvalid addrTxt + Just (Left (AddressByron payaddr)) -> + pure $ + AddressInfo + { aiType = "payment" + , aiEra = "byron" + , aiEncoding = "base58" + , aiAddress = addrTxt + , aiBase16 = serialiseToRawBytesHexText payaddr + } + Just (Left (AddressShelley payaddr)) -> + pure $ + AddressInfo + { aiType = "payment" + , aiEra = "shelley" + , aiEncoding = "bech32" + , aiAddress = addrTxt + , aiBase16 = serialiseToRawBytesHexText payaddr + } + Just (Right addr) -> + pure $ + AddressInfo { aiType = "stake" , aiEra = "shelley" , aiEncoding = "bech32" @@ -68,7 +68,6 @@ runAddressInfoCmd addrTxt mOutputFp = do , aiBase16 = serialiseToRawBytesHexText addr } - case mOutputFp of - Just (File fpath) -> liftIO $ LBS.writeFile fpath $ encodePretty addrInfo - Nothing -> liftIO $ LBS.putStrLn $ encodePretty addrInfo - + case mOutputFp of + Just (File fpath) -> liftIO $ LBS.writeFile fpath $ encodePretty addrInfo + Nothing -> liftIO $ LBS.putStrLn $ encodePretty addrInfo diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs index 9ce6e3df65..99c033a561 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs @@ -17,15 +17,16 @@ module Cardano.CLI.EraBased.Run.CreateTestnetData ( genStuffedAddress - , getCurrentTimePlus30 - , readRelays - , readAndDecodeGenesisFile - , runGenesisKeyGenUTxOCmd - , runGenesisKeyGenGenesisCmd - , runGenesisKeyGenDelegateCmd - , runGenesisCreateTestNetDataCmd - , runGenesisKeyGenDelegateVRF - ) where + , getCurrentTimePlus30 + , readRelays + , readAndDecodeGenesisFile + , runGenesisKeyGenUTxOCmd + , runGenesisKeyGenGenesisCmd + , runGenesisKeyGenDelegateCmd + , runGenesisCreateTestNetDataCmd + , runGenesisKeyGenDelegateVRF + ) +where import Cardano.Api hiding (ConwayEra) import Cardano.Api.Ledger (StrictMaybe (SNothing)) @@ -93,7 +94,7 @@ runGenesisKeyGenGenesisCmd :: GenesisKeyGenGenesisCmdArgs -> ExceptT GenesisCmdError IO () runGenesisKeyGenGenesisCmd - Cmd.GenesisKeyGenGenesisCmdArgs + Cmd.GenesisKeyGenGenesisCmdArgs { Cmd.verificationKeyPath , Cmd.signingKeyPath } = do @@ -102,16 +103,15 @@ runGenesisKeyGenGenesisCmd firstExceptT GenesisCmdGenesisFileError . newExceptT $ do void $ writeLazyByteStringFile signingKeyPath $ textEnvelopeToJSON (Just skeyDesc) skey writeLazyByteStringFile verificationKeyPath $ textEnvelopeToJSON (Just Key.genesisVkeyDesc) vkey - where + where skeyDesc :: TextEnvelopeDescr skeyDesc = "Genesis Signing Key" - runGenesisKeyGenDelegateCmd :: GenesisKeyGenDelegateCmdArgs -> ExceptT GenesisCmdError IO () runGenesisKeyGenDelegateCmd - Cmd.GenesisKeyGenDelegateCmdArgs + Cmd.GenesisKeyGenDelegateCmdArgs { Cmd.verificationKeyPath , Cmd.signingKeyPath , Cmd.opCertCounterPath @@ -119,58 +119,62 @@ runGenesisKeyGenDelegateCmd skey <- generateSigningKey AsGenesisDelegateKey let vkey = getVerificationKey skey firstExceptT GenesisCmdGenesisFileError . newExceptT $ do - void $ writeLazyByteStringFile signingKeyPath - $ textEnvelopeToJSON (Just skeyDesc) skey - void $ writeLazyByteStringFile verificationKeyPath - $ textEnvelopeToJSON (Just Key.genesisVkeyDelegateDesc) vkey - writeLazyByteStringFile opCertCounterPath - $ textEnvelopeToJSON (Just certCtrDesc) - $ OperationalCertificateIssueCounter + void $ + writeLazyByteStringFile signingKeyPath $ + textEnvelopeToJSON (Just skeyDesc) skey + void $ + writeLazyByteStringFile verificationKeyPath $ + textEnvelopeToJSON (Just Key.genesisVkeyDelegateDesc) vkey + writeLazyByteStringFile opCertCounterPath $ + textEnvelopeToJSON (Just certCtrDesc) $ + OperationalCertificateIssueCounter initialCounter - (castVerificationKey vkey) -- Cast to a 'StakePoolKey' - where + (castVerificationKey vkey) -- Cast to a 'StakePoolKey' + where skeyDesc, certCtrDesc :: TextEnvelopeDescr skeyDesc = "Genesis delegate operator key" - certCtrDesc = "Next certificate issue number: " - <> fromString (show initialCounter) + certCtrDesc = + "Next certificate issue number: " + <> fromString (show initialCounter) initialCounter :: Word64 initialCounter = 0 - -runGenesisKeyGenDelegateVRF :: - VerificationKeyFile Out +runGenesisKeyGenDelegateVRF + :: VerificationKeyFile Out -> SigningKeyFile Out -> ExceptT GenesisCmdError IO () runGenesisKeyGenDelegateVRF vkeyPath skeyPath = do - skey <- generateSigningKey AsVrfKey - let vkey = getVerificationKey skey - firstExceptT GenesisCmdGenesisFileError . newExceptT $ do - void $ writeLazyByteStringFile skeyPath - $ textEnvelopeToJSON (Just skeyDesc) skey - writeLazyByteStringFile vkeyPath - $ textEnvelopeToJSON (Just vkeyDesc) vkey - where - skeyDesc, vkeyDesc :: TextEnvelopeDescr - skeyDesc = "VRF Signing Key" - vkeyDesc = "VRF Verification Key" + skey <- generateSigningKey AsVrfKey + let vkey = getVerificationKey skey + firstExceptT GenesisCmdGenesisFileError . newExceptT $ do + void $ + writeLazyByteStringFile skeyPath $ + textEnvelopeToJSON (Just skeyDesc) skey + writeLazyByteStringFile vkeyPath $ + textEnvelopeToJSON (Just vkeyDesc) vkey + where + skeyDesc, vkeyDesc :: TextEnvelopeDescr + skeyDesc = "VRF Signing Key" + vkeyDesc = "VRF Verification Key" runGenesisKeyGenUTxOCmd :: GenesisKeyGenUTxOCmdArgs -> ExceptT GenesisCmdError IO () runGenesisKeyGenUTxOCmd - Cmd.GenesisKeyGenUTxOCmdArgs + Cmd.GenesisKeyGenUTxOCmdArgs { Cmd.verificationKeyPath , Cmd.signingKeyPath } = do skey <- generateSigningKey AsGenesisUTxOKey let vkey = getVerificationKey skey firstExceptT GenesisCmdGenesisFileError . newExceptT $ do - void $ writeLazyByteStringFile signingKeyPath - $ textEnvelopeToJSON (Just skeyDesc) skey - writeLazyByteStringFile verificationKeyPath - $ textEnvelopeToJSON (Just vkeyDesc) vkey - where + void $ + writeLazyByteStringFile signingKeyPath $ + textEnvelopeToJSON (Just skeyDesc) skey + writeLazyByteStringFile verificationKeyPath $ + textEnvelopeToJSON (Just vkeyDesc) vkey + where skeyDesc, vkeyDesc :: TextEnvelopeDescr skeyDesc = "Genesis Initial UTxO Signing Key" vkeyDesc = "Genesis Initial UTxO Verification Key" @@ -178,180 +182,225 @@ runGenesisKeyGenUTxOCmd runGenesisCreateTestNetDataCmd :: GenesisCreateTestNetDataCmdArgs -> ExceptT GenesisCmdError IO () -runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs - { networkId - , specShelley - , specAlonzo - , specConway - , numGenesisKeys - , numPools - , stakeDelegators = StakeDelegators { stakeDelegatorsGenerationMode - , numOfStakeDelegators - } - , numDRepKeys = DRepCredentials { dRepCredentialGenerationMode - , numOfDRepCredentials - } - , numStuffedUtxo - , numUtxoKeys - , totalSupply - , delegatedSupply - , relays - , systemStart - , outputDir - } = do - liftIO $ createDirectoryIfMissing False outputDir - shelleyGenesisInit <- maybeReadAndDecodeGenesisFileSpec specShelley shelleyGenesisDefaults - alonzoGenesis <- maybeReadAndDecodeGenesisFileSpec specAlonzo alonzoGenesisDefaults - conwayGenesis <- maybeReadAndDecodeGenesisFileSpec specConway conwayGenesisDefaults - - -- Read NetworkId either from file or from the flag. Flag overrides template file. - let actualNetworkId = - case networkId of - Just networkFromFlag -> networkFromFlag - Nothing -> fromNetworkMagic (NetworkMagic $ sgNetworkMagic shelleyGenesisInit) - shelleyGenesis = shelleyGenesisInit { sgNetworkMagic = unNetworkMagic (toNetworkMagic actualNetworkId) } - -- {0 -> genesis-keys/genesis0/key.vkey, 1 -> genesis-keys/genesis1/key.vkey, ...} - genesisVKeysPaths = mkPaths numGenesisKeys genesisDir "genesis" "key.vkey" - -- {0 -> delegate-keys/delegate0/key.vkey, 1 -> delegate-keys/delegate1/key.vkey, ...} - delegateKeys = mkPaths numGenesisKeys delegateDir "delegate" "key.vkey" - -- {0 -> delegate-keys/delegate0/vrf.vkey, 1 -> delegate-keys/delegate1/vrf.vkey, ...} - delegateVrfKeys = mkPaths numGenesisKeys delegateDir "delegate" "vrf.vkey" - -- {"stake-delegators/delegator1", "stake-delegators/delegator2", ...} - stakeDelegatorsDirs = [stakeDelegatorsDir "delegator" <> show i | i <- [1 .. numOfStakeDelegators]] - - forM_ [ 1 .. numGenesisKeys ] $ \index -> do - createGenesisKeys (genesisDir ("genesis" <> show index)) - createDelegateKeys desiredKeyOutputFormat (delegateDir ("delegate" <> show index)) - - when (0 < numGenesisKeys) $ do - writeREADME genesisDir genesisREADME - writeREADME delegateDir delegatesREADME - - -- UTxO keys - let utxoKeyFileNames = [utxoKeysDir ("utxo" <> show index) "utxo.vkey" - | index <- [ 1 .. numUtxoKeys ]] - forM_ [ 1 .. numUtxoKeys ] $ \index -> - createUtxoKeys (utxoKeysDir ("utxo" <> show index)) - - when (0 < numUtxoKeys) $ writeREADME utxoKeysDir utxoKeysREADME - - mSPOsRelays <- forM relays readRelays - case (relays, mSPOsRelays) of - (Just fp, Just stakePoolRelays) | Map.size stakePoolRelays > fromIntegral numPools -> - throwError $ GenesisCmdTooManyRelaysError fp (fromIntegral numPools) (Map.size stakePoolRelays) - _ -> pure () - - -- Pools - poolParams <- forM [ 1 .. numPools ] $ \index -> do - let poolDir = poolsDir ("pool" <> show index) - - createPoolCredentials desiredKeyOutputFormat poolDir - -- Indexes of directories created on disk start at 1, but - -- indexes in terms of the relays' list start at 0. Hence 'index - 1' here: - buildPoolParams actualNetworkId poolDir (index - 1) (fromMaybe mempty mSPOsRelays) - - when (0 < numPools) $ writeREADME poolsDir poolsREADME - - -- DReps - g <- Random.getStdGen - - dRepKeys <- firstExceptT GenesisCmdFileError $ - case dRepCredentialGenerationMode of - OnDisk -> forM [ 1 .. numOfDRepCredentials ] $ \index -> do - let drepDir = drepsDir "drep" <> show index - vkeyFile = File @(VerificationKey ()) $ drepDir "drep.vkey" - skeyFile = File @(SigningKey ()) $ drepDir "drep.skey" - cmd = DRep.GovernanceDRepKeyGenCmdArgs ConwayEraOnwardsConway vkeyFile skeyFile - liftIO $ createDirectoryIfMissing True drepDir - fst <$> DRep.runGovernanceDRepKeyGenCmd cmd - Transient -> liftIO $ mapAccumM (\g' _ -> swap . first getVerificationKey <$> generateInsecureSigningKey g' AsDRepKey) - g [ 1 .. numOfStakeDelegators ] - - when (0 < numOfDRepCredentials && dRepCredentialGenerationMode == OnDisk) $ writeREADME drepsDir drepsREADME - - - -- Stake delegators - g2 <- Random.getStdGen - delegatorKeys <- case stakeDelegatorsGenerationMode of - OnDisk -> forM stakeDelegatorsDirs $ \delegator -> createStakeDelegatorCredentials delegator - Transient -> liftIO $ mapAccumM (\g' _ -> computeInsecureStakeKeyAddr g') g2 [ 1 .. numOfStakeDelegators ] - - let (delegsPerPool, delegsRemaining) = - if numPools == 0 - then (0, 0) - else numOfStakeDelegators `divMod` numPools - delegsForPool poolIx = - if poolIx <= delegsRemaining - then delegsPerPool + 1 - else delegsPerPool - distribution = [pool | (pool, poolIx) <- zip poolParams [1 ..], _ <- [1 .. delegsForPool poolIx]] - - -- Distribute M delegates across N pools: - let delegations = zipWithDeepSeq (computeDelegation actualNetworkId) delegatorKeys distribution - - genDlgs <- readGenDelegsMap genesisVKeysPaths delegateKeys delegateVrfKeys - nonDelegAddrs <- readInitialFundAddresses utxoKeyFileNames actualNetworkId - start <- maybe (SystemStart <$> getCurrentTimePlus30) pure systemStart - - let network = toShelleyNetwork actualNetworkId - stuffedUtxoAddrs <- liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) $ genStuffedAddress network - - - let conwayGenesis' = addDRepsToConwayGenesis dRepKeys (map snd delegatorKeys) conwayGenesis - - let stake = second L.ppId . mkDelegationMapEntry <$> delegations - stakePools = [ (L.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations ] - delegAddrs = dInitialUtxoAddr <$> delegations - !shelleyGenesis' <- - updateOutputTemplate - start genDlgs totalSupply nonDelegAddrs stakePools stake delegatedSupply (length delegations) - delegAddrs stuffedUtxoAddrs shelleyGenesis - - -- Write genesis.json file to output - liftIO $ LBS.writeFile (outputDir "conway-genesis.json") $ Aeson.encode conwayGenesis' - liftIO $ LBS.writeFile (outputDir "shelley-genesis.json") $ Aeson.encode shelleyGenesis' - liftIO $ LBS.writeFile (outputDir "alonzo-genesis.json") $ Aeson.encode alonzoGenesis - where +runGenesisCreateTestNetDataCmd + Cmd.GenesisCreateTestNetDataCmdArgs + { networkId + , specShelley + , specAlonzo + , specConway + , numGenesisKeys + , numPools + , stakeDelegators = + StakeDelegators + { stakeDelegatorsGenerationMode + , numOfStakeDelegators + } + , numDRepKeys = + DRepCredentials + { dRepCredentialGenerationMode + , numOfDRepCredentials + } + , numStuffedUtxo + , numUtxoKeys + , totalSupply + , delegatedSupply + , relays + , systemStart + , outputDir + } = do + liftIO $ createDirectoryIfMissing False outputDir + shelleyGenesisInit <- maybeReadAndDecodeGenesisFileSpec specShelley shelleyGenesisDefaults + alonzoGenesis <- maybeReadAndDecodeGenesisFileSpec specAlonzo alonzoGenesisDefaults + conwayGenesis <- maybeReadAndDecodeGenesisFileSpec specConway conwayGenesisDefaults + + -- Read NetworkId either from file or from the flag. Flag overrides template file. + let actualNetworkId = + case networkId of + Just networkFromFlag -> networkFromFlag + Nothing -> fromNetworkMagic (NetworkMagic $ sgNetworkMagic shelleyGenesisInit) + shelleyGenesis = shelleyGenesisInit{sgNetworkMagic = unNetworkMagic (toNetworkMagic actualNetworkId)} + -- {0 -> genesis-keys/genesis0/key.vkey, 1 -> genesis-keys/genesis1/key.vkey, ...} + genesisVKeysPaths = mkPaths numGenesisKeys genesisDir "genesis" "key.vkey" + -- {0 -> delegate-keys/delegate0/key.vkey, 1 -> delegate-keys/delegate1/key.vkey, ...} + delegateKeys = mkPaths numGenesisKeys delegateDir "delegate" "key.vkey" + -- {0 -> delegate-keys/delegate0/vrf.vkey, 1 -> delegate-keys/delegate1/vrf.vkey, ...} + delegateVrfKeys = mkPaths numGenesisKeys delegateDir "delegate" "vrf.vkey" + -- {"stake-delegators/delegator1", "stake-delegators/delegator2", ...} + stakeDelegatorsDirs = [stakeDelegatorsDir "delegator" <> show i | i <- [1 .. numOfStakeDelegators]] + + forM_ [1 .. numGenesisKeys] $ \index -> do + createGenesisKeys (genesisDir ("genesis" <> show index)) + createDelegateKeys desiredKeyOutputFormat (delegateDir ("delegate" <> show index)) + + when (0 < numGenesisKeys) $ do + writeREADME genesisDir genesisREADME + writeREADME delegateDir delegatesREADME + + -- UTxO keys + let utxoKeyFileNames = + [ utxoKeysDir ("utxo" <> show index) "utxo.vkey" + | index <- [1 .. numUtxoKeys] + ] + forM_ [1 .. numUtxoKeys] $ \index -> + createUtxoKeys (utxoKeysDir ("utxo" <> show index)) + + when (0 < numUtxoKeys) $ writeREADME utxoKeysDir utxoKeysREADME + + mSPOsRelays <- forM relays readRelays + case (relays, mSPOsRelays) of + (Just fp, Just stakePoolRelays) + | Map.size stakePoolRelays > fromIntegral numPools -> + throwError $ GenesisCmdTooManyRelaysError fp (fromIntegral numPools) (Map.size stakePoolRelays) + _ -> pure () + + -- Pools + poolParams <- forM [1 .. numPools] $ \index -> do + let poolDir = poolsDir ("pool" <> show index) + + createPoolCredentials desiredKeyOutputFormat poolDir + -- Indexes of directories created on disk start at 1, but + -- indexes in terms of the relays' list start at 0. Hence 'index - 1' here: + buildPoolParams actualNetworkId poolDir (index - 1) (fromMaybe mempty mSPOsRelays) + + when (0 < numPools) $ writeREADME poolsDir poolsREADME + + -- DReps + g <- Random.getStdGen + + dRepKeys <- firstExceptT GenesisCmdFileError $ + case dRepCredentialGenerationMode of + OnDisk -> forM [1 .. numOfDRepCredentials] $ \index -> do + let drepDir = drepsDir "drep" <> show index + vkeyFile = File @(VerificationKey ()) $ drepDir "drep.vkey" + skeyFile = File @(SigningKey ()) $ drepDir "drep.skey" + cmd = DRep.GovernanceDRepKeyGenCmdArgs ConwayEraOnwardsConway vkeyFile skeyFile + liftIO $ createDirectoryIfMissing True drepDir + fst <$> DRep.runGovernanceDRepKeyGenCmd cmd + Transient -> + liftIO $ + mapAccumM + (\g' _ -> swap . first getVerificationKey <$> generateInsecureSigningKey g' AsDRepKey) + g + [1 .. numOfStakeDelegators] + + when (0 < numOfDRepCredentials && dRepCredentialGenerationMode == OnDisk) $ + writeREADME drepsDir drepsREADME + + -- Stake delegators + g2 <- Random.getStdGen + delegatorKeys <- case stakeDelegatorsGenerationMode of + OnDisk -> forM stakeDelegatorsDirs $ \delegator -> createStakeDelegatorCredentials delegator + Transient -> liftIO $ mapAccumM (\g' _ -> computeInsecureStakeKeyAddr g') g2 [1 .. numOfStakeDelegators] + + let (delegsPerPool, delegsRemaining) = + if numPools == 0 + then (0, 0) + else numOfStakeDelegators `divMod` numPools + delegsForPool poolIx = + if poolIx <= delegsRemaining + then delegsPerPool + 1 + else delegsPerPool + distribution = [pool | (pool, poolIx) <- zip poolParams [1 ..], _ <- [1 .. delegsForPool poolIx]] + + -- Distribute M delegates across N pools: + let delegations = zipWithDeepSeq (computeDelegation actualNetworkId) delegatorKeys distribution + + genDlgs <- readGenDelegsMap genesisVKeysPaths delegateKeys delegateVrfKeys + nonDelegAddrs <- readInitialFundAddresses utxoKeyFileNames actualNetworkId + start <- maybe (SystemStart <$> getCurrentTimePlus30) pure systemStart + + let network = toShelleyNetwork actualNetworkId + stuffedUtxoAddrs <- + liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) $ genStuffedAddress network + + let conwayGenesis' = addDRepsToConwayGenesis dRepKeys (map snd delegatorKeys) conwayGenesis + + let stake = second L.ppId . mkDelegationMapEntry <$> delegations + stakePools = [(L.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations] + delegAddrs = dInitialUtxoAddr <$> delegations + !shelleyGenesis' <- + updateOutputTemplate + start + genDlgs + totalSupply + nonDelegAddrs + stakePools + stake + delegatedSupply + (length delegations) + delegAddrs + stuffedUtxoAddrs + shelleyGenesis + + -- Write genesis.json file to output + liftIO $ LBS.writeFile (outputDir "conway-genesis.json") $ Aeson.encode conwayGenesis' + liftIO $ LBS.writeFile (outputDir "shelley-genesis.json") $ Aeson.encode shelleyGenesis' + liftIO $ LBS.writeFile (outputDir "alonzo-genesis.json") $ Aeson.encode alonzoGenesis + where genesisDir = outputDir "genesis-keys" delegateDir = outputDir "delegate-keys" drepsDir = outputDir "drep-keys" utxoKeysDir = outputDir "utxo-keys" poolsDir = outputDir "pools-keys" stakeDelegatorsDir = outputDir "stake-delegators" - mkDelegationMapEntry :: Delegation -> (L.KeyHash L.Staking L.StandardCrypto, L.PoolParams L.StandardCrypto) + mkDelegationMapEntry + :: Delegation -> (L.KeyHash L.Staking L.StandardCrypto, L.PoolParams L.StandardCrypto) mkDelegationMapEntry d = (dDelegStaking d, dPoolParams d) - addDRepsToConwayGenesis :: [VerificationKey DRepKey] -> [VerificationKey StakeKey] - -> L.ConwayGenesis L.StandardCrypto -> L.ConwayGenesis L.StandardCrypto + addDRepsToConwayGenesis + :: [VerificationKey DRepKey] + -> [VerificationKey StakeKey] + -> L.ConwayGenesis L.StandardCrypto + -> L.ConwayGenesis L.StandardCrypto addDRepsToConwayGenesis dRepKeys stakingKeys conwayGenesis = - conwayGenesis { L.cgDelegs = delegs (zip stakingKeys (case dRepKeys of [] -> []; _ -> cycle dRepKeys)) - , L.cgInitialDReps = initialDReps (L.ucppDRepDeposit $ L.cgUpgradePParams conwayGenesis) dRepKeys + conwayGenesis + { L.cgDelegs = delegs (zip stakingKeys (case dRepKeys of [] -> []; _ -> cycle dRepKeys)) + , L.cgInitialDReps = initialDReps (L.ucppDRepDeposit $ L.cgUpgradePParams conwayGenesis) dRepKeys + } + where + delegs + :: [(VerificationKey StakeKey, VerificationKey DRepKey)] + -> ListMap (L.Credential L.Staking L.StandardCrypto) (L.Delegatee L.StandardCrypto) + delegs = + ListMap.fromList + . map + ( bimap + verificationKeytoStakeCredential + (L.DelegVote . L.DRepCredential . verificationKeyToDRepCredential) + ) + + initialDReps + :: L.Coin + -> [VerificationKey DRepKey] + -> ListMap (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto) + initialDReps minDeposit = + ListMap.fromList + . map + ( \c -> + ( verificationKeyToDRepCredential c + , L.DRepState + { L.drepExpiry = EpochNo 1_000 + , L.drepAnchor = SNothing + , L.drepDeposit = max (L.Coin 1_000_000) minDeposit } + ) + ) - where - delegs :: [(VerificationKey StakeKey, VerificationKey DRepKey)] -> ListMap (L.Credential L.Staking L.StandardCrypto) (L.Delegatee L.StandardCrypto) - delegs = ListMap.fromList . map (bimap verificationKeytoStakeCredential (L.DelegVote . L.DRepCredential . verificationKeyToDRepCredential)) - - initialDReps :: L.Coin -> [VerificationKey DRepKey] -> ListMap (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto) - initialDReps minDeposit = ListMap.fromList . map (\c -> ( verificationKeyToDRepCredential c - , L.DRepState { L.drepExpiry = EpochNo 1_000 - , L.drepAnchor = SNothing - , L.drepDeposit = max (L.Coin 1_000_000) minDeposit - })) - - verificationKeyToDRepCredential :: VerificationKey DRepKey -> L.Credential L.DRepRole L.StandardCrypto + verificationKeyToDRepCredential + :: VerificationKey DRepKey -> L.Credential L.DRepRole L.StandardCrypto verificationKeyToDRepCredential vk = dRepKeyToCredential (verificationKeyHash vk) - where - dRepKeyToCredential :: Hash DRepKey -> L.Credential L.DRepRole L.StandardCrypto - dRepKeyToCredential (DRepKeyHash v) = L.KeyHashObj v + where + dRepKeyToCredential :: Hash DRepKey -> L.Credential L.DRepRole L.StandardCrypto + dRepKeyToCredential (DRepKeyHash v) = L.KeyHashObj v - verificationKeytoStakeCredential :: VerificationKey StakeKey -> L.Credential L.Staking L.StandardCrypto + verificationKeytoStakeCredential + :: VerificationKey StakeKey -> L.Credential L.Staking L.StandardCrypto verificationKeytoStakeCredential vk = stakeKeyToCredential (verificationKeyHash vk) - where - stakeKeyToCredential :: Hash StakeKey -> L.Credential L.Staking L.StandardCrypto - stakeKeyToCredential (StakeKeyHash v) = L.KeyHashObj v + where + stakeKeyToCredential :: Hash StakeKey -> L.Credential L.Staking L.StandardCrypto + stakeKeyToCredential (StakeKeyHash v) = L.KeyHashObj v - -- | 'zipWithDeepSeq' is like 'zipWith' but it ensures each element of the result is fully + -- \| 'zipWithDeepSeq' is like 'zipWith' but it ensures each element of the result is fully -- evaluated before calculating the rest of the list. We do this in order to avoid the -- case were we expand the intermediate representation (the two input lists) before -- converging to the result. The intermediate representation is larger than the result, @@ -359,220 +408,264 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs zipWithDeepSeq :: NFData c => (a -> b -> c) -> [a] -> [b] -> [c] zipWithDeepSeq _ _ [] = [] zipWithDeepSeq _ [] _ = [] - zipWithDeepSeq f (h1:t1) (h2:t2) = let h = f h1 h2 in - h `deepseq` (h:zipWithDeepSeq f t1 t2) + zipWithDeepSeq f (h1 : t1) (h2 : t2) = + let h = f h1 h2 + in h `deepseq` (h : zipWithDeepSeq f t1 t2) - -- | Manually implemented (because the one in Data.Traversable requires `base-4.18` or greater) + -- \| Manually implemented (because the one in Data.Traversable requires `base-4.18` or greater) mapAccumM :: (acc -> b -> IO (acc, c)) -> acc -> [b] -> IO [c] mapAccumM _ _ [] = return [] - mapAccumM f a (h:t) = do (a', h') <- f a h - rest <- mapAccumM f a' t - return $ h':rest + mapAccumM f a (h : t) = do + (a', h') <- f a h + rest <- mapAccumM f a' t + return $ h' : rest -- | The output format used all along this file desiredKeyOutputFormat :: KeyOutputFormat desiredKeyOutputFormat = KeyOutputFormatTextEnvelope -writeREADME :: () +writeREADME + :: () => FilePath -> Text.Text -> ExceptT GenesisCmdError IO () writeREADME dir content = do firstExceptT GenesisCmdFileError . newExceptT $ writeTextFile file content - where - file :: File Text.Text Out = File $ dir "README.md" + where + file :: File Text.Text Out = File $ dir "README.md" genesisREADME :: Text.Text -genesisREADME = Text.intercalate "\n" - ["Keys generated by the --genesis-keys flag. In Byron these keys were used to mint blocks and initiate hard forks." - , "Starting with Shelley and decentralization, blocks started being produced by other keys than genesis keys." - , "Still, these keys were required to trigger hard forks." - , "With the introduction of Conway, these keys should become useless"] +genesisREADME = + Text.intercalate + "\n" + [ "Keys generated by the --genesis-keys flag. In Byron these keys were used to mint blocks and initiate hard forks." + , "Starting with Shelley and decentralization, blocks started being produced by other keys than genesis keys." + , "Still, these keys were required to trigger hard forks." + , "With the introduction of Conway, these keys should become useless" + ] delegatesREADME :: Text.Text -delegatesREADME = Text.intercalate "\n" - ["Keys generated by the --genesis-keys flag. These keys are used to mint blocks when not being completely decentralized", - "(e.g. when stake pools are not the sole block producers). These keys are intended to run nodes."] +delegatesREADME = + Text.intercalate + "\n" + [ "Keys generated by the --genesis-keys flag. These keys are used to mint blocks when not being completely decentralized" + , "(e.g. when stake pools are not the sole block producers). These keys are intended to run nodes." + ] drepsREADME :: Text.Text -drepsREADME = Text.intercalate "\n" - ["Keys generated by the --drep-keys flag. These keys are for Delegated Representatives (DReps) that make decisions", - "related to Cardano governance. Delegators that do not want to vote for each decision will pick DReps in line with", - "their views delegate their voting power to them. The DRep's in this generated testnet data will automatically get", - "registered and all the stake delegators (if any) will automatically delegate their vote to one of the DReps here."] +drepsREADME = + Text.intercalate + "\n" + [ "Keys generated by the --drep-keys flag. These keys are for Delegated Representatives (DReps) that make decisions" + , "related to Cardano governance. Delegators that do not want to vote for each decision will pick DReps in line with" + , "their views delegate their voting power to them. The DRep's in this generated testnet data will automatically get" + , "registered and all the stake delegators (if any) will automatically delegate their vote to one of the DReps here." + ] utxoKeysREADME :: Text.Text -utxoKeysREADME = Text.intercalate "\n" - ["Keys generated by the --utxo-keys flag. These keys receive a portion of the supply."] +utxoKeysREADME = + Text.intercalate + "\n" + ["Keys generated by the --utxo-keys flag. These keys receive a portion of the supply."] poolsREADME :: Text.Text -poolsREADME = Text.intercalate "\n" - ["Keys generated by the --pools flag. These keys are intended to run nodes."] +poolsREADME = + Text.intercalate + "\n" + ["Keys generated by the --pools flag. These keys are intended to run nodes."] -- | @mkPaths numKeys dir segment filename@ returns the paths to the keys to generate. -- For example @mkPaths 3 dir prefix fn.ext@ returns -- [dir/segment1/fn.ext, dir/segment2/fn.ext, dir/segment3/fn.ext] mkPaths :: Word -> String -> String -> String -> Map Int FilePath mkPaths numKeys dir segment filename = - fromList [(fromIntegral idx, dir (segment <> show idx) filename) - | idx <- [1 .. numKeys]] + fromList + [ (fromIntegral idx, dir (segment <> show idx) filename) + | idx <- [1 .. numKeys] + ] genStuffedAddress :: L.Network -> IO (AddressInEra ShelleyEra) genStuffedAddress network = - shelleyAddressInEra ShelleyBasedEraShelley <$> - (ShelleyAddress - <$> pure network - <*> (L.KeyHashObj . mkKeyHash . read64BitInt - <$> Crypto.runSecureRandom (getRandomBytes 8)) - <*> pure L.StakeRefNull) - where - read64BitInt :: ByteString -> Int - read64BitInt = (fromIntegral :: Word64 -> Int) - . Bin.runGet Bin.getWord64le . LBS.fromStrict + shelleyAddressInEra ShelleyBasedEraShelley + <$> ( ShelleyAddress + <$> pure network + <*> ( L.KeyHashObj . mkKeyHash . read64BitInt + <$> Crypto.runSecureRandom (getRandomBytes 8) + ) + <*> pure L.StakeRefNull + ) + where + read64BitInt :: ByteString -> Int + read64BitInt = + (fromIntegral :: Word64 -> Int) + . Bin.runGet Bin.getWord64le + . LBS.fromStrict - mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash.Hash h a - mkDummyHash _ = coerce . L.hashWithSerialiser @h L.toCBOR + mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash.Hash h a + mkDummyHash _ = coerce . L.hashWithSerialiser @h L.toCBOR - mkKeyHash :: forall c discriminator. L.Crypto c => Int -> L.KeyHash discriminator c - mkKeyHash = L.KeyHash . mkDummyHash (Proxy @(L.ADDRHASH c)) + mkKeyHash :: forall c discriminator. L.Crypto c => Int -> L.KeyHash discriminator c + mkKeyHash = L.KeyHash . mkDummyHash (Proxy @(L.ADDRHASH c)) createDelegateKeys :: KeyOutputFormat -> FilePath -> ExceptT GenesisCmdError IO () createDelegateKeys fmt dir = do liftIO $ createDirectoryIfMissing True dir runGenesisKeyGenDelegateCmd Cmd.GenesisKeyGenDelegateCmdArgs - { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "key.vkey" - , Cmd.signingKeyPath = onlyOut coldSK - , Cmd.opCertCounterPath = onlyOut opCertCtr - } + { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "key.vkey" + , Cmd.signingKeyPath = onlyOut coldSK + , Cmd.opCertCounterPath = onlyOut opCertCtr + } runGenesisKeyGenDelegateVRF - (File @(VerificationKey ()) $ dir "vrf.vkey") - (File @(SigningKey ()) $ dir "vrf.skey") + (File @(VerificationKey ()) $ dir "vrf.vkey") + (File @(SigningKey ()) $ dir "vrf.skey") firstExceptT GenesisCmdNodeCmdError $ do - runNodeKeyGenKesCmd $ Cmd.NodeKeyGenKESCmdArgs + runNodeKeyGenKesCmd $ + Cmd.NodeKeyGenKESCmdArgs fmt (onlyOut kesVK) (File @(SigningKey ()) $ dir "kes.skey") - runNodeIssueOpCertCmd $ Cmd.NodeIssueOpCertCmdArgs + runNodeIssueOpCertCmd $ + Cmd.NodeIssueOpCertCmdArgs (VerificationKeyFilePath (onlyIn kesVK)) (onlyIn coldSK) opCertCtr (KESPeriod 0) (File $ dir "opcert.cert") where - kesVK = File @(VerificationKey ()) $ dir "kes.vkey" - coldSK = File @(SigningKey ()) $ dir "key.skey" - opCertCtr = File $ dir "opcert.counter" + kesVK = File @(VerificationKey ()) $ dir "kes.vkey" + coldSK = File @(SigningKey ()) $ dir "key.skey" + opCertCtr = File $ dir "opcert.counter" createGenesisKeys :: FilePath -> ExceptT GenesisCmdError IO () createGenesisKeys dir = do liftIO $ createDirectoryIfMissing True dir runGenesisKeyGenGenesisCmd GenesisKeyGenGenesisCmdArgs - { verificationKeyPath = File @(VerificationKey ()) $ dir "key.vkey" - , signingKeyPath = File @(SigningKey ()) $ dir "key.skey" - } + { verificationKeyPath = File @(VerificationKey ()) $ dir "key.vkey" + , signingKeyPath = File @(SigningKey ()) $ dir "key.skey" + } -createStakeDelegatorCredentials :: FilePath - -> ExceptT GenesisCmdError IO (VerificationKey PaymentKey, - VerificationKey StakeKey) +createStakeDelegatorCredentials + :: FilePath + -> ExceptT + GenesisCmdError + IO + ( VerificationKey PaymentKey + , VerificationKey StakeKey + ) createStakeDelegatorCredentials dir = do liftIO $ createDirectoryIfMissing True dir - (pvk, _psk) <- firstExceptT GenesisCmdAddressCmdError $ generateAndWriteKeyFiles desiredKeyOutputFormat AsPaymentKey paymentVK paymentSK - (svk, _ssk) <- firstExceptT GenesisCmdStakeAddressCmdError $ runStakeAddressKeyGenCmd desiredKeyOutputFormat stakingVK stakingSK + (pvk, _psk) <- + firstExceptT GenesisCmdAddressCmdError $ + generateAndWriteKeyFiles desiredKeyOutputFormat AsPaymentKey paymentVK paymentSK + (svk, _ssk) <- + firstExceptT GenesisCmdStakeAddressCmdError $ + runStakeAddressKeyGenCmd desiredKeyOutputFormat stakingVK stakingSK return (pvk, svk) - where - paymentVK = File @(VerificationKey ()) $ dir "payment.vkey" - paymentSK = File @(SigningKey ()) $ dir "payment.skey" - stakingVK = File @(VerificationKey ()) $ dir "staking.vkey" - stakingSK = File @(SigningKey ()) $ dir "staking.skey" - + where + paymentVK = File @(VerificationKey ()) $ dir "payment.vkey" + paymentSK = File @(SigningKey ()) $ dir "payment.skey" + stakingVK = File @(VerificationKey ()) $ dir "staking.vkey" + stakingSK = File @(SigningKey ()) $ dir "staking.skey" createUtxoKeys :: FilePath -> ExceptT GenesisCmdError IO () createUtxoKeys dir = do liftIO $ createDirectoryIfMissing True dir runGenesisKeyGenUTxOCmd Cmd.GenesisKeyGenUTxOCmdArgs - { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "utxo.vkey" - , Cmd.signingKeyPath = File @(SigningKey ()) $ dir "utxo.skey" - } + { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "utxo.vkey" + , Cmd.signingKeyPath = File @(SigningKey ()) $ dir "utxo.skey" + } createPoolCredentials :: KeyOutputFormat -> FilePath -> ExceptT GenesisCmdError IO () createPoolCredentials fmt dir = do liftIO $ createDirectoryIfMissing True dir firstExceptT GenesisCmdNodeCmdError $ do - runNodeKeyGenKesCmd $ Cmd.NodeKeyGenKESCmdArgs + runNodeKeyGenKesCmd $ + Cmd.NodeKeyGenKESCmdArgs fmt (onlyOut kesVK) (File @(SigningKey ()) $ dir "kes.skey") - runNodeKeyGenVrfCmd $ Cmd.NodeKeyGenVRFCmdArgs + runNodeKeyGenVrfCmd $ + Cmd.NodeKeyGenVRFCmdArgs fmt (File @(VerificationKey ()) $ dir "vrf.vkey") (File @(SigningKey ()) $ dir "vrf.skey") - runNodeKeyGenColdCmd $ Cmd.NodeKeyGenColdCmdArgs + runNodeKeyGenColdCmd $ + Cmd.NodeKeyGenColdCmdArgs fmt (File @(VerificationKey ()) $ dir "cold.vkey") (onlyOut coldSK) (onlyOut opCertCtr) - runNodeIssueOpCertCmd $ Cmd.NodeIssueOpCertCmdArgs + runNodeIssueOpCertCmd $ + Cmd.NodeIssueOpCertCmdArgs (VerificationKeyFilePath (onlyIn kesVK)) (onlyIn coldSK) opCertCtr (KESPeriod 0) (File $ dir "opcert.cert") firstExceptT GenesisCmdStakeAddressCmdError $ - void $ runStakeAddressKeyGenCmd + void $ + runStakeAddressKeyGenCmd fmt (File @(VerificationKey ()) $ dir "staking-reward.vkey") (File @(SigningKey ()) $ dir "staking-reward.skey") where - kesVK = File @(VerificationKey ()) $ dir "kes.vkey" - coldSK = File @(SigningKey ()) $ dir "cold.skey" - opCertCtr = File $ dir "opcert.counter" + kesVK = File @(VerificationKey ()) $ dir "kes.vkey" + coldSK = File @(SigningKey ()) $ dir "cold.skey" + opCertCtr = File $ dir "opcert.counter" data Delegation = Delegation - { dInitialUtxoAddr :: !(AddressInEra ShelleyEra) - , dDelegStaking :: !(L.KeyHash L.Staking L.StandardCrypto) - , dPoolParams :: !(L.PoolParams L.StandardCrypto) + { dInitialUtxoAddr :: !(AddressInEra ShelleyEra) + , dDelegStaking :: !(L.KeyHash L.Staking L.StandardCrypto) + , dPoolParams :: !(L.PoolParams L.StandardCrypto) } deriving (Generic, NFData) buildPoolParams :: NetworkId - -> FilePath -- ^ File directory where the necessary pool credentials were created - -> Word -- ^ The index of the pool being built. Starts at 0. - -> Map Word [L.StakePoolRelay] -- ^ User submitted stake pool relay map. Starts at 0 + -> FilePath + -- ^ File directory where the necessary pool credentials were created + -> Word + -- ^ The index of the pool being built. Starts at 0. + -> Map Word [L.StakePoolRelay] + -- ^ User submitted stake pool relay map. Starts at 0 -> ExceptT GenesisCmdError IO (L.PoolParams L.StandardCrypto) buildPoolParams nw dir index specifiedRelays = do - StakePoolVerificationKey poolColdVK - <- firstExceptT (GenesisCmdStakePoolCmdError . StakePoolCmdReadFileError) - . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakePoolKey) poolColdVKF - - VrfVerificationKey poolVrfVK - <- firstExceptT (GenesisCmdNodeCmdError . NodeCmdReadFileError) - . newExceptT $ readFileTextEnvelope (AsVerificationKey AsVrfKey) poolVrfVKF - rewardsSVK - <- firstExceptT GenesisCmdTextEnvReadFileError - . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF - - pure L.PoolParams - { L.ppId = L.hashKey poolColdVK - , L.ppVrf = L.hashVerKeyVRF poolVrfVK - , L.ppPledge = L.Coin 0 - , L.ppCost = L.Coin 0 - , L.ppMargin = minBound - , L.ppRewardAccount = + StakePoolVerificationKey poolColdVK <- + firstExceptT (GenesisCmdStakePoolCmdError . StakePoolCmdReadFileError) + . newExceptT + $ readFileTextEnvelope (AsVerificationKey AsStakePoolKey) poolColdVKF + + VrfVerificationKey poolVrfVK <- + firstExceptT (GenesisCmdNodeCmdError . NodeCmdReadFileError) + . newExceptT + $ readFileTextEnvelope (AsVerificationKey AsVrfKey) poolVrfVKF + rewardsSVK <- + firstExceptT GenesisCmdTextEnvReadFileError + . newExceptT + $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF + + pure + L.PoolParams + { L.ppId = L.hashKey poolColdVK + , L.ppVrf = L.hashVerKeyVRF poolVrfVK + , L.ppPledge = L.Coin 0 + , L.ppCost = L.Coin 0 + , L.ppMargin = minBound + , L.ppRewardAccount = toShelleyStakeAddr $ makeStakeAddress nw $ StakeCredentialByKey (verificationKeyHash rewardsSVK) - , L.ppOwners = mempty - , L.ppRelays = lookupPoolRelay specifiedRelays - , L.ppMetadata = L.SNothing + , L.ppOwners = mempty + , L.ppRelays = lookupPoolRelay specifiedRelays + , L.ppMetadata = L.SNothing } where - lookupPoolRelay :: Map Word [L.StakePoolRelay] -> Seq.StrictSeq L.StakePoolRelay - lookupPoolRelay m = Seq.fromList $ Map.findWithDefault [] index m - poolColdVKF = File $ dir "cold.vkey" - poolVrfVKF = File $ dir "vrf.vkey" - poolRewardVKF = File $ dir "staking-reward.vkey" + lookupPoolRelay :: Map Word [L.StakePoolRelay] -> Seq.StrictSeq L.StakePoolRelay + lookupPoolRelay m = Seq.fromList $ Map.findWithDefault [] index m + poolColdVKF = File $ dir "cold.vkey" + poolVrfVKF = File $ dir "vrf.vkey" + poolRewardVKF = File $ dir "staking-reward.vkey" -- | This function should only be used for testing purposes. -- Keys returned by this function are not cryptographically secure. @@ -580,9 +673,9 @@ computeInsecureStakeKeyAddr :: StdGen -> IO (StdGen, (VerificationKey PaymentKey, VerificationKey StakeKey)) computeInsecureStakeKeyAddr g0 = do - (paymentKeys, g1) <- first getVerificationKey <$> generateInsecureSigningKey g0 AsPaymentKey - (stakeKeys , g2) <- first getVerificationKey <$> generateInsecureSigningKey g1 AsStakeKey - return (g2, (paymentKeys, stakeKeys)) + (paymentKeys, g1) <- first getVerificationKey <$> generateInsecureSigningKey g0 AsPaymentKey + (stakeKeys, g2) <- first getVerificationKey <$> generateInsecureSigningKey g1 AsStakeKey + return (g2, (paymentKeys, stakeKeys)) computeDelegation :: NetworkId @@ -590,54 +683,78 @@ computeDelegation -> L.PoolParams L.StandardCrypto -> Delegation computeDelegation nw (paymentVK, stakeVK) dPoolParams = do - let paymentCredential = PaymentCredentialByKey (verificationKeyHash paymentVK) - let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK - Delegation - { dInitialUtxoAddr = makeShelleyAddressInEra ShelleyBasedEraShelley nw paymentCredential stakeAddressReference - , dDelegStaking = L.hashKey $ unStakeVerificationKey stakeVK - , dPoolParams - } + let paymentCredential = PaymentCredentialByKey (verificationKeyHash paymentVK) + let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK + Delegation + { dInitialUtxoAddr = + makeShelleyAddressInEra ShelleyBasedEraShelley nw paymentCredential stakeAddressReference + , dDelegStaking = L.hashKey $ unStakeVerificationKey stakeVK + , dPoolParams + } updateOutputTemplate - :: forall m. MonadError GenesisCmdError m - => SystemStart -- ^ System start time - -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) -- ^ Genesis delegation (not stake-based) - -> Maybe L.Coin -- ^ Total amount of lovelace - -> [AddressInEra ShelleyEra] -- ^ UTxO addresses that are not delegating - -> [(L.KeyHash 'L.StakePool L.StandardCrypto, L.PoolParams L.StandardCrypto)] -- ^ Pool map - -> [(L.KeyHash 'L.Staking L.StandardCrypto, L.KeyHash 'L.StakePool L.StandardCrypto)] -- ^ Delegaton map - -> Maybe L.Coin -- ^ Amount of lovelace to delegate - -> Int -- ^ Number of UTxO address for delegation - -> [AddressInEra ShelleyEra] -- ^ UTxO address for delegation - -> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses - -> ShelleyGenesis L.StandardCrypto -- ^ Template from which to build a genesis - -> m (ShelleyGenesis L.StandardCrypto) -- ^ Updated genesis + :: forall m + . MonadError GenesisCmdError m + => SystemStart + -- ^ System start time + -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) + -- ^ Genesis delegation (not stake-based) + -> Maybe L.Coin + -- ^ Total amount of lovelace + -> [AddressInEra ShelleyEra] + -- ^ UTxO addresses that are not delegating + -> [(L.KeyHash 'L.StakePool L.StandardCrypto, L.PoolParams L.StandardCrypto)] + -- ^ Pool map + -> [(L.KeyHash 'L.Staking L.StandardCrypto, L.KeyHash 'L.StakePool L.StandardCrypto)] + -- ^ Delegaton map + -> Maybe L.Coin + -- ^ Amount of lovelace to delegate + -> Int + -- ^ Number of UTxO address for delegation + -> [AddressInEra ShelleyEra] + -- ^ UTxO address for delegation + -> [AddressInEra ShelleyEra] + -- ^ Stuffed UTxO addresses + -> ShelleyGenesis L.StandardCrypto + -- ^ Template from which to build a genesis + -> m (ShelleyGenesis L.StandardCrypto) + -- ^ Updated genesis updateOutputTemplate (SystemStart sgSystemStart) - genDelegMap mTotalSupply utxoAddrsNonDeleg pools stake + genDelegMap + mTotalSupply + utxoAddrsNonDeleg + pools + stake mDelegatedSupply - nUtxoAddrsDeleg utxoAddrsDeleg stuffedUtxoAddrs - template@ShelleyGenesis{ sgProtocolParams } = do - when (delegCoinRaw > totalSupply) (throwError $ GenesisCmdDelegatedSupplyExceedsTotalSupply delegCoinRaw totalSupply) - pure template - { sgSystemStart - , sgMaxLovelaceSupply = totalSupply - , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = ListMap.fromList - [ (toShelleyAddr addr, v) - | (addr, v) <- - distribute nonDelegCoin nUtxoAddrsNonDeleg utxoAddrsNonDeleg - ++ distribute delegCoin nUtxoAddrsDeleg utxoAddrsDeleg - ++ mkStuffedUtxo stuffedUtxoAddrs - ] - , sgStaking = + nUtxoAddrsDeleg + utxoAddrsDeleg + stuffedUtxoAddrs + template@ShelleyGenesis{sgProtocolParams} = do + when + (delegCoinRaw > totalSupply) + (throwError $ GenesisCmdDelegatedSupplyExceedsTotalSupply delegCoinRaw totalSupply) + pure + template + { sgSystemStart + , sgMaxLovelaceSupply = totalSupply + , sgGenDelegs = shelleyDelKeys + , sgInitialFunds = + ListMap.fromList + [ (toShelleyAddr addr, v) + | (addr, v) <- + distribute nonDelegCoin nUtxoAddrsNonDeleg utxoAddrsNonDeleg + ++ distribute delegCoin nUtxoAddrsDeleg utxoAddrsDeleg + ++ mkStuffedUtxo stuffedUtxoAddrs + ] + , sgStaking = ShelleyGenesisStaking { sgsPools = ListMap pools , sgsStake = ListMap stake } - , sgProtocolParams - } - where + , sgProtocolParams + } + where nonDelegCoin = getCoinForDistribution nonDelegCoinRaw delegCoin = getCoinForDistribution delegCoinRaw @@ -647,7 +764,7 @@ updateOutputTemplate -- So subtrahend a part for the treasury: fromInteger $ inputCoin - (inputCoin `quot` 10) - nUtxoAddrsNonDeleg = length utxoAddrsNonDeleg + nUtxoAddrsNonDeleg = length utxoAddrsNonDeleg maximumLovelaceSupply :: Word64 maximumLovelaceSupply = sgMaxLovelaceSupply template @@ -662,23 +779,29 @@ updateOutputTemplate distribute :: Natural -> Int -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, L.Coin)] distribute funds nAddrs addrs = - zip addrs $ L.Coin . toInteger <$> (coinPerAddr + remainder:repeat coinPerAddr) - where coinPerAddr, remainder :: Natural - (coinPerAddr, remainder) = funds `divMod` fromIntegral nAddrs + zip addrs $ L.Coin . toInteger <$> (coinPerAddr + remainder : repeat coinPerAddr) + where + coinPerAddr, remainder :: Natural + (coinPerAddr, remainder) = funds `divMod` fromIntegral nAddrs mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, L.Coin)] - mkStuffedUtxo xs = (, L.Coin minUtxoVal) <$> xs - where L.Coin minUtxoVal = sgProtocolParams ^. L.ppMinUTxOValueL - shelleyDelKeys = Map.fromList - [ (gh, L.GenDelegPair gdh h) - | (GenesisKeyHash gh, - (GenesisDelegateKeyHash gdh, VrfKeyHash h)) <- Map.toList genDelegMap - ] + mkStuffedUtxo xs = (,L.Coin minUtxoVal) <$> xs + where + L.Coin minUtxoVal = sgProtocolParams ^. L.ppMinUTxOValueL + shelleyDelKeys = + Map.fromList + [ (gh, L.GenDelegPair gdh h) + | ( GenesisKeyHash gh + , (GenesisDelegateKeyHash gdh, VrfKeyHash h) + ) <- + Map.toList genDelegMap + ] unLovelace :: Integral a => L.Coin -> a unLovelace (L.Coin coin) = fromIntegral coin -maybeReadAndDecodeGenesisFileSpec :: (FromJSON a) => Maybe FilePath -> a -> ExceptT GenesisCmdError IO a +maybeReadAndDecodeGenesisFileSpec + :: FromJSON a => Maybe FilePath -> a -> ExceptT GenesisCmdError IO a maybeReadAndDecodeGenesisFileSpec spec defaultSpec = case spec of Just specPath -> @@ -687,74 +810,95 @@ maybeReadAndDecodeGenesisFileSpec spec defaultSpec = -- No template given: a default file is created pure defaultSpec -readAndDecodeGenesisFile :: (FromJSON a) => FilePath -> IO (Either GenesisCmdError a) +readAndDecodeGenesisFile :: FromJSON a => FilePath -> IO (Either GenesisCmdError a) readAndDecodeGenesisFile fpath = runExceptT $ do lbs <- handleIOExceptT (GenesisCmdGenesisFileReadError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (GenesisCmdGenesisFileDecodeError fpath . Text.pack) - . hoistEither $ Aeson.eitherDecode' lbs + . hoistEither + $ Aeson.eitherDecode' lbs -- @readRelays fp@ reads the relays specification from a file -readRelays :: () +readRelays + :: () => MonadIO m - => FilePath -- ^ The file to read from + => FilePath + -- ^ The file to read from -> ExceptT GenesisCmdError m (Map Word [L.StakePoolRelay]) readRelays fp = do relaySpecJsonBs <- handleIOExceptT (GenesisCmdStakePoolRelayFileError fp) (LBS.readFile fp) firstExceptT (GenesisCmdStakePoolRelayJsonDecodeError fp) - . hoistEither $ Aeson.eitherDecode relaySpecJsonBs + . hoistEither + $ Aeson.eitherDecode relaySpecJsonBs -- | Current UTCTime plus 30 seconds getCurrentTimePlus30 :: ExceptT a IO UTCTime getCurrentTimePlus30 = - plus30sec <$> liftIO getCurrentTime - where - plus30sec :: UTCTime -> UTCTime - plus30sec = addUTCTime (30 :: NominalDiffTime) - -readGenDelegsMap :: Map Int FilePath - -> Map Int FilePath - -> Map Int FilePath - -> ExceptT GenesisCmdError IO - (Map (Hash GenesisKey) - (Hash GenesisDelegateKey, Hash VrfKey)) + plus30sec <$> liftIO getCurrentTime + where + plus30sec :: UTCTime -> UTCTime + plus30sec = addUTCTime (30 :: NominalDiffTime) + +readGenDelegsMap + :: Map Int FilePath + -> Map Int FilePath + -> Map Int FilePath + -> ExceptT + GenesisCmdError + IO + ( Map + (Hash GenesisKey) + (Hash GenesisDelegateKey, Hash VrfKey) + ) readGenDelegsMap genesisKeys delegateKeys delegateVrfKeys = do - gkm <- readKeys (AsVerificationKey AsGenesisKey) genesisKeys - dkm <- readKeys (AsVerificationKey AsGenesisDelegateKey) delegateKeys - vkm <- readKeys (AsVerificationKey AsVrfKey) delegateVrfKeys - - let combinedMap :: Map Int (VerificationKey GenesisKey, - (VerificationKey GenesisDelegateKey, - VerificationKey VrfKey)) - combinedMap = - Map.intersectionWith (,) - gkm - (Map.intersectionWith (,) dkm vkm) - - -- All the maps should have an identical set of keys. Complain if not. - let gkmExtra = gkm Map.\\ combinedMap - dkmExtra = dkm Map.\\ combinedMap - vkmExtra = vkm Map.\\ combinedMap - unless (Map.null gkmExtra && Map.null dkmExtra && Map.null vkmExtra) $ - throwError $ GenesisCmdMismatchedGenesisKeyFiles - (Map.keys gkm) (Map.keys dkm) (Map.keys vkm) - - let delegsMap :: Map (Hash GenesisKey) - (Hash GenesisDelegateKey, Hash VrfKey) - delegsMap = - Map.fromList [ (gh, (dh, vh)) - | (g,(d,v)) <- Map.elems combinedMap - , let gh = verificationKeyHash g - dh = verificationKeyHash d - vh = verificationKeyHash v - ] - - pure delegsMap - + gkm <- readKeys (AsVerificationKey AsGenesisKey) genesisKeys + dkm <- readKeys (AsVerificationKey AsGenesisDelegateKey) delegateKeys + vkm <- readKeys (AsVerificationKey AsVrfKey) delegateVrfKeys + + let combinedMap + :: Map + Int + ( VerificationKey GenesisKey + , ( VerificationKey GenesisDelegateKey + , VerificationKey VrfKey + ) + ) + combinedMap = + Map.intersectionWith + (,) + gkm + (Map.intersectionWith (,) dkm vkm) + + -- All the maps should have an identical set of keys. Complain if not. + let gkmExtra = gkm Map.\\ combinedMap + dkmExtra = dkm Map.\\ combinedMap + vkmExtra = vkm Map.\\ combinedMap + unless (Map.null gkmExtra && Map.null dkmExtra && Map.null vkmExtra) $ + throwError $ + GenesisCmdMismatchedGenesisKeyFiles + (Map.keys gkm) + (Map.keys dkm) + (Map.keys vkm) + + let delegsMap + :: Map + (Hash GenesisKey) + (Hash GenesisDelegateKey, Hash VrfKey) + delegsMap = + Map.fromList + [ (gh, (dh, vh)) + | (g, (d, v)) <- Map.elems combinedMap + , let gh = verificationKeyHash g + dh = verificationKeyHash d + vh = verificationKeyHash v + ] + + pure delegsMap -- | Given a map @{0 -> someKey0, 1 -> someKey1}@, lift reading -- the files to the map's values. -readKeys :: () +readKeys + :: () => HasTextEnvelope a => Ord k => AsType a @@ -762,25 +906,36 @@ readKeys :: () -> ExceptT GenesisCmdError IO (Map k a) readKeys asType genesisVKeys = do firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList <$> - sequence + Map.fromList + <$> sequence [ (,) ix <$> readKey (File file) - | (ix, file) <- toList genesisVKeys ] - where - readKey = newExceptT . readFileTextEnvelope asType - + | (ix, file) <- toList genesisVKeys + ] + where + readKey = newExceptT . readFileTextEnvelope asType -readInitialFundAddresses :: [FilePath] -> NetworkId - -> ExceptT GenesisCmdError IO [AddressInEra ShelleyEra] +readInitialFundAddresses + :: [FilePath] + -> NetworkId + -> ExceptT GenesisCmdError IO [AddressInEra ShelleyEra] readInitialFundAddresses utxoKeyFileNames nw = do - vkeys <- firstExceptT GenesisCmdTextEnvReadFileError $ - sequence - [ newExceptT $ - readFileTextEnvelope (AsVerificationKey AsGenesisUTxOKey) - (File file) - | file <- utxoKeyFileNames ] - return [ addr | vkey <- vkeys - , let vkh = verificationKeyHash (castVerificationKey vkey) - addr = makeShelleyAddressInEra ShelleyBasedEraShelley nw (PaymentCredentialByKey vkh) - NoStakeAddress - ] + vkeys <- + firstExceptT GenesisCmdTextEnvReadFileError $ + sequence + [ newExceptT $ + readFileTextEnvelope + (AsVerificationKey AsGenesisUTxOKey) + (File file) + | file <- utxoKeyFileNames + ] + return + [ addr + | vkey <- vkeys + , let vkh = verificationKeyHash (castVerificationKey vkey) + addr = + makeShelleyAddressInEra + ShelleyBasedEraShelley + nw + (PaymentCredentialByKey vkh) + NoStakeAddress + ] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs index b367cd00cc..cd1c7bd661 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis.hs @@ -6,15 +6,14 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {- HLINT ignore "Replace case with maybe" -} {- HLINT ignore "Reduce duplication" -} @@ -23,7 +22,6 @@ module Cardano.CLI.EraBased.Run.Genesis ( runGenesisCmds - , runGenesisAddrCmd , runGenesisCreateCardanoCmd , runGenesisCreateCmd @@ -33,9 +31,10 @@ module Cardano.CLI.EraBased.Run.Genesis , runGenesisTxInCmd , runGenesisVerKeyCmd - -- * Protocol Parameters + -- * Protocol Parameters , readProtocolParameters - ) where + ) +where import Cardano.Api import Cardano.Api.Byron (toByronLovelace, toByronProtocolMagicId, @@ -115,7 +114,6 @@ import qualified Text.JSON.Canonical (ToJSON) import Text.JSON.Canonical (parseCanonicalJSON, renderCanonicalJSON) import Text.Read (readMaybe) - runGenesisCmds :: GenesisCmds era -> ExceptT GenesisCmdError IO () runGenesisCmds = \case GenesisKeyGenGenesis args -> TN.runGenesisKeyGenGenesisCmd args @@ -133,100 +131,110 @@ runGenesisCmds = \case runGenesisKeyHashCmd :: VerificationKeyFile In -> ExceptT GenesisCmdError IO () runGenesisKeyHashCmd vkeyPath = do - vkey <- firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ - readFileTextEnvelopeAnyOf - [ FromSomeType (AsVerificationKey AsGenesisKey) - AGenesisKey - , FromSomeType (AsVerificationKey AsGenesisDelegateKey) - AGenesisDelegateKey - , FromSomeType (AsVerificationKey AsGenesisUTxOKey) - AGenesisUTxOKey - ] - vkeyPath - liftIO $ BS.putStrLn (renderKeyHash vkey) - where - renderKeyHash :: SomeGenesisKey VerificationKey -> ByteString - renderKeyHash (AGenesisKey vk) = renderVerificationKeyHash vk - renderKeyHash (AGenesisDelegateKey vk) = renderVerificationKeyHash vk - renderKeyHash (AGenesisUTxOKey vk) = renderVerificationKeyHash vk - - renderVerificationKeyHash :: Key keyrole => VerificationKey keyrole -> ByteString - renderVerificationKeyHash = serialiseToRawBytesHex - . verificationKeyHash + vkey <- + firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ + readFileTextEnvelopeAnyOf + [ FromSomeType + (AsVerificationKey AsGenesisKey) + AGenesisKey + , FromSomeType + (AsVerificationKey AsGenesisDelegateKey) + AGenesisDelegateKey + , FromSomeType + (AsVerificationKey AsGenesisUTxOKey) + AGenesisUTxOKey + ] + vkeyPath + liftIO $ BS.putStrLn (renderKeyHash vkey) + where + renderKeyHash :: SomeGenesisKey VerificationKey -> ByteString + renderKeyHash (AGenesisKey vk) = renderVerificationKeyHash vk + renderKeyHash (AGenesisDelegateKey vk) = renderVerificationKeyHash vk + renderKeyHash (AGenesisUTxOKey vk) = renderVerificationKeyHash vk + renderVerificationKeyHash :: Key keyrole => VerificationKey keyrole -> ByteString + renderVerificationKeyHash = + serialiseToRawBytesHex + . verificationKeyHash runGenesisVerKeyCmd :: GenesisVerKeyCmdArgs -> ExceptT GenesisCmdError IO () runGenesisVerKeyCmd - Cmd.GenesisVerKeyCmdArgs + Cmd.GenesisVerKeyCmdArgs { Cmd.verificationKeyPath , Cmd.signingKeyPath } = do - skey <- firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ - readFileTextEnvelopeAnyOf - [ FromSomeType (AsSigningKey AsGenesisKey) - AGenesisKey - , FromSomeType (AsSigningKey AsGenesisDelegateKey) - AGenesisDelegateKey - , FromSomeType (AsSigningKey AsGenesisUTxOKey) - AGenesisUTxOKey - ] - signingKeyPath + skey <- + firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ + readFileTextEnvelopeAnyOf + [ FromSomeType + (AsSigningKey AsGenesisKey) + AGenesisKey + , FromSomeType + (AsSigningKey AsGenesisDelegateKey) + AGenesisDelegateKey + , FromSomeType + (AsSigningKey AsGenesisUTxOKey) + AGenesisUTxOKey + ] + signingKeyPath let vkey :: SomeGenesisKey VerificationKey vkey = case skey of - AGenesisKey sk -> AGenesisKey (getVerificationKey sk) + AGenesisKey sk -> AGenesisKey (getVerificationKey sk) AGenesisDelegateKey sk -> AGenesisDelegateKey (getVerificationKey sk) - AGenesisUTxOKey sk -> AGenesisUTxOKey (getVerificationKey sk) + AGenesisUTxOKey sk -> AGenesisUTxOKey (getVerificationKey sk) firstExceptT GenesisCmdGenesisFileError . newExceptT . liftIO $ case vkey of - AGenesisKey vk -> writeLazyByteStringFile verificationKeyPath $ textEnvelopeToJSON Nothing vk + AGenesisKey vk -> writeLazyByteStringFile verificationKeyPath $ textEnvelopeToJSON Nothing vk AGenesisDelegateKey vk -> writeLazyByteStringFile verificationKeyPath $ textEnvelopeToJSON Nothing vk - AGenesisUTxOKey vk -> writeLazyByteStringFile verificationKeyPath $ textEnvelopeToJSON Nothing vk + AGenesisUTxOKey vk -> writeLazyByteStringFile verificationKeyPath $ textEnvelopeToJSON Nothing vk data SomeGenesisKey f - = AGenesisKey (f GenesisKey) - | AGenesisDelegateKey (f GenesisDelegateKey) - | AGenesisUTxOKey (f GenesisUTxOKey) - + = AGenesisKey (f GenesisKey) + | AGenesisDelegateKey (f GenesisDelegateKey) + | AGenesisUTxOKey (f GenesisUTxOKey) runGenesisTxInCmd :: GenesisTxInCmdArgs -> ExceptT GenesisCmdError IO () runGenesisTxInCmd - Cmd.GenesisTxInCmdArgs + Cmd.GenesisTxInCmdArgs { Cmd.verificationKeyPath , Cmd.network , Cmd.mOutFile } = do - vkey <- firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ - readFileTextEnvelope (AsVerificationKey AsGenesisUTxOKey) verificationKeyPath + vkey <- + firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ + readFileTextEnvelope (AsVerificationKey AsGenesisUTxOKey) verificationKeyPath let txin = genesisUTxOPseudoTxIn network (verificationKeyHash vkey) liftIO $ writeOutput mOutFile (renderTxIn txin) - runGenesisAddrCmd :: GenesisAddrCmdArgs -> ExceptT GenesisCmdError IO () runGenesisAddrCmd - Cmd.GenesisAddrCmdArgs + Cmd.GenesisAddrCmdArgs { Cmd.verificationKeyPath , Cmd.network , Cmd.mOutFile } = do - vkey <- firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ - readFileTextEnvelope (AsVerificationKey AsGenesisUTxOKey) verificationKeyPath - let vkh = verificationKeyHash (castVerificationKey vkey) - addr = makeShelleyAddress network (PaymentCredentialByKey vkh) - NoStakeAddress + vkey <- + firstExceptT GenesisCmdTextEnvReadFileError . newExceptT $ + readFileTextEnvelope (AsVerificationKey AsGenesisUTxOKey) verificationKeyPath + let vkh = verificationKeyHash (castVerificationKey vkey) + addr = + makeShelleyAddress + network + (PaymentCredentialByKey vkh) + NoStakeAddress liftIO $ writeOutput mOutFile (serialiseAddress addr) writeOutput :: Maybe (File () Out) -> Text -> IO () writeOutput (Just (File fpath)) = Text.writeFile fpath -writeOutput Nothing = Text.putStrLn - +writeOutput Nothing = Text.putStrLn -- -- Create Genesis command implementation @@ -236,7 +244,7 @@ runGenesisCreateCmd :: GenesisCreateCmdArgs -> ExceptT GenesisCmdError IO () runGenesisCreateCmd - Cmd.GenesisCreateCmdArgs + Cmd.GenesisCreateCmdArgs { Cmd.keyOutputFormat , Cmd.genesisDir , Cmd.numGenesisKeys @@ -245,47 +253,57 @@ runGenesisCreateCmd , Cmd.mSupply , Cmd.network } = do - let GenesisDir rootdir = genesisDir - gendir = rootdir "genesis-keys" - deldir = rootdir "delegate-keys" - utxodir = rootdir "utxo-keys" - liftIO $ do - createDirectoryIfMissing False rootdir - createDirectoryIfMissing False gendir - createDirectoryIfMissing False deldir - createDirectoryIfMissing False utxodir - - template <- readShelleyGenesisWithDefault (rootdir "genesis.spec.json") adjustTemplate - alonzoGenesis <- readAlonzoGenesis (rootdir "genesis.alonzo.spec.json") - conwayGenesis <- readConwayGenesis (rootdir "genesis.conway.spec.json") - - forM_ [ 1 .. numGenesisKeys ] $ \index -> do - createGenesisKeys gendir index - createDelegateKeys keyOutputFormat deldir index - - forM_ [ 1 .. numUTxOKeys ] $ \index -> - createUtxoKeys utxodir index - - genDlgs <- readGenDelegsMap gendir deldir - utxoAddrs <- readInitialFundAddresses utxodir network - start <- maybe (SystemStart <$> TN.getCurrentTimePlus30) pure mSystemStart - - let shelleyGenesis = - updateTemplate - -- Shelley genesis parameters - start genDlgs mSupply utxoAddrs mempty (L.Coin 0) [] [] template - - void $ writeFileGenesis (rootdir "genesis.json") $ WritePretty shelleyGenesis - void $ writeFileGenesis (rootdir "genesis.alonzo.json") $ WritePretty alonzoGenesis - void $ writeFileGenesis (rootdir "genesis.conway.json") $ WritePretty conwayGenesis - --TODO: rationalise the naming convention on these genesis json files. - where - adjustTemplate t = t { sgNetworkMagic = unNetworkMagic (toNetworkMagic network) } + let GenesisDir rootdir = genesisDir + gendir = rootdir "genesis-keys" + deldir = rootdir "delegate-keys" + utxodir = rootdir "utxo-keys" + liftIO $ do + createDirectoryIfMissing False rootdir + createDirectoryIfMissing False gendir + createDirectoryIfMissing False deldir + createDirectoryIfMissing False utxodir + + template <- readShelleyGenesisWithDefault (rootdir "genesis.spec.json") adjustTemplate + alonzoGenesis <- readAlonzoGenesis (rootdir "genesis.alonzo.spec.json") + conwayGenesis <- readConwayGenesis (rootdir "genesis.conway.spec.json") + + forM_ [1 .. numGenesisKeys] $ \index -> do + createGenesisKeys gendir index + createDelegateKeys keyOutputFormat deldir index + + forM_ [1 .. numUTxOKeys] $ \index -> + createUtxoKeys utxodir index + + genDlgs <- readGenDelegsMap gendir deldir + utxoAddrs <- readInitialFundAddresses utxodir network + start <- maybe (SystemStart <$> TN.getCurrentTimePlus30) pure mSystemStart + + let shelleyGenesis = + updateTemplate + -- Shelley genesis parameters + start + genDlgs + mSupply + utxoAddrs + mempty + (L.Coin 0) + [] + [] + template + + void $ writeFileGenesis (rootdir "genesis.json") $ WritePretty shelleyGenesis + void $ writeFileGenesis (rootdir "genesis.alonzo.json") $ WritePretty alonzoGenesis + void $ writeFileGenesis (rootdir "genesis.conway.json") $ WritePretty conwayGenesis + where + -- TODO: rationalise the naming convention on these genesis json files. + + adjustTemplate t = t{sgNetworkMagic = unNetworkMagic (toNetworkMagic network)} toSKeyJSON :: Key a => SigningKey a -> ByteString toSKeyJSON = LBS.toStrict . textEnvelopeToJSON Nothing -toVkeyJSON :: () +toVkeyJSON + :: () => Key a => HasTypeProxy a => SigningKey a @@ -301,12 +319,17 @@ toOpCert = LBS.toStrict . textEnvelopeToJSON Nothing . fst toCounter :: (OperationalCertificate, OperationalCertificateIssueCounter) -> ByteString toCounter = LBS.toStrict . textEnvelopeToJSON Nothing . snd -generateShelleyNodeSecrets :: [SigningKey GenesisDelegateExtendedKey] -> [VerificationKey GenesisKey] - -> IO (Map (Hash GenesisKey) - ( Hash GenesisDelegateKey, Hash VrfKey) +generateShelleyNodeSecrets + :: [SigningKey GenesisDelegateExtendedKey] + -> [VerificationKey GenesisKey] + -> IO + ( Map + (Hash GenesisKey) + (Hash GenesisDelegateKey, Hash VrfKey) , [SigningKey VrfKey] , [SigningKey KesKey] - , [(OperationalCertificate, OperationalCertificateIssueCounter)]) + , [(OperationalCertificate, OperationalCertificateIssueCounter)] + ) generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys = do let shelleyDelegatevkeys :: [VerificationKey GenesisDelegateKey] @@ -317,30 +340,41 @@ generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys = do let opCertInputs :: [(VerificationKey KesKey, SigningKey GenesisDelegateExtendedKey)] opCertInputs = zip (map getVerificationKey kesKeys) shelleyDelegateKeys - createOpCert :: (VerificationKey KesKey, SigningKey GenesisDelegateExtendedKey) -> (OperationalCertificate, OperationalCertificateIssueCounter) + createOpCert + :: (VerificationKey KesKey, SigningKey GenesisDelegateExtendedKey) + -> (OperationalCertificate, OperationalCertificateIssueCounter) createOpCert (kesKey, delegateKey) = either (error . show) id eResult - where - eResult = issueOperationalCertificate kesKey (Right delegateKey) (KESPeriod 0) counter - counter = OperationalCertificateIssueCounter 0 (convert . getVerificationKey $ delegateKey) - convert :: VerificationKey GenesisDelegateExtendedKey - -> VerificationKey StakePoolKey - convert = (castVerificationKey :: VerificationKey GenesisDelegateKey - -> VerificationKey StakePoolKey) - . (castVerificationKey :: VerificationKey GenesisDelegateExtendedKey - -> VerificationKey GenesisDelegateKey) + where + eResult = issueOperationalCertificate kesKey (Right delegateKey) (KESPeriod 0) counter + counter = OperationalCertificateIssueCounter 0 (convert . getVerificationKey $ delegateKey) + convert + :: VerificationKey GenesisDelegateExtendedKey + -> VerificationKey StakePoolKey + convert = + ( castVerificationKey + :: VerificationKey GenesisDelegateKey + -> VerificationKey StakePoolKey + ) + . ( castVerificationKey + :: VerificationKey GenesisDelegateExtendedKey + -> VerificationKey GenesisDelegateKey + ) opCerts :: [(OperationalCertificate, OperationalCertificateIssueCounter)] opCerts = map createOpCert opCertInputs vrfvkeys = map getVerificationKey vrfKeys - combinedMap :: [ ( VerificationKey GenesisKey - , VerificationKey GenesisDelegateKey - , VerificationKey VrfKey - ) - ] + combinedMap + :: [ ( VerificationKey GenesisKey + , VerificationKey GenesisDelegateKey + , VerificationKey VrfKey + ) + ] combinedMap = zip3 shelleyGenesisvkeys shelleyDelegatevkeys vrfvkeys - hashKeys :: (VerificationKey GenesisKey, VerificationKey GenesisDelegateKey, VerificationKey VrfKey) -> (Hash GenesisKey, (Hash GenesisDelegateKey, Hash VrfKey)) - hashKeys (genesis,delegate,vrf) = (verificationKeyHash genesis, (verificationKeyHash delegate, verificationKeyHash vrf)); + hashKeys + :: (VerificationKey GenesisKey, VerificationKey GenesisDelegateKey, VerificationKey VrfKey) + -> (Hash GenesisKey, (Hash GenesisDelegateKey, Hash VrfKey)) + hashKeys (genesis, delegate, vrf) = (verificationKeyHash genesis, (verificationKeyHash delegate, verificationKeyHash vrf)) delegateMap :: Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) delegateMap = Map.fromList . map hashKeys $ combinedMap @@ -354,7 +388,7 @@ runGenesisCreateCardanoCmd :: GenesisCreateCardanoCmdArgs -> ExceptT GenesisCmdError IO () runGenesisCreateCardanoCmd - Cmd.GenesisCreateCardanoCmdArgs + Cmd.GenesisCreateCardanoCmdArgs { Cmd.genesisDir , Cmd.numGenesisKeys , Cmd.numUTxOKeys @@ -370,110 +404,125 @@ runGenesisCreateCardanoCmd , Cmd.conwayGenesisTemplate , Cmd.mNodeConfigTemplate } = do - start <- maybe (SystemStart <$> TN.getCurrentTimePlus30) pure mSystemStart - (byronGenesis', byronSecrets) <- convertToShelleyError $ Byron.mkGenesis $ byronParams start - let - byronGenesis = byronGenesis' - { gdProtocolParameters = (gdProtocolParameters byronGenesis') { - ppSlotDuration = floor ( toRational slotLength * recip slotCoeff ) - } - } - - genesisKeys = gsDlgIssuersSecrets byronSecrets - byronGenesisKeys = map ByronSigningKey genesisKeys - shelleyGenesisKeys = map convertGenesisKey genesisKeys - shelleyGenesisvkeys :: [VerificationKey GenesisKey] - shelleyGenesisvkeys = map (castVerificationKey . getVerificationKey) shelleyGenesisKeys - - delegateKeys = gsRichSecrets byronSecrets - byronDelegateKeys = map ByronSigningKey delegateKeys - shelleyDelegateKeys :: [SigningKey GenesisDelegateExtendedKey] - shelleyDelegateKeys = map convertDelegate delegateKeys - shelleyDelegatevkeys :: [VerificationKey GenesisDelegateKey] - shelleyDelegatevkeys = map (castVerificationKey . getVerificationKey) shelleyDelegateKeys - - utxoKeys = gsPoorSecrets byronSecrets - byronUtxoKeys = map (ByronSigningKey . Genesis.poorSecretToKey) utxoKeys - shelleyUtxoKeys = map (convertPoor . Genesis.poorSecretToKey) utxoKeys + start <- maybe (SystemStart <$> TN.getCurrentTimePlus30) pure mSystemStart + (byronGenesis', byronSecrets) <- convertToShelleyError $ Byron.mkGenesis $ byronParams start + let + byronGenesis = + byronGenesis' + { gdProtocolParameters = + (gdProtocolParameters byronGenesis') + { ppSlotDuration = floor (toRational slotLength * recip slotCoeff) + } + } - dlgCerts <- convertToShelleyError $ mapM (findDelegateCert byronGenesis) byronDelegateKeys - let - overrideShelleyGenesis t = t - { sgNetworkMagic = unNetworkMagic (toNetworkMagic network) - , sgNetworkId = toShelleyNetwork network - , sgActiveSlotsCoeff = fromMaybe (error $ "Could not convert from Rational: " ++ show slotCoeff) $ L.boundRational slotCoeff - , sgSecurityParam = unBlockCount security - , sgUpdateQuorum = fromIntegral $ ((numGenesisKeys `div` 3) * 2) + 1 - , sgEpochLength = EpochSize $ floor $ (fromIntegral (unBlockCount security) * 10) / slotCoeff - , sgMaxLovelaceSupply = 45_000_000_000_000_000 - , sgSystemStart = getSystemStart start - , sgSlotLength = L.secondsToNominalDiffTimeMicro $ MkFixed (fromIntegral slotLength) * 1000 - } - shelleyGenesisTemplate' <- liftIO $ overrideShelleyGenesis . fromRight (error "shelley genesis template not found") <$> TN.readAndDecodeGenesisFile shelleyGenesisTemplate - alonzoGenesis <- readAlonzoGenesis alonzoGenesisTemplate - conwayGenesis <- readConwayGenesis conwayGenesisTemplate - (delegateMap, vrfKeys, kesKeys, opCerts) <- liftIO $ generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys - let - shelleyGenesis :: ShelleyGenesis L.StandardCrypto - shelleyGenesis = updateTemplate start delegateMap Nothing [] mempty 0 [] [] shelleyGenesisTemplate' - - let GenesisDir rootdir = genesisDir - gendir = rootdir "genesis-keys" - deldir = rootdir "delegate-keys" - utxodir = rootdir "utxo-keys" - - liftIO $ do - createDirectoryIfMissing False rootdir - createDirectoryIfMissing False gendir - createDirectoryIfMissing False deldir - createDirectoryIfMissing False utxodir - - writeSecrets gendir "byron" "key" serialiseToRawBytes byronGenesisKeys - writeSecrets gendir "shelley" "skey" toSKeyJSON shelleyGenesisKeys - writeSecrets gendir "shelley" "vkey" toVkeyJSON shelleyGenesisKeys - - writeSecrets deldir "byron" "key" serialiseToRawBytes byronDelegateKeys - writeSecrets deldir "shelley" "skey" toSKeyJSON shelleyDelegateKeys - writeSecrets deldir "shelley" "vkey" toVkeyJSON' shelleyDelegatevkeys - writeSecrets deldir "shelley" "vrf.skey" toSKeyJSON vrfKeys - writeSecrets deldir "shelley" "vrf.vkey" toVkeyJSON vrfKeys - writeSecrets deldir "shelley" "kes.skey" toSKeyJSON kesKeys - writeSecrets deldir "shelley" "kes.vkey" toVkeyJSON kesKeys - - writeSecrets utxodir "byron" "key" serialiseToRawBytes byronUtxoKeys - writeSecrets utxodir "shelley" "skey" toSKeyJSON shelleyUtxoKeys - writeSecrets utxodir "shelley" "vkey" toVkeyJSON shelleyUtxoKeys - - writeSecrets deldir "byron" "cert.json" serialiseDelegationCert dlgCerts - - writeSecrets deldir "shelley" "opcert.json" toOpCert opCerts - writeSecrets deldir "shelley" "counter.json" toCounter opCerts - - byronGenesisHash <- writeFileGenesis (rootdir "byron-genesis.json") $ WriteCanonical byronGenesis - shelleyGenesisHash <- writeFileGenesis (rootdir "shelley-genesis.json") $ WritePretty shelleyGenesis - alonzoGenesisHash <- writeFileGenesis (rootdir "alonzo-genesis.json") $ WritePretty alonzoGenesis - conwayGenesisHash <- writeFileGenesis (rootdir "conway-genesis.json") $ WritePretty conwayGenesis - - liftIO $ do - case mNodeConfigTemplate of - Nothing -> pure () - Just nodeCfg -> do - nodeConfig <- Yaml.decodeFileThrow nodeCfg - let - setHash field hash = Aeson.insert field $ String $ Crypto.hashToTextAsHex hash - updateConfig :: Yaml.Value -> Yaml.Value - updateConfig (Object obj) = Object - $ setHash "ByronGenesisHash" byronGenesisHash - $ setHash "ShelleyGenesisHash" shelleyGenesisHash - $ setHash "AlonzoGenesisHash" alonzoGenesisHash - $ setHash "ConwayGenesisHash" conwayGenesisHash - obj - updateConfig x = x - newConfig :: Yaml.Value - newConfig = updateConfig nodeConfig - encodeFile (rootdir "node-config.json") newConfig - - where + genesisKeys = gsDlgIssuersSecrets byronSecrets + byronGenesisKeys = map ByronSigningKey genesisKeys + shelleyGenesisKeys = map convertGenesisKey genesisKeys + shelleyGenesisvkeys :: [VerificationKey GenesisKey] + shelleyGenesisvkeys = map (castVerificationKey . getVerificationKey) shelleyGenesisKeys + + delegateKeys = gsRichSecrets byronSecrets + byronDelegateKeys = map ByronSigningKey delegateKeys + shelleyDelegateKeys :: [SigningKey GenesisDelegateExtendedKey] + shelleyDelegateKeys = map convertDelegate delegateKeys + shelleyDelegatevkeys :: [VerificationKey GenesisDelegateKey] + shelleyDelegatevkeys = map (castVerificationKey . getVerificationKey) shelleyDelegateKeys + + utxoKeys = gsPoorSecrets byronSecrets + byronUtxoKeys = map (ByronSigningKey . Genesis.poorSecretToKey) utxoKeys + shelleyUtxoKeys = map (convertPoor . Genesis.poorSecretToKey) utxoKeys + + dlgCerts <- convertToShelleyError $ mapM (findDelegateCert byronGenesis) byronDelegateKeys + let + overrideShelleyGenesis t = + t + { sgNetworkMagic = unNetworkMagic (toNetworkMagic network) + , sgNetworkId = toShelleyNetwork network + , sgActiveSlotsCoeff = + fromMaybe (error $ "Could not convert from Rational: " ++ show slotCoeff) $ + L.boundRational slotCoeff + , sgSecurityParam = unBlockCount security + , sgUpdateQuorum = fromIntegral $ ((numGenesisKeys `div` 3) * 2) + 1 + , sgEpochLength = EpochSize $ floor $ (fromIntegral (unBlockCount security) * 10) / slotCoeff + , sgMaxLovelaceSupply = 45_000_000_000_000_000 + , sgSystemStart = getSystemStart start + , sgSlotLength = L.secondsToNominalDiffTimeMicro $ MkFixed (fromIntegral slotLength) * 1000 + } + shelleyGenesisTemplate' <- + liftIO $ + overrideShelleyGenesis . fromRight (error "shelley genesis template not found") + <$> TN.readAndDecodeGenesisFile shelleyGenesisTemplate + alonzoGenesis <- readAlonzoGenesis alonzoGenesisTemplate + conwayGenesis <- readConwayGenesis conwayGenesisTemplate + (delegateMap, vrfKeys, kesKeys, opCerts) <- + liftIO $ generateShelleyNodeSecrets shelleyDelegateKeys shelleyGenesisvkeys + let + shelleyGenesis :: ShelleyGenesis L.StandardCrypto + shelleyGenesis = updateTemplate start delegateMap Nothing [] mempty 0 [] [] shelleyGenesisTemplate' + + let GenesisDir rootdir = genesisDir + gendir = rootdir "genesis-keys" + deldir = rootdir "delegate-keys" + utxodir = rootdir "utxo-keys" + + liftIO $ do + createDirectoryIfMissing False rootdir + createDirectoryIfMissing False gendir + createDirectoryIfMissing False deldir + createDirectoryIfMissing False utxodir + + writeSecrets gendir "byron" "key" serialiseToRawBytes byronGenesisKeys + writeSecrets gendir "shelley" "skey" toSKeyJSON shelleyGenesisKeys + writeSecrets gendir "shelley" "vkey" toVkeyJSON shelleyGenesisKeys + + writeSecrets deldir "byron" "key" serialiseToRawBytes byronDelegateKeys + writeSecrets deldir "shelley" "skey" toSKeyJSON shelleyDelegateKeys + writeSecrets deldir "shelley" "vkey" toVkeyJSON' shelleyDelegatevkeys + writeSecrets deldir "shelley" "vrf.skey" toSKeyJSON vrfKeys + writeSecrets deldir "shelley" "vrf.vkey" toVkeyJSON vrfKeys + writeSecrets deldir "shelley" "kes.skey" toSKeyJSON kesKeys + writeSecrets deldir "shelley" "kes.vkey" toVkeyJSON kesKeys + + writeSecrets utxodir "byron" "key" serialiseToRawBytes byronUtxoKeys + writeSecrets utxodir "shelley" "skey" toSKeyJSON shelleyUtxoKeys + writeSecrets utxodir "shelley" "vkey" toVkeyJSON shelleyUtxoKeys + + writeSecrets deldir "byron" "cert.json" serialiseDelegationCert dlgCerts + + writeSecrets deldir "shelley" "opcert.json" toOpCert opCerts + writeSecrets deldir "shelley" "counter.json" toCounter opCerts + + byronGenesisHash <- + writeFileGenesis (rootdir "byron-genesis.json") $ WriteCanonical byronGenesis + shelleyGenesisHash <- + writeFileGenesis (rootdir "shelley-genesis.json") $ WritePretty shelleyGenesis + alonzoGenesisHash <- + writeFileGenesis (rootdir "alonzo-genesis.json") $ WritePretty alonzoGenesis + conwayGenesisHash <- + writeFileGenesis (rootdir "conway-genesis.json") $ WritePretty conwayGenesis + + liftIO $ do + case mNodeConfigTemplate of + Nothing -> pure () + Just nodeCfg -> do + nodeConfig <- Yaml.decodeFileThrow nodeCfg + let + setHash field hash = Aeson.insert field $ String $ Crypto.hashToTextAsHex hash + updateConfig :: Yaml.Value -> Yaml.Value + updateConfig (Object obj) = + Object $ + setHash "ByronGenesisHash" byronGenesisHash $ + setHash "ShelleyGenesisHash" shelleyGenesisHash $ + setHash "AlonzoGenesisHash" alonzoGenesisHash $ + setHash + "ConwayGenesisHash" + conwayGenesisHash + obj + updateConfig x = x + newConfig :: Yaml.Value + newConfig = updateConfig nodeConfig + encodeFile (rootdir "node-config.json") newConfig + where convertToShelleyError = withExceptT GenesisCmdByronError convertGenesisKey :: Byron.SigningKey -> SigningKey GenesisExtendedKey convertGenesisKey (Byron.SigningKey xsk) = GenesisExtendedSigningKey xsk @@ -484,17 +533,29 @@ runGenesisCreateCardanoCmd convertPoor :: Byron.SigningKey -> SigningKey ByronKey convertPoor = ByronSigningKey - byronParams start = Byron.GenesisParameters (getSystemStart start) byronGenesisTemplate security byronNetwork byronBalance byronFakeAvvm byronAvvmFactor Nothing - byronNetwork = CC.AProtocolMagic - (L.Annotated (toByronProtocolMagicId network) ()) - (toByronRequiresNetworkMagic network) - byronBalance = TestnetBalanceOptions + byronParams start = + Byron.GenesisParameters + (getSystemStart start) + byronGenesisTemplate + security + byronNetwork + byronBalance + byronFakeAvvm + byronAvvmFactor + Nothing + byronNetwork = + CC.AProtocolMagic + (L.Annotated (toByronProtocolMagicId network) ()) + (toByronRequiresNetworkMagic network) + byronBalance = + TestnetBalanceOptions { tboRichmen = numGenesisKeys , tboPoors = numUTxOKeys , tboTotalBalance = fromMaybe zeroLovelace $ toByronLovelace (fromMaybe 0 mSupply) , tboRichmenShare = 0 } - byronFakeAvvm = FakeAvvmOptions + byronFakeAvvm = + FakeAvvmOptions { faoCount = 0 , faoOneBalance = zeroLovelace } @@ -505,12 +566,16 @@ runGenesisCreateCardanoCmd isCertForSK :: CC.SigningKey -> Dlg.Certificate -> Bool isCertForSK sk cert = delegateVK cert == CC.toVerification sk - findDelegateCert :: Genesis.GenesisData -> SigningKey ByronKey -> ExceptT ByronGenesisError IO Dlg.Certificate + findDelegateCert + :: Genesis.GenesisData -> SigningKey ByronKey -> ExceptT ByronGenesisError IO Dlg.Certificate findDelegateCert byronGenesis bSkey@(ByronSigningKey sk) = do case List.find (isCertForSK sk) (Map.elems $ dlgCertMap byronGenesis) of - Nothing -> throwE . NoGenesisDelegationForKey - . Byron.prettyPublicKey $ getVerificationKey bSkey - Just x -> pure x + Nothing -> + throwE + . NoGenesisDelegationForKey + . Byron.prettyPublicKey + $ getVerificationKey bSkey + Just x -> pure x dlgCertMap :: Genesis.GenesisData -> Map Byron.KeyHash Dlg.Certificate dlgCertMap byronGenesis = Genesis.unGenesisDelegation $ Genesis.gdHeavyDelegation byronGenesis @@ -519,7 +584,7 @@ runGenesisCreateStakedCmd :: GenesisCreateStakedCmdArgs -> ExceptT GenesisCmdError IO () runGenesisCreateStakedCmd - Cmd.GenesisCreateStakedCmdArgs + Cmd.GenesisCreateStakedCmdArgs { Cmd.keyOutputFormat , Cmd.genesisDir , Cmd.numGenesisKeys @@ -535,153 +600,196 @@ runGenesisCreateStakedCmd , Cmd.numStuffedUtxo , Cmd.mStakePoolRelaySpecFile } = do - let GenesisDir rootdir = genesisDir - gendir = rootdir "genesis-keys" - deldir = rootdir "delegate-keys" - pooldir = rootdir "pools" - stdeldir = rootdir "stake-delegator-keys" - utxodir = rootdir "utxo-keys" - - liftIO $ do - createDirectoryIfMissing False rootdir - createDirectoryIfMissing False gendir - createDirectoryIfMissing False deldir - createDirectoryIfMissing False pooldir - createDirectoryIfMissing False stdeldir - createDirectoryIfMissing False utxodir - - template <- readShelleyGenesisWithDefault (rootdir "genesis.spec.json") adjustTemplate - alonzoGenesis <- readAlonzoGenesis (rootdir "genesis.alonzo.spec.json") - conwayGenesis <- readConwayGenesis (rootdir "genesis.conway.spec.json") - - forM_ [ 1 .. numGenesisKeys ] $ \index -> do - createGenesisKeys gendir index - createDelegateKeys keyOutputFormat deldir index - - forM_ [ 1 .. numUTxOKeys ] $ \index -> - createUtxoKeys utxodir index - - mayStakePoolRelays <- forM mStakePoolRelaySpecFile TN.readRelays - - poolParams <- forM [ 1 .. numPools ] $ \index -> do - createPoolCredentials keyOutputFormat pooldir index - buildPoolParams networkId pooldir (Just index) (fromMaybe mempty mayStakePoolRelays) - - when (numBulkPoolCredFiles * numBulkPoolsPerFile > numPools) $ - left $ GenesisCmdTooFewPoolsForBulkCreds numPools numBulkPoolCredFiles numBulkPoolsPerFile - -- We generate the bulk files for the last pool indices, - -- so that all the non-bulk pools have stable indices at beginning: - let bulkOffset = fromIntegral $ numPools - numBulkPoolCredFiles * numBulkPoolsPerFile - bulkIndices :: [Word] = [ 1 + bulkOffset .. numPools ] - bulkSlices :: [[Word]] = List.chunksOf (fromIntegral numBulkPoolsPerFile) bulkIndices - forM_ (zip [ 1 .. numBulkPoolCredFiles ] bulkSlices) $ - uncurry (writeBulkPoolCredentials pooldir) - - let (delegsPerPool, delegsRemaining) = - if numPools == 0 - then (0, 0) - else numStakeDelegators `divMod` numPools - delegsForPool poolIx = - if delegsRemaining /= 0 && poolIx == numPools - then delegsPerPool - else delegsPerPool + delegsRemaining - distribution = [pool | (pool, poolIx) <- zip poolParams [1 ..], _ <- [1 .. delegsForPool poolIx]] - - g <- Random.getStdGen - - -- Distribute M delegates across N pools: - delegations <- liftIO $ Lazy.forStateM g distribution $ flip computeInsecureDelegation networkId - - let numDelegations = length delegations - - genDlgs <- readGenDelegsMap gendir deldir - nonDelegAddrs <- readInitialFundAddresses utxodir networkId - start <- maybe (SystemStart <$> TN.getCurrentTimePlus30) pure mSystemStart - - let network = toShelleyNetwork networkId - stuffedUtxoAddrs <- liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) $ TN.genStuffedAddress network - - let stake = second L.ppId . mkDelegationMapEntry <$> delegations - stakePools = [ (L.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations ] - delegAddrs = dInitialUtxoAddr <$> delegations - !shelleyGenesis = - updateOutputTemplate - -- Shelley genesis parameters - start genDlgs mNonDelegatedSupply (length nonDelegAddrs) nonDelegAddrs stakePools stake - (Just delegatedSupply) numDelegations delegAddrs stuffedUtxoAddrs template - - liftIO $ LBS.writeFile (rootdir "genesis.json") $ encodePretty shelleyGenesis - - void $ writeFileGenesis (rootdir "genesis.alonzo.json") $ WritePretty alonzoGenesis - void $ writeFileGenesis (rootdir "genesis.conway.json") $ WritePretty conwayGenesis - --TODO: rationalise the naming convention on these genesis json files. - - liftIO $ Text.hPutStrLn IO.stderr $ mconcat $ - [ "generated genesis with: " - , textShow numGenesisKeys, " genesis keys, " - , textShow numUTxOKeys, " non-delegating UTxO keys, " - , textShow numPools, " stake pools, " - , textShow numStakeDelegators, " delegating UTxO keys, " - , textShow numDelegations, " delegation map entries, " - ] ++ - [ mconcat - [ ", " - , textShow numBulkPoolCredFiles, " bulk pool credential files, " - , textShow numBulkPoolsPerFile, " pools per bulk credential file, indices starting from " - , textShow bulkOffset, ", " - , textShow $ length bulkIndices, " total pools in bulk nodes, each bulk node having this many entries: " - , textShow $ length <$> bulkSlices - ] - | numBulkPoolCredFiles * numBulkPoolsPerFile > 0 ] - - where - adjustTemplate t = t { sgNetworkMagic = unNetworkMagic (toNetworkMagic networkId) } - mkDelegationMapEntry :: Delegation -> (L.KeyHash L.Staking L.StandardCrypto, L.PoolParams L.StandardCrypto) + let GenesisDir rootdir = genesisDir + gendir = rootdir "genesis-keys" + deldir = rootdir "delegate-keys" + pooldir = rootdir "pools" + stdeldir = rootdir "stake-delegator-keys" + utxodir = rootdir "utxo-keys" + + liftIO $ do + createDirectoryIfMissing False rootdir + createDirectoryIfMissing False gendir + createDirectoryIfMissing False deldir + createDirectoryIfMissing False pooldir + createDirectoryIfMissing False stdeldir + createDirectoryIfMissing False utxodir + + template <- readShelleyGenesisWithDefault (rootdir "genesis.spec.json") adjustTemplate + alonzoGenesis <- readAlonzoGenesis (rootdir "genesis.alonzo.spec.json") + conwayGenesis <- readConwayGenesis (rootdir "genesis.conway.spec.json") + + forM_ [1 .. numGenesisKeys] $ \index -> do + createGenesisKeys gendir index + createDelegateKeys keyOutputFormat deldir index + + forM_ [1 .. numUTxOKeys] $ \index -> + createUtxoKeys utxodir index + + mayStakePoolRelays <- forM mStakePoolRelaySpecFile TN.readRelays + + poolParams <- forM [1 .. numPools] $ \index -> do + createPoolCredentials keyOutputFormat pooldir index + buildPoolParams networkId pooldir (Just index) (fromMaybe mempty mayStakePoolRelays) + + when (numBulkPoolCredFiles * numBulkPoolsPerFile > numPools) $ + left $ + GenesisCmdTooFewPoolsForBulkCreds numPools numBulkPoolCredFiles numBulkPoolsPerFile + -- We generate the bulk files for the last pool indices, + -- so that all the non-bulk pools have stable indices at beginning: + let bulkOffset = fromIntegral $ numPools - numBulkPoolCredFiles * numBulkPoolsPerFile + bulkIndices :: [Word] = [1 + bulkOffset .. numPools] + bulkSlices :: [[Word]] = List.chunksOf (fromIntegral numBulkPoolsPerFile) bulkIndices + forM_ (zip [1 .. numBulkPoolCredFiles] bulkSlices) $ + uncurry (writeBulkPoolCredentials pooldir) + + let (delegsPerPool, delegsRemaining) = + if numPools == 0 + then (0, 0) + else numStakeDelegators `divMod` numPools + delegsForPool poolIx = + if delegsRemaining /= 0 && poolIx == numPools + then delegsPerPool + else delegsPerPool + delegsRemaining + distribution = [pool | (pool, poolIx) <- zip poolParams [1 ..], _ <- [1 .. delegsForPool poolIx]] + + g <- Random.getStdGen + + -- Distribute M delegates across N pools: + delegations <- liftIO $ Lazy.forStateM g distribution $ flip computeInsecureDelegation networkId + + let numDelegations = length delegations + + genDlgs <- readGenDelegsMap gendir deldir + nonDelegAddrs <- readInitialFundAddresses utxodir networkId + start <- maybe (SystemStart <$> TN.getCurrentTimePlus30) pure mSystemStart + + let network = toShelleyNetwork networkId + stuffedUtxoAddrs <- + liftIO $ Lazy.replicateM (fromIntegral numStuffedUtxo) $ TN.genStuffedAddress network + + let stake = second L.ppId . mkDelegationMapEntry <$> delegations + stakePools = [(L.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations] + delegAddrs = dInitialUtxoAddr <$> delegations + !shelleyGenesis = + updateOutputTemplate + -- Shelley genesis parameters + start + genDlgs + mNonDelegatedSupply + (length nonDelegAddrs) + nonDelegAddrs + stakePools + stake + (Just delegatedSupply) + numDelegations + delegAddrs + stuffedUtxoAddrs + template + + liftIO $ LBS.writeFile (rootdir "genesis.json") $ encodePretty shelleyGenesis + + void $ writeFileGenesis (rootdir "genesis.alonzo.json") $ WritePretty alonzoGenesis + void $ writeFileGenesis (rootdir "genesis.conway.json") $ WritePretty conwayGenesis + -- TODO: rationalise the naming convention on these genesis json files. + + liftIO $ + Text.hPutStrLn IO.stderr $ + mconcat $ + [ "generated genesis with: " + , textShow numGenesisKeys + , " genesis keys, " + , textShow numUTxOKeys + , " non-delegating UTxO keys, " + , textShow numPools + , " stake pools, " + , textShow numStakeDelegators + , " delegating UTxO keys, " + , textShow numDelegations + , " delegation map entries, " + ] + ++ [ mconcat + [ ", " + , textShow numBulkPoolCredFiles + , " bulk pool credential files, " + , textShow numBulkPoolsPerFile + , " pools per bulk credential file, indices starting from " + , textShow bulkOffset + , ", " + , textShow $ length bulkIndices + , " total pools in bulk nodes, each bulk node having this many entries: " + , textShow $ length <$> bulkSlices + ] + | numBulkPoolCredFiles * numBulkPoolsPerFile > 0 + ] + where + adjustTemplate t = t{sgNetworkMagic = unNetworkMagic (toNetworkMagic networkId)} + mkDelegationMapEntry + :: Delegation -> (L.KeyHash L.Staking L.StandardCrypto, L.PoolParams L.StandardCrypto) mkDelegationMapEntry d = (dDelegStaking d, dPoolParams d) -- ------------------------------------------------------------------------------------------------- updateOutputTemplate - :: SystemStart -- ^ System start time - -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) -- ^ Genesis delegation (not stake-based) - -> Maybe L.Coin -- ^ Amount of lovelace not delegated - -> Int -- ^ Number of UTxO addresses that are delegating - -> [AddressInEra ShelleyEra] -- ^ UTxO addresses that are not delegating - -> [(L.KeyHash 'L.StakePool L.StandardCrypto, L.PoolParams L.StandardCrypto)] -- ^ Pool map - -> [(L.KeyHash 'L.Staking L.StandardCrypto, L.KeyHash 'L.StakePool L.StandardCrypto)] -- ^ Delegaton map - -> Maybe L.Coin -- ^ Amount of lovelace to delegate - -> Int -- ^ Number of UTxO address for delegation - -> [AddressInEra ShelleyEra] -- ^ UTxO address for delegation - -> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses - -> ShelleyGenesis L.StandardCrypto -- ^ Template from which to build a genesis - -> ShelleyGenesis L.StandardCrypto -- ^ Updated genesis + :: SystemStart + -- ^ System start time + -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) + -- ^ Genesis delegation (not stake-based) + -> Maybe L.Coin + -- ^ Amount of lovelace not delegated + -> Int + -- ^ Number of UTxO addresses that are delegating + -> [AddressInEra ShelleyEra] + -- ^ UTxO addresses that are not delegating + -> [(L.KeyHash 'L.StakePool L.StandardCrypto, L.PoolParams L.StandardCrypto)] + -- ^ Pool map + -> [(L.KeyHash 'L.Staking L.StandardCrypto, L.KeyHash 'L.StakePool L.StandardCrypto)] + -- ^ Delegaton map + -> Maybe L.Coin + -- ^ Amount of lovelace to delegate + -> Int + -- ^ Number of UTxO address for delegation + -> [AddressInEra ShelleyEra] + -- ^ UTxO address for delegation + -> [AddressInEra ShelleyEra] + -- ^ Stuffed UTxO addresses + -> ShelleyGenesis L.StandardCrypto + -- ^ Template from which to build a genesis + -> ShelleyGenesis L.StandardCrypto + -- ^ Updated genesis updateOutputTemplate (SystemStart sgSystemStart) - genDelegMap mAmountNonDeleg nUtxoAddrsNonDeleg utxoAddrsNonDeleg pools stake + genDelegMap + mAmountNonDeleg + nUtxoAddrsNonDeleg + utxoAddrsNonDeleg + pools + stake amountDeleg - nUtxoAddrsDeleg utxoAddrsDeleg stuffedUtxoAddrs - template@ShelleyGenesis{ sgProtocolParams } = + nUtxoAddrsDeleg + utxoAddrsDeleg + stuffedUtxoAddrs + template@ShelleyGenesis{sgProtocolParams} = template - { sgSystemStart - , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin - , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = ListMap.fromList - [ (toShelleyAddr addr, v) - | (addr, v) <- - distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg - ++ - distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg - ++ - mkStuffedUtxo stuffedUtxoAddrs - ] - , sgStaking = - ShelleyGenesisStaking - { sgsPools = ListMap pools - , sgsStake = ListMap stake - } - , sgProtocolParams - } - where + { sgSystemStart + , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin + , sgGenDelegs = shelleyDelKeys + , sgInitialFunds = + ListMap.fromList + [ (toShelleyAddr addr, v) + | (addr, v) <- + distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg + ++ distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg + ++ mkStuffedUtxo stuffedUtxoAddrs + ] + , sgStaking = + ShelleyGenesisStaking + { sgsPools = ListMap pools + , sgsStake = ListMap stake + } + , sgProtocolParams + } + where maximumLovelaceSupply :: Word64 maximumLovelaceSupply = sgMaxLovelaceSupply template -- If the initial funds are equal to the maximum funds, rewards cannot be created. @@ -693,19 +801,24 @@ updateOutputTemplate delegCoin = maybe 0 fromIntegral amountDeleg distribute :: Integer -> Int -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, L.Coin)] - distribute funds nAddrs addrs = zip addrs (fmap L.Coin (coinPerAddr + remainder:repeat coinPerAddr)) - where coinPerAddr, remainder :: Integer - (coinPerAddr, remainder) = funds `divMod` fromIntegral nAddrs + distribute funds nAddrs addrs = zip addrs (fmap L.Coin (coinPerAddr + remainder : repeat coinPerAddr)) + where + coinPerAddr, remainder :: Integer + (coinPerAddr, remainder) = funds `divMod` fromIntegral nAddrs mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, L.Coin)] - mkStuffedUtxo xs = (, L.Coin minUtxoVal) <$> xs - where L.Coin minUtxoVal = sgProtocolParams ^. L.ppMinUTxOValueL + mkStuffedUtxo xs = (,L.Coin minUtxoVal) <$> xs + where + L.Coin minUtxoVal = sgProtocolParams ^. L.ppMinUTxOValueL - shelleyDelKeys = Map.fromList - [ (gh, L.GenDelegPair gdh h) - | (GenesisKeyHash gh, - (GenesisDelegateKeyHash gdh, VrfKeyHash h)) <- Map.toList genDelegMap - ] + shelleyDelKeys = + Map.fromList + [ (gh, L.GenDelegPair gdh h) + | ( GenesisKeyHash gh + , (GenesisDelegateKeyHash gdh, VrfKeyHash h) + ) <- + Map.toList genDelegMap + ] unLovelace :: Integral a => L.Coin -> a unLovelace (L.Coin coin) = fromIntegral coin @@ -715,29 +828,31 @@ createDelegateKeys fmt dir index = do liftIO $ createDirectoryIfMissing False dir TN.runGenesisKeyGenDelegateCmd Cmd.GenesisKeyGenDelegateCmdArgs - { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "delegate" ++ strIndex ++ ".vkey" - , Cmd.signingKeyPath = onlyOut coldSK - , Cmd.opCertCounterPath = onlyOut opCertCtr - } + { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "delegate" ++ strIndex ++ ".vkey" + , Cmd.signingKeyPath = onlyOut coldSK + , Cmd.opCertCounterPath = onlyOut opCertCtr + } TN.runGenesisKeyGenDelegateVRF - (File @(VerificationKey ()) $ dir "delegate" ++ strIndex ++ ".vrf.vkey") - (File @(SigningKey ()) $ dir "delegate" ++ strIndex ++ ".vrf.skey") + (File @(VerificationKey ()) $ dir "delegate" ++ strIndex ++ ".vrf.vkey") + (File @(SigningKey ()) $ dir "delegate" ++ strIndex ++ ".vrf.skey") firstExceptT GenesisCmdNodeCmdError $ do - runNodeKeyGenKesCmd $ Cmd.NodeKeyGenKESCmdArgs + runNodeKeyGenKesCmd $ + Cmd.NodeKeyGenKESCmdArgs fmt (onlyOut kesVK) (File @(SigningKey ()) $ dir "delegate" ++ strIndex ++ ".kes.skey") - runNodeIssueOpCertCmd $ Cmd.NodeIssueOpCertCmdArgs + runNodeIssueOpCertCmd $ + Cmd.NodeIssueOpCertCmdArgs (VerificationKeyFilePath (onlyIn kesVK)) (onlyIn coldSK) opCertCtr (KESPeriod 0) (File $ dir "opcert" ++ strIndex ++ ".cert") where - strIndex = show index - kesVK = File @(VerificationKey ()) $ dir "delegate" ++ strIndex ++ ".kes.vkey" - coldSK = File @(SigningKey ()) $ dir "delegate" ++ strIndex ++ ".skey" - opCertCtr = File $ dir "delegate" ++ strIndex ++ ".counter" + strIndex = show index + kesVK = File @(VerificationKey ()) $ dir "delegate" ++ strIndex ++ ".kes.vkey" + coldSK = File @(SigningKey ()) $ dir "delegate" ++ strIndex ++ ".skey" + opCertCtr = File $ dir "delegate" ++ strIndex ++ ".counter" createGenesisKeys :: FilePath -> Word -> ExceptT GenesisCmdError IO () createGenesisKeys dir index = do @@ -745,9 +860,9 @@ createGenesisKeys dir index = do let strIndex = show index TN.runGenesisKeyGenGenesisCmd GenesisKeyGenGenesisCmdArgs - { verificationKeyPath = File @(VerificationKey ()) $ dir "genesis" ++ strIndex ++ ".vkey" - , signingKeyPath = File @(SigningKey ()) $ dir "genesis" ++ strIndex ++ ".skey" - } + { verificationKeyPath = File @(VerificationKey ()) $ dir "genesis" ++ strIndex ++ ".vkey" + , signingKeyPath = File @(SigningKey ()) $ dir "genesis" ++ strIndex ++ ".skey" + } createUtxoKeys :: FilePath -> Word -> ExceptT GenesisCmdError IO () createUtxoKeys dir index = do @@ -755,119 +870,137 @@ createUtxoKeys dir index = do let strIndex = show index TN.runGenesisKeyGenUTxOCmd Cmd.GenesisKeyGenUTxOCmdArgs - { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "utxo" ++ strIndex ++ ".vkey" - , Cmd.signingKeyPath = File @(SigningKey ()) $ dir "utxo" ++ strIndex ++ ".skey" - } + { Cmd.verificationKeyPath = File @(VerificationKey ()) $ dir "utxo" ++ strIndex ++ ".vkey" + , Cmd.signingKeyPath = File @(SigningKey ()) $ dir "utxo" ++ strIndex ++ ".skey" + } createPoolCredentials :: KeyOutputFormat -> FilePath -> Word -> ExceptT GenesisCmdError IO () createPoolCredentials fmt dir index = do liftIO $ createDirectoryIfMissing False dir firstExceptT GenesisCmdNodeCmdError $ do - runNodeKeyGenKesCmd $ Cmd.NodeKeyGenKESCmdArgs + runNodeKeyGenKesCmd $ + Cmd.NodeKeyGenKESCmdArgs fmt (onlyOut kesVK) (File @(SigningKey ()) $ dir "kes" ++ strIndex ++ ".skey") - runNodeKeyGenVrfCmd $ Cmd.NodeKeyGenVRFCmdArgs + runNodeKeyGenVrfCmd $ + Cmd.NodeKeyGenVRFCmdArgs fmt (File @(VerificationKey ()) $ dir "vrf" ++ strIndex ++ ".vkey") (File @(SigningKey ()) $ dir "vrf" ++ strIndex ++ ".skey") - runNodeKeyGenColdCmd $ Cmd.NodeKeyGenColdCmdArgs + runNodeKeyGenColdCmd $ + Cmd.NodeKeyGenColdCmdArgs fmt (File @(VerificationKey ()) $ dir "cold" ++ strIndex ++ ".vkey") (onlyOut coldSK) (onlyOut opCertCtr) - runNodeIssueOpCertCmd $ Cmd.NodeIssueOpCertCmdArgs + runNodeIssueOpCertCmd $ + Cmd.NodeIssueOpCertCmdArgs (VerificationKeyFilePath (onlyIn kesVK)) (onlyIn coldSK) opCertCtr (KESPeriod 0) (File $ dir "opcert" ++ strIndex ++ ".cert") firstExceptT GenesisCmdStakeAddressCmdError $ - void $ runStakeAddressKeyGenCmd + void $ + runStakeAddressKeyGenCmd fmt (File @(VerificationKey ()) $ dir "staking-reward" ++ strIndex ++ ".vkey") (File @(SigningKey ()) $ dir "staking-reward" ++ strIndex ++ ".skey") where - strIndex = show index - kesVK = File @(VerificationKey ()) $ dir "kes" ++ strIndex ++ ".vkey" - coldSK = File @(SigningKey ()) $ dir "cold" ++ strIndex ++ ".skey" - opCertCtr = File $ dir "opcert" ++ strIndex ++ ".counter" + strIndex = show index + kesVK = File @(VerificationKey ()) $ dir "kes" ++ strIndex ++ ".vkey" + coldSK = File @(SigningKey ()) $ dir "cold" ++ strIndex ++ ".skey" + opCertCtr = File $ dir "opcert" ++ strIndex ++ ".counter" data Delegation = Delegation - { dInitialUtxoAddr :: !(AddressInEra ShelleyEra) - , dDelegStaking :: !(L.KeyHash L.Staking L.StandardCrypto) - , dPoolParams :: !(L.PoolParams L.StandardCrypto) + { dInitialUtxoAddr :: !(AddressInEra ShelleyEra) + , dDelegStaking :: !(L.KeyHash L.Staking L.StandardCrypto) + , dPoolParams :: !(L.PoolParams L.StandardCrypto) } deriving (Generic, NFData) buildPoolParams :: NetworkId - -> FilePath -- ^ File directory where the necessary pool credentials were created + -> FilePath + -- ^ File directory where the necessary pool credentials were created -> Maybe Word - -> Map Word [L.StakePoolRelay] -- ^ User submitted stake pool relay map + -> Map Word [L.StakePoolRelay] + -- ^ User submitted stake pool relay map -> ExceptT GenesisCmdError IO (L.PoolParams L.StandardCrypto) buildPoolParams nw dir index specifiedRelays = do - StakePoolVerificationKey poolColdVK - <- firstExceptT (GenesisCmdStakePoolCmdError . StakePoolCmdReadFileError) - . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakePoolKey) poolColdVKF - - VrfVerificationKey poolVrfVK - <- firstExceptT (GenesisCmdNodeCmdError . NodeCmdReadFileError) - . newExceptT $ readFileTextEnvelope (AsVerificationKey AsVrfKey) poolVrfVKF - rewardsSVK - <- firstExceptT GenesisCmdTextEnvReadFileError - . newExceptT $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF - - pure L.PoolParams - { L.ppId = L.hashKey poolColdVK - , L.ppVrf = L.hashVerKeyVRF poolVrfVK - , L.ppPledge = L.Coin 0 - , L.ppCost = L.Coin 0 - , L.ppMargin = minBound + StakePoolVerificationKey poolColdVK <- + firstExceptT (GenesisCmdStakePoolCmdError . StakePoolCmdReadFileError) + . newExceptT + $ readFileTextEnvelope (AsVerificationKey AsStakePoolKey) poolColdVKF + + VrfVerificationKey poolVrfVK <- + firstExceptT (GenesisCmdNodeCmdError . NodeCmdReadFileError) + . newExceptT + $ readFileTextEnvelope (AsVerificationKey AsVrfKey) poolVrfVKF + rewardsSVK <- + firstExceptT GenesisCmdTextEnvReadFileError + . newExceptT + $ readFileTextEnvelope (AsVerificationKey AsStakeKey) poolRewardVKF + + pure + L.PoolParams + { L.ppId = L.hashKey poolColdVK + , L.ppVrf = L.hashVerKeyVRF poolVrfVK + , L.ppPledge = L.Coin 0 + , L.ppCost = L.Coin 0 + , L.ppMargin = minBound , L.ppRewardAccount = toShelleyStakeAddr $ makeStakeAddress nw $ StakeCredentialByKey (verificationKeyHash rewardsSVK) - , L.ppOwners = mempty - , L.ppRelays = lookupPoolRelay specifiedRelays - , L.ppMetadata = L.SNothing + , L.ppOwners = mempty + , L.ppRelays = lookupPoolRelay specifiedRelays + , L.ppMetadata = L.SNothing } where - lookupPoolRelay - :: Map Word [L.StakePoolRelay] -> Seq.StrictSeq L.StakePoolRelay - lookupPoolRelay m = - case index of - Nothing -> mempty - Just index' -> maybe mempty Seq.fromList (Map.lookup index' m) - - strIndex = maybe "" show index - poolColdVKF = File $ dir "cold" ++ strIndex ++ ".vkey" - poolVrfVKF = File $ dir "vrf" ++ strIndex ++ ".vkey" - poolRewardVKF = File $ dir "staking-reward" ++ strIndex ++ ".vkey" + lookupPoolRelay + :: Map Word [L.StakePoolRelay] -> Seq.StrictSeq L.StakePoolRelay + lookupPoolRelay m = + case index of + Nothing -> mempty + Just index' -> maybe mempty Seq.fromList (Map.lookup index' m) + + strIndex = maybe "" show index + poolColdVKF = File $ dir "cold" ++ strIndex ++ ".vkey" + poolVrfVKF = File $ dir "vrf" ++ strIndex ++ ".vkey" + poolRewardVKF = File $ dir "staking-reward" ++ strIndex ++ ".vkey" writeBulkPoolCredentials :: FilePath -> Word -> [Word] -> ExceptT GenesisCmdError IO () writeBulkPoolCredentials dir bulkIx poolIxs = do creds <- mapM readPoolCreds poolIxs handleIOExceptT (GenesisCmdFileError . FileIOError bulkFile) $ - LBS.writeFile bulkFile $ Aeson.encode creds + LBS.writeFile bulkFile $ + Aeson.encode creds where - bulkFile = dir "bulk" ++ show bulkIx ++ ".creds" - - readPoolCreds :: Word -> ExceptT GenesisCmdError IO - (TextEnvelope, TextEnvelope, TextEnvelope) - readPoolCreds ix = do - (,,) <$> readEnvelope poolOpCert - <*> readEnvelope poolVrfSKF - <*> readEnvelope poolKesSKF - where - strIndex = show ix - poolOpCert = dir "opcert" ++ strIndex ++ ".cert" - poolVrfSKF = dir "vrf" ++ strIndex ++ ".skey" - poolKesSKF = dir "kes" ++ strIndex ++ ".skey" - readEnvelope :: FilePath -> ExceptT GenesisCmdError IO TextEnvelope - readEnvelope fp = do - content <- handleIOExceptT (GenesisCmdFileError . FileIOError fp) $ - BS.readFile fp - firstExceptT (GenesisCmdAesonDecodeError fp . Text.pack) . hoistEither $ - Aeson.eitherDecodeStrict' content + bulkFile = dir "bulk" ++ show bulkIx ++ ".creds" + + readPoolCreds + :: Word + -> ExceptT + GenesisCmdError + IO + (TextEnvelope, TextEnvelope, TextEnvelope) + readPoolCreds ix = do + (,,) + <$> readEnvelope poolOpCert + <*> readEnvelope poolVrfSKF + <*> readEnvelope poolKesSKF + where + strIndex = show ix + poolOpCert = dir "opcert" ++ strIndex ++ ".cert" + poolVrfSKF = dir "vrf" ++ strIndex ++ ".skey" + poolKesSKF = dir "kes" ++ strIndex ++ ".skey" + readEnvelope :: FilePath -> ExceptT GenesisCmdError IO TextEnvelope + readEnvelope fp = do + content <- + handleIOExceptT (GenesisCmdFileError . FileIOError fp) $ + BS.readFile fp + firstExceptT (GenesisCmdAesonDecodeError fp . Text.pack) . hoistEither $ + Aeson.eitherDecodeStrict' content -- | This function should only be used for testing purposes. -- Keys returned by this function are not cryptographically secure. @@ -877,19 +1010,23 @@ computeInsecureDelegation -> L.PoolParams L.StandardCrypto -> IO (StdGen, Delegation) computeInsecureDelegation g0 nw pool = do - (paymentVK, g1) <- first getVerificationKey <$> generateInsecureSigningKey g0 AsPaymentKey - (stakeVK , g2) <- first getVerificationKey <$> generateInsecureSigningKey g1 AsStakeKey - - let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK - let initialUtxoAddr = makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash paymentVK)) stakeAddressReference - - delegation <- pure $ force Delegation - { dInitialUtxoAddr = shelleyAddressInEra ShelleyBasedEraShelley initialUtxoAddr - , dDelegStaking = L.hashKey (unStakeVerificationKey stakeVK) - , dPoolParams = pool - } + (paymentVK, g1) <- first getVerificationKey <$> generateInsecureSigningKey g0 AsPaymentKey + (stakeVK, g2) <- first getVerificationKey <$> generateInsecureSigningKey g1 AsStakeKey + + let stakeAddressReference = StakeAddressByValue . StakeCredentialByKey . verificationKeyHash $ stakeVK + let initialUtxoAddr = + makeShelleyAddress nw (PaymentCredentialByKey (verificationKeyHash paymentVK)) stakeAddressReference + + delegation <- + pure $ + force + Delegation + { dInitialUtxoAddr = shelleyAddressInEra ShelleyBasedEraShelley initialUtxoAddr + , dDelegStaking = L.hashKey (unStakeVerificationKey stakeVK) + , dPoolParams = pool + } - pure (g2, delegation) + pure (g2, delegation) -- | Attempts to read Shelley genesis from disk -- and if not found creates a default Shelley genesis. @@ -898,59 +1035,79 @@ readShelleyGenesisWithDefault -> (ShelleyGenesis L.StandardCrypto -> ShelleyGenesis L.StandardCrypto) -> ExceptT GenesisCmdError IO (ShelleyGenesis L.StandardCrypto) readShelleyGenesisWithDefault fpath adjustDefaults = do - newExceptT (TN.readAndDecodeGenesisFile fpath) - `catchError` \err -> - case err of - GenesisCmdGenesisFileReadError (FileIOError _ ioe) - | isDoesNotExistError ioe -> writeDefault - _ -> left err - where - defaults :: ShelleyGenesis L.StandardCrypto - defaults = adjustDefaults shelleyGenesisDefaults - - writeDefault = do - handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ - LBS.writeFile fpath (encode defaults) - return defaults + newExceptT (TN.readAndDecodeGenesisFile fpath) + `catchError` \err -> + case err of + GenesisCmdGenesisFileReadError (FileIOError _ ioe) + | isDoesNotExistError ioe -> writeDefault + _ -> left err + where + defaults :: ShelleyGenesis L.StandardCrypto + defaults = adjustDefaults shelleyGenesisDefaults -updateTemplate - :: SystemStart -- ^ System start time - -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) -- ^ Genesis delegation (not stake-based) - -> Maybe L.Coin -- ^ Amount of lovelace not delegated - -> [AddressInEra ShelleyEra] -- ^ UTxO addresses that are not delegating - -> Map (L.KeyHash 'L.Staking L.StandardCrypto) (L.PoolParams L.StandardCrypto) -- ^ Genesis staking: pools/delegation map & delegated initial UTxO spec - -> L.Coin -- ^ Number of UTxO Addresses for delegation - -> [AddressInEra ShelleyEra] -- ^ UTxO Addresses for delegation - -> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses - -> ShelleyGenesis L.StandardCrypto -- ^ Template from which to build a genesis - -> ShelleyGenesis L.StandardCrypto -- ^ Updated genesis -updateTemplate (SystemStart start) - genDelegMap mAmountNonDeleg utxoAddrsNonDeleg - poolSpecs (L.Coin amountDeleg) utxoAddrsDeleg stuffedUtxoAddrs - template = do + writeDefault = do + handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ + LBS.writeFile fpath (encode defaults) + return defaults +updateTemplate + :: SystemStart + -- ^ System start time + -> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) + -- ^ Genesis delegation (not stake-based) + -> Maybe L.Coin + -- ^ Amount of lovelace not delegated + -> [AddressInEra ShelleyEra] + -- ^ UTxO addresses that are not delegating + -> Map (L.KeyHash 'L.Staking L.StandardCrypto) (L.PoolParams L.StandardCrypto) + -- ^ Genesis staking: pools/delegation map & delegated initial UTxO spec + -> L.Coin + -- ^ Number of UTxO Addresses for delegation + -> [AddressInEra ShelleyEra] + -- ^ UTxO Addresses for delegation + -> [AddressInEra ShelleyEra] + -- ^ Stuffed UTxO addresses + -> ShelleyGenesis L.StandardCrypto + -- ^ Template from which to build a genesis + -> ShelleyGenesis L.StandardCrypto + -- ^ Updated genesis +updateTemplate + (SystemStart start) + genDelegMap + mAmountNonDeleg + utxoAddrsNonDeleg + poolSpecs + (L.Coin amountDeleg) + utxoAddrsDeleg + stuffedUtxoAddrs + template = do let pparamsFromTemplate = sgProtocolParams template - shelleyGenesis = template - { sgSystemStart = start - , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin - , sgGenDelegs = shelleyDelKeys - , sgInitialFunds = ListMap.fromList - [ (toShelleyAddr addr, v) - | (addr, v) <- - distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg ++ - distribute (delegCoin - subtractForTreasury) utxoAddrsDeleg ++ - mkStuffedUtxo stuffedUtxoAddrs ] - , sgStaking = - ShelleyGenesisStaking - { sgsPools = ListMap.fromList - [ (L.ppId poolParams, poolParams) - | poolParams <- Map.elems poolSpecs ] - , sgsStake = ListMap.fromMap $ L.ppId <$> poolSpecs - } - , sgProtocolParams = pparamsFromTemplate - } + shelleyGenesis = + template + { sgSystemStart = start + , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin + , sgGenDelegs = shelleyDelKeys + , sgInitialFunds = + ListMap.fromList + [ (toShelleyAddr addr, v) + | (addr, v) <- + distribute (nonDelegCoin - subtractForTreasury) utxoAddrsNonDeleg + ++ distribute (delegCoin - subtractForTreasury) utxoAddrsDeleg + ++ mkStuffedUtxo stuffedUtxoAddrs + ] + , sgStaking = + ShelleyGenesisStaking + { sgsPools = + ListMap.fromList + [ (L.ppId poolParams, poolParams) + | poolParams <- Map.elems poolSpecs + ] + , sgsStake = ListMap.fromMap $ L.ppId <$> poolSpecs + } + , sgProtocolParams = pparamsFromTemplate + } shelleyGenesis - where + where maximumLovelaceSupply :: Word64 maximumLovelaceSupply = sgMaxLovelaceSupply template -- If the initial funds are equal to the maximum funds, rewards cannot be created. @@ -964,28 +1121,32 @@ updateTemplate (SystemStart start) distribute funds addrs = fst $ List.foldl' folder ([], fromIntegral funds) addrs where - nAddrs, coinPerAddr, splitThreshold :: Integer - nAddrs = fromIntegral $ length addrs - coinPerAddr = funds `div` nAddrs - splitThreshold = coinPerAddr + nAddrs - - folder :: ([(AddressInEra ShelleyEra, L.Coin)], Integer) - -> AddressInEra ShelleyEra - -> ([(AddressInEra ShelleyEra, L.Coin)], Integer) - folder (acc, rest) addr - | rest > splitThreshold = - ((addr, L.Coin coinPerAddr) : acc, rest - coinPerAddr) - | otherwise = ((addr, L.Coin rest) : acc, 0) + nAddrs, coinPerAddr, splitThreshold :: Integer + nAddrs = fromIntegral $ length addrs + coinPerAddr = funds `div` nAddrs + splitThreshold = coinPerAddr + nAddrs + + folder + :: ([(AddressInEra ShelleyEra, L.Coin)], Integer) + -> AddressInEra ShelleyEra + -> ([(AddressInEra ShelleyEra, L.Coin)], Integer) + folder (acc, rest) addr + | rest > splitThreshold = + ((addr, L.Coin coinPerAddr) : acc, rest - coinPerAddr) + | otherwise = ((addr, L.Coin rest) : acc, 0) mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, L.Coin)] - mkStuffedUtxo xs = (, L.Coin minUtxoVal) <$> xs - where L.Coin minUtxoVal = sgProtocolParams template ^. L.ppMinUTxOValueL + mkStuffedUtxo xs = (,L.Coin minUtxoVal) <$> xs + where + L.Coin minUtxoVal = sgProtocolParams template ^. L.ppMinUTxOValueL shelleyDelKeys = Map.fromList [ (gh, L.GenDelegPair gdh h) - | (GenesisKeyHash gh, - (GenesisDelegateKeyHash gdh, VrfKeyHash h)) <- Map.toList genDelegMap + | ( GenesisKeyHash gh + , (GenesisDelegateKeyHash gdh, VrfKeyHash h) + ) <- + Map.toList genDelegMap ] unLovelace :: Integral a => L.Coin -> a @@ -999,14 +1160,16 @@ writeFileGenesis fpath genesis = do handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ BS.writeFile fpath content return $ Crypto.hashWith id content - where - content = case genesis of - WritePretty a -> LBS.toStrict $ encodePretty a - WriteCanonical a -> LBS.toStrict - . renderCanonicalJSON - . either (error . ("error parsing json that was just encoded!? " ++) . show) id - . parseCanonicalJSON - . canonicalEncodePretty $ a + where + content = case genesis of + WritePretty a -> LBS.toStrict $ encodePretty a + WriteCanonical a -> + LBS.toStrict + . renderCanonicalJSON + . either (error . ("error parsing json that was just encoded!? " ++) . show) id + . parseCanonicalJSON + . canonicalEncodePretty + $ a data WriteFileGenesis where WriteCanonical :: Text.JSON.Canonical.ToJSON Identity genesis => genesis -> WriteFileGenesis @@ -1014,147 +1177,203 @@ data WriteFileGenesis where -- ---------------------------------------------------------------------------- -readGenDelegsMap :: FilePath -> FilePath - -> ExceptT GenesisCmdError IO - (Map (Hash GenesisKey) - (Hash GenesisDelegateKey, Hash VrfKey)) +readGenDelegsMap + :: FilePath + -> FilePath + -> ExceptT + GenesisCmdError + IO + ( Map + (Hash GenesisKey) + (Hash GenesisDelegateKey, Hash VrfKey) + ) readGenDelegsMap gendir deldir = do - gkm <- readGenesisKeys gendir - dkm <- readDelegateKeys deldir - vkm <- readDelegateVrfKeys deldir - - let combinedMap :: Map Int (VerificationKey GenesisKey, - (VerificationKey GenesisDelegateKey, - VerificationKey VrfKey)) - combinedMap = - Map.intersectionWith (,) - gkm - (Map.intersectionWith (,) - dkm vkm) - - -- All the maps should have an identical set of keys. Complain if not. - let gkmExtra = gkm Map.\\ combinedMap - dkmExtra = dkm Map.\\ combinedMap - vkmExtra = vkm Map.\\ combinedMap - unless (Map.null gkmExtra && Map.null dkmExtra && Map.null vkmExtra) $ - throwError $ GenesisCmdMismatchedGenesisKeyFiles - (Map.keys gkm) (Map.keys dkm) (Map.keys vkm) - - let delegsMap :: Map (Hash GenesisKey) - (Hash GenesisDelegateKey, Hash VrfKey) - delegsMap = - Map.fromList [ (gh, (dh, vh)) - | (g,(d,v)) <- Map.elems combinedMap - , let gh = verificationKeyHash g - dh = verificationKeyHash d - vh = verificationKeyHash v - ] - - pure delegsMap - - -readGenesisKeys :: FilePath -> ExceptT GenesisCmdError IO - (Map Int (VerificationKey GenesisKey)) + gkm <- readGenesisKeys gendir + dkm <- readDelegateKeys deldir + vkm <- readDelegateVrfKeys deldir + + let combinedMap + :: Map + Int + ( VerificationKey GenesisKey + , ( VerificationKey GenesisDelegateKey + , VerificationKey VrfKey + ) + ) + combinedMap = + Map.intersectionWith + (,) + gkm + ( Map.intersectionWith + (,) + dkm + vkm + ) + + -- All the maps should have an identical set of keys. Complain if not. + let gkmExtra = gkm Map.\\ combinedMap + dkmExtra = dkm Map.\\ combinedMap + vkmExtra = vkm Map.\\ combinedMap + unless (Map.null gkmExtra && Map.null dkmExtra && Map.null vkmExtra) $ + throwError $ + GenesisCmdMismatchedGenesisKeyFiles + (Map.keys gkm) + (Map.keys dkm) + (Map.keys vkm) + + let delegsMap + :: Map + (Hash GenesisKey) + (Hash GenesisDelegateKey, Hash VrfKey) + delegsMap = + Map.fromList + [ (gh, (dh, vh)) + | (g, (d, v)) <- Map.elems combinedMap + , let gh = verificationKeyHash g + dh = verificationKeyHash d + vh = verificationKeyHash v + ] + + pure delegsMap + +readGenesisKeys + :: FilePath + -> ExceptT + GenesisCmdError + IO + (Map Int (VerificationKey GenesisKey)) readGenesisKeys gendir = do files <- liftIO (listDirectory gendir) - fileIxs <- extractFileNameIndexes [ gendir file - | file <- files - , takeExtension file == ".vkey" ] + fileIxs <- + extractFileNameIndexes + [ gendir file + | file <- files + , takeExtension file == ".vkey" + ] firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList <$> - sequence + Map.fromList + <$> sequence [ (,) ix <$> readKey (File file) - | (file, ix) <- fileIxs ] - where - readKey = newExceptT - . readFileTextEnvelope (AsVerificationKey AsGenesisKey) - -readDelegateKeys :: FilePath - -> ExceptT GenesisCmdError IO - (Map Int (VerificationKey GenesisDelegateKey)) + | (file, ix) <- fileIxs + ] + where + readKey = + newExceptT + . readFileTextEnvelope (AsVerificationKey AsGenesisKey) + +readDelegateKeys + :: FilePath + -> ExceptT + GenesisCmdError + IO + (Map Int (VerificationKey GenesisDelegateKey)) readDelegateKeys deldir = do files <- liftIO (listDirectory deldir) - fileIxs <- extractFileNameIndexes [ deldir file - | file <- files - , takeExtensions file == ".vkey" ] + fileIxs <- + extractFileNameIndexes + [ deldir file + | file <- files + , takeExtensions file == ".vkey" + ] firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList <$> - sequence + Map.fromList + <$> sequence [ (,) ix <$> readKey (File file) - | (file, ix) <- fileIxs ] - where - readKey = newExceptT - . readFileTextEnvelope (AsVerificationKey AsGenesisDelegateKey) + | (file, ix) <- fileIxs + ] + where + readKey = + newExceptT + . readFileTextEnvelope (AsVerificationKey AsGenesisDelegateKey) -readDelegateVrfKeys :: FilePath -> ExceptT GenesisCmdError IO - (Map Int (VerificationKey VrfKey)) +readDelegateVrfKeys + :: FilePath + -> ExceptT + GenesisCmdError + IO + (Map Int (VerificationKey VrfKey)) readDelegateVrfKeys deldir = do files <- liftIO (listDirectory deldir) - fileIxs <- extractFileNameIndexes [ deldir file - | file <- files - , takeExtensions file == ".vrf.vkey" ] + fileIxs <- + extractFileNameIndexes + [ deldir file + | file <- files + , takeExtensions file == ".vrf.vkey" + ] firstExceptT GenesisCmdTextEnvReadFileError $ - Map.fromList <$> - sequence + Map.fromList + <$> sequence [ (,) ix <$> readKey (File file) - | (file, ix) <- fileIxs ] - where - readKey = newExceptT - . readFileTextEnvelope (AsVerificationKey AsVrfKey) - + | (file, ix) <- fileIxs + ] + where + readKey = + newExceptT + . readFileTextEnvelope (AsVerificationKey AsVrfKey) -- | The file path is of the form @"delegate-keys/delegate3.vkey"@. -- This function reads the file and extracts the index (in this case 3). --- extractFileNameIndex :: FilePath -> Maybe Int extractFileNameIndex fp = case filter isDigit fp of [] -> Nothing xs -> readMaybe xs -extractFileNameIndexes :: [FilePath] - -> ExceptT GenesisCmdError IO [(FilePath, Int)] +extractFileNameIndexes + :: [FilePath] + -> ExceptT GenesisCmdError IO [(FilePath, Int)] extractFileNameIndexes files = do - case [ file | (file, Nothing) <- filesIxs ] of - [] -> return () - files' -> throwError (GenesisCmdFilesNoIndex files') - case filter (\g -> length g > 1) - . List.groupBy ((==) `on` snd) - . List.sortBy (compare `on` snd) - $ [ (file, ix) | (file, Just ix) <- filesIxs ] of - [] -> return () - (g:_) -> throwError (GenesisCmdFilesDupIndex (map fst g)) - - return [ (file, ix) | (file, Just ix) <- filesIxs ] - where - filesIxs = [ (file, extractFileNameIndex file) | file <- files ] - -readInitialFundAddresses :: FilePath -> NetworkId - -> ExceptT GenesisCmdError IO [AddressInEra ShelleyEra] -readInitialFundAddresses utxodir nw = do - files <- liftIO (listDirectory utxodir) - vkeys <- firstExceptT GenesisCmdTextEnvReadFileError $ - sequence - [ newExceptT $ - readFileTextEnvelope (AsVerificationKey AsGenesisUTxOKey) - (File (utxodir file)) - | file <- files - , takeExtension file == ".vkey" ] - return [ addr | vkey <- vkeys - , let vkh = verificationKeyHash (castVerificationKey vkey) - addr = makeShelleyAddressInEra ShelleyBasedEraShelley nw (PaymentCredentialByKey vkh) - NoStakeAddress - ] + case [file | (file, Nothing) <- filesIxs] of + [] -> return () + files' -> throwError (GenesisCmdFilesNoIndex files') + case filter (\g -> length g > 1) + . List.groupBy ((==) `on` snd) + . List.sortBy (compare `on` snd) + $ [(file, ix) | (file, Just ix) <- filesIxs] of + [] -> return () + (g : _) -> throwError (GenesisCmdFilesDupIndex (map fst g)) + + return [(file, ix) | (file, Just ix) <- filesIxs] + where + filesIxs = [(file, extractFileNameIndex file) | file <- files] +readInitialFundAddresses + :: FilePath + -> NetworkId + -> ExceptT GenesisCmdError IO [AddressInEra ShelleyEra] +readInitialFundAddresses utxodir nw = do + files <- liftIO (listDirectory utxodir) + vkeys <- + firstExceptT GenesisCmdTextEnvReadFileError $ + sequence + [ newExceptT $ + readFileTextEnvelope + (AsVerificationKey AsGenesisUTxOKey) + (File (utxodir file)) + | file <- files + , takeExtension file == ".vkey" + ] + return + [ addr + | vkey <- vkeys + , let vkh = verificationKeyHash (castVerificationKey vkey) + addr = + makeShelleyAddressInEra + ShelleyBasedEraShelley + nw + (PaymentCredentialByKey vkh) + NoStakeAddress + ] -- | Hash a genesis file runGenesisHashFileCmd :: GenesisFile -> ExceptT GenesisCmdError IO () runGenesisHashFileCmd (GenesisFile fpath) = do - content <- handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ - BS.readFile fpath - let gh :: Crypto.Hash Crypto.Blake2b_256 ByteString - gh = Crypto.hashWith id content - liftIO $ Text.putStrLn (Crypto.hashToTextAsHex gh) + content <- + handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ + BS.readFile fpath + let gh :: Crypto.Hash Crypto.Blake2b_256 ByteString + gh = Crypto.hashWith id content + liftIO $ Text.putStrLn (Crypto.hashToTextAsHex gh) readAlonzoGenesis :: FilePath @@ -1162,7 +1381,8 @@ readAlonzoGenesis readAlonzoGenesis fpath = do lbs <- handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (GenesisCmdAesonDecodeError fpath . Text.pack) - . hoistEither $ Aeson.eitherDecode' lbs + . hoistEither + $ Aeson.eitherDecode' lbs readConwayGenesis :: FilePath @@ -1170,17 +1390,20 @@ readConwayGenesis readConwayGenesis fpath = do lbs <- handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $ LBS.readFile fpath firstExceptT (GenesisCmdAesonDecodeError fpath . Text.pack) - . hoistEither $ Aeson.eitherDecode' lbs + . hoistEither + $ Aeson.eitherDecode' lbs -- Protocol Parameters ---TODO: eliminate this and get only the necessary params, and get them in a more +-- TODO: eliminate this and get only the necessary params, and get them in a more -- helpful way rather than requiring them as a local file. -readProtocolParameters :: () +readProtocolParameters + :: () => ShelleyBasedEra era -> ProtocolParamsFile -> ExceptT ProtocolParamsError IO (L.PParams (ShelleyLedgerEra era)) readProtocolParameters sbe (ProtocolParamsFile fpath) = do pparams <- handleIOExceptT (ProtocolParamsErrorFile . FileIOError fpath) $ LBS.readFile fpath firstExceptT (ProtocolParamsErrorJSON fpath . Text.pack) . hoistEither $ - shelleyBasedEraConstraints sbe $ Aeson.eitherDecode' pparams + shelleyBasedEraConstraints sbe $ + Aeson.eitherDecode' pparams diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs index 0300745f8b..328cefd02c 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance.hs @@ -9,11 +9,11 @@ module Cardano.CLI.EraBased.Run.Governance ( runGovernanceCmds - , runGovernanceMIRCertificatePayStakeAddrs , runGovernanceCreateMirCertificateTransferToTreasuryCmd , runGovernanceCreateMirCertificateTransferToReservesCmd - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -33,75 +33,77 @@ import Control.Monad import Data.Function import qualified Data.Map.Strict as Map -runGovernanceCmds :: () +runGovernanceCmds + :: () => Cmd.GovernanceCmds era -> ExceptT CmdError IO () runGovernanceCmds = \case Cmd.GovernanceCreateMirCertificateStakeAddressesCmd w mirpot vKeys rewards out -> runGovernanceMIRCertificatePayStakeAddrs w mirpot vKeys rewards out & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceCreateMirCertificateTransferToTreasuryCmd w ll oFp -> runGovernanceCreateMirCertificateTransferToTreasuryCmd w ll oFp & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceCreateMirCertificateTransferToReservesCmd w ll oFp -> runGovernanceCreateMirCertificateTransferToReservesCmd w ll oFp & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceGenesisKeyDelegationCertificate sta genVk genDelegVk vrfVk out -> runGovernanceGenesisKeyDelegationCertificate sta genVk genDelegVk vrfVk out & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceCommitteeCmds cmds -> runGovernanceCommitteeCmds cmds & firstExceptT CmdGovernanceCommitteeError - Cmd.GovernanceActionCmds cmds -> runGovernanceActionCmds cmds & firstExceptT CmdGovernanceActionError - Cmd.GovernanceDRepCmds cmds -> runGovernanceDRepCmds cmds - Cmd.GovernancePollCmds cmds -> runGovernancePollCmds cmds & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceVoteCmds cmds -> runGovernanceVoteCmds cmds runGovernanceMIRCertificatePayStakeAddrs :: ShelleyToBabbageEra era -> L.MIRPot - -> [StakeAddress] -- ^ Stake addresses - -> [L.Coin] -- ^ Corresponding reward amounts (same length) + -> [StakeAddress] + -- ^ Stake addresses + -> [L.Coin] + -- ^ Corresponding reward amounts (same length) -> File () Out -> ExceptT GovernanceCmdError IO () runGovernanceMIRCertificatePayStakeAddrs w mirPot sAddrs rwdAmts oFp = do unless (length sAddrs == length rwdAmts) $ - left $ GovernanceCmdMIRCertificateKeyRewardMistmach - (unFile oFp) (length sAddrs) (length rwdAmts) - - let sCreds = map stakeAddressCredential sAddrs - mirTarget = L.StakeAddressesMIR - $ Map.fromList [ (toShelleyStakeCredential scred, L.toDeltaCoin rwdAmt) - | (scred, rwdAmt) <- zip sCreds rwdAmts - ] - let mirCert = makeMIRCertificate - $ MirCertificateRequirements w mirPot - $ shelleyToBabbageEraConstraints w mirTarget + left $ + GovernanceCmdMIRCertificateKeyRewardMistmach + (unFile oFp) + (length sAddrs) + (length rwdAmts) + + let sCreds = map stakeAddressCredential sAddrs + mirTarget = + L.StakeAddressesMIR $ + Map.fromList + [ (toShelleyStakeCredential scred, L.toDeltaCoin rwdAmt) + | (scred, rwdAmt) <- zip sCreds rwdAmts + ] + let mirCert = + makeMIRCertificate $ + MirCertificateRequirements w mirPot $ + shelleyToBabbageEraConstraints w mirTarget firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra w) $ writeLazyByteStringFile oFp $ textEnvelopeToJSON (Just mirCertDesc) mirCert - where - mirCertDesc :: TextEnvelopeDescr - mirCertDesc = "Move Instantaneous Rewards Certificate" + where + mirCertDesc :: TextEnvelopeDescr + mirCertDesc = "Move Instantaneous Rewards Certificate" -runGovernanceCreateMirCertificateTransferToTreasuryCmd :: () +runGovernanceCreateMirCertificateTransferToTreasuryCmd + :: () => ShelleyToBabbageEra era -> L.Coin -> File () Out @@ -116,11 +118,12 @@ runGovernanceCreateMirCertificateTransferToTreasuryCmd w ll oFp = do $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra w) $ writeLazyByteStringFile oFp $ textEnvelopeToJSON (Just mirCertDesc) mirCert - where - mirCertDesc :: TextEnvelopeDescr - mirCertDesc = "MIR Certificate Send To Treasury" + where + mirCertDesc :: TextEnvelopeDescr + mirCertDesc = "MIR Certificate Send To Treasury" -runGovernanceCreateMirCertificateTransferToReservesCmd :: () +runGovernanceCreateMirCertificateTransferToReservesCmd + :: () => ShelleyToBabbageEra era -> L.Coin -> File () Out @@ -135,6 +138,6 @@ runGovernanceCreateMirCertificateTransferToReservesCmd w ll oFp = do $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra w) $ writeLazyByteStringFile oFp $ textEnvelopeToJSON (Just mirCertDesc) mirCert - where - mirCertDesc :: TextEnvelopeDescr - mirCertDesc = "MIR Certificate Send To Reserves" + where + mirCertDesc :: TextEnvelopeDescr + mirCertDesc = "MIR Certificate Send To Reserves" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs index cdd836b560..7da6ba2329 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs @@ -7,9 +7,10 @@ module Cardano.CLI.EraBased.Run.Governance.Actions ( runGovernanceActionCmds - , GovernanceActionsError(..) + , GovernanceActionsError (..) , addCostModelsToEraBasedProtocolParametersUpdate - ) where + ) +where import Cardano.Api import Cardano.Api.Ledger (StrictMaybe (..)) @@ -27,35 +28,30 @@ import Cardano.CLI.Types.Key import Control.Monad import GHC.Exts (IsList (..)) -runGovernanceActionCmds :: () +runGovernanceActionCmds + :: () => GovernanceActionCmds era -> ExceptT GovernanceActionsError IO () runGovernanceActionCmds = \case GovernanceActionCreateConstitutionCmd args -> runGovernanceActionCreateConstitutionCmd args - GovernanceActionProtocolParametersUpdateCmd args -> runGovernanceActionCreateProtocolParametersUpdateCmd args - GovernanceActionTreasuryWithdrawalCmd args -> runGovernanceActionTreasuryWithdrawalCmd args - GovernanceActionUpdateCommitteeCmd args -> runGovernanceActionUpdateCommitteeCmd args - GovernanceActionCreateNoConfidenceCmd args -> runGovernanceActionCreateNoConfidenceCmd args - GovernanceActionHardforkInitCmd args -> runGovernanceActionHardforkInitCmd args - GovernanceActionInfoCmd args -> runGovernanceActionInfoCmd args - GovernanceActionViewCmd args -> runGovernanceActionViewCmd args -runGovernanceActionViewCmd :: () +runGovernanceActionViewCmd + :: () => GovernanceActionViewCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionViewCmd @@ -65,255 +61,313 @@ runGovernanceActionViewCmd , Cmd.mOutFile , Cmd.eon } = do - proposal <- fmap fst . firstExceptT GovernanceActionsCmdProposalError . newExceptT - $ readProposal eon (actionFile, Nothing) - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ - friendlyProposal - (case outFormat of - ViewOutputFormatJson -> FriendlyJson - ViewOutputFormatYaml -> FriendlyYaml) - mOutFile - eon - proposal - -runGovernanceActionInfoCmd :: () + proposal <- + fmap fst . firstExceptT GovernanceActionsCmdProposalError . newExceptT $ + readProposal eon (actionFile, Nothing) + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + friendlyProposal + ( case outFormat of + ViewOutputFormatJson -> FriendlyJson + ViewOutputFormatYaml -> FriendlyYaml + ) + mOutFile + eon + proposal + +runGovernanceActionInfoCmd + :: () => GovernanceActionInfoCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionInfoCmd - Cmd.GovernanceActionInfoCmdArgs - { Cmd.eon - , Cmd.networkId - , Cmd.deposit - , Cmd.returnStakeAddress - , Cmd.proposalUrl - , Cmd.proposalHash - , Cmd.outFile - } = do - depositStakeCredential <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier returnStakeAddress - - let proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash = proposalHash - } - - let sbe = conwayEraOnwardsToShelleyBasedEra eon - govAction = InfoAct - proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAction proposalAnchor - - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints eon - $ writeFileTextEnvelope outFile (Just "Info proposal") proposalProcedure + Cmd.GovernanceActionInfoCmdArgs + { Cmd.eon + , Cmd.networkId + , Cmd.deposit + , Cmd.returnStakeAddress + , Cmd.proposalUrl + , Cmd.proposalHash + , Cmd.outFile + } = do + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier returnStakeAddress + + let proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash = proposalHash + } + + let sbe = conwayEraOnwardsToShelleyBasedEra eon + govAction = InfoAct + proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAction proposalAnchor + + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints eon $ + writeFileTextEnvelope outFile (Just "Info proposal") proposalProcedure -- TODO: Conway era - update with new ledger types from cardano-ledger-conway-1.7.0.0 -runGovernanceActionCreateNoConfidenceCmd :: () +runGovernanceActionCreateNoConfidenceCmd + :: () => GovernanceActionCreateNoConfidenceCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionCreateNoConfidenceCmd - Cmd.GovernanceActionCreateNoConfidenceCmdArgs - { Cmd.eon - , Cmd.networkId - , Cmd.deposit - , Cmd.returnStakeAddress - , Cmd.proposalUrl - , Cmd.proposalHash - , Cmd.mPrevGovernanceActionId - , Cmd.outFile - } = do - depositStakeCredential - <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier returnStakeAddress - - let proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash = proposalHash - } - - let sbe = conwayEraOnwardsToShelleyBasedEra eon - previousGovernanceAction = - MotionOfNoConfidence $ L.maybeToStrictMaybe - $ shelleyBasedEraConstraints sbe - $ uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId - - proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential previousGovernanceAction proposalAnchor - - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints eon - $ writeFileTextEnvelope outFile (Just "Motion of no confidence proposal") proposalProcedure - -runGovernanceActionCreateConstitutionCmd :: () + Cmd.GovernanceActionCreateNoConfidenceCmdArgs + { Cmd.eon + , Cmd.networkId + , Cmd.deposit + , Cmd.returnStakeAddress + , Cmd.proposalUrl + , Cmd.proposalHash + , Cmd.mPrevGovernanceActionId + , Cmd.outFile + } = do + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier returnStakeAddress + + let proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash = proposalHash + } + + let sbe = conwayEraOnwardsToShelleyBasedEra eon + previousGovernanceAction = + MotionOfNoConfidence $ + L.maybeToStrictMaybe $ + shelleyBasedEraConstraints sbe $ + uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId + + proposalProcedure = + createProposalProcedure + sbe + networkId + deposit + depositStakeCredential + previousGovernanceAction + proposalAnchor + + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints eon $ + writeFileTextEnvelope outFile (Just "Motion of no confidence proposal") proposalProcedure + +runGovernanceActionCreateConstitutionCmd + :: () => GovernanceActionCreateConstitutionCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionCreateConstitutionCmd - Cmd.GovernanceActionCreateConstitutionCmdArgs - { Cmd.eon - , Cmd.networkId - , Cmd.deposit - , Cmd.stakeCredential - , Cmd.mPrevGovernanceActionId - , Cmd.proposalUrl - , Cmd.proposalHash - , Cmd.constitutionUrl - , Cmd.constitutionHash - , Cmd.constitutionScript - , Cmd.outFile - } = do - - depositStakeCredential - <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier stakeCredential - - let proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash = proposalHash - } - - let prevGovActId = L.maybeToStrictMaybe - $ shelleyBasedEraConstraints sbe - $ uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId - constitutionAnchor = L.Anchor - { L.anchorUrl = unConstitutionUrl constitutionUrl - , L.anchorDataHash = constitutionHash - } - govAct = ProposeNewConstitution - prevGovActId - constitutionAnchor - (toShelleyScriptHash <$> L.maybeToStrictMaybe constitutionScript) - sbe = conwayEraOnwardsToShelleyBasedEra eon - proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAct proposalAnchor - - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints eon - $ writeFileTextEnvelope outFile (Just "Update to the Constitution or policy proposal") proposalProcedure + Cmd.GovernanceActionCreateConstitutionCmdArgs + { Cmd.eon + , Cmd.networkId + , Cmd.deposit + , Cmd.stakeCredential + , Cmd.mPrevGovernanceActionId + , Cmd.proposalUrl + , Cmd.proposalHash + , Cmd.constitutionUrl + , Cmd.constitutionHash + , Cmd.constitutionScript + , Cmd.outFile + } = do + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier stakeCredential + + let proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash = proposalHash + } + + let prevGovActId = + L.maybeToStrictMaybe $ + shelleyBasedEraConstraints sbe $ + uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId + constitutionAnchor = + L.Anchor + { L.anchorUrl = unConstitutionUrl constitutionUrl + , L.anchorDataHash = constitutionHash + } + govAct = + ProposeNewConstitution + prevGovActId + constitutionAnchor + (toShelleyScriptHash <$> L.maybeToStrictMaybe constitutionScript) + sbe = conwayEraOnwardsToShelleyBasedEra eon + proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential govAct proposalAnchor + + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints eon $ + writeFileTextEnvelope + outFile + (Just "Update to the Constitution or policy proposal") + proposalProcedure -- TODO: Conway era - After ledger bump update this function -- with the new ledger types -runGovernanceActionUpdateCommitteeCmd :: () +runGovernanceActionUpdateCommitteeCmd + :: () => GovernanceActionUpdateCommitteeCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionUpdateCommitteeCmd - Cmd.GovernanceActionUpdateCommitteeCmdArgs - { Cmd.eon - , Cmd.networkId - , Cmd.deposit - , Cmd.returnAddress - , Cmd.proposalUrl - , Cmd.proposalHash - , Cmd.oldCommitteeVkeySource - , Cmd.newCommitteeVkeySource - , Cmd.requiredThreshold - , Cmd.mPrevGovernanceActionId - , Cmd.outFile - } = do - let sbe = conwayEraOnwardsToShelleyBasedEra eon - govActIdentifier = L.maybeToStrictMaybe - $ shelleyBasedEraConstraints sbe - $ uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId - thresholdRational = toRational requiredThreshold - - let proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash = proposalHash - } - - oldCommitteeKeyHashes <- forM oldCommitteeVkeySource $ \vkeyOrHashOrTextFile -> - modifyError GovernanceActionsCmdReadFileError $ - readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeColdKey unCommitteeColdKeyHash vkeyOrHashOrTextFile - - newCommitteeKeyHashes <- forM newCommitteeVkeySource $ \(vkeyOrHashOrTextFile, expEpoch) -> do - kh <- modifyError GovernanceActionsCmdReadFileError $ - readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeColdKey unCommitteeColdKeyHash vkeyOrHashOrTextFile - pure (kh, expEpoch) - - depositStakeCredential - <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier returnAddress - - let proposeNewCommittee = ProposeNewCommittee - govActIdentifier - oldCommitteeKeyHashes - (fromList newCommitteeKeyHashes) - thresholdRational - proposal = createProposalProcedure sbe networkId deposit depositStakeCredential proposeNewCommittee proposalAnchor - - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints eon - $ writeFileTextEnvelope outFile (Just "New constitutional committee and/or threshold and/or terms proposal") proposal - -runGovernanceActionCreateProtocolParametersUpdateCmd :: () + Cmd.GovernanceActionUpdateCommitteeCmdArgs + { Cmd.eon + , Cmd.networkId + , Cmd.deposit + , Cmd.returnAddress + , Cmd.proposalUrl + , Cmd.proposalHash + , Cmd.oldCommitteeVkeySource + , Cmd.newCommitteeVkeySource + , Cmd.requiredThreshold + , Cmd.mPrevGovernanceActionId + , Cmd.outFile + } = do + let sbe = conwayEraOnwardsToShelleyBasedEra eon + govActIdentifier = + L.maybeToStrictMaybe $ + shelleyBasedEraConstraints sbe $ + uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId + thresholdRational = toRational requiredThreshold + + let proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash = proposalHash + } + + oldCommitteeKeyHashes <- forM oldCommitteeVkeySource $ \vkeyOrHashOrTextFile -> + modifyError GovernanceActionsCmdReadFileError $ + readVerificationKeyOrHashOrFileOrScriptHash + AsCommitteeColdKey + unCommitteeColdKeyHash + vkeyOrHashOrTextFile + + newCommitteeKeyHashes <- forM newCommitteeVkeySource $ \(vkeyOrHashOrTextFile, expEpoch) -> do + kh <- + modifyError GovernanceActionsCmdReadFileError $ + readVerificationKeyOrHashOrFileOrScriptHash + AsCommitteeColdKey + unCommitteeColdKeyHash + vkeyOrHashOrTextFile + pure (kh, expEpoch) + + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier returnAddress + + let proposeNewCommittee = + ProposeNewCommittee + govActIdentifier + oldCommitteeKeyHashes + (fromList newCommitteeKeyHashes) + thresholdRational + proposal = + createProposalProcedure + sbe + networkId + deposit + depositStakeCredential + proposeNewCommittee + proposalAnchor + + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints eon $ + writeFileTextEnvelope + outFile + (Just "New constitutional committee and/or threshold and/or terms proposal") + proposal + +runGovernanceActionCreateProtocolParametersUpdateCmd + :: () => Cmd.GovernanceActionProtocolParametersUpdateCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionCreateProtocolParametersUpdateCmd eraBasedPParams' = do let sbe = uppShelleyBasedEra eraBasedPParams' caseShelleyToBabbageOrConwayEraOnwards - (\sToB -> do - let oFp = uppFilePath eraBasedPParams' - anyEra = AnyShelleyBasedEra $ shelleyToBabbageEraToShelleyBasedEra sToB - UpdateProtocolParametersPreConway _stB expEpoch genesisVerKeys - <- hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) - $ uppPreConway eraBasedPParams' + ( \sToB -> do + let oFp = uppFilePath eraBasedPParams' + anyEra = AnyShelleyBasedEra $ shelleyToBabbageEraToShelleyBasedEra sToB + UpdateProtocolParametersPreConway _stB expEpoch genesisVerKeys <- + hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) $ + uppPreConway eraBasedPParams' - eraBasedPParams <- theUpdate + eraBasedPParams <- theUpdate - let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams - apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams + let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams + apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams - genVKeys <- sequence - [ firstExceptT GovernanceActionsCmdReadTextEnvelopeFileError . newExceptT - $ readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile - | vkeyFile <- genesisVerKeys - ] + genVKeys <- + sequence + [ firstExceptT GovernanceActionsCmdReadTextEnvelopeFileError . newExceptT $ + readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile + | vkeyFile <- genesisVerKeys + ] - let genKeyHashes = fmap verificationKeyHash genVKeys - upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType genKeyHashes expEpoch + let genKeyHashes = fmap verificationKeyHash genVKeys + upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType genKeyHashes expEpoch - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ writeLazyByteStringFile oFp $ textEnvelopeToJSON Nothing upProp + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + writeLazyByteStringFile oFp $ + textEnvelopeToJSON Nothing upProp ) - (\conwayOnwards -> do + ( \conwayOnwards -> do let oFp = uppFilePath eraBasedPParams' anyEra = AnyShelleyBasedEra $ conwayEraOnwardsToShelleyBasedEra conwayOnwards - UpdateProtocolParametersConwayOnwards _cOnwards network deposit returnAddr proposalUrl - proposalHash mPrevGovActId mConstitutionalScriptHash - <- hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) - $ uppConwayOnwards eraBasedPParams' + UpdateProtocolParametersConwayOnwards + _cOnwards + network + deposit + returnAddr + proposalUrl + proposalHash + mPrevGovActId + mConstitutionalScriptHash <- + hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) $ + uppConwayOnwards eraBasedPParams' eraBasedPParams <- theUpdate - depositStakeCredential - <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier returnAddr + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier returnAddr let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams prevGovActId = L.maybeToStrictMaybe $ uncurry createPreviousGovernanceActionId <$> mPrevGovActId - proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash = proposalHash - } - govAct = UpdatePParams prevGovActId updateProtocolParams - (toShelleyScriptHash <$> L.maybeToStrictMaybe mConstitutionalScriptHash) - + proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash = proposalHash + } + govAct = + UpdatePParams + prevGovActId + updateProtocolParams + (toShelleyScriptHash <$> L.maybeToStrictMaybe mConstitutionalScriptHash) let proposalProcedure = createProposalProcedure sbe network deposit depositStakeCredential govAct proposalAnchor - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints conwayOnwards - $ writeFileTextEnvelope oFp (Just "Update protocol parameters proposal") proposalProcedure + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints conwayOnwards $ + writeFileTextEnvelope oFp (Just "Update protocol parameters proposal") proposalProcedure ) sbe - where - theUpdate = - case uppCostModelsFile eraBasedPParams' of - Nothing -> pure $ uppNewPParams eraBasedPParams' - Just (Cmd.CostModelsFile alonzoOnwards costModelsFile) -> do - costModels <- firstExceptT GovernanceActionsCmdCostModelsError - $ readCostModels costModelsFile - pure . addCostModelsToEraBasedProtocolParametersUpdate alonzoOnwards costModels - $ uppNewPParams eraBasedPParams' - -readStakeKeyHash :: VerificationKeyOrHashOrFile StakeKey -> ExceptT GovernanceActionsError IO (Hash StakeKey) + where + theUpdate = + case uppCostModelsFile eraBasedPParams' of + Nothing -> pure $ uppNewPParams eraBasedPParams' + Just (Cmd.CostModelsFile alonzoOnwards costModelsFile) -> do + costModels <- + firstExceptT GovernanceActionsCmdCostModelsError $ + readCostModels costModelsFile + pure . addCostModelsToEraBasedProtocolParametersUpdate alonzoOnwards costModels $ + uppNewPParams eraBasedPParams' + +readStakeKeyHash + :: VerificationKeyOrHashOrFile StakeKey -> ExceptT GovernanceActionsError IO (Hash StakeKey) readStakeKeyHash stake = modifyError GovernanceActionsCmdReadFileError $ readVerificationKeyOrHashOrFile AsStakeKey stake @@ -324,93 +378,107 @@ addCostModelsToEraBasedProtocolParametersUpdate -> EraBasedProtocolParametersUpdate era -> EraBasedProtocolParametersUpdate era addCostModelsToEraBasedProtocolParametersUpdate - AlonzoEraOnwardsAlonzo - cmdls - (AlonzoEraBasedProtocolParametersUpdate common sTa aOn depAfterB) = - AlonzoEraBasedProtocolParametersUpdate common sTa (aOn { alCostModels = SJust cmdls }) depAfterB + AlonzoEraOnwardsAlonzo + cmdls + (AlonzoEraBasedProtocolParametersUpdate common sTa aOn depAfterB) = + AlonzoEraBasedProtocolParametersUpdate common sTa (aOn{alCostModels = SJust cmdls}) depAfterB addCostModelsToEraBasedProtocolParametersUpdate - AlonzoEraOnwardsBabbage - cmdls - (BabbageEraBasedProtocolParametersUpdate common aOn depAfterB inB) = - BabbageEraBasedProtocolParametersUpdate common (aOn { alCostModels = SJust cmdls }) depAfterB inB + AlonzoEraOnwardsBabbage + cmdls + (BabbageEraBasedProtocolParametersUpdate common aOn depAfterB inB) = + BabbageEraBasedProtocolParametersUpdate common (aOn{alCostModels = SJust cmdls}) depAfterB inB addCostModelsToEraBasedProtocolParametersUpdate - AlonzoEraOnwardsConway - cmdls - (ConwayEraBasedProtocolParametersUpdate common aOn inB inC) = - ConwayEraBasedProtocolParametersUpdate common (aOn { alCostModels = SJust cmdls }) inB inC + AlonzoEraOnwardsConway + cmdls + (ConwayEraBasedProtocolParametersUpdate common aOn inB inC) = + ConwayEraBasedProtocolParametersUpdate common (aOn{alCostModels = SJust cmdls}) inB inC -runGovernanceActionTreasuryWithdrawalCmd :: () +runGovernanceActionTreasuryWithdrawalCmd + :: () => GovernanceActionTreasuryWithdrawalCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionTreasuryWithdrawalCmd - Cmd.GovernanceActionTreasuryWithdrawalCmdArgs - { Cmd.eon - , Cmd.networkId - , Cmd.deposit - , Cmd.returnAddr - , Cmd.proposalUrl - , Cmd.proposalHash - , Cmd.treasuryWithdrawal - , Cmd.constitutionScriptHash - , Cmd.outFile - } = do - - let proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash = proposalHash - } - - depositStakeCredential - <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier returnAddr - - withdrawals <- forM treasuryWithdrawal $ \(verificationKeyOrHashOrFile, lovelace) -> do - stakeKeyHash <- readStakeKeyHash verificationKeyOrHashOrFile - pure (networkId, StakeCredentialByKey stakeKeyHash, lovelace) - - let sbe = conwayEraOnwardsToShelleyBasedEra eon - treasuryWithdrawals = TreasuryWithdrawal withdrawals - (toShelleyScriptHash <$> L.maybeToStrictMaybe constitutionScriptHash) - proposal = createProposalProcedure sbe networkId deposit depositStakeCredential treasuryWithdrawals proposalAnchor - - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints eon - $ writeFileTextEnvelope outFile (Just "Treasury withdrawal proposal") proposal - -runGovernanceActionHardforkInitCmd :: () + Cmd.GovernanceActionTreasuryWithdrawalCmdArgs + { Cmd.eon + , Cmd.networkId + , Cmd.deposit + , Cmd.returnAddr + , Cmd.proposalUrl + , Cmd.proposalHash + , Cmd.treasuryWithdrawal + , Cmd.constitutionScriptHash + , Cmd.outFile + } = do + let proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash = proposalHash + } + + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier returnAddr + + withdrawals <- forM treasuryWithdrawal $ \(verificationKeyOrHashOrFile, lovelace) -> do + stakeKeyHash <- readStakeKeyHash verificationKeyOrHashOrFile + pure (networkId, StakeCredentialByKey stakeKeyHash, lovelace) + + let sbe = conwayEraOnwardsToShelleyBasedEra eon + treasuryWithdrawals = + TreasuryWithdrawal + withdrawals + (toShelleyScriptHash <$> L.maybeToStrictMaybe constitutionScriptHash) + proposal = + createProposalProcedure + sbe + networkId + deposit + depositStakeCredential + treasuryWithdrawals + proposalAnchor + + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints eon $ + writeFileTextEnvelope outFile (Just "Treasury withdrawal proposal") proposal + +runGovernanceActionHardforkInitCmd + :: () => GovernanceActionHardforkInitCmdArgs era -> ExceptT GovernanceActionsError IO () runGovernanceActionHardforkInitCmd - Cmd.GovernanceActionHardforkInitCmdArgs - { Cmd.eon - , Cmd.networkId - , Cmd.deposit - , Cmd.returnStakeAddress - , Cmd.mPrevGovernanceActionId - , Cmd.proposalUrl - , Cmd.proposalHash = anchorDataHash - , Cmd.protVer - , Cmd.outFile - } = do - depositStakeCredential - <- firstExceptT GovernanceActionsReadStakeCredErrror - $ getStakeCredentialFromIdentifier returnStakeAddress - - let proposalAnchor = L.Anchor - { L.anchorUrl = unProposalUrl proposalUrl - , L.anchorDataHash - } - - let sbe = conwayEraOnwardsToShelleyBasedEra eon - govActIdentifier = L.maybeToStrictMaybe - $ shelleyBasedEraConstraints sbe - $ uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId - initHardfork = InitiateHardfork - govActIdentifier - protVer - - proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential initHardfork proposalAnchor - - firstExceptT GovernanceActionsCmdWriteFileError . newExceptT - $ conwayEraOnwardsConstraints eon - $ writeFileTextEnvelope outFile (Just "Hardfork initiation proposal") proposalProcedure + Cmd.GovernanceActionHardforkInitCmdArgs + { Cmd.eon + , Cmd.networkId + , Cmd.deposit + , Cmd.returnStakeAddress + , Cmd.mPrevGovernanceActionId + , Cmd.proposalUrl + , Cmd.proposalHash = anchorDataHash + , Cmd.protVer + , Cmd.outFile + } = do + depositStakeCredential <- + firstExceptT GovernanceActionsReadStakeCredErrror $ + getStakeCredentialFromIdentifier returnStakeAddress + + let proposalAnchor = + L.Anchor + { L.anchorUrl = unProposalUrl proposalUrl + , L.anchorDataHash + } + + let sbe = conwayEraOnwardsToShelleyBasedEra eon + govActIdentifier = + L.maybeToStrictMaybe $ + shelleyBasedEraConstraints sbe $ + uncurry createPreviousGovernanceActionId <$> mPrevGovernanceActionId + initHardfork = + InitiateHardfork + govActIdentifier + protVer + + proposalProcedure = createProposalProcedure sbe networkId deposit depositStakeCredential initHardfork proposalAnchor + + firstExceptT GovernanceActionsCmdWriteFileError . newExceptT $ + conwayEraOnwardsConstraints eon $ + writeFileTextEnvelope outFile (Just "Hardfork initiation proposal") proposalProcedure diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Committee.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Committee.hs index 1076bd9f2b..3f862d9602 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Committee.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Committee.hs @@ -5,8 +5,9 @@ module Cardano.CLI.EraBased.Run.Governance.Committee ( runGovernanceCommitteeCmds - , GovernanceCommitteeError(..) - ) where + , GovernanceCommitteeError (..) + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -22,7 +23,8 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Function -runGovernanceCommitteeCmds :: () +runGovernanceCommitteeCmds + :: () => GovernanceCommitteeCmds era -> ExceptT GovernanceCommitteeError IO () runGovernanceCommitteeCmds = \case @@ -37,143 +39,149 @@ runGovernanceCommitteeCmds = \case GovernanceCommitteeCreateColdKeyResignationCertificateCmd cmd -> runGovernanceCommitteeColdKeyResignationCertificate cmd -runGovernanceCommitteeKeyGenCold :: () +runGovernanceCommitteeKeyGenCold + :: () => Cmd.GovernanceCommitteeKeyGenColdCmdArgs era -> ExceptT GovernanceCommitteeError IO () runGovernanceCommitteeKeyGenCold - Cmd.GovernanceCommitteeKeyGenColdCmdArgs - { Cmd.vkeyOutFile = vkeyPath - , Cmd.skeyOutFile = skeyPath - } = do - skey <- generateSigningKey AsCommitteeColdKey + Cmd.GovernanceCommitteeKeyGenColdCmdArgs + { Cmd.vkeyOutFile = vkeyPath + , Cmd.skeyOutFile = skeyPath + } = do + skey <- generateSigningKey AsCommitteeColdKey - let vkey = getVerificationKey skey + let vkey = getVerificationKey skey - writeLazyByteStringFile skeyPath (textEnvelopeToJSON (Just Key.ccColdSkeyDesc) skey) - & onLeft (left . GovernanceCommitteeCmdWriteFileError) + writeLazyByteStringFile skeyPath (textEnvelopeToJSON (Just Key.ccColdSkeyDesc) skey) + & onLeft (left . GovernanceCommitteeCmdWriteFileError) - writeLazyByteStringFile vkeyPath (textEnvelopeToJSON (Just Key.ccColdVkeyDesc) vkey) - & onLeft (left . GovernanceCommitteeCmdWriteFileError) + writeLazyByteStringFile vkeyPath (textEnvelopeToJSON (Just Key.ccColdVkeyDesc) vkey) + & onLeft (left . GovernanceCommitteeCmdWriteFileError) -runGovernanceCommitteeKeyGenHot :: () +runGovernanceCommitteeKeyGenHot + :: () => Cmd.GovernanceCommitteeKeyGenHotCmdArgs era -> ExceptT GovernanceCommitteeError IO () runGovernanceCommitteeKeyGenHot - Cmd.GovernanceCommitteeKeyGenHotCmdArgs - { Cmd.eon = _eon - , Cmd.vkeyOutFile = vkeyPath - , Cmd.skeyOutFile = skeyPath - } = do - skey <- generateSigningKey AsCommitteeHotKey + Cmd.GovernanceCommitteeKeyGenHotCmdArgs + { Cmd.eon = _eon + , Cmd.vkeyOutFile = vkeyPath + , Cmd.skeyOutFile = skeyPath + } = do + skey <- generateSigningKey AsCommitteeHotKey - let vkey = getVerificationKey skey + let vkey = getVerificationKey skey - firstExceptT GovernanceCommitteeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile skeyPath - $ textEnvelopeToJSON (Just Key.ccHotSkeyDesc) skey + firstExceptT GovernanceCommitteeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile skeyPath + $ textEnvelopeToJSON (Just Key.ccHotSkeyDesc) skey - firstExceptT GovernanceCommitteeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile vkeyPath - $ textEnvelopeToJSON (Just Key.ccHotVkeyDesc) vkey + firstExceptT GovernanceCommitteeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile vkeyPath + $ textEnvelopeToJSON (Just Key.ccHotVkeyDesc) vkey data SomeCommitteeKey - = ACommitteeHotKey (VerificationKey CommitteeHotKey) - | ACommitteeHotExtendedKey (VerificationKey CommitteeHotExtendedKey) + = ACommitteeHotKey (VerificationKey CommitteeHotKey) + | ACommitteeHotExtendedKey (VerificationKey CommitteeHotExtendedKey) | ACommitteeColdKey (VerificationKey CommitteeColdKey) | ACommitteeColdExtendedKey (VerificationKey CommitteeColdExtendedKey) -runGovernanceCommitteeKeyHash :: () +runGovernanceCommitteeKeyHash + :: () => Cmd.GovernanceCommitteeKeyHashCmdArgs era -> ExceptT GovernanceCommitteeError IO () runGovernanceCommitteeKeyHash - Cmd.GovernanceCommitteeKeyHashCmdArgs - { Cmd.vkeySource - } = do - vkey <- - case vkeySource of - AnyVerificationKeySourceOfText vkText -> do - let asTypes = - [ FromSomeType (AsVerificationKey AsCommitteeHotKey) ACommitteeHotKey - , FromSomeType (AsVerificationKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedKey - , FromSomeType (AsVerificationKey AsCommitteeColdKey) ACommitteeColdKey - , FromSomeType (AsVerificationKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedKey - ] - pure (deserialiseAnyOfFromBech32 asTypes (unAnyVerificationKeyText vkText)) - & onLeft (left . GovernanceCommitteeCmdKeyDecodeError . InputBech32DecodeError) - AnyVerificationKeySourceOfFile vkeyPath -> do - let asTypes = - [ FromSomeType (AsVerificationKey AsCommitteeHotKey) ACommitteeHotKey - , FromSomeType (AsVerificationKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedKey - , FromSomeType (AsVerificationKey AsCommitteeColdKey) ACommitteeColdKey - , FromSomeType (AsVerificationKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedKey - ] - readFileTextEnvelopeAnyOf asTypes vkeyPath - & firstExceptT GovernanceCommitteeCmdTextEnvReadFileError . newExceptT - - liftIO $ BS.putStrLn (renderKeyHash vkey) - - where + Cmd.GovernanceCommitteeKeyHashCmdArgs + { Cmd.vkeySource + } = do + vkey <- + case vkeySource of + AnyVerificationKeySourceOfText vkText -> do + let asTypes = + [ FromSomeType (AsVerificationKey AsCommitteeHotKey) ACommitteeHotKey + , FromSomeType (AsVerificationKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedKey + , FromSomeType (AsVerificationKey AsCommitteeColdKey) ACommitteeColdKey + , FromSomeType (AsVerificationKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedKey + ] + pure (deserialiseAnyOfFromBech32 asTypes (unAnyVerificationKeyText vkText)) + & onLeft (left . GovernanceCommitteeCmdKeyDecodeError . InputBech32DecodeError) + AnyVerificationKeySourceOfFile vkeyPath -> do + let asTypes = + [ FromSomeType (AsVerificationKey AsCommitteeHotKey) ACommitteeHotKey + , FromSomeType (AsVerificationKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedKey + , FromSomeType (AsVerificationKey AsCommitteeColdKey) ACommitteeColdKey + , FromSomeType (AsVerificationKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedKey + ] + readFileTextEnvelopeAnyOf asTypes vkeyPath + & firstExceptT GovernanceCommitteeCmdTextEnvReadFileError . newExceptT + + liftIO $ BS.putStrLn (renderKeyHash vkey) + where renderKeyHash :: SomeCommitteeKey -> ByteString renderKeyHash = \case - ACommitteeHotKey vk -> renderVerificationKeyHash vk - ACommitteeHotExtendedKey vk -> renderVerificationKeyHash vk - ACommitteeColdKey vk -> renderVerificationKeyHash vk + ACommitteeHotKey vk -> renderVerificationKeyHash vk + ACommitteeHotExtendedKey vk -> renderVerificationKeyHash vk + ACommitteeColdKey vk -> renderVerificationKeyHash vk ACommitteeColdExtendedKey vk -> renderVerificationKeyHash vk renderVerificationKeyHash :: Key keyrole => VerificationKey keyrole -> ByteString - renderVerificationKeyHash = serialiseToRawBytesHex - . verificationKeyHash + renderVerificationKeyHash = + serialiseToRawBytesHex + . verificationKeyHash -runGovernanceCommitteeCreateHotKeyAuthorizationCertificate :: () +runGovernanceCommitteeCreateHotKeyAuthorizationCertificate + :: () => Cmd.GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs era -> ExceptT GovernanceCommitteeError IO () runGovernanceCommitteeCreateHotKeyAuthorizationCertificate - Cmd.GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs - { Cmd.eon = eon - , Cmd.vkeyColdKeySource - , Cmd.vkeyHotKeySource - , Cmd.outFile = oFp - } = - conwayEraOnwardsConstraints eon $ do - let mapError' = modifyError $ either GovernanceCommitteeCmdScriptReadError GovernanceCommitteeCmdKeyReadError - hotCred <- - mapError' $ - readVerificationKeySource AsCommitteeHotKey unCommitteeHotKeyHash vkeyHotKeySource - coldCred <- - mapError' $ - readVerificationKeySource AsCommitteeColdKey unCommitteeColdKeyHash vkeyColdKeySource - - makeCommitteeHotKeyAuthorizationCertificate (CommitteeHotKeyAuthorizationRequirements eon coldCred hotCred) - & textEnvelopeToJSON (Just genKeyDelegCertDesc) - & writeLazyByteStringFile oFp - & firstExceptT GovernanceCommitteeCmdTextEnvWriteError . newExceptT - - where + Cmd.GovernanceCommitteeCreateHotKeyAuthorizationCertificateCmdArgs + { Cmd.eon = eon + , Cmd.vkeyColdKeySource + , Cmd.vkeyHotKeySource + , Cmd.outFile = oFp + } = + conwayEraOnwardsConstraints eon $ do + let mapError' = modifyError $ either GovernanceCommitteeCmdScriptReadError GovernanceCommitteeCmdKeyReadError + hotCred <- + mapError' $ + readVerificationKeySource AsCommitteeHotKey unCommitteeHotKeyHash vkeyHotKeySource + coldCred <- + mapError' $ + readVerificationKeySource AsCommitteeColdKey unCommitteeColdKeyHash vkeyColdKeySource + + makeCommitteeHotKeyAuthorizationCertificate + (CommitteeHotKeyAuthorizationRequirements eon coldCred hotCred) + & textEnvelopeToJSON (Just genKeyDelegCertDesc) + & writeLazyByteStringFile oFp + & firstExceptT GovernanceCommitteeCmdTextEnvWriteError . newExceptT + where genKeyDelegCertDesc :: TextEnvelopeDescr genKeyDelegCertDesc = "Constitutional Committee Hot Key Registration Certificate" -runGovernanceCommitteeColdKeyResignationCertificate :: () +runGovernanceCommitteeColdKeyResignationCertificate + :: () => Cmd.GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs era -> ExceptT GovernanceCommitteeError IO () runGovernanceCommitteeColdKeyResignationCertificate - Cmd.GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs - { Cmd.eon - , Cmd.vkeyColdKeySource - , Cmd.anchor - , Cmd.outFile - } = - conwayEraOnwardsConstraints eon $ do - let modifyError' = modifyError $ either GovernanceCommitteeCmdScriptReadError GovernanceCommitteeCmdKeyReadError - coldVKeyCred <- modifyError' $ - readVerificationKeySource AsCommitteeColdKey unCommitteeColdKeyHash vkeyColdKeySource - - makeCommitteeColdkeyResignationCertificate (CommitteeColdkeyResignationRequirements eon coldVKeyCred anchor) - & textEnvelopeToJSON (Just genKeyDelegCertDesc) - & writeLazyByteStringFile outFile - & firstExceptT GovernanceCommitteeCmdTextEnvWriteError . newExceptT - - where + Cmd.GovernanceCommitteeCreateColdKeyResignationCertificateCmdArgs + { Cmd.eon + , Cmd.vkeyColdKeySource + , Cmd.anchor + , Cmd.outFile + } = + conwayEraOnwardsConstraints eon $ do + let modifyError' = modifyError $ either GovernanceCommitteeCmdScriptReadError GovernanceCommitteeCmdKeyReadError + coldVKeyCred <- + modifyError' $ + readVerificationKeySource AsCommitteeColdKey unCommitteeColdKeyHash vkeyColdKeySource + + makeCommitteeColdkeyResignationCertificate + (CommitteeColdkeyResignationRequirements eon coldVKeyCred anchor) + & textEnvelopeToJSON (Just genKeyDelegCertDesc) + & writeLazyByteStringFile outFile + & firstExceptT GovernanceCommitteeCmdTextEnvWriteError . newExceptT + where genKeyDelegCertDesc :: TextEnvelopeDescr genKeyDelegCertDesc = "Constitutional Committee Cold Key Resignation Certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs index 743d1c8561..543e10b1c0 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/DRep.hs @@ -12,7 +12,8 @@ module Cardano.CLI.EraBased.Run.Governance.DRep ( runGovernanceDRepCmds , runGovernanceDRepKeyGenCmd - ) where + ) +where import Cardano.Api import Cardano.Api.Ledger (Credential (KeyHashObj)) @@ -30,146 +31,150 @@ import Control.Monad (void) import Data.Function import qualified Data.Text.Encoding as Text -runGovernanceDRepCmds :: () +runGovernanceDRepCmds + :: () => Cmd.GovernanceDRepCmds era -> ExceptT CmdError IO () runGovernanceDRepCmds = \case Cmd.GovernanceDRepKeyGenCmd args -> - void $ runGovernanceDRepKeyGenCmd args - & firstExceptT (CmdGovernanceCmdError . GovernanceCmdWriteFileError) - + void $ + runGovernanceDRepKeyGenCmd args + & firstExceptT (CmdGovernanceCmdError . GovernanceCmdWriteFileError) Cmd.GovernanceDRepIdCmd args -> runGovernanceDRepIdCmd args & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceDRepRegistrationCertificateCmd args -> runGovernanceDRepRegistrationCertificateCmd args & firstExceptT CmdRegistrationError - Cmd.GovernanceDRepRetirementCertificateCmd args -> runGovernanceDRepRetirementCertificateCmd args & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceDRepUpdateCertificateCmd args -> runGovernanceDRepUpdateCertificateCmd args & firstExceptT CmdGovernanceCmdError - Cmd.GovernanceDRepMetadataHashCmd args -> runGovernanceDRepMetadataHashCmd args & firstExceptT CmdGovernanceCmdError -runGovernanceDRepKeyGenCmd :: () +runGovernanceDRepKeyGenCmd + :: () => Cmd.GovernanceDRepKeyGenCmdArgs era -> ExceptT (FileError ()) IO (VerificationKey DRepKey, SigningKey DRepKey) runGovernanceDRepKeyGenCmd - Cmd.GovernanceDRepKeyGenCmdArgs - { vkeyFile - , skeyFile - } = do - (vkey, skey) <- liftIO $ generateKeyPair AsDRepKey - newExceptT $ writeLazyByteStringFile skeyFile (textEnvelopeToJSON (Just Key.drepSkeyDesc) skey) - newExceptT $ writeLazyByteStringFile vkeyFile (textEnvelopeToJSON (Just Key.drepVkeyDesc) vkey) - return (vkey, skey) - -runGovernanceDRepIdCmd :: () + Cmd.GovernanceDRepKeyGenCmdArgs + { vkeyFile + , skeyFile + } = do + (vkey, skey) <- liftIO $ generateKeyPair AsDRepKey + newExceptT $ writeLazyByteStringFile skeyFile (textEnvelopeToJSON (Just Key.drepSkeyDesc) skey) + newExceptT $ writeLazyByteStringFile vkeyFile (textEnvelopeToJSON (Just Key.drepVkeyDesc) vkey) + return (vkey, skey) + +runGovernanceDRepIdCmd + :: () => Cmd.GovernanceDRepIdCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceDRepIdCmd - Cmd.GovernanceDRepIdCmdArgs - { vkeySource - , idOutputFormat - , mOutFile - } = do - drepVerKey <- modifyError ReadFileError $ - readVerificationKeyOrTextEnvFile AsDRepKey vkeySource - - content <- - pure $ case idOutputFormat of - IdOutputFormatHex -> serialiseToRawBytesHex $ verificationKeyHash drepVerKey - IdOutputFormatBech32 -> Text.encodeUtf8 $ serialiseToBech32 $ verificationKeyHash drepVerKey - - lift (writeByteStringOutput mOutFile content) - & onLeft (left . WriteFileError) + Cmd.GovernanceDRepIdCmdArgs + { vkeySource + , idOutputFormat + , mOutFile + } = do + drepVerKey <- + modifyError ReadFileError $ + readVerificationKeyOrTextEnvFile AsDRepKey vkeySource + + content <- + pure $ case idOutputFormat of + IdOutputFormatHex -> serialiseToRawBytesHex $ verificationKeyHash drepVerKey + IdOutputFormatBech32 -> Text.encodeUtf8 $ serialiseToBech32 $ verificationKeyHash drepVerKey + + lift (writeByteStringOutput mOutFile content) + & onLeft (left . WriteFileError) -------------------------------------------------------------------------------- -- Registration Certificate related -runGovernanceDRepRegistrationCertificateCmd :: () +runGovernanceDRepRegistrationCertificateCmd + :: () => Cmd.GovernanceDRepRegistrationCertificateCmdArgs era -> ExceptT RegistrationError IO () runGovernanceDRepRegistrationCertificateCmd - Cmd.GovernanceDRepRegistrationCertificateCmdArgs - { eon = w - , drepHashSource - , deposit - , mAnchor - , outFile - } = - conwayEraOnwardsConstraints w $ do - drepCred <- modifyError RegistrationReadError $ readDRepCredential drepHashSource - let req = DRepRegistrationRequirements w drepCred deposit - registrationCert = makeDrepRegistrationCertificate req mAnchor - description = Just @TextEnvelopeDescr "DRep Key Registration Certificate" - - firstExceptT RegistrationWriteFileError - . newExceptT - . writeLazyByteStringFile outFile - $ conwayEraOnwardsConstraints w - $ textEnvelopeToJSON description registrationCert + Cmd.GovernanceDRepRegistrationCertificateCmdArgs + { eon = w + , drepHashSource + , deposit + , mAnchor + , outFile + } = + conwayEraOnwardsConstraints w $ do + drepCred <- modifyError RegistrationReadError $ readDRepCredential drepHashSource + let req = DRepRegistrationRequirements w drepCred deposit + registrationCert = makeDrepRegistrationCertificate req mAnchor + description = Just @TextEnvelopeDescr "DRep Key Registration Certificate" + + firstExceptT RegistrationWriteFileError + . newExceptT + . writeLazyByteStringFile outFile + $ conwayEraOnwardsConstraints w + $ textEnvelopeToJSON description registrationCert -runGovernanceDRepRetirementCertificateCmd :: () +runGovernanceDRepRetirementCertificateCmd + :: () => Cmd.GovernanceDRepRetirementCertificateCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceDRepRetirementCertificateCmd - Cmd.GovernanceDRepRetirementCertificateCmdArgs - { eon = w - , drepHashSource - , deposit - , outFile - } = - conwayEraOnwardsConstraints w $ do - drepCredential <- modifyError GovernanceCmdKeyReadError $ readDRepCredential drepHashSource - makeDrepUnregistrationCertificate (DRepUnregistrationRequirements w drepCredential deposit) - & writeFileTextEnvelope outFile (Just genKeyDelegCertDesc) - & modifyError GovernanceCmdTextEnvWriteError . newExceptT - - where + Cmd.GovernanceDRepRetirementCertificateCmdArgs + { eon = w + , drepHashSource + , deposit + , outFile + } = + conwayEraOnwardsConstraints w $ do + drepCredential <- modifyError GovernanceCmdKeyReadError $ readDRepCredential drepHashSource + makeDrepUnregistrationCertificate (DRepUnregistrationRequirements w drepCredential deposit) + & writeFileTextEnvelope outFile (Just genKeyDelegCertDesc) + & modifyError GovernanceCmdTextEnvWriteError . newExceptT + where genKeyDelegCertDesc :: TextEnvelopeDescr genKeyDelegCertDesc = "DRep Retirement Certificate" -runGovernanceDRepUpdateCertificateCmd :: () +runGovernanceDRepUpdateCertificateCmd + :: () => Cmd.GovernanceDRepUpdateCertificateCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceDRepUpdateCertificateCmd - Cmd.GovernanceDRepUpdateCertificateCmdArgs - { eon = w - , drepVkeyHashSource - , mAnchor - , outFile - } = - conwayEraOnwardsConstraints w $ do - DRepKeyHash drepKeyHash <- firstExceptT GovernanceCmdKeyReadError - $ readVerificationKeyOrHashOrFile AsDRepKey drepVkeyHashSource - makeDrepUpdateCertificate (DRepUpdateRequirements w (KeyHashObj drepKeyHash)) mAnchor - & writeFileTextEnvelope outFile (Just "DRep Update Certificate") - & firstExceptT GovernanceCmdTextEnvWriteError . newExceptT - -runGovernanceDRepMetadataHashCmd :: () + Cmd.GovernanceDRepUpdateCertificateCmdArgs + { eon = w + , drepVkeyHashSource + , mAnchor + , outFile + } = + conwayEraOnwardsConstraints w $ do + DRepKeyHash drepKeyHash <- + firstExceptT GovernanceCmdKeyReadError $ + readVerificationKeyOrHashOrFile AsDRepKey drepVkeyHashSource + makeDrepUpdateCertificate (DRepUpdateRequirements w (KeyHashObj drepKeyHash)) mAnchor + & writeFileTextEnvelope outFile (Just "DRep Update Certificate") + & firstExceptT GovernanceCmdTextEnvWriteError . newExceptT + +runGovernanceDRepMetadataHashCmd + :: () => Cmd.GovernanceDRepMetadataHashCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceDRepMetadataHashCmd - Cmd.GovernanceDRepMetadataHashCmdArgs - { metadataFile - , mOutFile - } = do - metadataBytes <- firstExceptT ReadFileError $ newExceptT (readByteStringFile metadataFile) - (_metadata, metadataHash) <- - firstExceptT GovernanceCmdDRepMetadataValidationError - . hoistEither - $ validateAndHashDRepMetadata metadataBytes - firstExceptT WriteFileError - . newExceptT - . writeByteStringOutput mOutFile - . serialiseToRawBytesHex - $ metadataHash + Cmd.GovernanceDRepMetadataHashCmdArgs + { metadataFile + , mOutFile + } = do + metadataBytes <- firstExceptT ReadFileError $ newExceptT (readByteStringFile metadataFile) + (_metadata, metadataHash) <- + firstExceptT GovernanceCmdDRepMetadataValidationError + . hoistEither + $ validateAndHashDRepMetadata metadataBytes + firstExceptT WriteFileError + . newExceptT + . writeByteStringOutput mOutFile + . serialiseToRawBytesHex + $ metadataHash diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs index 527963b536..f8759e4acc 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/GenesisKeyDelegationCertificate.hs @@ -3,8 +3,8 @@ module Cardano.CLI.EraBased.Run.Governance.GenesisKeyDelegationCertificate ( runGovernanceGenesisKeyDelegationCertificate - ) where - + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -19,26 +19,30 @@ runGovernanceGenesisKeyDelegationCertificate -> VerificationKeyOrHashOrFile VrfKey -> File () Out -> ExceptT GovernanceCmdError IO () -runGovernanceGenesisKeyDelegationCertificate stb - genVkOrHashOrFp - genDelVkOrHashOrFp - vrfVkOrHashOrFp - oFp = do - genesisVkHash <- modifyError GovernanceCmdKeyReadError - $ readVerificationKeyOrHashOrTextEnvFile AsGenesisKey genVkOrHashOrFp - genesisDelVkHash <- modifyError GovernanceCmdKeyReadError - $ readVerificationKeyOrHashOrTextEnvFile AsGenesisDelegateKey genDelVkOrHashOrFp - vrfVkHash <- modifyError GovernanceCmdKeyReadError - $ readVerificationKeyOrHashOrFile AsVrfKey vrfVkOrHashOrFp +runGovernanceGenesisKeyDelegationCertificate + stb + genVkOrHashOrFp + genDelVkOrHashOrFp + vrfVkOrHashOrFp + oFp = do + genesisVkHash <- + modifyError GovernanceCmdKeyReadError $ + readVerificationKeyOrHashOrTextEnvFile AsGenesisKey genVkOrHashOrFp + genesisDelVkHash <- + modifyError GovernanceCmdKeyReadError $ + readVerificationKeyOrHashOrTextEnvFile AsGenesisDelegateKey genDelVkOrHashOrFp + vrfVkHash <- + modifyError GovernanceCmdKeyReadError $ + readVerificationKeyOrHashOrFile AsVrfKey vrfVkOrHashOrFp - let req = GenesisKeyDelegationRequirements stb genesisVkHash genesisDelVkHash vrfVkHash - genKeyDelegCert = makeGenesisKeyDelegationCertificate req + let req = GenesisKeyDelegationRequirements stb genesisVkHash genesisDelVkHash vrfVkHash + genKeyDelegCert = makeGenesisKeyDelegationCertificate req - firstExceptT GovernanceCmdTextEnvWriteError - . newExceptT - $ writeLazyByteStringFile oFp - $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra stb) - $ textEnvelopeToJSON (Just genKeyDelegCertDesc) genKeyDelegCert - where + firstExceptT GovernanceCmdTextEnvWriteError + . newExceptT + $ writeLazyByteStringFile oFp + $ shelleyBasedEraConstraints (shelleyToBabbageEraToShelleyBasedEra stb) + $ textEnvelopeToJSON (Just genKeyDelegCertDesc) genKeyDelegCert + where genKeyDelegCertDesc :: TextEnvelopeDescr genKeyDelegCertDesc = "Genesis Key Delegation Certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Poll.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Poll.hs index 6681b3f725..412cb89fef 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Poll.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Poll.hs @@ -5,11 +5,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.EraBased.Run.Governance.Poll - ( runGovernancePollCmds, - runGovernanceCreatePollCmd, - runGovernanceAnswerPollCmd, - runGovernanceVerifyPollCmd - ) where + ( runGovernancePollCmds + , runGovernanceCreatePollCmd + , runGovernanceAnswerPollCmd + , runGovernanceVerifyPollCmd + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -29,8 +30,8 @@ import qualified Data.Text.Read as Text import qualified System.IO as IO import System.IO (stderr, stdin, stdout) - -runGovernancePollCmds :: () +runGovernancePollCmds + :: () => Cmd.GovernancePollCmds era -> ExceptT GovernanceCmdError IO () runGovernancePollCmds = \case @@ -38,140 +39,168 @@ runGovernancePollCmds = \case Cmd.GovernanceAnswerPoll args -> runGovernanceAnswerPollCmd args Cmd.GovernanceVerifyPoll args -> runGovernanceVerifyPollCmd args -runGovernanceCreatePollCmd :: () +runGovernanceCreatePollCmd + :: () => Cmd.GovernanceCreatePollCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceCreatePollCmd - Cmd.GovernanceCreatePollCmdArgs - { eon = _eon - , prompt = govPollQuestion - , choices = govPollAnswers - , nonce = govPollNonce - , outFile = out - } = do - let poll = GovernancePoll{ govPollQuestion, govPollAnswers, govPollNonce } - - let description = fromString $ "An on-chain poll for SPOs: " <> Text.unpack govPollQuestion - firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $ - writeFileTextEnvelope out (Just description) poll - - let metadata = asTxMetadata poll - & metadataToJson TxMetadataJsonDetailedSchema - - let outPath = unFile out & Text.encodeUtf8 . Text.pack - - liftIO $ do - BSC.hPutStrLn stderr $ mconcat - [ "Poll created successfully.\n" - , "Please submit a transaction using the resulting metadata.\n" - ] - BSC.hPutStrLn stdout (prettyPrintJSON metadata) - BSC.hPutStrLn stderr $ mconcat - [ "\n" - , "Hint (1): Use '--json-metadata-detailed-schema' and '--metadata-json-file' " - , "from the build or build-raw commands.\n" - , "Hint (2): You can redirect the standard output of this command to a JSON " - , "file to capture metadata.\n\n" - , "Note: A serialized version of the poll suitable for sharing with " - , "participants has been generated at '" <> outPath <> "'." - ] - -runGovernanceAnswerPollCmd :: () + Cmd.GovernanceCreatePollCmdArgs + { eon = _eon + , prompt = govPollQuestion + , choices = govPollAnswers + , nonce = govPollNonce + , outFile = out + } = do + let poll = GovernancePoll{govPollQuestion, govPollAnswers, govPollNonce} + + let description = fromString $ "An on-chain poll for SPOs: " <> Text.unpack govPollQuestion + firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $ + writeFileTextEnvelope out (Just description) poll + + let metadata = + asTxMetadata poll + & metadataToJson TxMetadataJsonDetailedSchema + + let outPath = unFile out & Text.encodeUtf8 . Text.pack + + liftIO $ do + BSC.hPutStrLn stderr $ + mconcat + [ "Poll created successfully.\n" + , "Please submit a transaction using the resulting metadata.\n" + ] + BSC.hPutStrLn stdout (prettyPrintJSON metadata) + BSC.hPutStrLn stderr $ + mconcat + [ "\n" + , "Hint (1): Use '--json-metadata-detailed-schema' and '--metadata-json-file' " + , "from the build or build-raw commands.\n" + , "Hint (2): You can redirect the standard output of this command to a JSON " + , "file to capture metadata.\n\n" + , "Note: A serialized version of the poll suitable for sharing with " + , "participants has been generated at '" <> outPath <> "'." + ] + +runGovernanceAnswerPollCmd + :: () => Cmd.GovernanceAnswerPollCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceAnswerPollCmd - Cmd.GovernanceAnswerPollCmdArgs - { eon = _eon - , pollFile = pollFile - , answerIndex = maybeChoice - , mOutFile = mOutFile - } = do - poll <- firstExceptT GovernanceCmdTextEnvReadError . newExceptT $ - readFileTextEnvelope AsGovernancePoll pollFile - - choice <- case maybeChoice of - Nothing -> do - askInteractively poll - Just ix -> do - validateChoice poll ix - liftIO $ BSC.hPutStrLn stderr $ Text.encodeUtf8 $ Text.intercalate "\n" - [ govPollQuestion poll - , "→ " <> (govPollAnswers poll !! fromIntegral ix) - , "" - ] - pure ix - - let pollAnswer = GovernancePollAnswer - { govAnsPoll = hashGovernancePoll poll - , govAnsChoice = choice - } - let metadata = - metadataToJson TxMetadataJsonDetailedSchema (asTxMetadata pollAnswer) - - liftIO $ BSC.hPutStrLn stderr $ mconcat - [ "Poll answer created successfully.\n" - , "Please submit a transaction using the resulting metadata.\n" - , "To be valid, the transaction must also be signed using a valid key\n" - , "identifying your stake pool (e.g. your cold key).\n" - ] - - lift (writeByteStringOutput mOutFile (prettyPrintJSON metadata)) - & onLeft (left . GovernanceCmdWriteFileError) - - liftIO $ BSC.hPutStrLn stderr $ mconcat - [ "\n" - , "Hint (1): Use '--json-metadata-detailed-schema' and '--metadata-json-file' " - , "from the build or build-raw commands.\n" - , "Hint (2): You can redirect the standard output of this command to a JSON " - , "file to capture metadata." - ] - where - validateChoice :: GovernancePoll -> Word -> ExceptT GovernanceCmdError IO () - validateChoice GovernancePoll{govPollAnswers} ix = do - let maxAnswerIndex = length govPollAnswers - 1 - ixInt = fromIntegral ix - when (ixInt < 0 || ixInt > maxAnswerIndex) $ left $ - GovernanceCmdPollOutOfBoundAnswer maxAnswerIndex - - askInteractively :: GovernancePoll -> ExceptT GovernanceCmdError IO Word - askInteractively poll@GovernancePoll{govPollQuestion, govPollAnswers} = do - liftIO $ BSC.hPutStrLn stderr $ Text.encodeUtf8 $ Text.intercalate "\n" - ( govPollQuestion - : [ "[" <> textShow ix <> "] " <> answer - | (ix :: Int, answer) <- zip [0..] govPollAnswers - ] - ) - liftIO $ BSC.hPutStrLn stderr "" - liftIO $ BSC.hPutStr stderr "Please indicate an answer (by index): " - txt <- liftIO $ Text.hGetLine stdin - liftIO $ BSC.hPutStrLn stderr "" - case Text.decimal txt of - Right (choice, rest) | Text.null rest -> - choice <$ validateChoice poll choice - _ -> - left GovernanceCmdPollInvalidChoice - -runGovernanceVerifyPollCmd :: () + Cmd.GovernanceAnswerPollCmdArgs + { eon = _eon + , pollFile = pollFile + , answerIndex = maybeChoice + , mOutFile = mOutFile + } = do + poll <- + firstExceptT GovernanceCmdTextEnvReadError . newExceptT $ + readFileTextEnvelope AsGovernancePoll pollFile + + choice <- case maybeChoice of + Nothing -> do + askInteractively poll + Just ix -> do + validateChoice poll ix + liftIO $ + BSC.hPutStrLn stderr $ + Text.encodeUtf8 $ + Text.intercalate + "\n" + [ govPollQuestion poll + , "→ " <> (govPollAnswers poll !! fromIntegral ix) + , "" + ] + pure ix + + let pollAnswer = + GovernancePollAnswer + { govAnsPoll = hashGovernancePoll poll + , govAnsChoice = choice + } + let metadata = + metadataToJson TxMetadataJsonDetailedSchema (asTxMetadata pollAnswer) + + liftIO $ + BSC.hPutStrLn stderr $ + mconcat + [ "Poll answer created successfully.\n" + , "Please submit a transaction using the resulting metadata.\n" + , "To be valid, the transaction must also be signed using a valid key\n" + , "identifying your stake pool (e.g. your cold key).\n" + ] + + lift (writeByteStringOutput mOutFile (prettyPrintJSON metadata)) + & onLeft (left . GovernanceCmdWriteFileError) + + liftIO $ + BSC.hPutStrLn stderr $ + mconcat + [ "\n" + , "Hint (1): Use '--json-metadata-detailed-schema' and '--metadata-json-file' " + , "from the build or build-raw commands.\n" + , "Hint (2): You can redirect the standard output of this command to a JSON " + , "file to capture metadata." + ] + where + validateChoice :: GovernancePoll -> Word -> ExceptT GovernanceCmdError IO () + validateChoice GovernancePoll{govPollAnswers} ix = do + let maxAnswerIndex = length govPollAnswers - 1 + ixInt = fromIntegral ix + when (ixInt < 0 || ixInt > maxAnswerIndex) $ + left $ + GovernanceCmdPollOutOfBoundAnswer maxAnswerIndex + + askInteractively :: GovernancePoll -> ExceptT GovernanceCmdError IO Word + askInteractively poll@GovernancePoll{govPollQuestion, govPollAnswers} = do + liftIO $ + BSC.hPutStrLn stderr $ + Text.encodeUtf8 $ + Text.intercalate + "\n" + ( govPollQuestion + : [ "[" <> textShow ix <> "] " <> answer + | (ix :: Int, answer) <- zip [0 ..] govPollAnswers + ] + ) + liftIO $ BSC.hPutStrLn stderr "" + liftIO $ BSC.hPutStr stderr "Please indicate an answer (by index): " + txt <- liftIO $ Text.hGetLine stdin + liftIO $ BSC.hPutStrLn stderr "" + case Text.decimal txt of + Right (choice, rest) + | Text.null rest -> + choice <$ validateChoice poll choice + _ -> + left GovernanceCmdPollInvalidChoice + +runGovernanceVerifyPollCmd + :: () => Cmd.GovernanceVerifyPollCmdArgs era -> ExceptT GovernanceCmdError IO () runGovernanceVerifyPollCmd - Cmd.GovernanceVerifyPollCmdArgs - { eon = _eon - , pollFile = pollFile - , txFile = txFile - , mOutFile = mOutFile - } = do - poll <- firstExceptT GovernanceCmdTextEnvReadError . newExceptT $ - readFileTextEnvelope AsGovernancePoll pollFile - - txFileOrPipe <- liftIO $ fileOrPipe (unFile txFile) - tx <- firstExceptT GovernanceCmdTextEnvCddlReadError . newExceptT $ - readFileTx txFileOrPipe - - signatories <- firstExceptT GovernanceCmdVerifyPollError . newExceptT $ pure $ - verifyPollAnswer poll tx - - liftIO $ IO.hPutStrLn stderr $ "Found valid poll answer with " <> show (length signatories) <> " signatories" - - lift (writeByteStringOutput mOutFile (prettyPrintJSON signatories)) - & onLeft (left . GovernanceCmdWriteFileError) + Cmd.GovernanceVerifyPollCmdArgs + { eon = _eon + , pollFile = pollFile + , txFile = txFile + , mOutFile = mOutFile + } = do + poll <- + firstExceptT GovernanceCmdTextEnvReadError . newExceptT $ + readFileTextEnvelope AsGovernancePoll pollFile + + txFileOrPipe <- liftIO $ fileOrPipe (unFile txFile) + tx <- + firstExceptT GovernanceCmdTextEnvCddlReadError . newExceptT $ + readFileTx txFileOrPipe + + signatories <- + firstExceptT GovernanceCmdVerifyPollError . newExceptT $ + pure $ + verifyPollAnswer poll tx + + liftIO $ + IO.hPutStrLn stderr $ + "Found valid poll answer with " <> show (length signatories) <> " signatories" + + lift (writeByteStringOutput mOutFile (prettyPrintJSON signatories)) + & onLeft (left . GovernanceCmdWriteFileError) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs index 7650c6e7ea..ccba3d3d27 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Vote.hs @@ -8,7 +8,8 @@ module Cardano.CLI.EraBased.Run.Governance.Vote ( runGovernanceVoteCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -26,7 +27,8 @@ import Data.Aeson.Encode.Pretty import Data.Function import qualified Data.Yaml.Pretty as Yaml -runGovernanceVoteCmds :: () +runGovernanceVoteCmds + :: () => Cmd.GovernanceVoteCmds era -> ExceptT CmdError IO () runGovernanceVoteCmds = \case @@ -37,69 +39,74 @@ runGovernanceVoteCmds = \case runGovernanceVoteViewCmd args & firstExceptT CmdGovernanceVoteError -runGovernanceVoteCreateCmd :: () +runGovernanceVoteCreateCmd + :: () => Cmd.GovernanceVoteCreateCmdArgs era -> ExceptT GovernanceVoteCmdError IO () runGovernanceVoteCreateCmd - Cmd.GovernanceVoteCreateCmdArgs - { eon - , voteChoice - , governanceAction - , votingStakeCredentialSource - , mAnchor - , outFile - } = do - let (govActionTxId, govActionIndex) = governanceAction - let sbe = conwayEraOnwardsToShelleyBasedEra eon -- TODO: Conway era - update vote creation related function to take ConwayEraOnwards - voteProcedure <- case mAnchor of - Nothing -> pure $ createVotingProcedure eon voteChoice Nothing - Just (VoteUrl url, voteHash) -> shelleyBasedEraConstraints sbe $ do - let voteAnchor = L.Anchor { L.anchorUrl = url, L.anchorDataHash = voteHash } - VotingProcedure votingProcedureWithoutAnchor = createVotingProcedure eon voteChoice Nothing - votingProcedureWithAnchor = VotingProcedure $ votingProcedureWithoutAnchor { L.vProcAnchor = L.SJust voteAnchor } - pure votingProcedureWithAnchor - - shelleyBasedEraConstraints sbe $ do - voter <- firstExceptT GovernanceVoteCmdReadVerificationKeyError $ case votingStakeCredentialSource of - AnyDRepVerificationKeyOrHashOrFileOrScriptHash stake -> do - drepCred <- readVerificationKeyOrHashOrFileOrScriptHash AsDRepKey unDRepKeyHash stake - pure $ L.DRepVoter drepCred + Cmd.GovernanceVoteCreateCmdArgs + { eon + , voteChoice + , governanceAction + , votingStakeCredentialSource + , mAnchor + , outFile + } = do + let (govActionTxId, govActionIndex) = governanceAction + let sbe = conwayEraOnwardsToShelleyBasedEra eon -- TODO: Conway era - update vote creation related function to take ConwayEraOnwards + voteProcedure <- case mAnchor of + Nothing -> pure $ createVotingProcedure eon voteChoice Nothing + Just (VoteUrl url, voteHash) -> shelleyBasedEraConstraints sbe $ do + let voteAnchor = L.Anchor{L.anchorUrl = url, L.anchorDataHash = voteHash} + VotingProcedure votingProcedureWithoutAnchor = createVotingProcedure eon voteChoice Nothing + votingProcedureWithAnchor = VotingProcedure $ votingProcedureWithoutAnchor{L.vProcAnchor = L.SJust voteAnchor} + pure votingProcedureWithAnchor - AnyStakePoolVerificationKeyOrHashOrFile stake -> do - StakePoolKeyHash h <- readVerificationKeyOrHashOrTextEnvFile AsStakePoolKey stake - pure $ L.StakePoolVoter h + shelleyBasedEraConstraints sbe $ do + voter <- firstExceptT GovernanceVoteCmdReadVerificationKeyError $ case votingStakeCredentialSource of + AnyDRepVerificationKeyOrHashOrFileOrScriptHash stake -> do + drepCred <- readVerificationKeyOrHashOrFileOrScriptHash AsDRepKey unDRepKeyHash stake + pure $ L.DRepVoter drepCred + AnyStakePoolVerificationKeyOrHashOrFile stake -> do + StakePoolKeyHash h <- readVerificationKeyOrHashOrTextEnvFile AsStakePoolKey stake + pure $ L.StakePoolVoter h + AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash stake -> do + hotCred <- readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeHotKey unCommitteeHotKeyHash stake + pure $ L.CommitteeVoter hotCred - AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash stake -> do - hotCred <- readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeHotKey unCommitteeHotKeyHash stake - pure $ L.CommitteeVoter hotCred + let govActIdentifier = createGovernanceActionId govActionTxId govActionIndex + votingProcedures = singletonVotingProcedures eon voter govActIdentifier (unVotingProcedure voteProcedure) + firstExceptT GovernanceVoteCmdWriteError . newExceptT $ + writeFileTextEnvelope outFile Nothing votingProcedures - let govActIdentifier = createGovernanceActionId govActionTxId govActionIndex - votingProcedures = singletonVotingProcedures eon voter govActIdentifier (unVotingProcedure voteProcedure) - firstExceptT GovernanceVoteCmdWriteError . newExceptT $ writeFileTextEnvelope outFile Nothing votingProcedures - -runGovernanceVoteViewCmd :: () +runGovernanceVoteViewCmd + :: () => Cmd.GovernanceVoteViewCmdArgs era -> ExceptT GovernanceVoteCmdError IO () runGovernanceVoteViewCmd - Cmd.GovernanceVoteViewCmdArgs - { eon - , outFormat - , voteFile - , mOutFile - } = do - let sbe = conwayEraOnwardsToShelleyBasedEra eon + Cmd.GovernanceVoteViewCmdArgs + { eon + , outFormat + , voteFile + , mOutFile + } = do + let sbe = conwayEraOnwardsToShelleyBasedEra eon - shelleyBasedEraConstraints sbe $ do - voteProcedures <- fmap fst . firstExceptT GovernanceVoteCmdReadVoteFileError . newExceptT $ - readSingleVote eon (voteFile, Nothing) - firstExceptT GovernanceVoteCmdWriteError . - newExceptT . - (case outFormat of - ViewOutputFormatYaml -> - writeByteStringOutput mOutFile . Yaml.encodePretty - (Yaml.setConfCompare compare Yaml.defConfig) - ViewOutputFormatJson -> - writeLazyByteStringOutput mOutFile . encodePretty' - (defConfig {confCompare = compare})) . - unVotingProcedures $ - voteProcedures + shelleyBasedEraConstraints sbe $ do + voteProcedures <- + fmap fst . firstExceptT GovernanceVoteCmdReadVoteFileError . newExceptT $ + readSingleVote eon (voteFile, Nothing) + firstExceptT GovernanceVoteCmdWriteError + . newExceptT + . ( case outFormat of + ViewOutputFormatYaml -> + writeByteStringOutput mOutFile + . Yaml.encodePretty + (Yaml.setConfCompare compare Yaml.defConfig) + ViewOutputFormatJson -> + writeLazyByteStringOutput mOutFile + . encodePretty' + (defConfig{confCompare = compare}) + ) + . unVotingProcedures + $ voteProcedures diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Key.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Key.hs index 1daa1452d7..fca88e3f32 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Key.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Key.hs @@ -8,7 +8,6 @@ module Cardano.CLI.EraBased.Run.Key ( runKeyCmds - , runConvertByronGenesisVKeyCmd , runConvertByronKeyCmd , runConvertCardanoAddressKeyCmd @@ -17,7 +16,6 @@ module Cardano.CLI.EraBased.Run.Key , runConvertITNKeyCmd , runNonExtendedKeyCmd , runVerificationKeyCmd - , ccColdSkeyDesc , ccColdVkeyDesc , ccHotSkeyDesc @@ -31,7 +29,8 @@ module Cardano.CLI.EraBased.Run.Key -- * Exports for testing , decodeBech32 - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Byron as ByronApi @@ -104,7 +103,8 @@ paymentVkeyDesc = "Payment Verification Key" stakeVkeyDesc :: TextEnvelopeDescr stakeVkeyDesc = "Stake Verification Key" -runKeyCmds :: () +runKeyCmds + :: () => Cmd.KeyCmds era -> ExceptT KeyCmdError IO () runKeyCmds = \case @@ -125,247 +125,253 @@ runKeyCmds = \case Cmd.KeyConvertCardanoAddressKeyCmd cmd -> runConvertCardanoAddressKeyCmd cmd -runVerificationKeyCmd :: () +runVerificationKeyCmd + :: () => Cmd.KeyVerificationKeyCmdArgs -> ExceptT KeyCmdError IO () runVerificationKeyCmd - Cmd.KeyVerificationKeyCmdArgs + Cmd.KeyVerificationKeyCmdArgs { Cmd.skeyFile = skf , Cmd.vkeyFile = vkf } = do - ssk <- firstExceptT KeyCmdReadKeyFileError $ readSigningKeyFile skf - withSomeSigningKey ssk $ \sk -> - let vk = getVerificationKey sk in - firstExceptT KeyCmdWriteFileError . newExceptT $ - writeLazyByteStringFile vkf $ textEnvelopeToJSON Nothing vk + ssk <- firstExceptT KeyCmdReadKeyFileError $ readSigningKeyFile skf + withSomeSigningKey ssk $ \sk -> + let vk = getVerificationKey sk + in firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile vkf $ + textEnvelopeToJSON Nothing vk runNonExtendedKeyCmd :: Cmd.KeyNonExtendedKeyCmdArgs -> ExceptT KeyCmdError IO () runNonExtendedKeyCmd - Cmd.KeyNonExtendedKeyCmdArgs - { Cmd.extendedVkeyFileIn = evkf - , Cmd.nonExtendedVkeyFileOut = vkf - } = - writeExtendedVerificationKey =<< readExtendedVerificationKeyFile evkf - where - -- TODO: Expose a function specifically for this purpose - -- and explain the extended verification keys can be converted - -- to their non-extended counterparts however this is NOT the case - -- for extended signing keys - - writeExtendedVerificationKey - :: SomeAddressVerificationKey - -> ExceptT KeyCmdError IO () - writeExtendedVerificationKey ssk = - case ssk of - APaymentExtendedVerificationKey vk -> - writeToDisk vkf (Just paymentVkeyDesc) (castVerificationKey vk :: VerificationKey PaymentKey) - ADRepExtendedVerificationKey vk -> - writeToDisk vkf (Just drepVkeyDesc) (castVerificationKey vk :: VerificationKey DRepKey) - ACommitteeColdExtendedVerificationKey vk -> - writeToDisk vkf (Just ccColdVkeyDesc) (castVerificationKey vk :: VerificationKey CommitteeColdKey) - ACommitteeHotExtendedVerificationKey vk -> - writeToDisk vkf (Just ccHotVkeyDesc) (castVerificationKey vk :: VerificationKey CommitteeHotKey) - AStakeExtendedVerificationKey vk -> - writeToDisk vkf (Just stakeVkeyDesc) (castVerificationKey vk :: VerificationKey StakeKey) - AGenesisExtendedVerificationKey vk -> - writeToDisk vkf (Just genesisVkeyDesc) (castVerificationKey vk :: VerificationKey GenesisKey) - AGenesisDelegateExtendedVerificationKey vk -> - writeToDisk vkf (Just genesisVkeyDelegateDesc) (castVerificationKey vk :: VerificationKey GenesisDelegateKey) - -- Non-extended keys are below and cause failure. - vk@AByronVerificationKey {} -> goFail vk - vk@APaymentVerificationKey {} -> goFail vk - vk@AGenesisUTxOVerificationKey {} -> goFail vk - vk@AKesVerificationKey {} -> goFail vk - vk@AVrfVerificationKey {} -> goFail vk - vk@AStakeVerificationKey {} -> goFail vk - vk@ADRepVerificationKey {} -> goFail vk - vk@ACommitteeColdVerificationKey{} -> goFail vk - vk@ACommitteeHotVerificationKey{} -> goFail vk - where + Cmd.KeyNonExtendedKeyCmdArgs + { Cmd.extendedVkeyFileIn = evkf + , Cmd.nonExtendedVkeyFileOut = vkf + } = + writeExtendedVerificationKey =<< readExtendedVerificationKeyFile evkf + where + -- TODO: Expose a function specifically for this purpose + -- and explain the extended verification keys can be converted + -- to their non-extended counterparts however this is NOT the case + -- for extended signing keys + + writeExtendedVerificationKey + :: SomeAddressVerificationKey + -> ExceptT KeyCmdError IO () + writeExtendedVerificationKey ssk = + case ssk of + APaymentExtendedVerificationKey vk -> + writeToDisk vkf (Just paymentVkeyDesc) (castVerificationKey vk :: VerificationKey PaymentKey) + ADRepExtendedVerificationKey vk -> + writeToDisk vkf (Just drepVkeyDesc) (castVerificationKey vk :: VerificationKey DRepKey) + ACommitteeColdExtendedVerificationKey vk -> + writeToDisk vkf (Just ccColdVkeyDesc) (castVerificationKey vk :: VerificationKey CommitteeColdKey) + ACommitteeHotExtendedVerificationKey vk -> + writeToDisk vkf (Just ccHotVkeyDesc) (castVerificationKey vk :: VerificationKey CommitteeHotKey) + AStakeExtendedVerificationKey vk -> + writeToDisk vkf (Just stakeVkeyDesc) (castVerificationKey vk :: VerificationKey StakeKey) + AGenesisExtendedVerificationKey vk -> + writeToDisk vkf (Just genesisVkeyDesc) (castVerificationKey vk :: VerificationKey GenesisKey) + AGenesisDelegateExtendedVerificationKey vk -> + writeToDisk + vkf + (Just genesisVkeyDelegateDesc) + (castVerificationKey vk :: VerificationKey GenesisDelegateKey) + -- Non-extended keys are below and cause failure. + vk@AByronVerificationKey{} -> goFail vk + vk@APaymentVerificationKey{} -> goFail vk + vk@AGenesisUTxOVerificationKey{} -> goFail vk + vk@AKesVerificationKey{} -> goFail vk + vk@AVrfVerificationKey{} -> goFail vk + vk@AStakeVerificationKey{} -> goFail vk + vk@ADRepVerificationKey{} -> goFail vk + vk@ACommitteeColdVerificationKey{} -> goFail vk + vk@ACommitteeHotVerificationKey{} -> goFail vk + where goFail nonExtendedKey = left $ KeyCmdExpectedExtendedVerificationKey nonExtendedKey - - writeToDisk - :: Key keyrole - => File content Out - -> Maybe TextEnvelopeDescr - -> VerificationKey keyrole - -> ExceptT KeyCmdError IO () - writeToDisk vkf' descr vk = - firstExceptT KeyCmdWriteFileError . newExceptT - $ writeLazyByteStringFile vkf' $ textEnvelopeToJSON descr vk - + writeToDisk + :: Key keyrole + => File content Out + -> Maybe TextEnvelopeDescr + -> VerificationKey keyrole + -> ExceptT KeyCmdError IO () + writeToDisk vkf' descr vk = + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile vkf' $ + textEnvelopeToJSON descr vk readExtendedVerificationKeyFile :: VerificationKeyFile In -> ExceptT KeyCmdError IO SomeAddressVerificationKey readExtendedVerificationKeyFile evkfile = do - vKey <- firstExceptT KeyCmdVerificationKeyReadError - . newExceptT $ readVerificationKeyTextOrFileAnyOf - $ VktofVerificationKeyFile evkfile + vKey <- + firstExceptT KeyCmdVerificationKeyReadError + . newExceptT + $ readVerificationKeyTextOrFileAnyOf + $ VktofVerificationKeyFile evkfile case vKey of - k@APaymentExtendedVerificationKey{} -> return k - k@ADRepExtendedVerificationKey{} -> return k - k@ACommitteeColdExtendedVerificationKey{} -> return k - k@ACommitteeHotExtendedVerificationKey{} -> return k - k@AStakeExtendedVerificationKey{} -> return k - k@AGenesisExtendedVerificationKey{} -> return k - k@AGenesisDelegateExtendedVerificationKey{} -> return k - -- Non-extended keys are below and cause failure. - k@AByronVerificationKey{} -> goFail k - k@APaymentVerificationKey{} -> goFail k - k@AGenesisUTxOVerificationKey{} -> goFail k - k@AKesVerificationKey{} -> goFail k - k@AVrfVerificationKey{} -> goFail k - k@AStakeVerificationKey{} -> goFail k - k@ADRepVerificationKey{} -> goFail k - k@ACommitteeColdVerificationKey{} -> goFail k - k@ACommitteeHotVerificationKey{} -> goFail k - where - goFail k = left $ KeyCmdExpectedExtendedVerificationKey k - + k@APaymentExtendedVerificationKey{} -> return k + k@ADRepExtendedVerificationKey{} -> return k + k@ACommitteeColdExtendedVerificationKey{} -> return k + k@ACommitteeHotExtendedVerificationKey{} -> return k + k@AStakeExtendedVerificationKey{} -> return k + k@AGenesisExtendedVerificationKey{} -> return k + k@AGenesisDelegateExtendedVerificationKey{} -> return k + -- Non-extended keys are below and cause failure. + k@AByronVerificationKey{} -> goFail k + k@APaymentVerificationKey{} -> goFail k + k@AGenesisUTxOVerificationKey{} -> goFail k + k@AKesVerificationKey{} -> goFail k + k@AVrfVerificationKey{} -> goFail k + k@AStakeVerificationKey{} -> goFail k + k@ADRepVerificationKey{} -> goFail k + k@ACommitteeColdVerificationKey{} -> goFail k + k@ACommitteeHotVerificationKey{} -> goFail k + where + goFail k = left $ KeyCmdExpectedExtendedVerificationKey k runConvertByronKeyCmd :: Cmd.KeyConvertByronKeyCmdArgs -> ExceptT KeyCmdError IO () runConvertByronKeyCmd - Cmd.KeyConvertByronKeyCmdArgs - { Cmd.mPassword = mPwd - , Cmd.byronKeyType - , Cmd.someKeyFileIn = inFile - , Cmd.someKeyFileOut = outFile - } = - case (byronKeyType, inFile) of - (ByronPaymentKey format, ASigningKeyFile skeyPathOld) -> - convertByronSigningKey mPwd format convert skeyPathOld outFile - where + Cmd.KeyConvertByronKeyCmdArgs + { Cmd.mPassword = mPwd + , Cmd.byronKeyType + , Cmd.someKeyFileIn = inFile + , Cmd.someKeyFileOut = outFile + } = + case (byronKeyType, inFile) of + (ByronPaymentKey format, ASigningKeyFile skeyPathOld) -> + convertByronSigningKey mPwd format convert skeyPathOld outFile + where convert :: Byron.SigningKey -> SigningKey ByronKey convert = ByronSigningKey - - (ByronGenesisKey format, ASigningKeyFile skeyPathOld) -> - convertByronSigningKey mPwd format convert skeyPathOld outFile - where + (ByronGenesisKey format, ASigningKeyFile skeyPathOld) -> + convertByronSigningKey mPwd format convert skeyPathOld outFile + where convert :: Byron.SigningKey -> SigningKey GenesisExtendedKey convert (Byron.SigningKey xsk) = GenesisExtendedSigningKey xsk - - (ByronDelegateKey format, ASigningKeyFile skeyPathOld) -> - convertByronSigningKey mPwd format convert skeyPathOld outFile - where + (ByronDelegateKey format, ASigningKeyFile skeyPathOld) -> + convertByronSigningKey mPwd format convert skeyPathOld outFile + where convert :: Byron.SigningKey -> SigningKey GenesisDelegateExtendedKey convert (Byron.SigningKey xsk) = GenesisDelegateExtendedSigningKey xsk - - (ByronPaymentKey NonLegacyByronKeyFormat, AVerificationKeyFile vkeyPathOld) -> - convertByronVerificationKey convert vkeyPathOld outFile - where + (ByronPaymentKey NonLegacyByronKeyFormat, AVerificationKeyFile vkeyPathOld) -> + convertByronVerificationKey convert vkeyPathOld outFile + where convert :: Byron.VerificationKey -> VerificationKey ByronKey convert = ByronVerificationKey - - (ByronGenesisKey NonLegacyByronKeyFormat, AVerificationKeyFile vkeyPathOld) -> - convertByronVerificationKey convert vkeyPathOld outFile - where + (ByronGenesisKey NonLegacyByronKeyFormat, AVerificationKeyFile vkeyPathOld) -> + convertByronVerificationKey convert vkeyPathOld outFile + where convert :: Byron.VerificationKey -> VerificationKey GenesisExtendedKey convert (Byron.VerificationKey xvk) = GenesisExtendedVerificationKey xvk - - (ByronDelegateKey NonLegacyByronKeyFormat, AVerificationKeyFile vkeyPathOld) -> - convertByronVerificationKey convert vkeyPathOld outFile - where + (ByronDelegateKey NonLegacyByronKeyFormat, AVerificationKeyFile vkeyPathOld) -> + convertByronVerificationKey convert vkeyPathOld outFile + where convert :: Byron.VerificationKey -> VerificationKey GenesisDelegateExtendedKey convert (Byron.VerificationKey xvk) = GenesisDelegateExtendedVerificationKey xvk - - (ByronPaymentKey LegacyByronKeyFormat, AVerificationKeyFile{}) -> - legacyVerificationKeysNotSupported - - (ByronGenesisKey LegacyByronKeyFormat, AVerificationKeyFile{}) -> - legacyVerificationKeysNotSupported - - (ByronDelegateKey LegacyByronKeyFormat, AVerificationKeyFile{}) -> - legacyVerificationKeysNotSupported + (ByronPaymentKey LegacyByronKeyFormat, AVerificationKeyFile{}) -> + legacyVerificationKeysNotSupported + (ByronGenesisKey LegacyByronKeyFormat, AVerificationKeyFile{}) -> + legacyVerificationKeysNotSupported + (ByronDelegateKey LegacyByronKeyFormat, AVerificationKeyFile{}) -> + legacyVerificationKeysNotSupported legacyVerificationKeysNotSupported :: ExceptT e IO a legacyVerificationKeysNotSupported = - liftIO $ do - putStrLn $ "convert keys: byron legacy format not supported for " - ++ "verification keys. Convert the signing key and then get the " - ++ "verification key." - exitFailure + liftIO $ do + putStrLn $ + "convert keys: byron legacy format not supported for " + ++ "verification keys. Convert the signing key and then get the " + ++ "verification key." + exitFailure convertByronSigningKey - :: forall keyrole. - Key keyrole - => Maybe Text -- ^ Password (if applicable) + :: forall keyrole + . Key keyrole + => Maybe Text + -- ^ Password (if applicable) -> ByronKeyFormat -> (Byron.SigningKey -> SigningKey keyrole) - -> SigningKeyFile In -- ^ Input file: old format - -> File () Out -- ^ Output file: new format + -> SigningKeyFile In + -- ^ Input file: old format + -> File () Out + -- ^ Output file: new format -> ExceptT KeyCmdError IO () convertByronSigningKey mPwd byronFormat convert skeyPathOld skeyPathNew = do - sKey <- firstExceptT KeyCmdByronKeyFailure - $ Byron.readByronSigningKey byronFormat skeyPathOld - - -- Account for password protected legacy Byron keys - unprotectedSk <- case sKey of - ByronApi.AByronSigningKeyLegacy (ByronSigningKeyLegacy sk@(Crypto.SigningKey xprv)) -> - case mPwd of - -- Change password to empty string - Just pwd -> return . Crypto.SigningKey - $ Crypto.xPrvChangePass (Text.encodeUtf8 pwd) (Text.encodeUtf8 "") xprv - Nothing -> return sk - ByronApi.AByronSigningKey (ByronSigningKey sk) -> return sk - + sKey <- + firstExceptT KeyCmdByronKeyFailure $ + Byron.readByronSigningKey byronFormat skeyPathOld + + -- Account for password protected legacy Byron keys + unprotectedSk <- case sKey of + ByronApi.AByronSigningKeyLegacy (ByronSigningKeyLegacy sk@(Crypto.SigningKey xprv)) -> + case mPwd of + -- Change password to empty string + Just pwd -> + return . Crypto.SigningKey $ + Crypto.xPrvChangePass (Text.encodeUtf8 pwd) (Text.encodeUtf8 "") xprv + Nothing -> return sk + ByronApi.AByronSigningKey (ByronSigningKey sk) -> return sk + + let sk' :: SigningKey keyrole + sk' = convert unprotectedSk - let sk' :: SigningKey keyrole - sk' = convert unprotectedSk - - firstExceptT KeyCmdWriteFileError . newExceptT $ - writeLazyByteStringFile skeyPathNew $ textEnvelopeToJSON Nothing sk' + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile skeyPathNew $ + textEnvelopeToJSON Nothing sk' convertByronVerificationKey - :: forall keyrole. - Key keyrole + :: forall keyrole + . Key keyrole => (Byron.VerificationKey -> VerificationKey keyrole) - -> VerificationKeyFile In -- ^ Input file: old format - -> File () Out -- ^ Output file: new format + -> VerificationKeyFile In + -- ^ Input file: old format + -> File () Out + -- ^ Output file: new format -> ExceptT KeyCmdError IO () convertByronVerificationKey convert vkeyPathOld vkeyPathNew = do + vk <- + firstExceptT KeyCmdByronKeyFailure $ + Byron.readPaymentVerificationKey vkeyPathOld - vk <- firstExceptT KeyCmdByronKeyFailure $ - Byron.readPaymentVerificationKey vkeyPathOld - - let vk' :: VerificationKey keyrole - vk' = convert vk - - firstExceptT KeyCmdWriteFileError . newExceptT $ - writeLazyByteStringFile vkeyPathNew $ textEnvelopeToJSON Nothing vk' + let vk' :: VerificationKey keyrole + vk' = convert vk + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile vkeyPathNew $ + textEnvelopeToJSON Nothing vk' runConvertByronGenesisVKeyCmd :: Cmd.KeyConvertByronGenesisVKeyCmdArgs -> ExceptT KeyCmdError IO () runConvertByronGenesisVKeyCmd - Cmd.KeyConvertByronGenesisVKeyCmdArgs - { Cmd.vkey = VerificationKeyBase64 b64ByronVKey - , Cmd.vkeyFileOut = vkeyPathNew - } = do - vk <- firstExceptT (KeyCmdByronKeyParseError . textShow) - . hoistEither - . Byron.Crypto.parseFullVerificationKey - . Text.pack - $ b64ByronVKey - - let vk' :: VerificationKey GenesisKey - vk' = convert vk + Cmd.KeyConvertByronGenesisVKeyCmdArgs + { Cmd.vkey = VerificationKeyBase64 b64ByronVKey + , Cmd.vkeyFileOut = vkeyPathNew + } = do + vk <- + firstExceptT (KeyCmdByronKeyParseError . textShow) + . hoistEither + . Byron.Crypto.parseFullVerificationKey + . Text.pack + $ b64ByronVKey + + let vk' :: VerificationKey GenesisKey + vk' = convert vk - firstExceptT KeyCmdWriteFileError . newExceptT $ - writeLazyByteStringFile vkeyPathNew $ textEnvelopeToJSON Nothing vk' - where + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile vkeyPathNew $ + textEnvelopeToJSON Nothing vk' + where convert :: Byron.VerificationKey -> VerificationKey GenesisKey convert (Byron.VerificationKey xvk) = castVerificationKey (GenesisExtendedVerificationKey xvk) - -------------------------------------------------------------------------------- -- ITN verification/signing key conversion to Haskell verficiation/signing keys -------------------------------------------------------------------------------- @@ -374,71 +380,77 @@ runConvertITNKeyCmd :: Cmd.KeyConvertITNKeyCmdArgs -> ExceptT KeyCmdError IO () runConvertITNKeyCmd - Cmd.KeyConvertITNKeyCmdArgs - { Cmd.itnKeyFile - , Cmd.outFile - } = - case itnKeyFile of - AVerificationKeyFile (File vk) -> do - bech32publicKey <- firstExceptT KeyCmdItnKeyConvError . newExceptT $ - readFileITNKey vk - vkey <- hoistEither - . first KeyCmdItnKeyConvError - $ convertITNVerificationKey bech32publicKey - firstExceptT KeyCmdWriteFileError . newExceptT $ - writeLazyByteStringFile outFile $ textEnvelopeToJSON Nothing vkey - - ASigningKeyFile (File sk) -> do - bech32privateKey <- firstExceptT KeyCmdItnKeyConvError . newExceptT $ - readFileITNKey sk - skey <- hoistEither - . first KeyCmdItnKeyConvError - $ convertITNSigningKey bech32privateKey - firstExceptT KeyCmdWriteFileError . newExceptT - $ writeLazyByteStringFile outFile - $ textEnvelopeToJSON Nothing skey - -runConvertITNExtendedKeyCmd :: () + Cmd.KeyConvertITNKeyCmdArgs + { Cmd.itnKeyFile + , Cmd.outFile + } = + case itnKeyFile of + AVerificationKeyFile (File vk) -> do + bech32publicKey <- + firstExceptT KeyCmdItnKeyConvError . newExceptT $ + readFileITNKey vk + vkey <- + hoistEither + . first KeyCmdItnKeyConvError + $ convertITNVerificationKey bech32publicKey + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile outFile $ + textEnvelopeToJSON Nothing vkey + ASigningKeyFile (File sk) -> do + bech32privateKey <- + firstExceptT KeyCmdItnKeyConvError . newExceptT $ + readFileITNKey sk + skey <- + hoistEither + . first KeyCmdItnKeyConvError + $ convertITNSigningKey bech32privateKey + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile outFile $ + textEnvelopeToJSON Nothing skey + +runConvertITNExtendedKeyCmd + :: () => Cmd.KeyConvertITNExtendedKeyCmdArgs -> ExceptT KeyCmdError IO () runConvertITNExtendedKeyCmd - Cmd.KeyConvertITNExtendedKeyCmdArgs - { Cmd.itnPrivKeyFile - , Cmd.outFile - } = - case itnPrivKeyFile of - AVerificationKeyFile _ -> - left KeyCmdWrongKeyTypeError - ASigningKeyFile (File sk) -> do - bech32privateKey <- firstExceptT KeyCmdItnKeyConvError . newExceptT $ readFileITNKey sk - skey <- - convertITNExtendedSigningKey bech32privateKey - & first KeyCmdItnKeyConvError - & hoistEither - firstExceptT KeyCmdWriteFileError . newExceptT - $ writeLazyByteStringFile outFile - $ textEnvelopeToJSON Nothing skey - -runConvertITNBip32KeyCmd :: () + Cmd.KeyConvertITNExtendedKeyCmdArgs + { Cmd.itnPrivKeyFile + , Cmd.outFile + } = + case itnPrivKeyFile of + AVerificationKeyFile _ -> + left KeyCmdWrongKeyTypeError + ASigningKeyFile (File sk) -> do + bech32privateKey <- firstExceptT KeyCmdItnKeyConvError . newExceptT $ readFileITNKey sk + skey <- + convertITNExtendedSigningKey bech32privateKey + & first KeyCmdItnKeyConvError + & hoistEither + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile outFile $ + textEnvelopeToJSON Nothing skey + +runConvertITNBip32KeyCmd + :: () => Cmd.KeyConvertITNBip32KeyCmdArgs -> ExceptT KeyCmdError IO () runConvertITNBip32KeyCmd - Cmd.KeyConvertITNBip32KeyCmdArgs - { Cmd.itnPrivKeyFile - , Cmd.outFile - } = - case itnPrivKeyFile of - AVerificationKeyFile _ -> - left KeyCmdWrongKeyTypeError - ASigningKeyFile (File sk) -> do - bech32privateKey <- firstExceptT KeyCmdItnKeyConvError . newExceptT $ readFileITNKey sk - skey <- - convertITNBIP32SigningKey bech32privateKey - & first KeyCmdItnKeyConvError - & hoistEither - firstExceptT KeyCmdWriteFileError . newExceptT - $ writeLazyByteStringFile outFile - $ textEnvelopeToJSON Nothing skey + Cmd.KeyConvertITNBip32KeyCmdArgs + { Cmd.itnPrivKeyFile + , Cmd.outFile + } = + case itnPrivKeyFile of + AVerificationKeyFile _ -> + left KeyCmdWrongKeyTypeError + ASigningKeyFile (File sk) -> do + bech32privateKey <- firstExceptT KeyCmdItnKeyConvError . newExceptT $ readFileITNKey sk + skey <- + convertITNBIP32SigningKey bech32privateKey + & first KeyCmdItnKeyConvError + & hoistEither + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeLazyByteStringFile outFile $ + textEnvelopeToJSON Nothing skey -- | Convert public ed25519 key to a Shelley stake verification key convertITNVerificationKey :: Text -> Either ItnKeyConversionError (VerificationKey StakeKey) @@ -487,30 +499,32 @@ readFileITNKey fp = do -- `cardano-address` extended signing key conversions -------------------------------------------------------------------------------- -runConvertCardanoAddressKeyCmd :: () +runConvertCardanoAddressKeyCmd + :: () => Cmd.KeyConvertCardanoAddressKeyCmdArgs -> ExceptT KeyCmdError IO () runConvertCardanoAddressKeyCmd - Cmd.KeyConvertCardanoAddressKeyCmdArgs - { cardanoAddressKeyType = keyType - , skeyFileIn = skFile - , skeyFileOut = outFile - } = do - sKey <- firstExceptT KeyCmdCardanoAddressSigningKeyFileError - . newExceptT - $ readSomeCardanoAddressSigningKeyFile keyType skFile - firstExceptT KeyCmdWriteFileError . newExceptT - $ writeSomeCardanoAddressSigningKeyFile outFile sKey + Cmd.KeyConvertCardanoAddressKeyCmdArgs + { cardanoAddressKeyType = keyType + , skeyFileIn = skFile + , skeyFileOut = outFile + } = do + sKey <- + firstExceptT KeyCmdCardanoAddressSigningKeyFileError + . newExceptT + $ readSomeCardanoAddressSigningKeyFile keyType skFile + firstExceptT KeyCmdWriteFileError . newExceptT $ + writeSomeCardanoAddressSigningKeyFile outFile sKey -- | Some kind of signing key that was converted from a @cardano-address@ -- signing key. data SomeCardanoAddressSigningKey = ACardanoAddrShelleyPaymentSigningKey !(SigningKey PaymentExtendedKey) - | ACardanoAddrShelleyStakeSigningKey !(SigningKey StakeExtendedKey) - | ACardanoAddrByronSigningKey !(SigningKey ByronKey) + | ACardanoAddrShelleyStakeSigningKey !(SigningKey StakeExtendedKey) + | ACardanoAddrByronSigningKey !(SigningKey ByronKey) | ACardanoAddrCommitteeColdKey !(SigningKey CommitteeColdExtendedKey) - | ACardanoAddrCommitteeHotKey !(SigningKey CommitteeHotExtendedKey) - | ACardanoAddrDRepKey !(SigningKey DRepExtendedKey) + | ACardanoAddrCommitteeHotKey !(SigningKey CommitteeHotExtendedKey) + | ACardanoAddrDRepKey !(SigningKey DRepExtendedKey) -- | Decode a Bech32-encoded string. decodeBech32 @@ -550,8 +564,9 @@ readBech32Bip32SigningKeyFile (File fp) = do Right str -> case decodeBech32 (Text.concat $ Text.words $ Text.pack str) of Left err -> - pure $ Left $ - FileError fp (CardanoAddressSigningKeyBech32DecodeError err) + pure $ + Left $ + FileError fp (CardanoAddressSigningKeyBech32DecodeError err) Right (_hrPart, _dataPart, bs) -> pure $ first (FileError fp) (convertBip32SigningKey bs) @@ -562,19 +577,19 @@ readSomeCardanoAddressSigningKeyFile -> SigningKeyFile In -> IO (Either (FileError CardanoAddressSigningKeyConversionError) SomeCardanoAddressSigningKey) readSomeCardanoAddressSigningKeyFile keyType skFile = do - xPrv <- readBech32Bip32SigningKeyFile skFile - pure (toSomeCardanoAddressSigningKey <$> xPrv) - where - toSomeCardanoAddressSigningKey :: Crypto.XPrv -> SomeCardanoAddressSigningKey - toSomeCardanoAddressSigningKey xPrv = - case keyType of - CardanoAddressShelleyPaymentKey -> ACardanoAddrShelleyPaymentSigningKey (PaymentExtendedSigningKey xPrv) - CardanoAddressShelleyStakeKey -> ACardanoAddrShelleyStakeSigningKey (StakeExtendedSigningKey xPrv) - CardanoAddressIcarusPaymentKey -> ACardanoAddrByronSigningKey $ ByronSigningKey (Byron.SigningKey xPrv) - CardanoAddressByronPaymentKey -> ACardanoAddrByronSigningKey $ ByronSigningKey (Byron.SigningKey xPrv) - CardanoAddressCommitteeColdKey -> ACardanoAddrCommitteeColdKey (CommitteeColdExtendedSigningKey xPrv) - CardanoAddressCommitteeHotKey -> ACardanoAddrCommitteeHotKey (CommitteeHotExtendedSigningKey xPrv) - CardanoAddressDRepKey -> ACardanoAddrDRepKey (DRepExtendedSigningKey xPrv) + xPrv <- readBech32Bip32SigningKeyFile skFile + pure (toSomeCardanoAddressSigningKey <$> xPrv) + where + toSomeCardanoAddressSigningKey :: Crypto.XPrv -> SomeCardanoAddressSigningKey + toSomeCardanoAddressSigningKey xPrv = + case keyType of + CardanoAddressShelleyPaymentKey -> ACardanoAddrShelleyPaymentSigningKey (PaymentExtendedSigningKey xPrv) + CardanoAddressShelleyStakeKey -> ACardanoAddrShelleyStakeSigningKey (StakeExtendedSigningKey xPrv) + CardanoAddressIcarusPaymentKey -> ACardanoAddrByronSigningKey $ ByronSigningKey (Byron.SigningKey xPrv) + CardanoAddressByronPaymentKey -> ACardanoAddrByronSigningKey $ ByronSigningKey (Byron.SigningKey xPrv) + CardanoAddressCommitteeColdKey -> ACardanoAddrCommitteeColdKey (CommitteeColdExtendedSigningKey xPrv) + CardanoAddressCommitteeHotKey -> ACardanoAddrCommitteeHotKey (CommitteeHotExtendedSigningKey xPrv) + CardanoAddressDRepKey -> ACardanoAddrDRepKey (DRepExtendedSigningKey xPrv) -- | Write a text envelope formatted file containing a @cardano-address@ -- extended signing key, but converted to a format supported by @cardano-cli@. @@ -585,10 +600,10 @@ writeSomeCardanoAddressSigningKeyFile writeSomeCardanoAddressSigningKeyFile outFile = \case ACardanoAddrShelleyPaymentSigningKey sk -> go Nothing sk - ACardanoAddrShelleyStakeSigningKey sk -> go Nothing sk - ACardanoAddrByronSigningKey sk -> go Nothing sk - ACardanoAddrCommitteeColdKey sk -> go (Just ccColdExtendedSkeyDesc) sk - ACardanoAddrCommitteeHotKey sk -> go (Just ccHotExtendedSkeyDesc) sk - ACardanoAddrDRepKey sk -> go (Just drepExtendedSkeyDesc) sk - where - go envelope sk = writeLazyByteStringFile outFile $ textEnvelopeToJSON envelope sk + ACardanoAddrShelleyStakeSigningKey sk -> go Nothing sk + ACardanoAddrByronSigningKey sk -> go Nothing sk + ACardanoAddrCommitteeColdKey sk -> go (Just ccColdExtendedSkeyDesc) sk + ACardanoAddrCommitteeHotKey sk -> go (Just ccHotExtendedSkeyDesc) sk + ACardanoAddrDRepKey sk -> go (Just drepExtendedSkeyDesc) sk + where + go envelope sk = writeLazyByteStringFile outFile $ textEnvelopeToJSON envelope sk diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Node.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Node.hs index eaf82926b4..d0c1d947db 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Node.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Node.hs @@ -5,14 +5,14 @@ module Cardano.CLI.EraBased.Run.Node ( runNodeCmds - , runNodeIssueOpCertCmd , runNodeKeyGenColdCmd , runNodeKeyGenKesCmd , runNodeKeyGenVrfCmd , runNodeKeyHashVrfCmd , runNodeNewCounterCmd - ) where + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -28,61 +28,62 @@ import Data.Word (Word64) {- HLINT ignore "Reduce duplication" -} -runNodeCmds :: () +runNodeCmds + :: () => Cmd.NodeCmds era -> ExceptT NodeCmdError IO () runNodeCmds = \case - Cmd.NodeKeyGenColdCmd args -> runNodeKeyGenColdCmd args - Cmd.NodeKeyGenKESCmd args -> runNodeKeyGenKesCmd args - Cmd.NodeKeyGenVRFCmd args -> runNodeKeyGenVrfCmd args - Cmd.NodeKeyHashVRFCmd args -> runNodeKeyHashVrfCmd args - Cmd.NodeNewCounterCmd args -> runNodeNewCounterCmd args - Cmd.NodeIssueOpCertCmd args -> runNodeIssueOpCertCmd args - -runNodeKeyGenColdCmd :: () + Cmd.NodeKeyGenColdCmd args -> runNodeKeyGenColdCmd args + Cmd.NodeKeyGenKESCmd args -> runNodeKeyGenKesCmd args + Cmd.NodeKeyGenVRFCmd args -> runNodeKeyGenVrfCmd args + Cmd.NodeKeyHashVRFCmd args -> runNodeKeyHashVrfCmd args + Cmd.NodeNewCounterCmd args -> runNodeNewCounterCmd args + Cmd.NodeIssueOpCertCmd args -> runNodeIssueOpCertCmd args + +runNodeKeyGenColdCmd + :: () => Cmd.NodeKeyGenColdCmdArgs -> ExceptT NodeCmdError IO () runNodeKeyGenColdCmd - Cmd.NodeKeyGenColdCmdArgs - { keyOutputFormat - , vkeyFile - , skeyFile - , operationalCertificateIssueCounter - } = do - skey <- generateSigningKey AsStakePoolKey - let vkey = getVerificationKey skey - - case keyOutputFormat of - KeyOutputFormatTextEnvelope -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile skeyFile - $ textEnvelopeToJSON (Just skeyDesc) skey - KeyOutputFormatBech32 -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeTextFile skeyFile - $ serialiseToBech32 skey - - case keyOutputFormat of - KeyOutputFormatTextEnvelope -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile vkeyFile - $ textEnvelopeToJSON (Just vkeyDesc) vkey - KeyOutputFormatBech32 -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeTextFile vkeyFile - $ serialiseToBech32 vkey - - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile operationalCertificateIssueCounter - $ textEnvelopeToJSON (Just ocertCtrDesc) - $ OperationalCertificateIssueCounter initialCounter vkey - - where + Cmd.NodeKeyGenColdCmdArgs + { keyOutputFormat + , vkeyFile + , skeyFile + , operationalCertificateIssueCounter + } = do + skey <- generateSigningKey AsStakePoolKey + let vkey = getVerificationKey skey + + case keyOutputFormat of + KeyOutputFormatTextEnvelope -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile skeyFile + $ textEnvelopeToJSON (Just skeyDesc) skey + KeyOutputFormatBech32 -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeTextFile skeyFile + $ serialiseToBech32 skey + + case keyOutputFormat of + KeyOutputFormatTextEnvelope -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile vkeyFile + $ textEnvelopeToJSON (Just vkeyDesc) vkey + KeyOutputFormatBech32 -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeTextFile vkeyFile + $ serialiseToBech32 vkey + + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile operationalCertificateIssueCounter + $ textEnvelopeToJSON (Just ocertCtrDesc) + $ OperationalCertificateIssueCounter initialCounter vkey + where skeyDesc :: TextEnvelopeDescr skeyDesc = "Stake Pool Operator Signing Key" @@ -90,181 +91,189 @@ runNodeKeyGenColdCmd vkeyDesc = "Stake Pool Operator Verification Key" ocertCtrDesc :: TextEnvelopeDescr - ocertCtrDesc = "Next certificate issue number: " - <> fromString (show initialCounter) + ocertCtrDesc = + "Next certificate issue number: " + <> fromString (show initialCounter) initialCounter :: Word64 initialCounter = 0 - -runNodeKeyGenKesCmd :: () +runNodeKeyGenKesCmd + :: () => Cmd.NodeKeyGenKESCmdArgs -> ExceptT NodeCmdError IO () runNodeKeyGenKesCmd - Cmd.NodeKeyGenKESCmdArgs - { keyOutputFormat - , vkeyFile - , skeyFile - } = do - skey <- generateSigningKey AsKesKey - - let vkey = getVerificationKey skey - - case keyOutputFormat of - KeyOutputFormatTextEnvelope -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFileWithOwnerPermissions skeyFile - $ textEnvelopeToJSON (Just skeyDesc) skey - KeyOutputFormatBech32 -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeTextFile skeyFile - $ serialiseToBech32 skey - - case keyOutputFormat of - KeyOutputFormatTextEnvelope -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile vkeyFile - $ textEnvelopeToJSON (Just vkeyDesc) vkey - KeyOutputFormatBech32 -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeTextFile vkeyFile - $ serialiseToBech32 vkey - - where + Cmd.NodeKeyGenKESCmdArgs + { keyOutputFormat + , vkeyFile + , skeyFile + } = do + skey <- generateSigningKey AsKesKey + + let vkey = getVerificationKey skey + + case keyOutputFormat of + KeyOutputFormatTextEnvelope -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFileWithOwnerPermissions skeyFile + $ textEnvelopeToJSON (Just skeyDesc) skey + KeyOutputFormatBech32 -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeTextFile skeyFile + $ serialiseToBech32 skey + + case keyOutputFormat of + KeyOutputFormatTextEnvelope -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile vkeyFile + $ textEnvelopeToJSON (Just vkeyDesc) vkey + KeyOutputFormatBech32 -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeTextFile vkeyFile + $ serialiseToBech32 vkey + where skeyDesc :: TextEnvelopeDescr skeyDesc = "KES Signing Key" vkeyDesc :: TextEnvelopeDescr vkeyDesc = "KES Verification Key" -runNodeKeyGenVrfCmd :: () +runNodeKeyGenVrfCmd + :: () => Cmd.NodeKeyGenVRFCmdArgs -> ExceptT NodeCmdError IO () runNodeKeyGenVrfCmd - Cmd.NodeKeyGenVRFCmdArgs - { keyOutputFormat - , vkeyFile - , skeyFile - } = do - skey <- generateSigningKey AsVrfKey - - let vkey = getVerificationKey skey - - case keyOutputFormat of - KeyOutputFormatTextEnvelope -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFileWithOwnerPermissions skeyFile - $ textEnvelopeToJSON (Just skeyDesc) skey - KeyOutputFormatBech32 -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeTextFile skeyFile - $ serialiseToBech32 skey - - case keyOutputFormat of - KeyOutputFormatTextEnvelope -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile vkeyFile - $ textEnvelopeToJSON (Just vkeyDesc) vkey - KeyOutputFormatBech32 -> - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeTextFile vkeyFile - $ serialiseToBech32 vkey - where + Cmd.NodeKeyGenVRFCmdArgs + { keyOutputFormat + , vkeyFile + , skeyFile + } = do + skey <- generateSigningKey AsVrfKey + + let vkey = getVerificationKey skey + + case keyOutputFormat of + KeyOutputFormatTextEnvelope -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFileWithOwnerPermissions skeyFile + $ textEnvelopeToJSON (Just skeyDesc) skey + KeyOutputFormatBech32 -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeTextFile skeyFile + $ serialiseToBech32 skey + + case keyOutputFormat of + KeyOutputFormatTextEnvelope -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile vkeyFile + $ textEnvelopeToJSON (Just vkeyDesc) vkey + KeyOutputFormatBech32 -> + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeTextFile vkeyFile + $ serialiseToBech32 vkey + where skeyDesc, vkeyDesc :: TextEnvelopeDescr skeyDesc = "VRF Signing Key" vkeyDesc = "VRF Verification Key" -runNodeKeyHashVrfCmd :: () +runNodeKeyHashVrfCmd + :: () => Cmd.NodeKeyHashVRFCmdArgs -> ExceptT NodeCmdError IO () runNodeKeyHashVrfCmd - Cmd.NodeKeyHashVRFCmdArgs - { vkeySource - , mOutFile - } = do - vkey <- firstExceptT NodeCmdReadKeyFileError - $ readVerificationKeyOrFile AsVrfKey vkeySource + Cmd.NodeKeyHashVRFCmdArgs + { vkeySource + , mOutFile + } = do + vkey <- + firstExceptT NodeCmdReadKeyFileError $ + readVerificationKeyOrFile AsVrfKey vkeySource - let hexKeyHash = serialiseToRawBytesHex (verificationKeyHash vkey) + let hexKeyHash = serialiseToRawBytesHex (verificationKeyHash vkey) - case mOutFile of - Just fpath -> liftIO $ BS.writeFile (unFile fpath) hexKeyHash - Nothing -> liftIO $ BS.putStrLn hexKeyHash + case mOutFile of + Just fpath -> liftIO $ BS.writeFile (unFile fpath) hexKeyHash + Nothing -> liftIO $ BS.putStrLn hexKeyHash -runNodeNewCounterCmd :: () +runNodeNewCounterCmd + :: () => Cmd.NodeNewCounterCmdArgs -> ExceptT NodeCmdError IO () runNodeNewCounterCmd - Cmd.NodeNewCounterCmdArgs - { coldVkeyFile - , counter - , mOutFile - } = do - vkey <- firstExceptT NodeCmdReadFileError . newExceptT $ - readColdVerificationKeyOrFile coldVkeyFile - - let ocertIssueCounter = - OperationalCertificateIssueCounter (fromIntegral counter) vkey - - firstExceptT NodeCmdWriteFileError . newExceptT - $ writeLazyByteStringFile (onlyOut mOutFile) - $ textEnvelopeToJSON Nothing ocertIssueCounter - -runNodeIssueOpCertCmd :: () + Cmd.NodeNewCounterCmdArgs + { coldVkeyFile + , counter + , mOutFile + } = do + vkey <- + firstExceptT NodeCmdReadFileError . newExceptT $ + readColdVerificationKeyOrFile coldVkeyFile + + let ocertIssueCounter = + OperationalCertificateIssueCounter (fromIntegral counter) vkey + + firstExceptT NodeCmdWriteFileError . newExceptT $ + writeLazyByteStringFile (onlyOut mOutFile) $ + textEnvelopeToJSON Nothing ocertIssueCounter + +runNodeIssueOpCertCmd + :: () => Cmd.NodeIssueOpCertCmdArgs -> ExceptT NodeCmdError IO () runNodeIssueOpCertCmd - Cmd.NodeIssueOpCertCmdArgs - { kesVkeySource - , poolSkeyFile - , operationalCertificateCounterFile - , kesPeriod - , outFile - } = do - ocertIssueCounter <- firstExceptT NodeCmdReadFileError - . newExceptT - $ readFileTextEnvelope AsOperationalCertificateIssueCounter (onlyIn operationalCertificateCounterFile) - - verKeyKes <- firstExceptT NodeCmdReadKeyFileError - $ readVerificationKeyOrFile AsKesKey kesVkeySource - - signKey <- firstExceptT NodeCmdReadKeyFileError - . newExceptT - $ readKeyFileAnyOf - bech32PossibleBlockIssuers - textEnvPossibleBlockIssuers - poolSkeyFile - - (ocert, nextOcertCtr) <- - firstExceptT NodeCmdOperationalCertificateIssueError - . hoistEither - $ issueOperationalCertificate + Cmd.NodeIssueOpCertCmdArgs + { kesVkeySource + , poolSkeyFile + , operationalCertificateCounterFile + , kesPeriod + , outFile + } = do + ocertIssueCounter <- + firstExceptT NodeCmdReadFileError + . newExceptT + $ readFileTextEnvelope AsOperationalCertificateIssueCounter (onlyIn operationalCertificateCounterFile) + + verKeyKes <- + firstExceptT NodeCmdReadKeyFileError $ + readVerificationKeyOrFile AsKesKey kesVkeySource + + signKey <- + firstExceptT NodeCmdReadKeyFileError + . newExceptT + $ readKeyFileAnyOf + bech32PossibleBlockIssuers + textEnvPossibleBlockIssuers + poolSkeyFile + + (ocert, nextOcertCtr) <- + firstExceptT NodeCmdOperationalCertificateIssueError + . hoistEither + $ issueOperationalCertificate verKeyKes signKey kesPeriod ocertIssueCounter - -- Write the counter first, to reduce the chance of ending up with - -- a new cert but without updating the counter. - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile (onlyOut operationalCertificateCounterFile) - $ textEnvelopeToJSON (Just $ ocertCtrDesc $ getCounter nextOcertCtr) nextOcertCtr - - firstExceptT NodeCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile outFile - $ textEnvelopeToJSON Nothing ocert - - where + -- Write the counter first, to reduce the chance of ending up with + -- a new cert but without updating the counter. + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile (onlyOut operationalCertificateCounterFile) + $ textEnvelopeToJSON (Just $ ocertCtrDesc $ getCounter nextOcertCtr) nextOcertCtr + + firstExceptT NodeCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile outFile + $ textEnvelopeToJSON Nothing ocert + where getCounter :: OperationalCertificateIssueCounter -> Word64 getCounter (OperationalCertificateIssueCounter n _) = n @@ -272,19 +281,27 @@ runNodeIssueOpCertCmd ocertCtrDesc n = "Next certificate issue number: " <> fromString (show n) textEnvPossibleBlockIssuers - :: [FromSomeType HasTextEnvelope - (Either (SigningKey StakePoolKey) - (SigningKey GenesisDelegateExtendedKey))] + :: [ FromSomeType + HasTextEnvelope + ( Either + (SigningKey StakePoolKey) + (SigningKey GenesisDelegateExtendedKey) + ) + ] textEnvPossibleBlockIssuers = - [ FromSomeType (AsSigningKey AsStakePoolKey) Left + [ FromSomeType (AsSigningKey AsStakePoolKey) Left , FromSomeType (AsSigningKey AsGenesisDelegateKey) (Left . castSigningKey) , FromSomeType (AsSigningKey AsGenesisDelegateExtendedKey) Right ] bech32PossibleBlockIssuers - :: [FromSomeType SerialiseAsBech32 - (Either (SigningKey StakePoolKey) - (SigningKey GenesisDelegateExtendedKey))] + :: [ FromSomeType + SerialiseAsBech32 + ( Either + (SigningKey StakePoolKey) + (SigningKey GenesisDelegateExtendedKey) + ) + ] bech32PossibleBlockIssuers = [FromSomeType (AsSigningKey AsStakePoolKey) Left] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs index ef9c7c1801..ea411348cc 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs @@ -15,7 +15,6 @@ module Cardano.CLI.EraBased.Run.Query ( runQueryCmds - , runQueryConstitutionHashCmd , runQueryKesPeriodInfoCmd , runQueryLeadershipScheduleCmd @@ -31,13 +30,13 @@ module Cardano.CLI.EraBased.Run.Query , runQueryTipCmd , runQueryTxMempoolCmd , runQueryUTxOCmd - - , DelegationsAndRewards(..) + , DelegationsAndRewards (..) , newOutputFormat , renderQueryCmdError , renderOpCertIntervalInformation , percentage - ) where + ) +where {- HLINT ignore "Use list comprehension" -} @@ -105,89 +104,94 @@ import Text.Printf (printf) runQueryCmds :: Cmd.QueryCmds era -> ExceptT QueryCmdError IO () runQueryCmds = \case - Cmd.QueryLeadershipScheduleCmd args -> runQueryLeadershipScheduleCmd args - Cmd.QueryProtocolParametersCmd args -> runQueryProtocolParametersCmd args - Cmd.QueryConstitutionHashCmd args -> runQueryConstitutionHashCmd args - Cmd.QueryTipCmd args -> runQueryTipCmd args - Cmd.QueryStakePoolsCmd args -> runQueryStakePoolsCmd args - Cmd.QueryStakeDistributionCmd args -> runQueryStakeDistributionCmd args - Cmd.QueryStakeAddressInfoCmd args -> runQueryStakeAddressInfoCmd args - Cmd.QueryLedgerStateCmd args -> runQueryLedgerStateCmd args - Cmd.QueryStakeSnapshotCmd args -> runQueryStakeSnapshotCmd args - Cmd.QueryProtocolStateCmd args -> runQueryProtocolStateCmd args - Cmd.QueryUTxOCmd args -> runQueryUTxOCmd args - Cmd.QueryKesPeriodInfoCmd args -> runQueryKesPeriodInfoCmd args - Cmd.QueryPoolStateCmd args -> runQueryPoolStateCmd args - Cmd.QueryTxMempoolCmd args -> runQueryTxMempoolCmd args - Cmd.QuerySlotNumberCmd args -> runQuerySlotNumberCmd args - Cmd.QueryRefScriptSizeCmd args -> runQueryRefScriptSizeCmd args - Cmd.QueryConstitutionCmd args -> runQueryConstitution args - Cmd.QueryGovStateCmd args -> runQueryGovState args - Cmd.QueryDRepStateCmd args -> runQueryDRepState args + Cmd.QueryLeadershipScheduleCmd args -> runQueryLeadershipScheduleCmd args + Cmd.QueryProtocolParametersCmd args -> runQueryProtocolParametersCmd args + Cmd.QueryConstitutionHashCmd args -> runQueryConstitutionHashCmd args + Cmd.QueryTipCmd args -> runQueryTipCmd args + Cmd.QueryStakePoolsCmd args -> runQueryStakePoolsCmd args + Cmd.QueryStakeDistributionCmd args -> runQueryStakeDistributionCmd args + Cmd.QueryStakeAddressInfoCmd args -> runQueryStakeAddressInfoCmd args + Cmd.QueryLedgerStateCmd args -> runQueryLedgerStateCmd args + Cmd.QueryStakeSnapshotCmd args -> runQueryStakeSnapshotCmd args + Cmd.QueryProtocolStateCmd args -> runQueryProtocolStateCmd args + Cmd.QueryUTxOCmd args -> runQueryUTxOCmd args + Cmd.QueryKesPeriodInfoCmd args -> runQueryKesPeriodInfoCmd args + Cmd.QueryPoolStateCmd args -> runQueryPoolStateCmd args + Cmd.QueryTxMempoolCmd args -> runQueryTxMempoolCmd args + Cmd.QuerySlotNumberCmd args -> runQuerySlotNumberCmd args + Cmd.QueryRefScriptSizeCmd args -> runQueryRefScriptSizeCmd args + Cmd.QueryConstitutionCmd args -> runQueryConstitution args + Cmd.QueryGovStateCmd args -> runQueryGovState args + Cmd.QueryDRepStateCmd args -> runQueryDRepState args Cmd.QueryDRepStakeDistributionCmd args -> runQueryDRepStakeDistribution args Cmd.QueryCommitteeMembersStateCmd args -> runQueryCommitteeMembersState args -runQueryConstitutionHashCmd :: () +runQueryConstitutionHashCmd + :: () => Cmd.QueryConstitutionHashCmdArgs -> ExceptT QueryCmdError IO () runQueryConstitutionHashCmd - Cmd.QueryConstitutionHashCmdArgs + Cmd.QueryConstitutionHashCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.target , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) + result <- liftIO $ executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - lift (shelleyBasedEraConstraints sbe (queryConstitutionHash sbe)) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdEraMismatch) + lift (shelleyBasedEraConstraints sbe (queryConstitutionHash sbe)) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdEraMismatch) - writeConstitutionHash mOutFile =<< except (join (first QueryCmdAcquireFailure result)) - where + writeConstitutionHash mOutFile =<< except (join (first QueryCmdAcquireFailure result)) + where writeConstitutionHash :: Maybe (File () Out) -> L.SafeHash L.StandardCrypto L.AnchorData -> ExceptT QueryCmdError IO () writeConstitutionHash mOutFile' cHash = - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile' $ encodePretty cHash + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile' $ + encodePretty cHash -runQueryProtocolParametersCmd :: () +runQueryProtocolParametersCmd + :: () => Cmd.QueryProtocolParametersCmdArgs -> ExceptT QueryCmdError IO () runQueryProtocolParametersCmd - Cmd.QueryProtocolParametersCmdArgs + Cmd.QueryProtocolParametersCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - AnyCardanoEra era <- firstExceptT QueryCmdAcquireFailure $ determineEra localNodeConnInfo - sbe <- forEraInEon @ShelleyBasedEra era (left QueryCmdByronEra) pure - let qInMode = QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters - pp <- firstExceptT QueryCmdConvenienceError - $ executeQueryAnyMode localNodeConnInfo qInMode - writeProtocolParameters sbe mOutFile pp - where + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + AnyCardanoEra era <- firstExceptT QueryCmdAcquireFailure $ determineEra localNodeConnInfo + sbe <- forEraInEon @ShelleyBasedEra era (left QueryCmdByronEra) pure + let qInMode = QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters + pp <- + firstExceptT QueryCmdConvenienceError $ + executeQueryAnyMode localNodeConnInfo qInMode + writeProtocolParameters sbe mOutFile pp + where writeProtocolParameters :: ShelleyBasedEra era -> Maybe (File () Out) -> L.PParams (ShelleyLedgerEra era) -> ExceptT QueryCmdError IO () writeProtocolParameters sbe mOutFile' pparams = - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile' - $ shelleyBasedEraConstraints sbe - $ encodePretty pparams + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile' $ + shelleyBasedEraConstraints sbe $ + encodePretty pparams -- | Calculate the percentage sync rendered as text. percentage @@ -200,16 +204,17 @@ percentage -- ^ 'tipTime'. The time of the tip of the block chain to which we need to sync. -> Text percentage tolerance a b = Text.pack (printf "%.2f" pc) - where -- All calculations are in seconds (Integer) - t = relativeTimeSeconds tolerance - -- Plus 1 to prevent division by zero. The 's' prefix stands for strictly-positive. - sa = relativeTimeSeconds a + 1 - sb = relativeTimeSeconds b + 1 - -- Fast forward the 'nowTime` by the tolerance, but don't let the result exceed the tip time. - ua = min (sa + t) sb - ub = sb - -- Final percentage to render as text. - pc = id @Double (fromIntegral ua / fromIntegral ub) * 100.0 + where + -- All calculations are in seconds (Integer) + t = relativeTimeSeconds tolerance + -- Plus 1 to prevent division by zero. The 's' prefix stands for strictly-positive. + sa = relativeTimeSeconds a + 1 + sb = relativeTimeSeconds b + 1 + -- Fast forward the 'nowTime` by the tolerance, but don't let the result exceed the tip time. + ua = min (sa + t) sb + ub = sb + -- Final percentage to render as text. + pc = id @Double (fromIntegral ua / fromIntegral ub) * 100.0 relativeTimeSeconds :: RelativeTime -> Integer relativeTimeSeconds (RelativeTime dt) = floor (nominalDiffTimeToSeconds dt) @@ -223,94 +228,109 @@ queryChainTipViaChainSync localNodeConnInfo = do "Warning: Local header state query unavailable. Falling back to chain sync query" liftIO $ getLocalChainTip localNodeConnInfo -runQueryTipCmd :: () +runQueryTipCmd + :: () => Cmd.QueryTipCmdArgs -> ExceptT QueryCmdError IO () runQueryTipCmd - Cmd.QueryTipCmdArgs + Cmd.QueryTipCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.target , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - - eLocalState <- ExceptT $ fmap sequence $ - executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) - eraHistory <- lift queryEraHistory & onLeft (left . QueryCmdUnsupportedNtcVersion) - mChainBlockNo <- lift queryChainBlockNo & onLeft (left . QueryCmdUnsupportedNtcVersion) & fmap Just - mChainPoint <- lift queryChainPoint & onLeft (left . QueryCmdUnsupportedNtcVersion) & fmap Just - mSystemStart <- lift querySystemStart & onLeft (left . QueryCmdUnsupportedNtcVersion) & fmap Just - - return O.QueryTipLocalState - { O.era = era - , O.eraHistory = eraHistory - , O.mSystemStart = mSystemStart - , O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint - } - - mLocalState <- hushM (first QueryCmdAcquireFailure eLocalState) $ \e -> - liftIO . LT.hPutStrLn IO.stderr $ docToLazyText $ "Warning: Local state unavailable: " <> renderQueryCmdError e - - chainTip <- pure (mLocalState >>= O.mChainTip) - -- The chain tip is unavailable via local state query because we are connecting with an older - -- node to client protocol so we use chain sync instead which necessitates another connection. - -- At some point when we can stop supporting the older node to client protocols, this fallback - -- can be removed. - & onNothing (queryChainTipViaChainSync localNodeConnInfo) - - let tipSlotNo :: SlotNo = case chainTip of - ChainTipAtGenesis -> 0 - ChainTip slotNo _ _ -> slotNo - - localStateOutput <- forM mLocalState $ \localState -> do - case slotToEpoch tipSlotNo (O.eraHistory localState) of - Left e -> do - liftIO . LT.hPutStrLn IO.stderr $ docToLazyText $ - "Warning: Epoch unavailable: " <> renderQueryCmdError (QueryCmdPastHorizon e) - return $ O.QueryTipLocalStateOutput - { O.localStateChainTip = chainTip - , O.mEra = Nothing - , O.mEpoch = Nothing - , O.mSyncProgress = Nothing - , O.mSlotInEpoch = Nothing - , O.mSlotsToEpochEnd = Nothing - } - - Right (epochNo, SlotsInEpoch slotsInEpoch, SlotsToEpochEnd slotsToEpochEnd) -> do - syncProgressResult <- runExceptT $ do - systemStart <- fmap getSystemStart (O.mSystemStart localState) & hoistMaybe QueryCmdSystemStartUnavailable - nowSeconds <- toRelativeTime (SystemStart systemStart) <$> liftIO getCurrentTime - tipTimeResult <- getProgress tipSlotNo (O.eraHistory localState) & bimap QueryCmdPastHorizon fst & except - - let tolerance = RelativeTime (secondsToNominalDiffTime 600) - - return $ flip (percentage tolerance) nowSeconds tipTimeResult - - mSyncProgress <- hushM syncProgressResult $ \e -> do - liftIO . LT.hPutStrLn IO.stderr $ docToLazyText $ "Warning: Sync progress unavailable: " <> renderQueryCmdError e - - return $ O.QueryTipLocalStateOutput - { O.localStateChainTip = chainTip - , O.mEra = Just (O.era localState) - , O.mEpoch = Just epochNo - , O.mSlotInEpoch = Just slotsInEpoch - , O.mSlotsToEpochEnd = Just slotsToEpochEnd - , O.mSyncProgress = mSyncProgress - } - - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile $ encodePretty localStateOutput + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + + eLocalState <- ExceptT $ + fmap sequence $ + executeLocalStateQueryExpr localNodeConnInfo target $ + runExceptT $ do + era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) + eraHistory <- lift queryEraHistory & onLeft (left . QueryCmdUnsupportedNtcVersion) + mChainBlockNo <- lift queryChainBlockNo & onLeft (left . QueryCmdUnsupportedNtcVersion) & fmap Just + mChainPoint <- lift queryChainPoint & onLeft (left . QueryCmdUnsupportedNtcVersion) & fmap Just + mSystemStart <- lift querySystemStart & onLeft (left . QueryCmdUnsupportedNtcVersion) & fmap Just + + return + O.QueryTipLocalState + { O.era = era + , O.eraHistory = eraHistory + , O.mSystemStart = mSystemStart + , O.mChainTip = makeChainTip <$> mChainBlockNo <*> mChainPoint + } + + mLocalState <- hushM (first QueryCmdAcquireFailure eLocalState) $ \e -> + liftIO . LT.hPutStrLn IO.stderr $ + docToLazyText $ + "Warning: Local state unavailable: " <> renderQueryCmdError e + + chainTip <- + pure (mLocalState >>= O.mChainTip) + -- The chain tip is unavailable via local state query because we are connecting with an older + -- node to client protocol so we use chain sync instead which necessitates another connection. + -- At some point when we can stop supporting the older node to client protocols, this fallback + -- can be removed. + & onNothing (queryChainTipViaChainSync localNodeConnInfo) + + let tipSlotNo :: SlotNo = case chainTip of + ChainTipAtGenesis -> 0 + ChainTip slotNo _ _ -> slotNo + + localStateOutput <- forM mLocalState $ \localState -> do + case slotToEpoch tipSlotNo (O.eraHistory localState) of + Left e -> do + liftIO . LT.hPutStrLn IO.stderr $ + docToLazyText $ + "Warning: Epoch unavailable: " <> renderQueryCmdError (QueryCmdPastHorizon e) + return $ + O.QueryTipLocalStateOutput + { O.localStateChainTip = chainTip + , O.mEra = Nothing + , O.mEpoch = Nothing + , O.mSyncProgress = Nothing + , O.mSlotInEpoch = Nothing + , O.mSlotsToEpochEnd = Nothing + } + Right (epochNo, SlotsInEpoch slotsInEpoch, SlotsToEpochEnd slotsToEpochEnd) -> do + syncProgressResult <- runExceptT $ do + systemStart <- + fmap getSystemStart (O.mSystemStart localState) & hoistMaybe QueryCmdSystemStartUnavailable + nowSeconds <- toRelativeTime (SystemStart systemStart) <$> liftIO getCurrentTime + tipTimeResult <- + getProgress tipSlotNo (O.eraHistory localState) & bimap QueryCmdPastHorizon fst & except + + let tolerance = RelativeTime (secondsToNominalDiffTime 600) + + return $ flip (percentage tolerance) nowSeconds tipTimeResult + + mSyncProgress <- hushM syncProgressResult $ \e -> do + liftIO . LT.hPutStrLn IO.stderr $ + docToLazyText $ + "Warning: Sync progress unavailable: " <> renderQueryCmdError e + + return $ + O.QueryTipLocalStateOutput + { O.localStateChainTip = chainTip + , O.mEra = Just (O.era localState) + , O.mEpoch = Just epochNo + , O.mSlotInEpoch = Just slotsInEpoch + , O.mSlotsToEpochEnd = Just slotsToEpochEnd + , O.mSyncProgress = mSyncProgress + } + + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile $ + encodePretty localStateOutput -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node -- via the local state query protocol. -runQueryUTxOCmd :: () +runQueryUTxOCmd + :: () => Cmd.QueryUTxOCmdArgs -> ExceptT QueryCmdError IO () runQueryUTxOCmd - Cmd.QueryUTxOCmdArgs + Cmd.QueryUTxOCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.queryFilter @@ -319,31 +339,36 @@ runQueryUTxOCmd , Cmd.format , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - utxo <- lift (queryUtxo sbe queryFilter) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + utxo <- + lift (queryUtxo sbe queryFilter) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ do - writeFilteredUTxOs sbe format mOutFile utxo - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ do + writeFilteredUTxOs sbe format mOutFile utxo + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -runQueryKesPeriodInfoCmd :: () +runQueryKesPeriodInfoCmd + :: () => Cmd.QueryKesPeriodInfoCmdArgs -> ExceptT QueryCmdError IO () runQueryKesPeriodInfoCmd - Cmd.QueryKesPeriodInfoCmdArgs + Cmd.QueryKesPeriodInfoCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -351,69 +376,82 @@ runQueryKesPeriodInfoCmd , Cmd.target , Cmd.mOutFile } = do - opCert <- lift (readFileTextEnvelope AsOperationalCertificate nodeOpCertFp) - & onLeft (left . QueryCmdOpCertCounterReadError) - - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) - - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) - - -- We check that the KES period specified in the operational certificate is correct - -- based on the KES period defined in the genesis parameters and the current slot number - gParams <- lift (queryGenesisParameters sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - eraHistory <- lift queryEraHistory - & onLeft (left . QueryCmdUnsupportedNtcVersion) - - let eInfo = toTentativeEpochInfo eraHistory - - -- We get the operational certificate counter from the protocol state and check that - -- it is equivalent to what we have on disk. - ptclState <- lift (queryProtocolState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + opCert <- + lift (readFileTextEnvelope AsOperationalCertificate nodeOpCertFp) + & onLeft (left . QueryCmdOpCertCounterReadError) + + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) + + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) + + -- We check that the KES period specified in the operational certificate is correct + -- based on the KES period defined in the genesis parameters and the current slot number + gParams <- + lift (queryGenesisParameters sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + eraHistory <- + lift queryEraHistory + & onLeft (left . QueryCmdUnsupportedNtcVersion) + + let eInfo = toTentativeEpochInfo eraHistory + + -- We get the operational certificate counter from the protocol state and check that + -- it is equivalent to what we have on disk. + ptclState <- + lift (queryProtocolState sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ do - chainTip <- liftIO $ getLocalChainTip localNodeConnInfo - - let curKesPeriod = currentKesPeriod chainTip gParams - oCertStartKesPeriod = opCertStartingKesPeriod opCert - oCertEndKesPeriod = opCertEndKesPeriod gParams opCert - opCertIntervalInformation = opCertIntervalInfo gParams chainTip curKesPeriod oCertStartKesPeriod oCertEndKesPeriod - - (onDiskC, stateC) <- shelleyBasedEraConstraints sbe $ opCertOnDiskAndStateCounters ptclState opCert - - let counterInformation = opCertNodeAndOnDiskCounters onDiskC stateC - - -- Always render diagnostic information - liftIO . putStrLn $ docToString $ renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation - liftIO . putStrLn $ docToString $ renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation - - let qKesInfoOutput = createQueryKesPeriodInfoOutput opCertIntervalInformation counterInformation eInfo gParams - kesPeriodInfoJSON = encodePretty qKesInfoOutput - - liftIO $ LBS.putStrLn kesPeriodInfoJSON - forM_ mOutFile (\(File oFp) -> - handleIOExceptT (QueryCmdWriteFileError . FileIOError oFp) - $ LBS.writeFile oFp kesPeriodInfoJSON) - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left - - where + pure $ do + chainTip <- liftIO $ getLocalChainTip localNodeConnInfo + + let curKesPeriod = currentKesPeriod chainTip gParams + oCertStartKesPeriod = opCertStartingKesPeriod opCert + oCertEndKesPeriod = opCertEndKesPeriod gParams opCert + opCertIntervalInformation = opCertIntervalInfo gParams chainTip curKesPeriod oCertStartKesPeriod oCertEndKesPeriod + + (onDiskC, stateC) <- shelleyBasedEraConstraints sbe $ opCertOnDiskAndStateCounters ptclState opCert + + let counterInformation = opCertNodeAndOnDiskCounters onDiskC stateC + + -- Always render diagnostic information + liftIO . putStrLn $ + docToString $ + renderOpCertIntervalInformation (unFile nodeOpCertFp) opCertIntervalInformation + liftIO . putStrLn $ + docToString $ + renderOpCertNodeAndOnDiskCounterInformation (unFile nodeOpCertFp) counterInformation + + let qKesInfoOutput = createQueryKesPeriodInfoOutput opCertIntervalInformation counterInformation eInfo gParams + kesPeriodInfoJSON = encodePretty qKesInfoOutput + + liftIO $ LBS.putStrLn kesPeriodInfoJSON + forM_ + mOutFile + ( \(File oFp) -> + handleIOExceptT (QueryCmdWriteFileError . FileIOError oFp) $ + LBS.writeFile oFp kesPeriodInfoJSON + ) + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left + where currentKesPeriod :: ChainTip -> GenesisParameters era -> CurrentKesPeriod currentKesPeriod ChainTipAtGenesis _ = CurrentKesPeriod 0 currentKesPeriod (ChainTip currSlot _ _) gParams = let slotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams - in CurrentKesPeriod $ unSlotNo currSlot `div` slotsPerKesPeriod + in CurrentKesPeriod $ unSlotNo currSlot `div` slotsPerKesPeriod opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod opCertStartingKesPeriod = OpCertStartingKesPeriod . fromIntegral . getKesPeriod @@ -422,7 +460,7 @@ runQueryKesPeriodInfoCmd opCertEndKesPeriod gParams oCert = let OpCertStartingKesPeriod start = opCertStartingKesPeriod oCert maxKesEvo = fromIntegral $ protocolParamMaxKESEvolutions gParams - in OpCertEndingKesPeriod $ start + maxKesEvo + in OpCertEndingKesPeriod $ start + maxKesEvo -- See OCERT rule in Shelley Spec: https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/shelleyLedgerSpec/latest/download-by-type/doc-pdf/ledger-spec opCertIntervalInfo @@ -433,11 +471,13 @@ runQueryKesPeriodInfoCmd -> OpCertEndingKesPeriod -> OpCertIntervalInformation opCertIntervalInfo gParams currSlot' c s e@(OpCertEndingKesPeriod oCertEnd) = - let cSlot = case currSlot' of - (ChainTip cSlotN _ _) -> unSlotNo cSlotN - ChainTipAtGenesis -> 0 - slotsTillExp = SlotsTillKesKeyExpiry . SlotNo $ (oCertEnd * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) - cSlot - in O.createOpCertIntervalInfo c s e (Just slotsTillExp) + let cSlot = case currSlot' of + (ChainTip cSlotN _ _) -> unSlotNo cSlotN + ChainTipAtGenesis -> 0 + slotsTillExp = + SlotsTillKesKeyExpiry . SlotNo $ + (oCertEnd * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) - cSlot + in O.createOpCertIntervalInfo c s e (Just slotsTillExp) opCertNodeAndOnDiskCounters :: OpCertOnDiskCounter @@ -456,52 +496,65 @@ runQueryKesPeriodInfoCmd -> OpCertEndingKesPeriod -> Maybe UTCTime opCertExpiryUtcTime eInfo gParams (OpCertEndingKesPeriod oCertExpiryKesPeriod) = - let time = epochInfoSlotToUTCTime - (tentative eInfo) - (SystemStart $ protocolParamSystemStart gParams) - (fromIntegral $ oCertExpiryKesPeriod * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) - in case time of - Left _ -> Nothing - Right t -> Just t - - renderOpCertNodeAndOnDiskCounterInformation :: FilePath -> OpCertNodeAndOnDiskCounterInformation -> Doc AnsiStyle + let time = + epochInfoSlotToUTCTime + (tentative eInfo) + (SystemStart $ protocolParamSystemStart gParams) + (fromIntegral $ oCertExpiryKesPeriod * fromIntegral (protocolParamSlotsPerKESPeriod gParams)) + in case time of + Left _ -> Nothing + Right t -> Just t + + renderOpCertNodeAndOnDiskCounterInformation + :: FilePath -> OpCertNodeAndOnDiskCounterInformation -> Doc AnsiStyle renderOpCertNodeAndOnDiskCounterInformation opCertFile = \case OpCertOnDiskCounterEqualToNodeState _ _ -> - green "✓" <+> hang 0 + green "✓" + <+> hang + 0 ( vsep - [ "The operational certificate counter agrees with the node protocol state counter" - ] + [ "The operational certificate counter agrees with the node protocol state counter" + ] ) OpCertOnDiskCounterAheadOfNodeState _ _ -> - green "✓" <+> hang 0 + green "✓" + <+> hang + 0 ( vsep - [ "The operational certificate counter ahead of the node protocol state counter by 1" - ] + [ "The operational certificate counter ahead of the node protocol state counter by 1" + ] ) OpCertOnDiskCounterTooFarAheadOfNodeState onDiskC nodeStateC -> - red "✗" <+> hang 0 - ( vsep - [ "The operational certificate counter too far ahead of the node protocol state counter in the operational certificate at: " <> pretty opCertFile - , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) - , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) - ] - ) + red "✗" + <+> hang + 0 + ( vsep + [ "The operational certificate counter too far ahead of the node protocol state counter in the operational certificate at: " + <> pretty opCertFile + , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) + , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) + ] + ) OpCertOnDiskCounterBehindNodeState onDiskC nodeStateC -> - red "✗" <+> hang 0 - ( vsep - [ "The protocol state counter is greater than the counter in the operational certificate at: " <> pretty opCertFile - , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) - , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) - ] - ) + red "✗" + <+> hang + 0 + ( vsep + [ "The protocol state counter is greater than the counter in the operational certificate at: " + <> pretty opCertFile + , "On disk operational certificate counter: " <> pretty (unOpCertOnDiskCounter onDiskC) + , "Protocol state counter: " <> pretty (unOpCertNodeStateCounter nodeStateC) + ] + ) OpCertNoBlocksMintedYet (OpCertOnDiskCounter onDiskC) -> - red "✗" <+> hang 0 - ( vsep - [ "No blocks minted so far with the operational certificate at: " <> pretty opCertFile - , "On disk operational certificate counter: " <> pretty onDiskC - ] - ) - + red "✗" + <+> hang + 0 + ( vsep + [ "No blocks minted so far with the operational certificate at: " <> pretty opCertFile + , "On disk operational certificate counter: " <> pretty onDiskC + ] + ) createQueryKesPeriodInfoOutput :: OpCertIntervalInformation @@ -509,45 +562,47 @@ runQueryKesPeriodInfoCmd -> Tentative (EpochInfo (Either Text)) -> GenesisParameters era -> O.QueryKesPeriodInfoOutput - createQueryKesPeriodInfoOutput oCertIntervalInfo oCertCounterInfo eInfo gParams = + createQueryKesPeriodInfoOutput oCertIntervalInfo oCertCounterInfo eInfo gParams = let (e, mStillExp) = case oCertIntervalInfo of - OpCertWithinInterval _ end _ sTillExp -> (end, Just sTillExp) - OpCertStartingKesPeriodIsInTheFuture _ end _ -> (end, Nothing) - OpCertExpired _ end _ -> (end, Nothing) - OpCertSomeOtherError _ end _ -> (end, Nothing) + OpCertWithinInterval _ end _ sTillExp -> (end, Just sTillExp) + OpCertStartingKesPeriodIsInTheFuture _ end _ -> (end, Nothing) + OpCertExpired _ end _ -> (end, Nothing) + OpCertSomeOtherError _ end _ -> (end, Nothing) (onDiskCounter, mNodeCounter) = case oCertCounterInfo of - OpCertOnDiskCounterEqualToNodeState d n -> (d, Just n) - OpCertOnDiskCounterAheadOfNodeState d n -> (d, Just n) - OpCertOnDiskCounterTooFarAheadOfNodeState d n -> (d, Just n) - OpCertOnDiskCounterBehindNodeState d n -> (d, Just n) - OpCertNoBlocksMintedYet d -> (d, Nothing) - - in O.QueryKesPeriodInfoOutput - { O.qKesOpCertIntervalInformation = oCertIntervalInfo - , O.qKesInfoNodeStateOperationalCertNo = mNodeCounter - , O.qKesInfoOnDiskOperationalCertNo = onDiskCounter - , O.qKesInfoMaxKesKeyEvolutions = fromIntegral $ protocolParamMaxKESEvolutions gParams - , O.qKesInfoSlotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams - , O.qKesInfoKesKeyExpiry = - case mStillExp of - Just _ -> opCertExpiryUtcTime eInfo gParams e - Nothing -> Nothing - } + OpCertOnDiskCounterEqualToNodeState d n -> (d, Just n) + OpCertOnDiskCounterAheadOfNodeState d n -> (d, Just n) + OpCertOnDiskCounterTooFarAheadOfNodeState d n -> (d, Just n) + OpCertOnDiskCounterBehindNodeState d n -> (d, Just n) + OpCertNoBlocksMintedYet d -> (d, Nothing) + in O.QueryKesPeriodInfoOutput + { O.qKesOpCertIntervalInformation = oCertIntervalInfo + , O.qKesInfoNodeStateOperationalCertNo = mNodeCounter + , O.qKesInfoOnDiskOperationalCertNo = onDiskCounter + , O.qKesInfoMaxKesKeyEvolutions = fromIntegral $ protocolParamMaxKESEvolutions gParams + , O.qKesInfoSlotsPerKesPeriod = fromIntegral $ protocolParamSlotsPerKESPeriod gParams + , O.qKesInfoKesKeyExpiry = + case mStillExp of + Just _ -> opCertExpiryUtcTime eInfo gParams e + Nothing -> Nothing + } -- We get the operational certificate counter from the protocol state and check that -- it is equivalent to what we have on disk. - opCertOnDiskAndStateCounters :: forall era . () - => Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) - => FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) - => L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 - => ProtocolState era - -> OperationalCertificate - -> ExceptT QueryCmdError IO (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter) + opCertOnDiskAndStateCounters + :: forall era + . () + => Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) + => FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + => L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + => ProtocolState era + -> OperationalCertificate + -> ExceptT QueryCmdError IO (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter) opCertOnDiskAndStateCounters ptclState opCert@(OperationalCertificate _ stakePoolVKey) = do let onDiskOpCertCount = fromIntegral $ getOpCertCount opCert - chainDepState <- pure (decodeProtocolState ptclState) - & onLeft (left . QueryCmdProtocolStateDecodeFailure) + chainDepState <- + pure (decodeProtocolState ptclState) + & onLeft (left . QueryCmdProtocolStateDecodeFailure) -- We need the stake pool id to determine what the counter of our SPO -- should be. @@ -561,51 +616,65 @@ runQueryKesPeriodInfoCmd Just ptclStateCounter -> return (OpCertOnDiskCounter onDiskOpCertCount, Just $ OpCertNodeStateCounter ptclStateCounter) Nothing -> return (OpCertOnDiskCounter onDiskOpCertCount, Nothing) - renderOpCertIntervalInformation :: FilePath -> OpCertIntervalInformation -> Doc AnsiStyle renderOpCertIntervalInformation opCertFile opCertInfo = case opCertInfo of OpCertWithinInterval _start _end _current _stillExp -> - green "✓" <+> hang 0 - ( vsep - [ "Operational certificate's KES period is within the correct KES period interval" - ] - ) - OpCertStartingKesPeriodIsInTheFuture (OpCertStartingKesPeriod start) (OpCertEndingKesPeriod end) (CurrentKesPeriod current) -> - red "✗" <+> hang 0 - ( vsep - [ "Node operational certificate at: " <> pretty opCertFile <> " has an incorrectly specified starting KES period. " - , "Current KES period: " <> pretty current - , "Operational certificate's starting KES period: " <> pretty start - , "Operational certificate's expiry KES period: " <> pretty end - ] - ) + green "✓" + <+> hang + 0 + ( vsep + [ "Operational certificate's KES period is within the correct KES period interval" + ] + ) + OpCertStartingKesPeriodIsInTheFuture + (OpCertStartingKesPeriod start) + (OpCertEndingKesPeriod end) + (CurrentKesPeriod current) -> + red "✗" + <+> hang + 0 + ( vsep + [ "Node operational certificate at: " + <> pretty opCertFile + <> " has an incorrectly specified starting KES period. " + , "Current KES period: " <> pretty current + , "Operational certificate's starting KES period: " <> pretty start + , "Operational certificate's expiry KES period: " <> pretty end + ] + ) OpCertExpired _ (OpCertEndingKesPeriod end) (CurrentKesPeriod current) -> - red "✗" <+> hang 0 - ( vsep - [ "Node operational certificate at: " <> pretty opCertFile <> " has expired. " - , "Current KES period: " <> pretty current - , "Operational certificate's expiry KES period: " <> pretty end - ] - ) - - OpCertSomeOtherError (OpCertStartingKesPeriod start) (OpCertEndingKesPeriod end) (CurrentKesPeriod current) -> - red "✗" <+> hang 0 - ( vsep - [ "An unknown error occurred with operational certificate at: " <> pretty opCertFile - , "Current KES period: " <> pretty current - , "Operational certificate's starting KES period: " <> pretty start - , "Operational certificate's expiry KES period: " <> pretty end - ] - ) + red "✗" + <+> hang + 0 + ( vsep + [ "Node operational certificate at: " <> pretty opCertFile <> " has expired. " + , "Current KES period: " <> pretty current + , "Operational certificate's expiry KES period: " <> pretty end + ] + ) + OpCertSomeOtherError + (OpCertStartingKesPeriod start) + (OpCertEndingKesPeriod end) + (CurrentKesPeriod current) -> + red "✗" + <+> hang + 0 + ( vsep + [ "An unknown error occurred with operational certificate at: " <> pretty opCertFile + , "Current KES period: " <> pretty current + , "Operational certificate's starting KES period: " <> pretty start + , "Operational certificate's expiry KES period: " <> pretty end + ] + ) -- | Query the current and future parameters for a stake pool, including the retirement date. -- Any of these may be empty (in which case a null will be displayed). --- -runQueryPoolStateCmd :: () +runQueryPoolStateCmd + :: () => Cmd.QueryPoolStateCmdArgs -> ExceptT QueryCmdError IO () runQueryPoolStateCmd - Cmd.QueryPoolStateCmdArgs + Cmd.QueryPoolStateCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -613,77 +682,84 @@ runQueryPoolStateCmd , Cmd.target , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - beo <- requireEon BabbageEra era + beo <- requireEon BabbageEra era - let poolFilter = case allOrOnlyPoolIds of - All -> Nothing - Only poolIds -> Just $ Set.fromList poolIds + let poolFilter = case allOrOnlyPoolIds of + All -> Nothing + Only poolIds -> Just $ Set.fromList poolIds - result <- lift (queryPoolState beo poolFilter) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- + lift (queryPoolState beo poolFilter) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ do - shelleyBasedEraConstraints sbe (writePoolState mOutFile) result - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ do + shelleyBasedEraConstraints sbe (writePoolState mOutFile) result + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -- | Query the local mempool state -runQueryTxMempoolCmd :: () +runQueryTxMempoolCmd + :: () => Cmd.QueryTxMempoolCmdArgs -> ExceptT QueryCmdError IO () runQueryTxMempoolCmd - Cmd.QueryTxMempoolCmdArgs + Cmd.QueryTxMempoolCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.query , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - localQuery <- case query of + localQuery <- case query of TxMempoolQueryTxExists tx -> do AnyCardanoEra era <- modifyError QueryCmdAcquireFailure (determineEra localNodeConnInfo) pure $ LocalTxMonitoringQueryTx $ TxIdInMode era tx TxMempoolQueryNextTx -> pure LocalTxMonitoringSendNextTx TxMempoolQueryInfo -> pure LocalTxMonitoringMempoolInformation - result <- liftIO $ queryTxMonitoringLocal localNodeConnInfo localQuery - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile $ encodePretty result + result <- liftIO $ queryTxMonitoringLocal localNodeConnInfo localQuery + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile $ + encodePretty result -runQuerySlotNumberCmd :: () +runQuerySlotNumberCmd + :: () => Cmd.QuerySlotNumberCmdArgs -> ExceptT QueryCmdError IO () runQuerySlotNumberCmd - Cmd.QuerySlotNumberCmdArgs + Cmd.QuerySlotNumberCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.utcTime , Cmd.target } = do - SlotNo slotNo <- utcTimeToSlotNo nodeSocketPath consensusModeParams networkId target utcTime - liftIO . putStr $ show slotNo + SlotNo slotNo <- utcTimeToSlotNo nodeSocketPath consensusModeParams networkId target utcTime + liftIO . putStr $ show slotNo runQueryRefScriptSizeCmd :: () => Cmd.QueryRefScriptSizeCmdArgs -> ExceptT QueryCmdError IO () runQueryRefScriptSizeCmd - Cmd.QueryRefScriptSizeCmdArgs + Cmd.QueryRefScriptSizeCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.transactionInputs @@ -692,33 +768,37 @@ runQueryRefScriptSizeCmd , Cmd.format , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - beo <- requireEon BabbageEra era + beo <- requireEon BabbageEra era - utxo <- lift (queryUtxo sbe $ QueryUTxOByTxIn transactionInputs) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + utxo <- + lift (queryUtxo sbe $ QueryUTxOByTxIn transactionInputs) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ - writeFormattedOutput format mOutFile $ - RefInputScriptSize $ - getReferenceInputsSizeForTxIds beo (toLedgerUTxO sbe utxo) transactionInputs - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ + writeFormattedOutput format mOutFile $ + RefInputScriptSize $ + getReferenceInputsSizeForTxIds beo (toLedgerUTxO sbe utxo) transactionInputs + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -newtype RefInputScriptSize = RefInputScriptSize { refInputScriptSize :: Int } - deriving (Generic) - deriving anyclass (ToJSON) +newtype RefInputScriptSize = RefInputScriptSize {refInputScriptSize :: Int} + deriving Generic + deriving anyclass ToJSON instance Pretty RefInputScriptSize where pretty (RefInputScriptSize s) = "Reference inputs scripts size is" <+> pretty s <+> "bytes." @@ -726,11 +806,12 @@ instance Pretty RefInputScriptSize where -- | Obtain stake snapshot information for a pool, plus information about the total active stake. -- This information can be used for leader slot calculation, for example, and has been requested by SPOs. -- Obtaining the information directly is significantly more time and memory efficient than using a full ledger state dump. -runQueryStakeSnapshotCmd :: () +runQueryStakeSnapshotCmd + :: () => Cmd.QueryStakeSnapshotCmdArgs -> ExceptT QueryCmdError IO () runQueryStakeSnapshotCmd - Cmd.QueryStakeSnapshotCmdArgs + Cmd.QueryStakeSnapshotCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -738,101 +819,115 @@ runQueryStakeSnapshotCmd , Cmd.target , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - let poolFilter = case allOrOnlyPoolIds of - All -> Nothing - Only poolIds -> Just $ Set.fromList poolIds + let poolFilter = case allOrOnlyPoolIds of + All -> Nothing + Only poolIds -> Just $ Set.fromList poolIds - beo <- requireEon BabbageEra era + beo <- requireEon BabbageEra era - result <- lift (queryStakeSnapshot beo poolFilter) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- + lift (queryStakeSnapshot beo poolFilter) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ do - shelleyBasedEraConstraints sbe (writeStakeSnapshots mOutFile) result - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ do + shelleyBasedEraConstraints sbe (writeStakeSnapshots mOutFile) result + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -runQueryLedgerStateCmd :: () +runQueryLedgerStateCmd + :: () => Cmd.QueryLedgerStateCmdArgs -> ExceptT QueryCmdError IO () runQueryLedgerStateCmd - Cmd.QueryLedgerStateCmdArgs + Cmd.QueryLedgerStateCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.target , Cmd.mOutFile - } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + } = do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - result <- lift (queryDebugLedgerState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- + lift (queryDebugLedgerState sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ do - shelleyBasedEraConstraints sbe (writeLedgerState mOutFile) result - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ do + shelleyBasedEraConstraints sbe (writeLedgerState mOutFile) result + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -runQueryProtocolStateCmd :: () +runQueryProtocolStateCmd + :: () => Cmd.QueryProtocolStateCmdArgs -> ExceptT QueryCmdError IO () runQueryProtocolStateCmd - Cmd.QueryProtocolStateCmdArgs + Cmd.QueryProtocolStateCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId , Cmd.target , Cmd.mOutFile - } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + } = do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - result <- lift (queryProtocolState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- + lift (queryProtocolState sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ shelleyBasedEraConstraints sbe $ writeProtocolState sbe mOutFile result - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ shelleyBasedEraConstraints sbe $ writeProtocolState sbe mOutFile result + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -- | Query the current delegations and reward accounts, filtered by a given -- set of addresses, from a Shelley node via the local state query protocol. - -runQueryStakeAddressInfoCmd :: () +runQueryStakeAddressInfoCmd + :: () => Cmd.QueryStakeAddressInfoCmdArgs -> ExceptT QueryCmdError IO () runQueryStakeAddressInfoCmd - Cmd.QueryStakeAddressInfoCmdArgs + Cmd.QueryStakeAddressInfoCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.addr = StakeAddress _ addr @@ -840,43 +935,48 @@ runQueryStakeAddressInfoCmd , Cmd.target , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr + let stakeAddr = Set.singleton $ fromShelleyStakeCredential addr - (stakeRewardAccountBalances, stakePools) <- lift (queryStakeAddresses sbe stakeAddr networkId) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + (stakeRewardAccountBalances, stakePools) <- + lift (queryStakeAddresses sbe stakeAddr networkId) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - beo <- requireEon BabbageEra era - - stakeDelegDeposits <- lift (queryStakeDelegDeposits beo stakeAddr) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + beo <- requireEon BabbageEra era - stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo -> - lift (queryStakeVoteDelegatees ceo stakeAddr) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - return $ do - writeStakeAddressInfo - sbe - mOutFile - (DelegationsAndRewards (stakeRewardAccountBalances, stakePools)) - (Map.mapKeys (makeStakeAddress networkId) stakeDelegDeposits) - (Map.mapKeys (makeStakeAddress networkId) stakeVoteDelegatees) - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + stakeDelegDeposits <- + lift (queryStakeDelegDeposits beo stakeAddr) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + stakeVoteDelegatees <- monoidForEraInEonA era $ \ceo -> + lift (queryStakeVoteDelegatees ceo stakeAddr) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + return $ do + writeStakeAddressInfo + sbe + mOutFile + (DelegationsAndRewards (stakeRewardAccountBalances, stakePools)) + (Map.mapKeys (makeStakeAddress networkId) stakeDelegDeposits) + (Map.mapKeys (makeStakeAddress networkId) stakeVoteDelegatees) + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -- ------------------------------------------------------------------------------------------------- @@ -884,8 +984,10 @@ writeStakeAddressInfo :: ShelleyBasedEra era -> Maybe (File () Out) -> DelegationsAndRewards - -> Map StakeAddress L.Coin -- ^ deposits - -> Map StakeAddress (L.DRep L.StandardCrypto) -- ^ vote delegatees + -> Map StakeAddress L.Coin + -- ^ deposits + -> Map StakeAddress (L.DRep L.StandardCrypto) + -- ^ vote delegatees -> ExceptT QueryCmdError IO () writeStakeAddressInfo sbe @@ -893,63 +995,70 @@ writeStakeAddressInfo (DelegationsAndRewards (stakeAccountBalances, stakePools)) stakeDelegDeposits voteDelegatees = - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile (encodePretty $ jsonInfo sbe) - where - jsonInfo :: ShelleyBasedEra era -> [Aeson.Value] - jsonInfo = - caseShelleyToBabbageOrConwayEraOnwards - ( const $ map - (\(addr, mBalance, mPoolId, _mDRep, mDeposit) -> - Aeson.object - [ "address" .= addr - , "delegation" .= mPoolId - , "rewardAccountBalance" .= mBalance - , "delegationDeposit" .= mDeposit - ] - ) - merged - ) - ( const $ map - (\(addr, mBalance, mPoolId, mDRep, mDeposit) -> - Aeson.object - [ "address" .= addr - , "stakeDelegation" .= mPoolId - , "voteDelegation" .= fmap friendlyDRep mDRep - , "rewardAccountBalance" .= mBalance - , "delegationDeposit" .= mDeposit - ] - ) - merged - ) - - friendlyDRep :: L.DRep L.StandardCrypto -> Text - friendlyDRep L.DRepAlwaysAbstain = "alwaysAbstain" - friendlyDRep L.DRepAlwaysNoConfidence = "alwaysNoConfidence" - friendlyDRep (L.DRepCredential cred) = - L.credToText cred -- this will pring "keyHash-..." or "scriptHash-...", depending on the type of credential - - merged :: [(StakeAddress, Maybe L.Coin, Maybe PoolId, Maybe (L.DRep L.StandardCrypto), Maybe L.Coin)] - merged = - [ (addr, mBalance, mPoolId, mDRep, mDeposit) - | addr <- Set.toList (Set.unions [ Map.keysSet stakeAccountBalances - , Map.keysSet stakePools - , Map.keysSet stakeDelegDeposits - , Map.keysSet voteDelegatees - ]) - , let mBalance = Map.lookup addr stakeAccountBalances - mPoolId = Map.lookup addr stakePools - mDeposit = Map.lookup addr stakeDelegDeposits - mDRep = Map.lookup addr voteDelegatees - ] + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile (encodePretty $ jsonInfo sbe) + where + jsonInfo :: ShelleyBasedEra era -> [Aeson.Value] + jsonInfo = + caseShelleyToBabbageOrConwayEraOnwards + ( const $ + map + ( \(addr, mBalance, mPoolId, _mDRep, mDeposit) -> + Aeson.object + [ "address" .= addr + , "delegation" .= mPoolId + , "rewardAccountBalance" .= mBalance + , "delegationDeposit" .= mDeposit + ] + ) + merged + ) + ( const $ + map + ( \(addr, mBalance, mPoolId, mDRep, mDeposit) -> + Aeson.object + [ "address" .= addr + , "stakeDelegation" .= mPoolId + , "voteDelegation" .= fmap friendlyDRep mDRep + , "rewardAccountBalance" .= mBalance + , "delegationDeposit" .= mDeposit + ] + ) + merged + ) -writeLedgerState :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ToJSON (DebugLedgerState era) - => FromCBOR (DebugLedgerState era) - => Maybe (File () Out) - -> SerialisedDebugLedgerState era - -> ExceptT QueryCmdError IO () + friendlyDRep :: L.DRep L.StandardCrypto -> Text + friendlyDRep L.DRepAlwaysAbstain = "alwaysAbstain" + friendlyDRep L.DRepAlwaysNoConfidence = "alwaysNoConfidence" + friendlyDRep (L.DRepCredential cred) = + L.credToText cred -- this will pring "keyHash-..." or "scriptHash-...", depending on the type of credential + merged + :: [(StakeAddress, Maybe L.Coin, Maybe PoolId, Maybe (L.DRep L.StandardCrypto), Maybe L.Coin)] + merged = + [ (addr, mBalance, mPoolId, mDRep, mDeposit) + | addr <- + Set.toList + ( Set.unions + [ Map.keysSet stakeAccountBalances + , Map.keysSet stakePools + , Map.keysSet stakeDelegDeposits + , Map.keysSet voteDelegatees + ] + ) + , let mBalance = Map.lookup addr stakeAccountBalances + mPoolId = Map.lookup addr stakePools + mDeposit = Map.lookup addr stakeDelegDeposits + mDRep = Map.lookup addr voteDelegatees + ] + +writeLedgerState + :: forall era ledgerera + . ShelleyLedgerEra era ~ ledgerera + => ToJSON (DebugLedgerState era) + => FromCBOR (DebugLedgerState era) + => Maybe (File () Out) + -> SerialisedDebugLedgerState era + -> ExceptT QueryCmdError IO () writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) = case mOutFile of Nothing -> @@ -957,25 +1066,31 @@ writeLedgerState mOutFile qState@(SerialisedDebugLedgerState serLedgerState) = Left (bs, _decoderError) -> firstExceptT QueryCmdHelpersError $ pPrintCBOR bs Right ledgerState -> liftIO . LBS.putStrLn $ Aeson.encode ledgerState Just (File fpath) -> - handleIOExceptT (QueryCmdWriteFileError . FileIOError fpath) - $ LBS.writeFile fpath $ unSerialised serLedgerState + handleIOExceptT (QueryCmdWriteFileError . FileIOError fpath) $ + LBS.writeFile fpath $ + unSerialised serLedgerState -writeStakeSnapshots :: forall era ledgerera. () +writeStakeSnapshots + :: forall era ledgerera + . () => ShelleyLedgerEra era ~ ledgerera => L.EraCrypto ledgerera ~ StandardCrypto => Maybe (File () Out) -> SerialisedStakeSnapshots era -> ExceptT QueryCmdError IO () writeStakeSnapshots mOutFile qState = do - StakeSnapshot snapshot <- pure (decodeStakeSnapshot qState) - & onLeft (left . QueryCmdStakeSnapshotDecodeError) + StakeSnapshot snapshot <- + pure (decodeStakeSnapshot qState) + & onLeft (left . QueryCmdStakeSnapshotDecodeError) -- Calculate the three pool and active stake values for the given pool liftIO . maybe LBS.putStrLn (LBS.writeFile . unFile) mOutFile $ encodePretty snapshot -- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state -- .nesEs.esLState.lsDPState.dpsPState.psStakePoolParams. -writePoolState :: forall era ledgerera. () +writePoolState + :: forall era ledgerera + . () => ShelleyLedgerEra era ~ ledgerera => L.EraCrypto ledgerera ~ StandardCrypto => L.Era ledgerera @@ -983,26 +1098,34 @@ writePoolState :: forall era ledgerera. () -> SerialisedPoolState era -> ExceptT QueryCmdError IO () writePoolState mOutFile serialisedCurrentEpochState = do - PoolState poolState <- pure (decodePoolState serialisedCurrentEpochState) - & onLeft (left . QueryCmdPoolStateDecodeError) + PoolState poolState <- + pure (decodePoolState serialisedCurrentEpochState) + & onLeft (left . QueryCmdPoolStateDecodeError) - let hks = Set.toList $ Set.fromList $ Map.keys (L.psStakePoolParams poolState) - <> Map.keys (L.psFutureStakePoolParams poolState) <> Map.keys (L.psRetiring poolState) + let hks = + Set.toList $ + Set.fromList $ + Map.keys (L.psStakePoolParams poolState) + <> Map.keys (L.psFutureStakePoolParams poolState) + <> Map.keys (L.psRetiring poolState) let poolStates :: Map (L.KeyHash 'L.StakePool StandardCrypto) (Params StandardCrypto) - poolStates = Map.fromList $ hks <&> - ( \hk -> - ( hk - , Params - { poolParameters = Map.lookup hk (L.psStakePoolParams poolState) - , futurePoolParameters = Map.lookup hk (L.psFutureStakePoolParams poolState) - , retiringEpoch = Map.lookup hk (L.psRetiring poolState) - } - ) - ) + poolStates = + Map.fromList $ + hks + <&> ( \hk -> + ( hk + , Params + { poolParameters = Map.lookup hk (L.psStakePoolParams poolState) + , futurePoolParameters = Map.lookup hk (L.psFutureStakePoolParams poolState) + , retiringEpoch = Map.lookup hk (L.psRetiring poolState) + } + ) + ) firstExceptT QueryCmdWriteFileError . newExceptT $ - writeLazyByteStringOutput mOutFile $ encodePretty poolStates + writeLazyByteStringOutput mOutFile $ + encodePretty poolStates writeProtocolState :: ShelleyBasedEra era @@ -1035,27 +1158,30 @@ writeProtocolState sbe mOutFile ps@(ProtocolState pstate) = case mOutFile of Nothing -> decodePState ps Just (File fpath) -> writePState fpath pstate - where - writePState fpath pstate' = - handleIOExceptT (QueryCmdWriteFileError . FileIOError fpath) - . LBS.writeFile fpath $ unSerialised pstate' - decodePState ps' = - case decodeProtocolState ps' of - Left (bs, _) -> firstExceptT QueryCmdHelpersError $ pPrintCBOR bs - Right chainDepstate -> liftIO . LBS.putStrLn $ encodePretty chainDepstate - -writeFilteredUTxOs :: Api.ShelleyBasedEra era - -> Maybe OutputFormatJsonOrText - -> Maybe (File () Out) - -> UTxO era - -> ExceptT QueryCmdError IO () + where + writePState fpath pstate' = + handleIOExceptT (QueryCmdWriteFileError . FileIOError fpath) + . LBS.writeFile fpath + $ unSerialised pstate' + decodePState ps' = + case decodeProtocolState ps' of + Left (bs, _) -> firstExceptT QueryCmdHelpersError $ pPrintCBOR bs + Right chainDepstate -> liftIO . LBS.putStrLn $ encodePretty chainDepstate + +writeFilteredUTxOs + :: Api.ShelleyBasedEra era + -> Maybe OutputFormatJsonOrText + -> Maybe (File () Out) + -> UTxO era + -> ExceptT QueryCmdError IO () writeFilteredUTxOs sbe format mOutFile utxo = - shelleyBasedEraConstraints sbe $ - firstExceptT QueryCmdWriteFileError . newExceptT . - writeLazyByteStringOutput mOutFile $ - case newOutputFormat format mOutFile of - OutputFormatJson -> encodePretty utxo - OutputFormatText -> strictTextToLazyBytestring $ filteredUTxOsToText sbe utxo + shelleyBasedEraConstraints sbe + $ firstExceptT QueryCmdWriteFileError + . newExceptT + . writeLazyByteStringOutput mOutFile + $ case newOutputFormat format mOutFile of + OutputFormatJson -> encodePretty utxo + OutputFormatText -> strictTextToLazyBytestring $ filteredUTxOsToText sbe utxo filteredUTxOsToText :: Api.ShelleyBasedEra era -> UTxO era -> Text filteredUTxOsToText sbe (UTxO utxo) = do @@ -1066,7 +1192,7 @@ filteredUTxOsToText sbe (UTxO utxo) = do map (utxoToText sbe) $ Map.toList utxo ShelleyBasedEraAllegra -> map (utxoToText sbe) $ Map.toList utxo - ShelleyBasedEraMary -> + ShelleyBasedEraMary -> map (utxoToText sbe) $ Map.toList utxo ShelleyBasedEraAlonzo -> map (utxoToText sbe) $ Map.toList utxo @@ -1075,11 +1201,10 @@ filteredUTxOsToText sbe (UTxO utxo) = do ShelleyBasedEraConway -> map (utxoToText sbe) $ Map.toList utxo ] - where - title :: Text - title = - " TxHash TxIx Amount" + title :: Text + title = + " TxHash TxIx Amount" utxoToText :: Api.ShelleyBasedEra era @@ -1089,64 +1214,64 @@ utxoToText sbe txInOutTuple = case sbe of ShelleyBasedEraShelley -> let (TxIn (TxId txhash) (TxIx index), TxOut _ value _ _) = txInOutTuple - in mconcat - [ Text.decodeLatin1 (hashToBytesAsHex txhash) - , textShowN 6 index - , " " <> printableValue value - ] - + in mconcat + [ Text.decodeLatin1 (hashToBytesAsHex txhash) + , textShowN 6 index + , " " <> printableValue value + ] ShelleyBasedEraAllegra -> let (TxIn (TxId txhash) (TxIx index), TxOut _ value _ _) = txInOutTuple - in mconcat - [ Text.decodeLatin1 (hashToBytesAsHex txhash) - , textShowN 6 index - , " " <> printableValue value - ] + in mconcat + [ Text.decodeLatin1 (hashToBytesAsHex txhash) + , textShowN 6 index + , " " <> printableValue value + ] ShelleyBasedEraMary -> let (TxIn (TxId txhash) (TxIx index), TxOut _ value _ _) = txInOutTuple - in mconcat - [ Text.decodeLatin1 (hashToBytesAsHex txhash) - , textShowN 6 index - , " " <> printableValue value - ] + in mconcat + [ Text.decodeLatin1 (hashToBytesAsHex txhash) + , textShowN 6 index + , " " <> printableValue value + ] ShelleyBasedEraAlonzo -> let (TxIn (TxId txhash) (TxIx index), TxOut _ value mDatum _) = txInOutTuple - in mconcat - [ Text.decodeLatin1 (hashToBytesAsHex txhash) - , textShowN 6 index - , " " <> printableValue value <> " + " <> Text.pack (show mDatum) - ] + in mconcat + [ Text.decodeLatin1 (hashToBytesAsHex txhash) + , textShowN 6 index + , " " <> printableValue value <> " + " <> Text.pack (show mDatum) + ] ShelleyBasedEraBabbage -> let (TxIn (TxId txhash) (TxIx index), TxOut _ value mDatum _) = txInOutTuple - in mconcat - [ Text.decodeLatin1 (hashToBytesAsHex txhash) - , textShowN 6 index - , " " <> printableValue value <> " + " <> Text.pack (show mDatum) - ] + in mconcat + [ Text.decodeLatin1 (hashToBytesAsHex txhash) + , textShowN 6 index + , " " <> printableValue value <> " + " <> Text.pack (show mDatum) + ] ShelleyBasedEraConway -> let (TxIn (TxId txhash) (TxIx index), TxOut _ value mDatum _) = txInOutTuple - in mconcat - [ Text.decodeLatin1 (hashToBytesAsHex txhash) - , textShowN 6 index - , " " <> printableValue value <> " + " <> Text.pack (show mDatum) - ] + in mconcat + [ Text.decodeLatin1 (hashToBytesAsHex txhash) + , textShowN 6 index + , " " <> printableValue value <> " + " <> Text.pack (show mDatum) + ] where textShowN :: Show a => Int -> a -> Text textShowN len x = let str = show x slen = length str - in Text.pack $ replicate (max 1 (len - slen)) ' ' ++ str + in Text.pack $ replicate (max 1 (len - slen)) ' ' ++ str printableValue :: TxOutValue era -> Text printableValue = \case TxOutValueByron (L.Coin i) -> Text.pack $ show i TxOutValueShelleyBased sbe2 val -> renderValue $ Api.fromLedgerValue sbe2 val -runQueryStakePoolsCmd :: () +runQueryStakePoolsCmd + :: () => Cmd.QueryStakePoolsCmdArgs -> ExceptT QueryCmdError IO () runQueryStakePoolsCmd - Cmd.QueryStakePoolsCmdArgs + Cmd.QueryStakePoolsCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -1154,22 +1279,26 @@ runQueryStakePoolsCmd , Cmd.format , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT @QueryCmdError $ do - AnyCardanoEra era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT @QueryCmdError $ do + AnyCardanoEra era <- lift queryCurrentEra & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - poolIds <- lift (queryStakePools sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdEraMismatch) + poolIds <- + lift (queryStakePools sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdEraMismatch) - pure $ writeStakePools (newOutputFormat format mOutFile) mOutFile poolIds - ) & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ writeStakePools (newOutputFormat format mOutFile) mOutFile poolIds + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left -- TODO: replace with writeFormattedOutput writeStakePools @@ -1179,16 +1308,16 @@ writeStakePools -> ExceptT QueryCmdError IO () writeStakePools format mOutFile stakePools = firstExceptT QueryCmdWriteFileError . newExceptT $ - writeLazyByteStringOutput mOutFile toWrite - where - toWrite :: LBS.ByteString = - case format of - OutputFormatText -> - LBS.unlines - $ map (strictTextToLazyBytestring . serialiseToBech32) - $ Set.toList stakePools - OutputFormatJson -> - encodePretty stakePools + writeLazyByteStringOutput mOutFile toWrite + where + toWrite :: LBS.ByteString = + case format of + OutputFormatText -> + LBS.unlines $ + map (strictTextToLazyBytestring . serialiseToBech32) $ + Set.toList stakePools + OutputFormatJson -> + encodePretty stakePools writeFormattedOutput :: MonadIOTransError QueryCmdError t m @@ -1200,18 +1329,19 @@ writeFormattedOutput -> t m () writeFormattedOutput mFormat mOutFile value = modifyError QueryCmdWriteFileError . hoistIOEither $ - writeLazyByteStringOutput mOutFile toWrite - where - toWrite :: LBS.ByteString = - case newOutputFormat mFormat mOutFile of - OutputFormatText -> fromString . docToString $ pretty value - OutputFormatJson -> encodePretty value - -runQueryStakeDistributionCmd :: () + writeLazyByteStringOutput mOutFile toWrite + where + toWrite :: LBS.ByteString = + case newOutputFormat mFormat mOutFile of + OutputFormatText -> fromString . docToString $ pretty value + OutputFormatJson -> encodePretty value + +runQueryStakeDistributionCmd + :: () => Cmd.QueryStakeDistributionCmdArgs -> ExceptT QueryCmdError IO () runQueryStakeDistributionCmd - Cmd.QueryStakeDistributionCmdArgs + Cmd.QueryStakeDistributionCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -1219,25 +1349,29 @@ runQueryStakeDistributionCmd , Cmd.target , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) - result <- lift (queryStakeDistribution sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + result <- + lift (queryStakeDistribution sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - pure $ do - writeStakeDistribution (newOutputFormat format mOutFile) mOutFile result - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left + pure $ do + writeStakeDistribution (newOutputFormat format mOutFile) mOutFile result + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left writeStakeDistribution :: OutputFormatJsonOrText @@ -1245,36 +1379,36 @@ writeStakeDistribution -> Map PoolId Rational -> ExceptT QueryCmdError IO () writeStakeDistribution format mOutFile stakeDistrib = - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile toWrite - where - toWrite :: LBS.ByteString = - case format of - OutputFormatJson -> encodePretty stakeDistrib - OutputFormatText -> strictTextToLazyBytestring stakeDistributionText - stakeDistributionText = - Text.unlines $ - [ title - , Text.replicate (Text.length title + 2) "-" - ] ++ - [ showStakeDistr poolId stakeFraction | (poolId, stakeFraction) <- Map.toList stakeDistrib ] - where - title :: Text - title = - " PoolId Stake frac" - showStakeDistr :: PoolId -> Rational -> Text - showStakeDistr poolId stakeFraction = - mconcat - [ serialiseToBech32 poolId - , " " - , Text.pack $ showEFloat (Just 3) (fromRational stakeFraction :: Double) "" - ] + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile toWrite + where + toWrite :: LBS.ByteString = + case format of + OutputFormatJson -> encodePretty stakeDistrib + OutputFormatText -> strictTextToLazyBytestring stakeDistributionText + stakeDistributionText = + Text.unlines $ + [ title + , Text.replicate (Text.length title + 2) "-" + ] + ++ [showStakeDistr poolId stakeFraction | (poolId, stakeFraction) <- Map.toList stakeDistrib] + where + title :: Text + title = + " PoolId Stake frac" + showStakeDistr :: PoolId -> Rational -> Text + showStakeDistr poolId stakeFraction = + mconcat + [ serialiseToBech32 poolId + , " " + , Text.pack $ showEFloat (Just 3) (fromRational stakeFraction :: Double) "" + ] runQueryLeadershipScheduleCmd :: Cmd.QueryLeadershipScheduleCmdArgs -> ExceptT QueryCmdError IO () runQueryLeadershipScheduleCmd - Cmd.QueryLeadershipScheduleCmdArgs + Cmd.QueryLeadershipScheduleCmdArgs { Cmd.nodeSocketPath , Cmd.consensusModeParams , Cmd.networkId @@ -1286,96 +1420,118 @@ runQueryLeadershipScheduleCmd , Cmd.format , Cmd.mOutFile } = do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - - poolid <- modifyError QueryCmdTextReadError $ - readVerificationKeyOrHashOrFile AsStakePoolKey poolColdVerKeyFile - - vrkSkey <- modifyError QueryCmdTextEnvelopeReadError . hoistIOEither $ - readFileTextEnvelope (AsSigningKey AsVrfKey) vrkSkeyFp - - shelleyGenesis <- modifyError QueryCmdGenesisReadError . hoistIOEither $ - readAndDecodeGenesisFile @(ShelleyGenesis StandardCrypto) genFile - - join $ lift - ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - AnyCardanoEra era <- lift queryCurrentEra - & onLeft (left . QueryCmdUnsupportedNtcVersion) - - sbe <- requireShelleyBasedEra era - & onNothing (left QueryCmdByronEra) - - pparams <- lift (queryProtocolParameters sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - ptclState <- lift (queryProtocolState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - eraHistory <- lift queryEraHistory - & onLeft (left . QueryCmdUnsupportedNtcVersion) - - let eInfo = toEpochInfo eraHistory - - curentEpoch <- lift (queryEpoch sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - case whichSchedule of - CurrentEpoch -> do - beo <- requireEon BabbageEra era - - serCurrentEpochState <- lift (queryPoolDistribution beo (Just (Set.singleton poolid))) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - pure $ do - schedule <- firstExceptT QueryCmdLeaderShipError $ hoistEither - $ shelleyBasedEraConstraints sbe - $ currentEpochEligibleLeadershipSlots - sbe - shelleyGenesis - eInfo - pparams - ptclState - poolid - vrkSkey - serCurrentEpochState - curentEpoch - - writeSchedule mOutFile eInfo shelleyGenesis schedule - - NextEpoch -> do - serCurrentEpochState <- lift (queryCurrentEpochState sbe) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) - - pure $ do - tip <- liftIO $ getLocalChainTip localNodeConnInfo - - schedule <- firstExceptT QueryCmdLeaderShipError $ hoistEither - $ shelleyBasedEraConstraints sbe - $ nextEpochEligibleLeadershipSlots sbe shelleyGenesis - serCurrentEpochState ptclState poolid vrkSkey pparams - eInfo (tip, curentEpoch) - - writeSchedule mOutFile eInfo shelleyGenesis schedule - ) - & onLeft (left . QueryCmdAcquireFailure) - & onLeft left - where + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + + poolid <- + modifyError QueryCmdTextReadError $ + readVerificationKeyOrHashOrFile AsStakePoolKey poolColdVerKeyFile + + vrkSkey <- + modifyError QueryCmdTextEnvelopeReadError . hoistIOEither $ + readFileTextEnvelope (AsSigningKey AsVrfKey) vrkSkeyFp + + shelleyGenesis <- + modifyError QueryCmdGenesisReadError . hoistIOEither $ + readAndDecodeGenesisFile @(ShelleyGenesis StandardCrypto) genFile + + join $ + lift + ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do + AnyCardanoEra era <- + lift queryCurrentEra + & onLeft (left . QueryCmdUnsupportedNtcVersion) + + sbe <- + requireShelleyBasedEra era + & onNothing (left QueryCmdByronEra) + + pparams <- + lift (queryProtocolParameters sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + ptclState <- + lift (queryProtocolState sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + eraHistory <- + lift queryEraHistory + & onLeft (left . QueryCmdUnsupportedNtcVersion) + + let eInfo = toEpochInfo eraHistory + + curentEpoch <- + lift (queryEpoch sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + case whichSchedule of + CurrentEpoch -> do + beo <- requireEon BabbageEra era + + serCurrentEpochState <- + lift (queryPoolDistribution beo (Just (Set.singleton poolid))) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + pure $ do + schedule <- + firstExceptT QueryCmdLeaderShipError $ + hoistEither $ + shelleyBasedEraConstraints sbe $ + currentEpochEligibleLeadershipSlots + sbe + shelleyGenesis + eInfo + pparams + ptclState + poolid + vrkSkey + serCurrentEpochState + curentEpoch + + writeSchedule mOutFile eInfo shelleyGenesis schedule + NextEpoch -> do + serCurrentEpochState <- + lift (queryCurrentEpochState sbe) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdLocalStateQueryError . EraMismatchError) + + pure $ do + tip <- liftIO $ getLocalChainTip localNodeConnInfo + + schedule <- + firstExceptT QueryCmdLeaderShipError $ + hoistEither $ + shelleyBasedEraConstraints sbe $ + nextEpochEligibleLeadershipSlots + sbe + shelleyGenesis + serCurrentEpochState + ptclState + poolid + vrkSkey + pparams + eInfo + (tip, curentEpoch) + + writeSchedule mOutFile eInfo shelleyGenesis schedule + ) + & onLeft (left . QueryCmdAcquireFailure) + & onLeft left + where writeSchedule mOutFile' eInfo shelleyGenesis schedule = - firstExceptT QueryCmdWriteFileError . newExceptT - $ writeLazyByteStringOutput mOutFile' toWrite - where - start = SystemStart $ sgSystemStart shelleyGenesis - toWrite = - case newOutputFormat format mOutFile' of - OutputFormatJson -> - encodePretty $ leadershipScheduleToJson schedule eInfo start - OutputFormatText -> - strictTextToLazyBytestring $ leadershipScheduleToText schedule eInfo start + firstExceptT QueryCmdWriteFileError . newExceptT $ + writeLazyByteStringOutput mOutFile' toWrite + where + start = SystemStart $ sgSystemStart shelleyGenesis + toWrite = + case newOutputFormat format mOutFile' of + OutputFormatJson -> + encodePretty $ leadershipScheduleToJson schedule eInfo start + OutputFormatText -> + strictTextToLazyBytestring $ leadershipScheduleToText schedule eInfo start leadershipScheduleToText :: Set SlotNo @@ -1385,29 +1541,29 @@ runQueryLeadershipScheduleCmd leadershipScheduleToText leadershipSlots eInfo sStart = do Text.unlines $ title - : Text.replicate (Text.length title + 2) "-" - : [ showLeadershipSlot slot eInfo sStart | slot <- Set.toList leadershipSlots ] - where - title :: Text - title = - " SlotNo UTC Time " - - showLeadershipSlot - :: SlotNo - -> EpochInfo (Either Text) - -> SystemStart - -> Text - showLeadershipSlot lSlot@(SlotNo sn) eInfo' sStart' = - case epochInfoSlotToUTCTime eInfo' sStart' lSlot of - Right slotTime -> - mconcat + : Text.replicate (Text.length title + 2) "-" + : [showLeadershipSlot slot eInfo sStart | slot <- Set.toList leadershipSlots] + where + title :: Text + title = + " SlotNo UTC Time " + + showLeadershipSlot + :: SlotNo + -> EpochInfo (Either Text) + -> SystemStart + -> Text + showLeadershipSlot lSlot@(SlotNo sn) eInfo' sStart' = + case epochInfoSlotToUTCTime eInfo' sStart' lSlot of + Right slotTime -> + mconcat [ " " , Text.pack $ show sn , " " , Text.pack $ show slotTime ] - Left err -> - mconcat + Left err -> + mconcat [ " " , Text.pack $ show sn , " " @@ -1420,193 +1576,206 @@ runQueryLeadershipScheduleCmd -> [Aeson.Value] leadershipScheduleToJson leadershipSlots eInfo sStart = showLeadershipSlot <$> List.sort (Set.toList leadershipSlots) - where - showLeadershipSlot :: SlotNo -> Aeson.Value - showLeadershipSlot lSlot@(SlotNo sn) = - case epochInfoSlotToUTCTime eInfo sStart lSlot of - Right slotTime -> - Aeson.object - [ "slotNumber" Aeson..= sn - , "slotTime" Aeson..= slotTime - ] - Left err -> - Aeson.object - [ "slotNumber" Aeson..= sn - , "error" Aeson..= Text.unpack err - ] + where + showLeadershipSlot :: SlotNo -> Aeson.Value + showLeadershipSlot lSlot@(SlotNo sn) = + case epochInfoSlotToUTCTime eInfo sStart lSlot of + Right slotTime -> + Aeson.object + [ "slotNumber" Aeson..= sn + , "slotTime" Aeson..= slotTime + ] + Left err -> + Aeson.object + [ "slotNumber" Aeson..= sn + , "error" Aeson..= Text.unpack err + ] runQueryConstitution :: Cmd.QueryNoArgCmdArgs era -> ExceptT QueryCmdError IO () runQueryConstitution - Cmd.QueryNoArgCmdArgs - { Cmd.eon - , Cmd.nodeSocketPath - , Cmd.consensusModeParams - , Cmd.networkId - , Cmd.target - , Cmd.mOutFile - } = conwayEraOnwardsConstraints eon $ do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - constitution <- runQuery localNodeConnInfo target $ queryConstitution eon - writeOutput mOutFile constitution + Cmd.QueryNoArgCmdArgs + { Cmd.eon + , Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.target + , Cmd.mOutFile + } = conwayEraOnwardsConstraints eon $ do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + constitution <- runQuery localNodeConnInfo target $ queryConstitution eon + writeOutput mOutFile constitution runQueryGovState :: Cmd.QueryNoArgCmdArgs era -> ExceptT QueryCmdError IO () runQueryGovState - Cmd.QueryNoArgCmdArgs - { Cmd.eon - , Cmd.nodeSocketPath - , Cmd.consensusModeParams - , Cmd.networkId - , Cmd.target - , Cmd.mOutFile - } = conwayEraOnwardsConstraints eon $ do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - govState <- runQuery localNodeConnInfo target $ queryGovState eon - writeOutput mOutFile govState + Cmd.QueryNoArgCmdArgs + { Cmd.eon + , Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.target + , Cmd.mOutFile + } = conwayEraOnwardsConstraints eon $ do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + govState <- runQuery localNodeConnInfo target $ queryGovState eon + writeOutput mOutFile govState runQueryDRepState :: Cmd.QueryDRepStateCmdArgs era -> ExceptT QueryCmdError IO () runQueryDRepState - Cmd.QueryDRepStateCmdArgs - { Cmd.eon - , Cmd.nodeSocketPath - , Cmd.consensusModeParams - , Cmd.networkId - , Cmd.drepHashSources = drepHashSources' - , Cmd.includeStake - , Cmd.target - , Cmd.mOutFile - } = conwayEraOnwardsConstraints eon $ do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - - let drepHashSources = case drepHashSources' of All -> []; Only l -> l - drepCreds <- modifyError QueryCmdDRepKeyError $ mapM readDRepCredential drepHashSources - - drepState <- runQuery localNodeConnInfo target $ queryDRepState eon $ Set.fromList drepCreds - - drepStakeDistribution <- - case includeStake of - Cmd.WithStake -> runQuery localNodeConnInfo target $ - queryDRepStakeDistribution eon (Set.fromList $ L.DRepCredential <$> drepCreds) - Cmd.NoStake -> return mempty - - writeOutput mOutFile $ - drepStateToJson drepStakeDistribution <$> Map.assocs drepState - where - drepStateToJson :: () + Cmd.QueryDRepStateCmdArgs + { Cmd.eon + , Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.drepHashSources = drepHashSources' + , Cmd.includeStake + , Cmd.target + , Cmd.mOutFile + } = conwayEraOnwardsConstraints eon $ do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + + let drepHashSources = case drepHashSources' of All -> []; Only l -> l + drepCreds <- modifyError QueryCmdDRepKeyError $ mapM readDRepCredential drepHashSources + + drepState <- runQuery localNodeConnInfo target $ queryDRepState eon $ Set.fromList drepCreds + + drepStakeDistribution <- + case includeStake of + Cmd.WithStake -> + runQuery localNodeConnInfo target $ + queryDRepStakeDistribution eon (Set.fromList $ L.DRepCredential <$> drepCreds) + Cmd.NoStake -> return mempty + + writeOutput mOutFile $ + drepStateToJson drepStakeDistribution <$> Map.assocs drepState + where + drepStateToJson + :: () => ToJSON a => Map (L.DRep StandardCrypto) a -> (L.Credential L.DRepRole StandardCrypto, L.DRepState StandardCrypto) -> (L.Credential L.DRepRole StandardCrypto, A.Value) - drepStateToJson stakeDistr (cred, ds) = (cred, A.object $ - [ "expiry" .= (ds ^. L.drepExpiryL) - , "anchor" .= (ds ^. L.drepAnchorL) - , "deposit" .= (ds ^. L.drepDepositL) - ] <> - (case includeStake of - Cmd.WithStake -> [ "stake" .= Map.lookup (L.DRepCredential cred) stakeDistr ] - Cmd.NoStake -> [])) + drepStateToJson stakeDistr (cred, ds) = + ( cred + , A.object $ + [ "expiry" .= (ds ^. L.drepExpiryL) + , "anchor" .= (ds ^. L.drepAnchorL) + , "deposit" .= (ds ^. L.drepDepositL) + ] + <> ( case includeStake of + Cmd.WithStake -> ["stake" .= Map.lookup (L.DRepCredential cred) stakeDistr] + Cmd.NoStake -> [] + ) + ) runQueryDRepStakeDistribution :: Cmd.QueryDRepStakeDistributionCmdArgs era -> ExceptT QueryCmdError IO () runQueryDRepStakeDistribution - Cmd.QueryDRepStakeDistributionCmdArgs - { Cmd.eon - , Cmd.nodeSocketPath - , Cmd.consensusModeParams - , Cmd.networkId - , Cmd.drepHashSources = drepHashSources' - , Cmd.target - , Cmd.mOutFile - } = conwayEraOnwardsConstraints eon $ do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - - let drepFromSource = fmap L.DRepCredential - . firstExceptT QueryCmdDRepKeyError - . readDRepCredential - drepHashSources = case drepHashSources' of - All -> [] - Only l -> l - dreps <- Set.fromList <$> mapM drepFromSource drepHashSources - - drepStakeDistribution <- runQuery localNodeConnInfo target $ queryDRepStakeDistribution eon dreps - writeOutput mOutFile $ - Map.assocs drepStakeDistribution + Cmd.QueryDRepStakeDistributionCmdArgs + { Cmd.eon + , Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.drepHashSources = drepHashSources' + , Cmd.target + , Cmd.mOutFile + } = conwayEraOnwardsConstraints eon $ do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + + let drepFromSource = + fmap L.DRepCredential + . firstExceptT QueryCmdDRepKeyError + . readDRepCredential + drepHashSources = case drepHashSources' of + All -> [] + Only l -> l + dreps <- Set.fromList <$> mapM drepFromSource drepHashSources + + drepStakeDistribution <- runQuery localNodeConnInfo target $ queryDRepStakeDistribution eon dreps + writeOutput mOutFile $ + Map.assocs drepStakeDistribution runQueryCommitteeMembersState :: Cmd.QueryCommitteeMembersStateCmdArgs era -> ExceptT QueryCmdError IO () runQueryCommitteeMembersState - Cmd.QueryCommitteeMembersStateCmdArgs - { Cmd.eon - , Cmd.nodeSocketPath - , Cmd.consensusModeParams - , Cmd.networkId - , Cmd.target - , Cmd.mOutFile - , Cmd.committeeColdKeys = coldCredKeys - , Cmd.committeeHotKeys = hotCredKeys - , Cmd.memberStatuses = memberStatuses - } = conwayEraOnwardsConstraints eon $ do - let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath - - let coldKeysFromVerKeyHashOrFile = - modifyError QueryCmdCommitteeColdKeyError . readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeColdKey unCommitteeColdKeyHash - coldKeys <- Set.fromList <$> mapM coldKeysFromVerKeyHashOrFile coldCredKeys - - let hotKeysFromVerKeyHashOrFile = - modifyError QueryCmdCommitteeHotKeyError . readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeHotKey unCommitteeHotKeyHash - hotKeys <- Set.fromList <$> mapM hotKeysFromVerKeyHashOrFile hotCredKeys - - committeeState <- runQuery localNodeConnInfo target $ - queryCommitteeMembersState eon coldKeys hotKeys (Set.fromList memberStatuses) - writeOutput mOutFile $ A.toJSON committeeState - -runQuery :: LocalNodeConnectInfo - -> Consensus.Target ChainPoint - -> LocalStateQueryExpr - BlockInMode - ChainPoint - QueryInMode - () - IO - (Either - UnsupportedNtcVersionError - (Either Consensus.EraMismatch a)) - -> ExceptT QueryCmdError IO a + Cmd.QueryCommitteeMembersStateCmdArgs + { Cmd.eon + , Cmd.nodeSocketPath + , Cmd.consensusModeParams + , Cmd.networkId + , Cmd.target + , Cmd.mOutFile + , Cmd.committeeColdKeys = coldCredKeys + , Cmd.committeeHotKeys = hotCredKeys + , Cmd.memberStatuses = memberStatuses + } = conwayEraOnwardsConstraints eon $ do + let localNodeConnInfo = LocalNodeConnectInfo consensusModeParams networkId nodeSocketPath + + let coldKeysFromVerKeyHashOrFile = + modifyError QueryCmdCommitteeColdKeyError + . readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeColdKey unCommitteeColdKeyHash + coldKeys <- Set.fromList <$> mapM coldKeysFromVerKeyHashOrFile coldCredKeys + + let hotKeysFromVerKeyHashOrFile = + modifyError QueryCmdCommitteeHotKeyError + . readVerificationKeyOrHashOrFileOrScriptHash AsCommitteeHotKey unCommitteeHotKeyHash + hotKeys <- Set.fromList <$> mapM hotKeysFromVerKeyHashOrFile hotCredKeys + + committeeState <- + runQuery localNodeConnInfo target $ + queryCommitteeMembersState eon coldKeys hotKeys (Set.fromList memberStatuses) + writeOutput mOutFile $ A.toJSON committeeState + +runQuery + :: LocalNodeConnectInfo + -> Consensus.Target ChainPoint + -> LocalStateQueryExpr + BlockInMode + ChainPoint + QueryInMode + () + IO + ( Either + UnsupportedNtcVersionError + (Either Consensus.EraMismatch a) + ) + -> ExceptT QueryCmdError IO a runQuery localNodeConnInfo target query = - firstExceptT QueryCmdAcquireFailure - ( newExceptT $ executeLocalStateQueryExpr localNodeConnInfo target query) - & onLeft (left . QueryCmdUnsupportedNtcVersion) - & onLeft (left . QueryCmdEraMismatch) - -writeOutput :: ToJSON b - => Maybe (File a Out) - -> b - -> ExceptT QueryCmdError IO () + firstExceptT + QueryCmdAcquireFailure + (newExceptT $ executeLocalStateQueryExpr localNodeConnInfo target query) + & onLeft (left . QueryCmdUnsupportedNtcVersion) + & onLeft (left . QueryCmdEraMismatch) + +writeOutput + :: ToJSON b + => Maybe (File a Out) + -> b + -> ExceptT QueryCmdError IO () writeOutput mOutFile content = case mOutFile of Nothing -> liftIO . LBS.putStrLn . encodePretty $ content Just (File f) -> handleIOExceptT (QueryCmdWriteFileError . FileIOError f) $ LBS.writeFile f (encodePretty content) - -- Helpers toEpochInfo :: EraHistory -> EpochInfo (Either Text) toEpochInfo (EraHistory interpreter) = - hoistEpochInfo (first (Text.pack . show) . runExcept) - $ Consensus.interpreterToEpochInfo interpreter + hoistEpochInfo (first (Text.pack . show) . runExcept) $ + Consensus.interpreterToEpochInfo interpreter -- | A value that is tentative or produces a tentative value if used. These values -- are considered accurate only if some future event such as a hard fork does not -- render them invalid. -newtype Tentative a = Tentative { tentative :: a } deriving (Eq, Show) +newtype Tentative a = Tentative {tentative :: a} deriving (Eq, Show) -- | Get an Epoch Info that computes tentative values. The values computed are -- tentative because it uses an interpreter that is extended past the horizon. @@ -1615,10 +1784,9 @@ newtype Tentative a = Tentative { tentative :: a } deriving (Eq, Show) -- "tentative" because they can change in the event of a hard fork. toTentativeEpochInfo :: EraHistory -> Tentative (EpochInfo (Either Text)) toTentativeEpochInfo (EraHistory interpreter) = - Tentative - $ hoistEpochInfo (first (Text.pack . show) . runExcept) - $ Consensus.interpreterToEpochInfo (Consensus.unsafeExtendSafeZone interpreter) - + Tentative $ + hoistEpochInfo (first (Text.pack . show) . runExcept) $ + Consensus.interpreterToEpochInfo (Consensus.unsafeExtendSafeZone interpreter) -- | Get slot number for timestamp, or an error if the UTC timestamp is before 'SystemStart' or after N+1 era utcTimeToSlotNo @@ -1633,11 +1801,13 @@ utcTimeToSlotNo nodeSocketPath consensusModeParams networkId target utcTime = do lift ( executeLocalStateQueryExpr localNodeConnInfo target $ runExceptT $ do - systemStart <- lift querySystemStart - & onLeft (left . QueryCmdUnsupportedNtcVersion) + systemStart <- + lift querySystemStart + & onLeft (left . QueryCmdUnsupportedNtcVersion) - eraHistory <- lift queryEraHistory - & onLeft (left . QueryCmdUnsupportedNtcVersion) + eraHistory <- + lift queryEraHistory + & onLeft (left . QueryCmdUnsupportedNtcVersion) let relTime = toRelativeTime systemStart utcTime @@ -1647,15 +1817,20 @@ utcTimeToSlotNo nodeSocketPath consensusModeParams networkId target utcTime = do & onLeft (left . QueryCmdAcquireFailure) & onLeft left - -requireEon :: forall eon era minEra m. (Eon eon, Monad m) - => CardanoEra minEra -- ^ minimal required era i.e. for 'ConwayEraOnwards' eon it's 'Conway' - -> CardanoEra era -- ^ node era - -> ExceptT QueryCmdError m (eon era) +requireEon + :: forall eon era minEra m + . (Eon eon, Monad m) + => CardanoEra minEra + -- ^ minimal required era i.e. for 'ConwayEraOnwards' eon it's 'Conway' + -> CardanoEra era + -- ^ node era + -> ExceptT QueryCmdError m (eon era) -- TODO: implement 'Bounded' for `Some eon` and remove 'minEra' requireEon minEra era = hoistMaybe - (QueryCmdLocalStateQueryError $ mkEraMismatchError NodeEraMismatchError { nodeEra = era, era = minEra }) + ( QueryCmdLocalStateQueryError $ + mkEraMismatchError NodeEraMismatchError{nodeEra = era, era = minEra} + ) (forEraMaybeEon era) -- | The output format to use, for commands with a recently introduced --output-[json,text] flag @@ -1666,7 +1841,7 @@ newOutputFormat format mOutFile = case (format, mOutFile) of (Just f, _) -> f -- Take flag from CLI if specified (Nothing, Nothing) -> OutputFormatText -- No CLI flag, writing to stdout: write text - (Nothing, Just _) -> OutputFormatJson -- No CLI flag, writing to a file: write JSON + (Nothing, Just _) -> OutputFormatJson -- No CLI flag, writing to a file: write JSON strictTextToLazyBytestring :: Text -> LBS.ByteString strictTextToLazyBytestring t = BS.fromChunks [Text.encodeUtf8 t] diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/StakeAddress.hs index 60fb15c2a6..9ce90fc675 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/StakeAddress.hs @@ -9,14 +9,14 @@ module Cardano.CLI.EraBased.Run.StakeAddress ( runStakeAddressCmds - , runStakeAddressBuildCmd , runStakeAddressKeyGenCmd , runStakeAddressKeyHashCmd , runStakeAddressStakeDelegationCertificateCmd , runStakeAddressDeregistrationCertificateCmd , runStakeAddressRegistrationCertificateCmd - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -36,7 +36,8 @@ import qualified Data.ByteString.Char8 as BS import Data.Function ((&)) import qualified Data.Text.IO as Text -runStakeAddressCmds :: () +runStakeAddressCmds + :: () => StakeAddressCmds era -> ExceptT StakeAddressCmdError IO () runStakeAddressCmds = \case @@ -50,14 +51,25 @@ runStakeAddressCmds = \case runStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit outputFp StakeAddressStakeDelegationCertificateCmd sbe stakeIdentifier stkPoolVerKeyHashOrFp outputFp -> runStakeAddressStakeDelegationCertificateCmd sbe stakeIdentifier stkPoolVerKeyHashOrFp outputFp - StakeAddressStakeAndVoteDelegationCertificateCmd w stakeIdentifier stakePoolVerificationKeyHashSource voteDelegationTarget outputFp -> - runStakeAddressStakeAndVoteDelegationCertificateCmd w stakeIdentifier stakePoolVerificationKeyHashSource voteDelegationTarget outputFp + StakeAddressStakeAndVoteDelegationCertificateCmd + w + stakeIdentifier + stakePoolVerificationKeyHashSource + voteDelegationTarget + outputFp -> + runStakeAddressStakeAndVoteDelegationCertificateCmd + w + stakeIdentifier + stakePoolVerificationKeyHashSource + voteDelegationTarget + outputFp StakeAddressVoteDelegationCertificateCmd w stakeIdentifier voteDelegationTarget outputFp -> runStakeAddressVoteDelegationCertificateCmd w stakeIdentifier voteDelegationTarget outputFp StakeAddressDeregistrationCertificateCmd sbe stakeIdentifier mDeposit outputFp -> runStakeAddressDeregistrationCertificateCmd sbe stakeIdentifier mDeposit outputFp -runStakeAddressKeyGenCmd :: () +runStakeAddressKeyGenCmd + :: () => KeyOutputFormat -> VerificationKeyFile Out -> SigningKeyFile Out @@ -83,13 +95,15 @@ runStakeAddressKeyGenCmd fmt vkFp skFp = do newExceptT $ writeTextFile vkFp $ serialiseToBech32 vkey return (vkey, skey) -runStakeAddressKeyHashCmd :: () +runStakeAddressKeyHashCmd + :: () => VerificationKeyOrFile StakeKey -> Maybe (File () Out) -> ExceptT StakeAddressCmdError IO () runStakeAddressKeyHashCmd stakeVerKeyOrFile mOutputFp = do - vkey <- modifyError StakeAddressCmdReadKeyFileError $ - readVerificationKeyOrFile AsStakeKey stakeVerKeyOrFile + vkey <- + modifyError StakeAddressCmdReadKeyFileError $ + readVerificationKeyOrFile AsStakeKey stakeVerKeyOrFile let hexKeyHash = serialiseToRawBytesHex (verificationKeyHash vkey) @@ -97,7 +111,8 @@ runStakeAddressKeyHashCmd stakeVerKeyOrFile mOutputFp = do Just (File fpath) -> liftIO $ BS.writeFile fpath hexKeyHash Nothing -> liftIO $ BS.putStrLn hexKeyHash -runStakeAddressBuildCmd :: () +runStakeAddressBuildCmd + :: () => StakeVerifier -> NetworkId -> Maybe (File () Out) @@ -112,11 +127,12 @@ runStakeAddressBuildCmd stakeVerifier network mOutputFp = do Just (File fpath) -> Text.writeFile fpath stakeAddrText Nothing -> Text.putStrLn stakeAddrText - -runStakeAddressRegistrationCertificateCmd :: () +runStakeAddressRegistrationCertificateCmd + :: () => ShelleyBasedEra era -> StakeIdentifier - -> Maybe L.Coin -- ^ Deposit required in conway era + -> Maybe L.Coin + -- ^ Deposit required in conway era -> File () Out -> ExceptT StakeAddressCmdError IO () runStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit oFp = do @@ -124,8 +140,10 @@ runStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit oFp = do getStakeCredentialFromIdentifier stakeIdentifier & firstExceptT StakeAddressCmdStakeCredentialError - req <- firstExceptT StakeAddressCmdRegistrationError - . hoistEither $ createRegistrationCertRequirements sbe stakeCred mDeposit + req <- + firstExceptT StakeAddressCmdRegistrationError + . hoistEither + $ createRegistrationCertRequirements sbe stakeCred mDeposit let regCert = makeStakeAddressRegistrationCertificate req @@ -134,15 +152,16 @@ runStakeAddressRegistrationCertificateCmd sbe stakeIdentifier mDeposit oFp = do $ writeLazyByteStringFile oFp $ shelleyBasedEraConstraints sbe $ textEnvelopeToJSON (Just regCertDesc) regCert + where + regCertDesc :: TextEnvelopeDescr + regCertDesc = "Stake Address Registration Certificate" - where - regCertDesc :: TextEnvelopeDescr - regCertDesc = "Stake Address Registration Certificate" - -createRegistrationCertRequirements :: () +createRegistrationCertRequirements + :: () => ShelleyBasedEra era -> StakeCredential - -> Maybe L.Coin -- ^ Deposit required in conway era + -> Maybe L.Coin + -- ^ Deposit required in conway era -> Either StakeAddressRegistrationError (StakeAddressRequirements era) createRegistrationCertRequirements sbe stakeCred mdeposit = case sbe of @@ -165,7 +184,8 @@ createRegistrationCertRequirements sbe stakeCred mdeposit = Just dep -> return $ StakeAddrRegistrationConway ConwayEraOnwardsConway dep stakeCred -runStakeAddressStakeDelegationCertificateCmd :: () +runStakeAddressStakeDelegationCertificateCmd + :: () => ShelleyBasedEra era -> StakeIdentifier -- ^ Delegator stake verification key, verification key file or script file. @@ -176,8 +196,9 @@ runStakeAddressStakeDelegationCertificateCmd :: () -> ExceptT StakeAddressCmdError IO () runStakeAddressStakeDelegationCertificateCmd sbe stakeVerifier poolVKeyOrHashOrFile outFp = shelleyBasedEraConstraints sbe $ do - poolStakeVKeyHash <- modifyError StakeAddressCmdReadKeyFileError $ - readVerificationKeyOrHashOrFile AsStakePoolKey poolVKeyOrHashOrFile + poolStakeVKeyHash <- + modifyError StakeAddressCmdReadKeyFileError $ + readVerificationKeyOrHashOrFile AsStakePoolKey poolVKeyOrHashOrFile stakeCred <- getStakeCredentialFromIdentifier stakeVerifier @@ -190,7 +211,8 @@ runStakeAddressStakeDelegationCertificateCmd sbe stakeVerifier poolVKeyOrHashOrF $ writeLazyByteStringFile outFp $ textEnvelopeToJSON (Just @TextEnvelopeDescr "Stake Delegation Certificate") certificate -runStakeAddressStakeAndVoteDelegationCertificateCmd :: () +runStakeAddressStakeAndVoteDelegationCertificateCmd + :: () => ConwayEraOnwards era -> StakeIdentifier -- ^ Delegator stake verification key, verification key file or script file. @@ -202,11 +224,13 @@ runStakeAddressStakeAndVoteDelegationCertificateCmd :: () -> ExceptT StakeAddressCmdError IO () runStakeAddressStakeAndVoteDelegationCertificateCmd w stakeVerifier poolVKeyOrHashOrFile voteDelegationTarget outFp = conwayEraOnwardsConstraints w $ do - StakePoolKeyHash poolStakeVKeyHash <- modifyError StakeAddressCmdReadKeyFileError $ - readVerificationKeyOrHashOrFile AsStakePoolKey poolVKeyOrHashOrFile + StakePoolKeyHash poolStakeVKeyHash <- + modifyError StakeAddressCmdReadKeyFileError $ + readVerificationKeyOrHashOrFile AsStakePoolKey poolVKeyOrHashOrFile - stakeCredential <- modifyError StakeAddressCmdStakeCredentialError $ - getStakeCredentialFromIdentifier stakeVerifier + stakeCredential <- + modifyError StakeAddressCmdStakeCredentialError $ + getStakeCredentialFromIdentifier stakeVerifier drep <- readVoteDelegationTarget voteDelegationTarget @@ -215,15 +239,16 @@ runStakeAddressStakeAndVoteDelegationCertificateCmd w stakeVerifier poolVKeyOrHa let delegatee = L.DelegStakeVote poolStakeVKeyHash drep let certificate = - ConwayCertificate w - $ L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) delegatee + ConwayCertificate w $ + L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) delegatee firstExceptT StakeAddressCmdWriteFileError . newExceptT $ writeLazyByteStringFile outFp $ textEnvelopeToJSON (Just @TextEnvelopeDescr "Stake and Vote Delegation Certificate") certificate -runStakeAddressVoteDelegationCertificateCmd :: () +runStakeAddressVoteDelegationCertificateCmd + :: () => ConwayEraOnwards era -> StakeIdentifier -- ^ Delegatee stake pool verification key or verification key file or @@ -244,35 +269,40 @@ runStakeAddressVoteDelegationCertificateCmd w stakeVerifier voteDelegationTarget let delegatee = L.DelegVote drep let certificate = - ConwayCertificate w - $ L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) delegatee + ConwayCertificate w $ + L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) delegatee firstExceptT StakeAddressCmdWriteFileError . newExceptT $ writeLazyByteStringFile outFp $ textEnvelopeToJSON (Just @TextEnvelopeDescr "Vote Delegation Certificate") certificate -createStakeDelegationCertificate :: forall era. () +createStakeDelegationCertificate + :: forall era + . () => StakeCredential -> Hash StakePoolKey -> ShelleyBasedEra era -> Certificate era createStakeDelegationCertificate stakeCredential (StakePoolKeyHash poolStakeVKeyHash) = do caseShelleyToBabbageOrConwayEraOnwards - (\w -> - shelleyToBabbageEraConstraints w - $ ShelleyRelatedCertificate w - $ L.mkDelegStakeTxCert (toShelleyStakeCredential stakeCredential) poolStakeVKeyHash) - (\w -> - conwayEraOnwardsConstraints w - $ ConwayCertificate w - $ L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) (L.DelegStake poolStakeVKeyHash) + ( \w -> + shelleyToBabbageEraConstraints w $ + ShelleyRelatedCertificate w $ + L.mkDelegStakeTxCert (toShelleyStakeCredential stakeCredential) poolStakeVKeyHash + ) + ( \w -> + conwayEraOnwardsConstraints w $ + ConwayCertificate w $ + L.mkDelegTxCert (toShelleyStakeCredential stakeCredential) (L.DelegStake poolStakeVKeyHash) ) -runStakeAddressDeregistrationCertificateCmd :: () +runStakeAddressDeregistrationCertificateCmd + :: () => ShelleyBasedEra era -> StakeIdentifier - -> Maybe L.Coin -- ^ Deposit required in conway era + -> Maybe L.Coin + -- ^ Deposit required in conway era -> File () Out -> ExceptT StakeAddressCmdError IO () runStakeAddressDeregistrationCertificateCmd sbe stakeVerifier mDeposit oFp = do @@ -280,8 +310,10 @@ runStakeAddressDeregistrationCertificateCmd sbe stakeVerifier mDeposit oFp = do getStakeCredentialFromIdentifier stakeVerifier & firstExceptT StakeAddressCmdStakeCredentialError - req <- firstExceptT StakeAddressCmdRegistrationError - . hoistEither $ createRegistrationCertRequirements sbe stakeCred mDeposit + req <- + firstExceptT StakeAddressCmdRegistrationError + . hoistEither + $ createRegistrationCertRequirements sbe stakeCred mDeposit let deRegCert = makeStakeAddressUnregistrationCertificate req @@ -290,7 +322,6 @@ runStakeAddressDeregistrationCertificateCmd sbe stakeVerifier mDeposit oFp = do $ writeLazyByteStringFile oFp $ shelleyBasedEraConstraints sbe $ textEnvelopeToJSON (Just deregCertDesc) deRegCert - - where - deregCertDesc :: TextEnvelopeDescr - deregCertDesc = "Stake Address Deregistration Certificate" + where + deregCertDesc :: TextEnvelopeDescr + deregCertDesc = "Stake Address Deregistration Certificate" diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/StakePool.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/StakePool.hs index f4270dc582..fe904eade3 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/StakePool.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/StakePool.hs @@ -7,12 +7,12 @@ module Cardano.CLI.EraBased.Run.StakePool ( runStakePoolCmds - , runStakePoolIdCmd , runStakePoolMetadataHashCmd , runStakePoolRegistrationCertificateCmd , runStakePoolDeregistrationCertificateCmd - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -27,14 +27,15 @@ import Cardano.CLI.Types.Key (readVerificationKeyOrFile) import qualified Data.ByteString.Char8 as BS import Data.Function ((&)) -runStakePoolCmds :: () +runStakePoolCmds + :: () => StakePoolCmds era -> ExceptT StakePoolCmdError IO () runStakePoolCmds = \case - StakePoolDeregistrationCertificateCmd args -> runStakePoolDeregistrationCertificateCmd args - StakePoolIdCmd args -> runStakePoolIdCmd args - StakePoolMetadataHashCmd args -> runStakePoolMetadataHashCmd args - StakePoolRegistrationCertificateCmd args -> runStakePoolRegistrationCertificateCmd args + StakePoolDeregistrationCertificateCmd args -> runStakePoolDeregistrationCertificateCmd args + StakePoolIdCmd args -> runStakePoolIdCmd args + StakePoolMetadataHashCmd args -> runStakePoolMetadataHashCmd args + StakePoolRegistrationCertificateCmd args -> runStakePoolRegistrationCertificateCmd args -- -- Stake pool command implementations @@ -43,124 +44,132 @@ runStakePoolCmds = \case -- | Create a stake pool registration cert. -- TODO: Metadata and more stake pool relay support to be -- added in the future. -runStakePoolRegistrationCertificateCmd :: () +runStakePoolRegistrationCertificateCmd + :: () => StakePoolRegistrationCertificateCmdArgs era -> ExceptT StakePoolCmdError IO () runStakePoolRegistrationCertificateCmd - Cmd.StakePoolRegistrationCertificateCmdArgs - { sbe - , poolVerificationKeyOrFile - , vrfVerificationKeyOrFile - , poolPledge - , poolCost - , poolMargin - , rewardStakeVerificationKeyOrFile - , ownerStakeVerificationKeyOrFiles - , relays - , mMetadata - , network - , outFile - } - = shelleyBasedEraConstraints sbe $ do - -- Pool verification key - stakePoolVerKey <- firstExceptT StakePoolCmdReadKeyFileError - $ readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile - let stakePoolId' = verificationKeyHash stakePoolVerKey - - -- VRF verification key - vrfVerKey <- firstExceptT StakePoolCmdReadKeyFileError - $ readVerificationKeyOrFile AsVrfKey vrfVerificationKeyOrFile - let vrfKeyHash' = verificationKeyHash vrfVerKey - - -- Pool reward account - rwdStakeVerKey <- firstExceptT StakePoolCmdReadKeyFileError - $ readVerificationKeyOrFile AsStakeKey rewardStakeVerificationKeyOrFile - let stakeCred = StakeCredentialByKey (verificationKeyHash rwdStakeVerKey) - rewardAccountAddr = makeStakeAddress network stakeCred - - -- Pool owner(s) - sPoolOwnerVkeys <- - mapM - (firstExceptT StakePoolCmdReadKeyFileError - . readVerificationKeyOrFile AsStakeKey - ) - ownerStakeVerificationKeyOrFiles - let stakePoolOwners' = map verificationKeyHash sPoolOwnerVkeys - - let stakePoolParams = - StakePoolParameters - { stakePoolId = stakePoolId' - , stakePoolVRF = vrfKeyHash' - , stakePoolCost = poolCost - , stakePoolMargin = poolMargin - , stakePoolRewardAccount = rewardAccountAddr - , stakePoolPledge = poolPledge - , stakePoolOwners = stakePoolOwners' - , stakePoolRelays = relays - , stakePoolMetadata = mMetadata - } - - let ledgerStakePoolParams = toShelleyPoolParams stakePoolParams - req = createStakePoolRegistrationRequirements sbe - $ shelleyBasedEraConstraints sbe ledgerStakePoolParams - registrationCert = makeStakePoolRegistrationCertificate req - - firstExceptT StakePoolCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile outFile - $ textEnvelopeToJSON (Just registrationCertDesc) registrationCert - where + Cmd.StakePoolRegistrationCertificateCmdArgs + { sbe + , poolVerificationKeyOrFile + , vrfVerificationKeyOrFile + , poolPledge + , poolCost + , poolMargin + , rewardStakeVerificationKeyOrFile + , ownerStakeVerificationKeyOrFiles + , relays + , mMetadata + , network + , outFile + } = + shelleyBasedEraConstraints sbe $ do + -- Pool verification key + stakePoolVerKey <- + firstExceptT StakePoolCmdReadKeyFileError $ + readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile + let stakePoolId' = verificationKeyHash stakePoolVerKey + + -- VRF verification key + vrfVerKey <- + firstExceptT StakePoolCmdReadKeyFileError $ + readVerificationKeyOrFile AsVrfKey vrfVerificationKeyOrFile + let vrfKeyHash' = verificationKeyHash vrfVerKey + + -- Pool reward account + rwdStakeVerKey <- + firstExceptT StakePoolCmdReadKeyFileError $ + readVerificationKeyOrFile AsStakeKey rewardStakeVerificationKeyOrFile + let stakeCred = StakeCredentialByKey (verificationKeyHash rwdStakeVerKey) + rewardAccountAddr = makeStakeAddress network stakeCred + + -- Pool owner(s) + sPoolOwnerVkeys <- + mapM + ( firstExceptT StakePoolCmdReadKeyFileError + . readVerificationKeyOrFile AsStakeKey + ) + ownerStakeVerificationKeyOrFiles + let stakePoolOwners' = map verificationKeyHash sPoolOwnerVkeys + + let stakePoolParams = + StakePoolParameters + { stakePoolId = stakePoolId' + , stakePoolVRF = vrfKeyHash' + , stakePoolCost = poolCost + , stakePoolMargin = poolMargin + , stakePoolRewardAccount = rewardAccountAddr + , stakePoolPledge = poolPledge + , stakePoolOwners = stakePoolOwners' + , stakePoolRelays = relays + , stakePoolMetadata = mMetadata + } + + let ledgerStakePoolParams = toShelleyPoolParams stakePoolParams + req = + createStakePoolRegistrationRequirements sbe $ + shelleyBasedEraConstraints sbe ledgerStakePoolParams + registrationCert = makeStakePoolRegistrationCertificate req + + firstExceptT StakePoolCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile outFile + $ textEnvelopeToJSON (Just registrationCertDesc) registrationCert + where registrationCertDesc :: TextEnvelopeDescr registrationCertDesc = "Stake Pool Registration Certificate" -createStakePoolRegistrationRequirements :: () +createStakePoolRegistrationRequirements + :: () => ShelleyBasedEra era -> L.PoolParams (L.EraCrypto (ShelleyLedgerEra era)) -> StakePoolRegistrationRequirements era createStakePoolRegistrationRequirements sbe pparams = - case sbe of - ShelleyBasedEraShelley -> - StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraShelley pparams - ShelleyBasedEraAllegra -> - StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraAllegra pparams - ShelleyBasedEraMary -> - StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraMary pparams - ShelleyBasedEraAlonzo -> - StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraAlonzo pparams - ShelleyBasedEraBabbage -> - StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraBabbage pparams - ShelleyBasedEraConway -> - StakePoolRegistrationRequirementsConwayOnwards ConwayEraOnwardsConway pparams - - -runStakePoolDeregistrationCertificateCmd :: () + case sbe of + ShelleyBasedEraShelley -> + StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraShelley pparams + ShelleyBasedEraAllegra -> + StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraAllegra pparams + ShelleyBasedEraMary -> + StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraMary pparams + ShelleyBasedEraAlonzo -> + StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraAlonzo pparams + ShelleyBasedEraBabbage -> + StakePoolRegistrationRequirementsPreConway ShelleyToBabbageEraBabbage pparams + ShelleyBasedEraConway -> + StakePoolRegistrationRequirementsConwayOnwards ConwayEraOnwardsConway pparams + +runStakePoolDeregistrationCertificateCmd + :: () => StakePoolDeregistrationCertificateCmdArgs era -> ExceptT StakePoolCmdError IO () runStakePoolDeregistrationCertificateCmd - Cmd.StakePoolDeregistrationCertificateCmdArgs - { sbe - , poolVerificationKeyOrFile - , retireEpoch - , outFile - } = - shelleyBasedEraConstraints sbe $ do - -- Pool verification key - stakePoolVerKey <- firstExceptT StakePoolCmdReadKeyFileError - $ readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile - - let stakePoolId' = verificationKeyHash stakePoolVerKey - req = createStakePoolRetirementRequirements sbe stakePoolId' retireEpoch - retireCert = makeStakePoolRetirementCertificate req - - firstExceptT StakePoolCmdWriteFileError - . newExceptT - $ writeLazyByteStringFile outFile - $ textEnvelopeToJSON (Just retireCertDesc) retireCert - where + Cmd.StakePoolDeregistrationCertificateCmdArgs + { sbe + , poolVerificationKeyOrFile + , retireEpoch + , outFile + } = + shelleyBasedEraConstraints sbe $ do + -- Pool verification key + stakePoolVerKey <- + firstExceptT StakePoolCmdReadKeyFileError $ + readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile + + let stakePoolId' = verificationKeyHash stakePoolVerKey + req = createStakePoolRetirementRequirements sbe stakePoolId' retireEpoch + retireCert = makeStakePoolRetirementCertificate req + + firstExceptT StakePoolCmdWriteFileError + . newExceptT + $ writeLazyByteStringFile outFile + $ textEnvelopeToJSON (Just retireCertDesc) retireCert + where retireCertDesc :: TextEnvelopeDescr retireCertDesc = "Stake Pool Retirement Certificate" -createStakePoolRetirementRequirements :: () +createStakePoolRetirementRequirements + :: () => ShelleyBasedEra era -> PoolId -> L.EpochNo @@ -180,47 +189,51 @@ createStakePoolRetirementRequirements sbe pid epoch = ShelleyBasedEraConway -> StakePoolRetirementRequirementsConwayOnwards ConwayEraOnwardsConway pid epoch -runStakePoolIdCmd :: () +runStakePoolIdCmd + :: () => StakePoolIdCmdArgs era -> ExceptT StakePoolCmdError IO () runStakePoolIdCmd - Cmd.StakePoolIdCmdArgs - { poolVerificationKeyOrFile - , outputFormat - , mOutFile - } = do - stakePoolVerKey <- firstExceptT StakePoolCmdReadKeyFileError - $ readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile - - case outputFormat of - IdOutputFormatHex -> - firstExceptT StakePoolCmdWriteFileError - . newExceptT - $ writeByteStringOutput mOutFile - $ serialiseToRawBytesHex (verificationKeyHash stakePoolVerKey) - IdOutputFormatBech32 -> - firstExceptT StakePoolCmdWriteFileError - . newExceptT - $ writeTextOutput mOutFile - $ serialiseToBech32 (verificationKeyHash stakePoolVerKey) + Cmd.StakePoolIdCmdArgs + { poolVerificationKeyOrFile + , outputFormat + , mOutFile + } = do + stakePoolVerKey <- + firstExceptT StakePoolCmdReadKeyFileError $ + readVerificationKeyOrFile AsStakePoolKey poolVerificationKeyOrFile + + case outputFormat of + IdOutputFormatHex -> + firstExceptT StakePoolCmdWriteFileError + . newExceptT + $ writeByteStringOutput mOutFile + $ serialiseToRawBytesHex (verificationKeyHash stakePoolVerKey) + IdOutputFormatBech32 -> + firstExceptT StakePoolCmdWriteFileError + . newExceptT + $ writeTextOutput mOutFile + $ serialiseToBech32 (verificationKeyHash stakePoolVerKey) -runStakePoolMetadataHashCmd :: () +runStakePoolMetadataHashCmd + :: () => StakePoolMetadataHashCmdArgs era -> ExceptT StakePoolCmdError IO () runStakePoolMetadataHashCmd - Cmd.StakePoolMetadataHashCmdArgs - { poolMetadataFile - , mOutFile - } = do - metadataBytes <- lift (readByteStringFile poolMetadataFile) - & onLeft (left . StakePoolCmdReadFileError) - - (_metadata, metadataHash) <- + Cmd.StakePoolMetadataHashCmdArgs + { poolMetadataFile + , mOutFile + } = do + metadataBytes <- + lift (readByteStringFile poolMetadataFile) + & onLeft (left . StakePoolCmdReadFileError) + + (_metadata, metadataHash) <- firstExceptT StakePoolCmdMetadataValidationError - . hoistEither - $ validateAndHashStakePoolMetadata metadataBytes - case mOutFile of - Nothing -> liftIO $ BS.putStrLn (serialiseToRawBytesHex metadataHash) - Just (File fpath) -> - handleIOExceptT (StakePoolCmdWriteFileError . FileIOError fpath) - $ BS.writeFile fpath (serialiseToRawBytesHex metadataHash) + . hoistEither + $ validateAndHashStakePoolMetadata metadataBytes + case mOutFile of + Nothing -> liftIO $ BS.putStrLn (serialiseToRawBytesHex metadataHash) + Just (File fpath) -> + handleIOExceptT (StakePoolCmdWriteFileError . FileIOError fpath) $ + BS.writeFile fpath (serialiseToRawBytesHex metadataHash) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/TextView.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/TextView.hs index 4c11600d6f..98a458b6e4 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/TextView.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/TextView.hs @@ -3,9 +3,9 @@ module Cardano.CLI.EraBased.Run.TextView ( runTextViewCmds - , runTextViewInfoCmd - ) where + ) +where import Cardano.Api @@ -19,7 +19,8 @@ runTextViewCmds :: TextViewCmds era -> ExceptT TextViewFileError IO () runTextViewCmds = \case TextViewInfo fpath mOutfile -> runTextViewInfoCmd fpath mOutfile -runTextViewInfoCmd :: () +runTextViewInfoCmd + :: () => FilePath -> Maybe (File () Out) -> ExceptT TextViewFileError IO () diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs index 7dac34d604..3b7abb0430 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/Transaction.hs @@ -10,7 +10,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {- HLINT ignore "Unused LANGUAGE pragma" -} @@ -32,7 +31,8 @@ module Cardano.CLI.EraBased.Run.Transaction , runTransactionSignWitnessCmd , toTxOutByronEra , toTxOutInAnyEra - ) where + ) +where import Cardano.Api import Cardano.Api.Byron hiding (SomeByronSigningKey (..)) @@ -80,185 +80,229 @@ import Data.Type.Equality (TestEquality (..)) import Lens.Micro ((^.)) import qualified System.IO as IO - runTransactionCmds :: Cmd.TransactionCmds era -> ExceptT TxCmdError IO () runTransactionCmds = \case - Cmd.TransactionBuildCmd args -> runTransactionBuildCmd args - Cmd.TransactionBuildEstimateCmd args -> runTransactionBuildEstimateCmd args - Cmd.TransactionBuildRawCmd args -> runTransactionBuildRawCmd args - Cmd.TransactionSignCmd args -> runTransactionSignCmd args - Cmd.TransactionSubmitCmd args -> runTransactionSubmitCmd args - Cmd.TransactionCalculateMinFeeCmd args -> runTransactionCalculateMinFeeCmd args + Cmd.TransactionBuildCmd args -> runTransactionBuildCmd args + Cmd.TransactionBuildEstimateCmd args -> runTransactionBuildEstimateCmd args + Cmd.TransactionBuildRawCmd args -> runTransactionBuildRawCmd args + Cmd.TransactionSignCmd args -> runTransactionSignCmd args + Cmd.TransactionSubmitCmd args -> runTransactionSubmitCmd args + Cmd.TransactionCalculateMinFeeCmd args -> runTransactionCalculateMinFeeCmd args Cmd.TransactionCalculateMinValueCmd args -> runTransactionCalculateMinValueCmd args - Cmd.TransactionHashScriptDataCmd args -> runTransactionHashScriptDataCmd args - Cmd.TransactionTxIdCmd args -> runTransactionTxIdCmd args - Cmd.TransactionViewCmd args -> runTransactionViewCmd args - Cmd.TransactionPolicyIdCmd args -> runTransactionPolicyIdCmd args - Cmd.TransactionWitnessCmd args -> runTransactionWitnessCmd args - Cmd.TransactionSignWitnessCmd args -> runTransactionSignWitnessCmd args + Cmd.TransactionHashScriptDataCmd args -> runTransactionHashScriptDataCmd args + Cmd.TransactionTxIdCmd args -> runTransactionTxIdCmd args + Cmd.TransactionViewCmd args -> runTransactionViewCmd args + Cmd.TransactionPolicyIdCmd args -> runTransactionPolicyIdCmd args + Cmd.TransactionWitnessCmd args -> runTransactionWitnessCmd args + Cmd.TransactionSignWitnessCmd args -> runTransactionSignWitnessCmd args -- ---------------------------------------------------------------------------- -- Building transactions -- -runTransactionBuildCmd :: () +runTransactionBuildCmd + :: () => Cmd.TransactionBuildCmdArgs era -> ExceptT TxCmdError IO () runTransactionBuildCmd - Cmd.TransactionBuildCmdArgs - { eon - , nodeSocketPath - , consensusModeParams - , networkId = networkId - , mScriptValidity = mScriptValidity - , mOverrideWitnesses = mOverrideWitnesses - , txins - , readOnlyReferenceInputs - , requiredSigners = reqSigners - , txinsc - , mReturnCollateral = mReturnColl - , mTotalCollateral - , txouts - , changeAddresses - , mValue - , mValidityLowerBound - , mValidityUpperBound - , certificates - , withdrawals - , metadataSchema - , scriptFiles - , metadataFiles - , mUpdateProposalFile - , voteFiles - , proposalFiles - , treasuryDonation -- Maybe TxTreasuryDonation - , buildOutputOptions - } = shelleyBasedEraConstraints eon $ do - let era = toCardanoEra eon - - -- The user can specify an era prior to the era that the node is currently in. - -- We cannot use the user specified era to construct a query against a node because it may differ - -- from the node's era and this will result in the 'QueryEraMismatch' failure. - - let localNodeConnInfo = LocalNodeConnectInfo - { localConsensusModeParams = consensusModeParams - , localNodeNetworkId = networkId - , localNodeSocketPath = nodeSocketPath - } - - inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon txins - certFilesAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon certificates - - -- TODO: Conway Era - How can we make this more composable? - certsAndMaybeScriptWits <- + Cmd.TransactionBuildCmdArgs + { eon + , nodeSocketPath + , consensusModeParams + , networkId = networkId + , mScriptValidity = mScriptValidity + , mOverrideWitnesses = mOverrideWitnesses + , txins + , readOnlyReferenceInputs + , requiredSigners = reqSigners + , txinsc + , mReturnCollateral = mReturnColl + , mTotalCollateral + , txouts + , changeAddresses + , mValue + , mValidityLowerBound + , mValidityUpperBound + , certificates + , withdrawals + , metadataSchema + , scriptFiles + , metadataFiles + , mUpdateProposalFile + , voteFiles + , proposalFiles + , treasuryDonation -- Maybe TxTreasuryDonation + , buildOutputOptions + } = shelleyBasedEraConstraints eon $ do + let era = toCardanoEra eon + + -- The user can specify an era prior to the era that the node is currently in. + -- We cannot use the user specified era to construct a query against a node because it may differ + -- from the node's era and this will result in the 'QueryEraMismatch' failure. + + let localNodeConnInfo = + LocalNodeConnectInfo + { localConsensusModeParams = consensusModeParams + , localNodeNetworkId = networkId + , localNodeSocketPath = nodeSocketPath + } + + inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon txins + certFilesAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ readScriptWitnessFiles eon certificates + + -- TODO: Conway Era - How can we make this more composable? + certsAndMaybeScriptWits <- sequence - [ fmap (,mSwit) (firstExceptT TxCmdReadTextViewFileError . newExceptT $ - readFileTextEnvelope AsCertificate (File certFile)) + [ fmap + (,mSwit) + ( firstExceptT TxCmdReadTextViewFileError . newExceptT $ + readFileTextEnvelope AsCertificate (File certFile) + ) | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits ] - withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError $ - readScriptWitnessFilesTuple eon withdrawals - txMetadata <- firstExceptT TxCmdMetadataError . newExceptT $ - readTxMetadata eon metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue - scripts <- firstExceptT TxCmdScriptFileError $ - mapM (readFileScriptInAnyLang . unFile) scriptFiles - txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts eon scripts - - mProp <- case mUpdateProposalFile of - Just (Featured w (Just updateProposalFile)) -> - readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError - _ -> pure TxUpdateProposalNone - - requiredSigners <- mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners - mReturnCollateral <- forM mReturnColl $ toTxOutInShelleyBasedEra eon - - txOuts <- mapM (toTxOutInAnyEra eon) txouts - - -- Conway related - votingProceduresAndMaybeScriptWits <- - inEonForEra - (pure mempty) - (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles)) - era + withdrawalsAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFilesTuple eon withdrawals + txMetadata <- + firstExceptT TxCmdMetadataError . newExceptT $ + readTxMetadata eon metadataSchema metadataFiles + valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue + scripts <- + firstExceptT TxCmdScriptFileError $ + mapM (readFileScriptInAnyLang . unFile) scriptFiles + txAuxScripts <- + hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts eon scripts + + mProp <- case mUpdateProposalFile of + Just (Featured w (Just updateProposalFile)) -> + readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError + _ -> pure TxUpdateProposalNone + + requiredSigners <- + mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners + mReturnCollateral <- forM mReturnColl $ toTxOutInShelleyBasedEra eon + + txOuts <- mapM (toTxOutInAnyEra eon) txouts + + -- Conway related + votingProceduresAndMaybeScriptWits <- + inEonForEra + (pure mempty) + (\w -> firstExceptT TxCmdVoteError $ ExceptT (readVotingProceduresFiles w voteFiles)) + era + + proposals <- + newExceptT $ + first TxCmdProposalError + <$> readTxGovernanceActions eon proposalFiles - proposals <- newExceptT $ first TxCmdProposalError - <$> readTxGovernanceActions eon proposalFiles - - -- the same collateral input can be used for several plutus scripts - let filteredTxinsc = Set.toList $ Set.fromList txinsc - - let allReferenceInputs = getAllReferenceInputs - inputsAndMaybeScriptWits - (snd valuesWithScriptWits) - certsAndMaybeScriptWits - withdrawalsAndMaybeScriptWits - votingProceduresAndMaybeScriptWits - proposals - readOnlyReferenceInputs - - let inputsThatRequireWitnessing = [input | (input,_) <- inputsAndMaybeScriptWits] - allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ filteredTxinsc - - AnyCardanoEra nodeEra <- lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra) - & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) - & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion) - - (txEraUtxo, _, eraHistory, systemStart, _, _, _, featuredCurrentTreasuryValueM) <- - lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip (queryStateForBalancedTx nodeEra allTxInputs [])) - & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) - & onLeft (left . TxCmdQueryConvenienceError) - - let currentTreasuryValueAndDonation = - case (treasuryDonation, unFeatured <$> featuredCurrentTreasuryValueM) of - (Nothing, _) -> Nothing -- We shouldn't specify the treasury value when no donation is being done - (Just _td, Nothing) -> Nothing -- TODO: Current treasury value couldn't be obtained but is required: we should fail suggesting that the node's version is too old - (Just td, Just ctv) -> Just (ctv, td) - - -- We need to construct the txBodycontent outside of runTxBuild - BalancedTxBody txBodyContent balancedTxBody _ _ <- - runTxBuild - eon nodeSocketPath networkId mScriptValidity inputsAndMaybeScriptWits readOnlyReferenceInputs - filteredTxinsc mReturnCollateral mTotalCollateral txOuts changeAddresses valuesWithScriptWits - mValidityLowerBound mValidityUpperBound certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits - requiredSigners txAuxScripts txMetadata mProp mOverrideWitnesses votingProceduresAndMaybeScriptWits - proposals - currentTreasuryValueAndDonation - - -- TODO: Calculating the script cost should live as a different command. - -- Why? Because then we can simply read a txbody and figure out - -- the script cost vs having to build the tx body each time - case buildOutputOptions of - OutputScriptCostOnly fp -> do - let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent - - pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody) - executionUnitPrices <- pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable) - - Refl <- testEquality era nodeEra - & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra) - - scriptExecUnitsMap <- - firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $ hoistEither - $ evaluateTransactionExecutionUnits era - systemStart (toLedgerEpochInfo eraHistory) - pparams txEraUtxo balancedTxBody - - let mScriptWits = forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent - - scriptCostOutput <- - firstExceptT TxCmdPlutusScriptCostErr $ hoistEither - $ renderScriptCosts - txEraUtxo - executionUnitPrices - mScriptWits - scriptExecUnitsMap - liftIO $ LBS.writeFile (unFile fp) $ encodePretty scriptCostOutput - - OutputTxBodyOnly fpath -> - let noWitTx = makeSignedTransaction [] balancedTxBody - in lift (cardanoEraConstraints era $ writeTxFileTextEnvelopeCddl eon fpath noWitTx) - & onLeft (left . TxCmdWriteFileError) + -- the same collateral input can be used for several plutus scripts + let filteredTxinsc = Set.toList $ Set.fromList txinsc + + let allReferenceInputs = + getAllReferenceInputs + inputsAndMaybeScriptWits + (snd valuesWithScriptWits) + certsAndMaybeScriptWits + withdrawalsAndMaybeScriptWits + votingProceduresAndMaybeScriptWits + proposals + readOnlyReferenceInputs + + let inputsThatRequireWitnessing = [input | (input, _) <- inputsAndMaybeScriptWits] + allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ filteredTxinsc + + AnyCardanoEra nodeEra <- + lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra) + & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) + & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion) + + (txEraUtxo, _, eraHistory, systemStart, _, _, _, featuredCurrentTreasuryValueM) <- + lift + ( executeLocalStateQueryExpr + localNodeConnInfo + Consensus.VolatileTip + (queryStateForBalancedTx nodeEra allTxInputs []) + ) + & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) + & onLeft (left . TxCmdQueryConvenienceError) + + let currentTreasuryValueAndDonation = + case (treasuryDonation, unFeatured <$> featuredCurrentTreasuryValueM) of + (Nothing, _) -> Nothing -- We shouldn't specify the treasury value when no donation is being done + (Just _td, Nothing) -> Nothing -- TODO: Current treasury value couldn't be obtained but is required: we should fail suggesting that the node's version is too old + (Just td, Just ctv) -> Just (ctv, td) + + -- We need to construct the txBodycontent outside of runTxBuild + BalancedTxBody txBodyContent balancedTxBody _ _ <- + runTxBuild + eon + nodeSocketPath + networkId + mScriptValidity + inputsAndMaybeScriptWits + readOnlyReferenceInputs + filteredTxinsc + mReturnCollateral + mTotalCollateral + txOuts + changeAddresses + valuesWithScriptWits + mValidityLowerBound + mValidityUpperBound + certsAndMaybeScriptWits + withdrawalsAndMaybeScriptWits + requiredSigners + txAuxScripts + txMetadata + mProp + mOverrideWitnesses + votingProceduresAndMaybeScriptWits + proposals + currentTreasuryValueAndDonation + + -- TODO: Calculating the script cost should live as a different command. + -- Why? Because then we can simply read a txbody and figure out + -- the script cost vs having to build the tx body each time + case buildOutputOptions of + OutputScriptCostOnly fp -> do + let BuildTxWith mTxProtocolParams = txProtocolParams txBodyContent + + pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody) + executionUnitPrices <- + pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable) + + Refl <- + testEquality era nodeEra + & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra) + + scriptExecUnitsMap <- + firstExceptT (TxCmdTxExecUnitsErr . AnyTxCmdTxExecUnitsErr) $ + hoistEither $ + evaluateTransactionExecutionUnits + era + systemStart + (toLedgerEpochInfo eraHistory) + pparams + txEraUtxo + balancedTxBody + + let mScriptWits = forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent + + scriptCostOutput <- + firstExceptT TxCmdPlutusScriptCostErr $ + hoistEither $ + renderScriptCosts + txEraUtxo + executionUnitPrices + mScriptWits + scriptExecUnitsMap + liftIO $ LBS.writeFile (unFile fp) $ encodePretty scriptCostOutput + OutputTxBodyOnly fpath -> + let noWitTx = makeSignedTransaction [] balancedTxBody + in lift (cardanoEraConstraints era $ writeTxFileTextEnvelopeCddl eon fpath noWitTx) + & onLeft (left . TxCmdWriteFileError) runTransactionBuildEstimateCmd :: () @@ -295,97 +339,128 @@ runTransactionBuildEstimateCmd -- TODO change type , currentTreasuryValueAndDonation , txBodyOutFile } = do - let sbe = maryEraOnwardsToShelleyBasedEra eon - ledgerPParams <- firstExceptT TxCmdProtocolParamsError $ readProtocolParameters sbe protocolParamsFile - inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFiles sbe txins - certFilesAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFiles sbe certificates - - withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFilesTuple sbe withdrawals - txMetadata <- firstExceptT TxCmdMetadataError - . newExceptT $ readTxMetadata sbe metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses sbe $ fromMaybe mempty mValue - scripts <- firstExceptT TxCmdScriptFileError $ - mapM (readFileScriptInAnyLang . unFile) scriptFiles - txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts sbe scripts - - - txUpdateProposal <- case mUpdateProposalFile of - Just (Featured w (Just updateProposalFile)) -> - readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError - _ -> pure TxUpdateProposalNone - - requiredSigners <- mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners - - mReturnCollateral <- mapM (toTxOutInShelleyBasedEra sbe) mReturnColl + let sbe = maryEraOnwardsToShelleyBasedEra eon + ledgerPParams <- + firstExceptT TxCmdProtocolParamsError $ readProtocolParameters sbe protocolParamsFile + inputsAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFiles sbe txins + certFilesAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFiles sbe certificates + + withdrawalsAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFilesTuple sbe withdrawals + txMetadata <- + firstExceptT TxCmdMetadataError + . newExceptT + $ readTxMetadata sbe metadataSchema metadataFiles + valuesWithScriptWits <- readValueScriptWitnesses sbe $ fromMaybe mempty mValue + scripts <- + firstExceptT TxCmdScriptFileError $ + mapM (readFileScriptInAnyLang . unFile) scriptFiles + txAuxScripts <- + hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts sbe scripts + + txUpdateProposal <- case mUpdateProposalFile of + Just (Featured w (Just updateProposalFile)) -> + readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError + _ -> pure TxUpdateProposalNone + + requiredSigners <- + mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners + + mReturnCollateral <- mapM (toTxOutInShelleyBasedEra sbe) mReturnColl + + txOuts <- mapM (toTxOutInAnyEra sbe) txouts - txOuts <- mapM (toTxOutInAnyEra sbe) txouts - - -- the same collateral input can be used for several plutus scripts - let filteredTxinsc = Set.toList $ Set.fromList txInsCollateral - - -- Conway related - votingProceduresAndMaybeScriptWits <- - inEonForShelleyBasedEra - (pure mempty) - (\w -> firstExceptT TxCmdVoteError . ExceptT $ conwayEraOnwardsConstraints w $ readVotingProceduresFiles w voteFiles) - sbe - - proposals <- - lift (readTxGovernanceActions sbe proposalFiles) - & onLeft (left . TxCmdProposalError) - - certsAndMaybeScriptWits <- + -- the same collateral input can be used for several plutus scripts + let filteredTxinsc = Set.toList $ Set.fromList txInsCollateral + + -- Conway related + votingProceduresAndMaybeScriptWits <- + inEonForShelleyBasedEra + (pure mempty) + ( \w -> + firstExceptT TxCmdVoteError . ExceptT $ + conwayEraOnwardsConstraints w $ + readVotingProceduresFiles w voteFiles + ) + sbe + + proposals <- + lift (readTxGovernanceActions sbe proposalFiles) + & onLeft (left . TxCmdProposalError) + + certsAndMaybeScriptWits <- shelleyBasedEraConstraints sbe $ sequence - [ fmap (,mSwit) (firstExceptT TxCmdReadTextViewFileError . newExceptT $ - readFileTextEnvelope AsCertificate (File certFile)) + [ fmap + (,mSwit) + ( firstExceptT TxCmdReadTextViewFileError . newExceptT $ + readFileTextEnvelope AsCertificate (File certFile) + ) | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits ] - txBodyContent <- hoistEither $ constructTxBodyContent - sbe mScriptValidity - (Just ledgerPParams) - inputsAndMaybeScriptWits - readOnlyRefIns - filteredTxinsc - mReturnCollateral - Nothing -- TODO: Remove total collateral parameter from estimateBalancedTxBody - txOuts - mValidityLowerBound - mValidityUpperBound - valuesWithScriptWits - certsAndMaybeScriptWits - withdrawalsAndMaybeScriptWits - requiredSigners - 0 - txAuxScripts - txMetadata - txUpdateProposal - votingProceduresAndMaybeScriptWits - proposals - currentTreasuryValueAndDonation - let stakeCredentialsToDeregisterMap = Map.fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert,_) <- certsAndMaybeScriptWits] - drepsToDeregisterMap = Map.fromList $ catMaybes [getDRepDeregistrationInfo cert | (cert,_) <- certsAndMaybeScriptWits] - poolsToDeregister = Set.fromList $ catMaybes [getPoolDeregistrationInfo cert | (cert,_) <- certsAndMaybeScriptWits] - totCol = fromMaybe 0 plutusCollateral - pScriptExecUnits = Map.fromList [ (sWitIndex, execUnits) - | (sWitIndex, AnyScriptWitness (PlutusScriptWitness _ _ _ _ _ execUnits)) <- collectTxBodyScriptWitnesses sbe txBodyContent - ] - - BalancedTxBody _ balancedTxBody _ _ <- - hoistEither $ first TxCmdFeeEstimationError $ - estimateBalancedTxBody eon txBodyContent ledgerPParams poolsToDeregister - stakeCredentialsToDeregisterMap drepsToDeregisterMap - pScriptExecUnits totCol shelleyWitnesses (fromMaybe 0 mByronWitnesses) - (maybe 0 unReferenceScriptSize totalReferenceScriptSize) (anyAddressInShelleyBasedEra sbe changeAddr) - totalUTxOValue - - let noWitTx = makeSignedTransaction [] balancedTxBody - lift (writeTxFileTextEnvelopeCddl sbe txBodyOutFile noWitTx) - & onLeft (left . TxCmdWriteFileError) + txBodyContent <- + hoistEither $ + constructTxBodyContent + sbe + mScriptValidity + (Just ledgerPParams) + inputsAndMaybeScriptWits + readOnlyRefIns + filteredTxinsc + mReturnCollateral + Nothing -- TODO: Remove total collateral parameter from estimateBalancedTxBody + txOuts + mValidityLowerBound + mValidityUpperBound + valuesWithScriptWits + certsAndMaybeScriptWits + withdrawalsAndMaybeScriptWits + requiredSigners + 0 + txAuxScripts + txMetadata + txUpdateProposal + votingProceduresAndMaybeScriptWits + proposals + currentTreasuryValueAndDonation + let stakeCredentialsToDeregisterMap = Map.fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] + drepsToDeregisterMap = Map.fromList $ catMaybes [getDRepDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] + poolsToDeregister = Set.fromList $ catMaybes [getPoolDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits] + totCol = fromMaybe 0 plutusCollateral + pScriptExecUnits = + Map.fromList + [ (sWitIndex, execUnits) + | (sWitIndex, AnyScriptWitness (PlutusScriptWitness _ _ _ _ _ execUnits)) <- + collectTxBodyScriptWitnesses sbe txBodyContent + ] + + BalancedTxBody _ balancedTxBody _ _ <- + hoistEither $ + first TxCmdFeeEstimationError $ + estimateBalancedTxBody + eon + txBodyContent + ledgerPParams + poolsToDeregister + stakeCredentialsToDeregisterMap + drepsToDeregisterMap + pScriptExecUnits + totCol + shelleyWitnesses + (fromMaybe 0 mByronWitnesses) + (maybe 0 unReferenceScriptSize totalReferenceScriptSize) + (anyAddressInShelleyBasedEra sbe changeAddr) + totalUTxOValue + + let noWitTx = makeSignedTransaction [] balancedTxBody + lift (writeTxFileTextEnvelopeCddl sbe txBodyOutFile noWitTx) + & onLeft (left . TxCmdWriteFileError) getPoolDeregistrationInfo :: Certificate era @@ -437,7 +512,6 @@ getStakeDeregistrationInfo -> Maybe (StakeCredential, L.Coin) getStakeDeregistrationInfo (ShelleyRelatedCertificate w cert) = shelleyToBabbageEraConstraints w $ getShelleyDeregistrationInfo cert - getStakeDeregistrationInfo (ConwayCertificate w cert) = conwayEraOnwardsConstraints w $ getConwayDeregistrationInfo cert @@ -451,7 +525,7 @@ getShelleyDeregistrationInfo -> Maybe (StakeCredential, L.Coin) getShelleyDeregistrationInfo cert = do case cert of - L.UnRegTxCert stakeCred -> Just (fromShelleyStakeCredential stakeCred, 0) + L.UnRegTxCert stakeCred -> Just (fromShelleyStakeCredential stakeCred, 0) _ -> Nothing getConwayDeregistrationInfo @@ -465,108 +539,141 @@ getConwayDeregistrationInfo cert = do L.UnRegDepositTxCert stakeCred depositRefund -> Just (fromShelleyStakeCredential stakeCred, depositRefund) _ -> Nothing - getExecutionUnitPrices :: CardanoEra era -> LedgerProtocolParameters era -> Maybe L.Prices getExecutionUnitPrices cEra (LedgerProtocolParameters pp) = forEraInEonMaybe cEra $ \aeo -> alonzoEraOnwardsConstraints aeo $ pp ^. L.ppPricesL -runTransactionBuildRawCmd :: () +runTransactionBuildRawCmd + :: () => Cmd.TransactionBuildRawCmdArgs era -> ExceptT TxCmdError IO () runTransactionBuildRawCmd - Cmd.TransactionBuildRawCmdArgs - { eon - , mScriptValidity - , txIns - , readOnlyRefIns - , txInsCollateral - , mReturnCollateral = mReturnColl - , mTotalCollateral - , requiredSigners = reqSigners - , txouts - , mValue - , mValidityLowerBound - , mValidityUpperBound - , fee - , certificates - , withdrawals - , metadataSchema - , scriptFiles - , metadataFiles - , mProtocolParamsFile - , mUpdateProprosalFile - , voteFiles - , proposalFiles - , currentTreasuryValueAndDonation - , txBodyOutFile - } = do - inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFiles eon txIns - certFilesAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFiles eon certificates - - withdrawalsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError - $ readScriptWitnessFilesTuple eon withdrawals - txMetadata <- firstExceptT TxCmdMetadataError - . newExceptT $ readTxMetadata eon metadataSchema metadataFiles - valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue - scripts <- firstExceptT TxCmdScriptFileError $ - mapM (readFileScriptInAnyLang . unFile) scriptFiles - txAuxScripts <- hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts eon scripts - - pparams <- forM mProtocolParamsFile $ \ppf -> - firstExceptT TxCmdProtocolParamsError (readProtocolParameters eon ppf) - - let mLedgerPParams = LedgerProtocolParameters <$> pparams - - txUpdateProposal <- case mUpdateProprosalFile of - Just (Featured w (Just updateProposalFile)) -> - readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError - _ -> pure TxUpdateProposalNone - - requiredSigners <- mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners - - mReturnCollateral <- mapM (toTxOutInShelleyBasedEra eon) mReturnColl - - txOuts <- mapM (toTxOutInAnyEra eon) txouts + Cmd.TransactionBuildRawCmdArgs + { eon + , mScriptValidity + , txIns + , readOnlyRefIns + , txInsCollateral + , mReturnCollateral = mReturnColl + , mTotalCollateral + , requiredSigners = reqSigners + , txouts + , mValue + , mValidityLowerBound + , mValidityUpperBound + , fee + , certificates + , withdrawals + , metadataSchema + , scriptFiles + , metadataFiles + , mProtocolParamsFile + , mUpdateProprosalFile + , voteFiles + , proposalFiles + , currentTreasuryValueAndDonation + , txBodyOutFile + } = do + inputsAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFiles eon txIns + certFilesAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFiles eon certificates + + withdrawalsAndMaybeScriptWits <- + firstExceptT TxCmdScriptWitnessError $ + readScriptWitnessFilesTuple eon withdrawals + txMetadata <- + firstExceptT TxCmdMetadataError + . newExceptT + $ readTxMetadata eon metadataSchema metadataFiles + valuesWithScriptWits <- readValueScriptWitnesses eon $ fromMaybe mempty mValue + scripts <- + firstExceptT TxCmdScriptFileError $ + mapM (readFileScriptInAnyLang . unFile) scriptFiles + txAuxScripts <- + hoistEither $ first TxCmdAuxScriptsValidationError $ validateTxAuxScripts eon scripts + + pparams <- forM mProtocolParamsFile $ \ppf -> + firstExceptT TxCmdProtocolParamsError (readProtocolParameters eon ppf) + + let mLedgerPParams = LedgerProtocolParameters <$> pparams + + txUpdateProposal <- case mUpdateProprosalFile of + Just (Featured w (Just updateProposalFile)) -> + readTxUpdateProposal w updateProposalFile & firstExceptT TxCmdReadTextViewFileError + _ -> pure TxUpdateProposalNone + + requiredSigners <- + mapM (firstExceptT TxCmdRequiredSignerError . newExceptT . readRequiredSigner) reqSigners + + mReturnCollateral <- mapM (toTxOutInShelleyBasedEra eon) mReturnColl + + txOuts <- mapM (toTxOutInAnyEra eon) txouts -- the same collateral input can be used for several plutus scripts - let filteredTxinsc = Set.toList $ Set.fromList txInsCollateral - - -- Conway related - votingProceduresAndMaybeScriptWits <- - inEonForShelleyBasedEra - (pure mempty) - (\w -> firstExceptT TxCmdVoteError . ExceptT $ conwayEraOnwardsConstraints w $ readVotingProceduresFiles w voteFiles) - eon - - proposals <- - lift (readTxGovernanceActions eon proposalFiles) - & onLeft (left . TxCmdProposalError) - - certsAndMaybeScriptWits <- + let filteredTxinsc = Set.toList $ Set.fromList txInsCollateral + + -- Conway related + votingProceduresAndMaybeScriptWits <- + inEonForShelleyBasedEra + (pure mempty) + ( \w -> + firstExceptT TxCmdVoteError . ExceptT $ + conwayEraOnwardsConstraints w $ + readVotingProceduresFiles w voteFiles + ) + eon + + proposals <- + lift (readTxGovernanceActions eon proposalFiles) + & onLeft (left . TxCmdProposalError) + + certsAndMaybeScriptWits <- shelleyBasedEraConstraints eon $ sequence - [ fmap (,mSwit) (firstExceptT TxCmdReadTextViewFileError . newExceptT $ - readFileTextEnvelope AsCertificate (File certFile)) + [ fmap + (,mSwit) + ( firstExceptT TxCmdReadTextViewFileError . newExceptT $ + readFileTextEnvelope AsCertificate (File certFile) + ) | (CertificateFile certFile, mSwit) <- certFilesAndMaybeScriptWits ] - txBody <- - hoistEither $ runTxBuildRaw - eon mScriptValidity inputsAndMaybeScriptWits readOnlyRefIns filteredTxinsc - mReturnCollateral mTotalCollateral txOuts mValidityLowerBound mValidityUpperBound fee valuesWithScriptWits - certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits requiredSigners txAuxScripts - txMetadata mLedgerPParams txUpdateProposal votingProceduresAndMaybeScriptWits proposals - currentTreasuryValueAndDonation - - let noWitTx = makeSignedTransaction [] txBody - lift (writeTxFileTextEnvelopeCddl eon txBodyOutFile noWitTx) - & onLeft (left . TxCmdWriteFileError) - - -runTxBuildRaw :: () + txBody <- + hoistEither $ + runTxBuildRaw + eon + mScriptValidity + inputsAndMaybeScriptWits + readOnlyRefIns + filteredTxinsc + mReturnCollateral + mTotalCollateral + txOuts + mValidityLowerBound + mValidityUpperBound + fee + valuesWithScriptWits + certsAndMaybeScriptWits + withdrawalsAndMaybeScriptWits + requiredSigners + txAuxScripts + txMetadata + mLedgerPParams + txUpdateProposal + votingProceduresAndMaybeScriptWits + proposals + currentTreasuryValueAndDonation + + let noWitTx = makeSignedTransaction [] txBody + lift (writeTxFileTextEnvelopeCddl eon txBodyOutFile noWitTx) + & onLeft (left . TxCmdWriteFileError) + +runTxBuildRaw + :: () => ShelleyBasedEra era -> Maybe ScriptValidity -- ^ Mark script as expected to pass or fail validation @@ -602,20 +709,53 @@ runTxBuildRaw :: () -> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))] -> Maybe (TxCurrentTreasuryValue, TxTreasuryDonation) -> Either TxCmdError (TxBody era) -runTxBuildRaw sbe - mScriptValidity inputsAndMaybeScriptWits - readOnlyRefIns txinsc - mReturnCollateral mTotCollateral txouts - mLowerBound mUpperBound - fee valuesWithScriptWits - certsAndMaybeSriptWits withdrawals reqSigners - txAuxScripts txMetadata mpparams txUpdateProposal votingProcedures proposals - mCurrentTreasuryValueAndDonation = do - - txBodyContent <- constructTxBodyContent sbe mScriptValidity (unLedgerProtocolParameters <$> mpparams) inputsAndMaybeScriptWits readOnlyRefIns txinsc - mReturnCollateral mTotCollateral txouts mLowerBound mUpperBound valuesWithScriptWits - certsAndMaybeSriptWits withdrawals reqSigners fee txAuxScripts txMetadata txUpdateProposal - votingProcedures proposals mCurrentTreasuryValueAndDonation +runTxBuildRaw + sbe + mScriptValidity + inputsAndMaybeScriptWits + readOnlyRefIns + txinsc + mReturnCollateral + mTotCollateral + txouts + mLowerBound + mUpperBound + fee + valuesWithScriptWits + certsAndMaybeSriptWits + withdrawals + reqSigners + txAuxScripts + txMetadata + mpparams + txUpdateProposal + votingProcedures + proposals + mCurrentTreasuryValueAndDonation = do + txBodyContent <- + constructTxBodyContent + sbe + mScriptValidity + (unLedgerProtocolParameters <$> mpparams) + inputsAndMaybeScriptWits + readOnlyRefIns + txinsc + mReturnCollateral + mTotCollateral + txouts + mLowerBound + mUpperBound + valuesWithScriptWits + certsAndMaybeSriptWits + withdrawals + reqSigners + fee + txAuxScripts + txMetadata + txUpdateProposal + votingProcedures + proposals + mCurrentTreasuryValueAndDonation first TxCmdTxBodyError $ createAndValidateTransactionBody sbe txBodyContent @@ -659,68 +799,104 @@ constructTxBodyContent -- semantics of the donation and treasury value depend on the script languages -- being used. -> Either TxCmdError (TxBodyContent BuildTx era) -constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits readOnlyRefIns txinsc - mReturnCollateral mTotCollateral txouts mLowerBound mUpperBound - valuesWithScriptWits certsAndMaybeScriptWits withdrawals - reqSigners fee txAuxScripts txMetadata txUpdateProposal - votingProcedures proposals mCurrentTreasuryValueAndDonation - = do - let allReferenceInputs = getAllReferenceInputs - inputsAndMaybeScriptWits - (snd valuesWithScriptWits) - certsAndMaybeScriptWits - withdrawals - votingProcedures - proposals - readOnlyRefIns - - validatedCollateralTxIns <- validateTxInsCollateral sbe txinsc - validatedRefInputs <- validateTxInsReference sbe allReferenceInputs - validatedTotCollateral <- first TxCmdNotSupportedInEraValidationError $ validateTxTotalCollateral sbe mTotCollateral - validatedRetCol <- first TxCmdNotSupportedInEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral - let txFee = TxFeeExplicit sbe fee - validatedLowerBound <- first TxCmdNotSupportedInEraValidationError $ validateTxValidityLowerBound sbe mLowerBound - validatedReqSigners <- first TxCmdNotSupportedInEraValidationError $ validateRequiredSigners sbe reqSigners - validatedMintValue <- createTxMintValue sbe valuesWithScriptWits - validatedTxScriptValidity <- first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity - validatedVotingProcedures <- first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures - validatedCurrentTreasuryValue <- first TxCmdNotSupportedInEraValidationError (validateTxCurrentTreasuryValue sbe (fst <$> mCurrentTreasuryValueAndDonation)) - validatedTreasuryDonation <- first TxCmdNotSupportedInEraValidationError (validateTxTreasuryDonation sbe (snd <$> mCurrentTreasuryValueAndDonation)) - return $ shelleyBasedEraConstraints sbe $ (defaultTxBodyContent sbe - & setTxIns (validateTxIns inputsAndMaybeScriptWits) - & setTxInsCollateral validatedCollateralTxIns - & setTxInsReference validatedRefInputs - & setTxOuts txouts - & setTxTotalCollateral validatedTotCollateral - & setTxReturnCollateral validatedRetCol - & setTxFee txFee - & setTxValidityLowerBound validatedLowerBound - & setTxValidityUpperBound mUpperBound - & setTxMetadata txMetadata - & setTxAuxScripts txAuxScripts - & setTxExtraKeyWits validatedReqSigners - & setTxProtocolParams (BuildTxWith $ LedgerProtocolParameters <$> mPparams) - & setTxWithdrawals (TxWithdrawals sbe $ map convertWithdrawals withdrawals) - & setTxCertificates (convertCertificates sbe certsAndMaybeScriptWits) - & setTxUpdateProposal txUpdateProposal - & setTxMintValue validatedMintValue - & setTxScriptValidity validatedTxScriptValidity) - -- TODO: Create set* function for proposal procedures and voting procedures - { txProposalProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` convToTxProposalProcedures proposals) - , txVotingProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` validatedVotingProcedures) - } - & setTxCurrentTreasuryValue validatedCurrentTreasuryValue - & setTxTreasuryDonation validatedTreasuryDonation - where - convertWithdrawals - :: (StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era)) - -> (StakeAddress, L.Coin, BuildTxWith BuildTx (Witness WitCtxStake era)) - convertWithdrawals (sAddr, ll, mScriptWitnessFiles) = - case mScriptWitnessFiles of - Just sWit -> (sAddr, ll, BuildTxWith $ ScriptWitness ScriptWitnessForStakeAddr sWit) - Nothing -> (sAddr, ll, BuildTxWith $ KeyWitness KeyWitnessForStakeAddr) - -runTxBuild :: () +constructTxBodyContent + sbe + mScriptValidity + mPparams + inputsAndMaybeScriptWits + readOnlyRefIns + txinsc + mReturnCollateral + mTotCollateral + txouts + mLowerBound + mUpperBound + valuesWithScriptWits + certsAndMaybeScriptWits + withdrawals + reqSigners + fee + txAuxScripts + txMetadata + txUpdateProposal + votingProcedures + proposals + mCurrentTreasuryValueAndDonation = + do + let allReferenceInputs = + getAllReferenceInputs + inputsAndMaybeScriptWits + (snd valuesWithScriptWits) + certsAndMaybeScriptWits + withdrawals + votingProcedures + proposals + readOnlyRefIns + + validatedCollateralTxIns <- validateTxInsCollateral sbe txinsc + validatedRefInputs <- validateTxInsReference sbe allReferenceInputs + validatedTotCollateral <- + first TxCmdNotSupportedInEraValidationError $ validateTxTotalCollateral sbe mTotCollateral + validatedRetCol <- + first TxCmdNotSupportedInEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral + let txFee = TxFeeExplicit sbe fee + validatedLowerBound <- + first TxCmdNotSupportedInEraValidationError $ validateTxValidityLowerBound sbe mLowerBound + validatedReqSigners <- + first TxCmdNotSupportedInEraValidationError $ validateRequiredSigners sbe reqSigners + validatedMintValue <- createTxMintValue sbe valuesWithScriptWits + validatedTxScriptValidity <- + first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity + validatedVotingProcedures <- + first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures + validatedCurrentTreasuryValue <- + first + TxCmdNotSupportedInEraValidationError + (validateTxCurrentTreasuryValue sbe (fst <$> mCurrentTreasuryValueAndDonation)) + validatedTreasuryDonation <- + first + TxCmdNotSupportedInEraValidationError + (validateTxTreasuryDonation sbe (snd <$> mCurrentTreasuryValueAndDonation)) + return $ + shelleyBasedEraConstraints sbe $ + ( defaultTxBodyContent sbe + & setTxIns (validateTxIns inputsAndMaybeScriptWits) + & setTxInsCollateral validatedCollateralTxIns + & setTxInsReference validatedRefInputs + & setTxOuts txouts + & setTxTotalCollateral validatedTotCollateral + & setTxReturnCollateral validatedRetCol + & setTxFee txFee + & setTxValidityLowerBound validatedLowerBound + & setTxValidityUpperBound mUpperBound + & setTxMetadata txMetadata + & setTxAuxScripts txAuxScripts + & setTxExtraKeyWits validatedReqSigners + & setTxProtocolParams (BuildTxWith $ LedgerProtocolParameters <$> mPparams) + & setTxWithdrawals (TxWithdrawals sbe $ map convertWithdrawals withdrawals) + & setTxCertificates (convertCertificates sbe certsAndMaybeScriptWits) + & setTxUpdateProposal txUpdateProposal + & setTxMintValue validatedMintValue + & setTxScriptValidity validatedTxScriptValidity + ) + { -- TODO: Create set* function for proposal procedures and voting procedures + txProposalProcedures = + forShelleyBasedEraInEonMaybe sbe (`Featured` convToTxProposalProcedures proposals) + , txVotingProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` validatedVotingProcedures) + } + & setTxCurrentTreasuryValue validatedCurrentTreasuryValue + & setTxTreasuryDonation validatedTreasuryDonation + where + convertWithdrawals + :: (StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era)) + -> (StakeAddress, L.Coin, BuildTxWith BuildTx (Witness WitCtxStake era)) + convertWithdrawals (sAddr, ll, mScriptWitnessFiles) = + case mScriptWitnessFiles of + Just sWit -> (sAddr, ll, BuildTxWith $ ScriptWitness ScriptWitnessForStakeAddr sWit) + Nothing -> (sAddr, ll, BuildTxWith $ KeyWitness KeyWitnessForStakeAddr) + +runTxBuild + :: () => ShelleyBasedEra era -> SocketPath -> NetworkId @@ -761,200 +937,248 @@ runTxBuild :: () -- ^ The current treasury value and the donation. -> ExceptT TxCmdError IO (BalancedTxBody era) runTxBuild - sbe socketPath networkId mScriptValidity - inputsAndMaybeScriptWits readOnlyRefIns txinsc mReturnCollateral mTotCollateral txouts - (TxOutChangeAddress changeAddr) valuesWithScriptWits mLowerBound mUpperBound - certsAndMaybeScriptWits withdrawals reqSigners txAuxScripts txMetadata - txUpdateProposal mOverrideWits votingProcedures proposals - mCurrentTreasuryValueAndDonation = + sbe + socketPath + networkId + mScriptValidity + inputsAndMaybeScriptWits + readOnlyRefIns + txinsc + mReturnCollateral + mTotCollateral + txouts + (TxOutChangeAddress changeAddr) + valuesWithScriptWits + mLowerBound + mUpperBound + certsAndMaybeScriptWits + withdrawals + reqSigners + txAuxScripts + txMetadata + txUpdateProposal + mOverrideWits + votingProcedures + proposals + mCurrentTreasuryValueAndDonation = shelleyBasedEraConstraints sbe $ do - - -- TODO: All functions should be parameterized by ShelleyBasedEra - -- as it's not possible to call this function with ByronEra - let era = toCardanoEra sbe - inputsThatRequireWitnessing = [input | (input,_) <- inputsAndMaybeScriptWits] - - let allReferenceInputs = getAllReferenceInputs - inputsAndMaybeScriptWits - (snd valuesWithScriptWits) - certsAndMaybeScriptWits - withdrawals - votingProcedures - proposals - readOnlyRefIns - - - let allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ txinsc - localNodeConnInfo = LocalNodeConnectInfo - { localConsensusModeParams = CardanoModeParams $ EpochSlots 21600 - , localNodeNetworkId = networkId - , localNodeSocketPath = socketPath - } - - AnyCardanoEra nodeEra <- lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra) - & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) - & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion) - - Refl <- testEquality era nodeEra - & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra) - - let certs = - case convertCertificates sbe certsAndMaybeScriptWits of - TxCertificates _ cs _ -> cs - _ -> [] - - (txEraUtxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits, _) <- - lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip $ queryStateForBalancedTx nodeEra allTxInputs certs) - & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) - & onLeft (left . TxCmdQueryConvenienceError) - - txBodyContent <- hoistEither $ constructTxBodyContent - sbe mScriptValidity - (Just $ unLedgerProtocolParameters pparams) - inputsAndMaybeScriptWits - readOnlyRefIns - txinsc - mReturnCollateral - mTotCollateral - txouts - mLowerBound - mUpperBound - valuesWithScriptWits - certsAndMaybeScriptWits - withdrawals - reqSigners - 0 - txAuxScripts - txMetadata - txUpdateProposal - votingProcedures proposals - mCurrentTreasuryValueAndDonation - - firstExceptT TxCmdTxInsDoNotExist - . hoistEither $ txInsExistInUTxO allTxInputs txEraUtxo - firstExceptT TxCmdQueryNotScriptLocked - . hoistEither $ notScriptLockedTxIns txinsc txEraUtxo - - cAddr <- pure (anyAddressInEra era changeAddr) - & onLeft (error $ "runTxBuild: Byron address used: " <> show changeAddr) -- should this throw instead? - - balancedTxBody@(BalancedTxBody _ _ _ fee) <- - firstExceptT (TxCmdBalanceTxBody . AnyTxBodyErrorAutoBalance) - . hoistEither - $ makeTransactionBodyAutoBalance sbe systemStart (toLedgerEpochInfo eraHistory) - pparams stakePools stakeDelegDeposits drepDelegDeposits - txEraUtxo txBodyContent cAddr mOverrideWits - - liftIO $ putStrLn $ "Estimated transaction fee: " <> (show fee :: String) - - return balancedTxBody - -convertCertificates :: () + -- TODO: All functions should be parameterized by ShelleyBasedEra + -- as it's not possible to call this function with ByronEra + let era = toCardanoEra sbe + inputsThatRequireWitnessing = [input | (input, _) <- inputsAndMaybeScriptWits] + + let allReferenceInputs = + getAllReferenceInputs + inputsAndMaybeScriptWits + (snd valuesWithScriptWits) + certsAndMaybeScriptWits + withdrawals + votingProcedures + proposals + readOnlyRefIns + + let allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ txinsc + localNodeConnInfo = + LocalNodeConnectInfo + { localConsensusModeParams = CardanoModeParams $ EpochSlots 21600 + , localNodeNetworkId = networkId + , localNodeSocketPath = socketPath + } + + AnyCardanoEra nodeEra <- + lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra) + & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) + & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion) + + Refl <- + testEquality era nodeEra + & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra) + + let certs = + case convertCertificates sbe certsAndMaybeScriptWits of + TxCertificates _ cs _ -> cs + _ -> [] + + (txEraUtxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits, _) <- + lift + ( executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip $ + queryStateForBalancedTx nodeEra allTxInputs certs + ) + & onLeft (left . TxCmdQueryConvenienceError . AcqFailure) + & onLeft (left . TxCmdQueryConvenienceError) + + txBodyContent <- + hoistEither $ + constructTxBodyContent + sbe + mScriptValidity + (Just $ unLedgerProtocolParameters pparams) + inputsAndMaybeScriptWits + readOnlyRefIns + txinsc + mReturnCollateral + mTotCollateral + txouts + mLowerBound + mUpperBound + valuesWithScriptWits + certsAndMaybeScriptWits + withdrawals + reqSigners + 0 + txAuxScripts + txMetadata + txUpdateProposal + votingProcedures + proposals + mCurrentTreasuryValueAndDonation + + firstExceptT TxCmdTxInsDoNotExist + . hoistEither + $ txInsExistInUTxO allTxInputs txEraUtxo + firstExceptT TxCmdQueryNotScriptLocked + . hoistEither + $ notScriptLockedTxIns txinsc txEraUtxo + + cAddr <- + pure (anyAddressInEra era changeAddr) + & onLeft (error $ "runTxBuild: Byron address used: " <> show changeAddr) -- should this throw instead? + balancedTxBody@(BalancedTxBody _ _ _ fee) <- + firstExceptT (TxCmdBalanceTxBody . AnyTxBodyErrorAutoBalance) + . hoistEither + $ makeTransactionBodyAutoBalance + sbe + systemStart + (toLedgerEpochInfo eraHistory) + pparams + stakePools + stakeDelegDeposits + drepDelegDeposits + txEraUtxo + txBodyContent + cAddr + mOverrideWits + + liftIO $ putStrLn $ "Estimated transaction fee: " <> (show fee :: String) + + return balancedTxBody + +convertCertificates + :: () => ShelleyBasedEra era -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] -> TxCertificates BuildTx era convertCertificates sbe certsAndScriptWitnesses = TxCertificates sbe certs $ BuildTxWith reqWits - where - certs = map fst certsAndScriptWitnesses - reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses - convert :: (Certificate era, Maybe (ScriptWitness WitCtxStake era)) - -> Maybe (StakeCredential, Witness WitCtxStake era) - convert (cert, mScriptWitnessFiles) = do - sCred <- selectStakeCredentialWitness cert - Just $ case mScriptWitnessFiles of - Just sWit -> (sCred, ScriptWitness ScriptWitnessForStakeAddr sWit) - Nothing -> (sCred, KeyWitness KeyWitnessForStakeAddr) + where + certs = map fst certsAndScriptWitnesses + reqWits = Map.fromList $ mapMaybe convert certsAndScriptWitnesses + convert + :: (Certificate era, Maybe (ScriptWitness WitCtxStake era)) + -> Maybe (StakeCredential, Witness WitCtxStake era) + convert (cert, mScriptWitnessFiles) = do + sCred <- selectStakeCredentialWitness cert + Just $ case mScriptWitnessFiles of + Just sWit -> (sCred, ScriptWitness ScriptWitnessForStakeAddr sWit) + Nothing -> (sCred, KeyWitness KeyWitnessForStakeAddr) -- ---------------------------------------------------------------------------- -- Transaction body validation and conversion -- -txFeatureMismatch :: () +txFeatureMismatch + :: () => Monad m => CardanoEra era -> TxFeature -> ExceptT TxCmdError m a txFeatureMismatch era feature = - hoistEither . Left $ TxCmdTxFeatureMismatch (anyCardanoEra era) feature + hoistEither . Left $ TxCmdTxFeatureMismatch (anyCardanoEra era) feature -txFeatureMismatchPure :: CardanoEra era - -> TxFeature - -> Either TxCmdError a +txFeatureMismatchPure + :: CardanoEra era + -> TxFeature + -> Either TxCmdError a txFeatureMismatchPure era feature = - Left (TxCmdTxFeatureMismatch (anyCardanoEra era) feature) - + Left (TxCmdTxFeatureMismatch (anyCardanoEra era) feature) validateTxIns :: [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] validateTxIns = map convert where - convert - :: (TxIn, Maybe (ScriptWitness WitCtxTxIn era)) - -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) - convert (txin, mScriptWitness) = - case mScriptWitness of - Just sWit -> - (txin , BuildTxWith $ ScriptWitness ScriptWitnessForSpending sWit) - Nothing -> - (txin, BuildTxWith $ KeyWitness KeyWitnessForSpending) - - -validateTxInsCollateral :: ShelleyBasedEra era - -> [TxIn] - -> Either TxCmdError (TxInsCollateral era) -validateTxInsCollateral _ [] = return TxInsCollateralNone + convert + :: (TxIn, Maybe (ScriptWitness WitCtxTxIn era)) + -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) + convert (txin, mScriptWitness) = + case mScriptWitness of + Just sWit -> + (txin, BuildTxWith $ ScriptWitness ScriptWitnessForSpending sWit) + Nothing -> + (txin, BuildTxWith $ KeyWitness KeyWitnessForSpending) + +validateTxInsCollateral + :: ShelleyBasedEra era + -> [TxIn] + -> Either TxCmdError (TxInsCollateral era) +validateTxInsCollateral _ [] = return TxInsCollateralNone validateTxInsCollateral era txins = do forShelleyBasedEraInEonMaybe era (\supported -> TxInsCollateral supported txins) & maybe (txFeatureMismatchPure (toCardanoEra era) TxFeatureCollateral) Right - validateTxInsReference :: ShelleyBasedEra era -> [TxIn] -> Either TxCmdError (TxInsReference BuildTx era) -validateTxInsReference _ [] = return TxInsReferenceNone +validateTxInsReference _ [] = return TxInsReferenceNone validateTxInsReference sbe allRefIns = do forShelleyBasedEraInEonMaybe sbe (\supported -> TxInsReference supported allRefIns) & maybe (txFeatureMismatchPure (toCardanoEra sbe) TxFeatureReferenceInputs) Right getAllReferenceInputs - :: [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))] - -> [ScriptWitness WitCtxMint era] - -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] - -> [(StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era))] - -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] - -> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))] - -> [TxIn] -- ^ Read only reference inputs - -> [TxIn] -getAllReferenceInputs txins mintWitnesses certFiles withdrawals - votingProceduresAndMaybeScriptWits propProceduresAnMaybeScriptWits - readOnlyRefIns = do - let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins] - mintingRefInputs = map getReferenceInput mintWitnesses - certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles] - withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals] - votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] - propsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits] - - catMaybes $ concat [ txinsWitByRefInputs - , mintingRefInputs - , certsWitByRefInputs - , withdrawalsWitByRefInputs - , votesWitByRefInputs - , propsWitByRefInputs - , map Just readOnlyRefIns - ] - where - getReferenceInput - :: ScriptWitness witctx era -> Maybe TxIn - getReferenceInput sWit = - case sWit of - PlutusScriptWitness _ _ (PReferenceScript refIn _) _ _ _ -> Just refIn - PlutusScriptWitness _ _ PScript{} _ _ _ -> Nothing - SimpleScriptWitness _ (SReferenceScript refIn _) -> Just refIn - SimpleScriptWitness _ SScript{} -> Nothing + :: [(TxIn, Maybe (ScriptWitness WitCtxTxIn era))] + -> [ScriptWitness WitCtxMint era] + -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))] + -> [(StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era))] + -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] + -> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))] + -> [TxIn] + -- ^ Read only reference inputs + -> [TxIn] +getAllReferenceInputs + txins + mintWitnesses + certFiles + withdrawals + votingProceduresAndMaybeScriptWits + propProceduresAnMaybeScriptWits + readOnlyRefIns = do + let txinsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- txins] + mintingRefInputs = map getReferenceInput mintWitnesses + certsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- certFiles] + withdrawalsWitByRefInputs = [getReferenceInput sWit | (_, _, Just sWit) <- withdrawals] + votesWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- votingProceduresAndMaybeScriptWits] + propsWitByRefInputs = [getReferenceInput sWit | (_, Just sWit) <- propProceduresAnMaybeScriptWits] + + catMaybes $ + concat + [ txinsWitByRefInputs + , mintingRefInputs + , certsWitByRefInputs + , withdrawalsWitByRefInputs + , votesWitByRefInputs + , propsWitByRefInputs + , map Just readOnlyRefIns + ] + where + getReferenceInput + :: ScriptWitness witctx era -> Maybe TxIn + getReferenceInput sWit = + case sWit of + PlutusScriptWitness _ _ (PReferenceScript refIn _) _ _ _ -> Just refIn + PlutusScriptWitness _ _ PScript{} _ _ _ -> Nothing + SimpleScriptWitness _ (SReferenceScript refIn _) -> Just refIn + SimpleScriptWitness _ SScript{} -> Nothing toAddressInAnyEra :: CardanoEra era @@ -962,21 +1186,21 @@ toAddressInAnyEra -> Either TxCmdError (AddressInEra era) toAddressInAnyEra era addrAny = runExcept $ do case addrAny of - AddressByron bAddr -> pure (AddressInEra ByronAddressInAnyEra bAddr) + AddressByron bAddr -> pure (AddressInEra ByronAddressInAnyEra bAddr) AddressShelley sAddr -> do - sbe <- requireShelleyBasedEra era - & onNothing (txFeatureMismatch era TxFeatureShelleyAddresses) + sbe <- + requireShelleyBasedEra era + & onNothing (txFeatureMismatch era TxFeatureShelleyAddresses) pure (AddressInEra (ShelleyAddressInEra sbe) sAddr) - toAddressInShelleyBasedEra :: ShelleyBasedEra era -> Address ShelleyAddr -> Either TxCmdError (AddressInEra era) -toAddressInShelleyBasedEra sbe sAddr = runExcept $ - pure (AddressInEra (ShelleyAddressInEra sbe) sAddr) - +toAddressInShelleyBasedEra sbe sAddr = + runExcept $ + pure (AddressInEra (ShelleyAddressInEra sbe) sAddr) toTxOutValueInAnyEra :: ShelleyBasedEra era @@ -984,12 +1208,11 @@ toTxOutValueInAnyEra -> Either TxCmdError (TxOutValue era) toTxOutValueInAnyEra era val = caseShelleyToAllegraOrMaryEraOnwards - (\_ -> case valueToLovelace val of - Just l -> return (TxOutValueShelleyBased era l) - Nothing -> txFeatureMismatchPure (toCardanoEra era) TxFeatureMultiAssetOutputs - ) - (\w -> return (TxOutValueShelleyBased era (toLedgerValue w val)) + ( \_ -> case valueToLovelace val of + Just l -> return (TxOutValueShelleyBased era l) + Nothing -> txFeatureMismatchPure (toCardanoEra era) TxFeatureMultiAssetOutputs ) + (\w -> return (TxOutValueShelleyBased era (toLedgerValue w val))) era toTxOutValueInShelleyBasedEra @@ -998,15 +1221,13 @@ toTxOutValueInShelleyBasedEra -> Either TxCmdError (TxOutValue era) toTxOutValueInShelleyBasedEra sbe val = caseShelleyToAllegraOrMaryEraOnwards - (\_ -> case valueToLovelace val of - Just l -> return (TxOutValueShelleyBased sbe l) - Nothing -> txFeatureMismatchPure (toCardanoEra sbe) TxFeatureMultiAssetOutputs - ) - (\w -> return (TxOutValueShelleyBased sbe (toLedgerValue w val)) + ( \_ -> case valueToLovelace val of + Just l -> return (TxOutValueShelleyBased sbe l) + Nothing -> txFeatureMismatchPure (toCardanoEra sbe) TxFeatureMultiAssetOutputs ) + (\w -> return (TxOutValueShelleyBased sbe (toLedgerValue w val))) sbe - toTxOutInShelleyBasedEra :: ShelleyBasedEra era -> TxOutShelleyBasedEra @@ -1021,14 +1242,14 @@ toTxOutInShelleyBasedEra era (TxOutShelleyBasedEra addr' val' mDatumHash refScri (\wa -> toTxAlonzoDatum wa mDatumHash) era - refScript <- inEonForEra - (pure ReferenceScriptNone) - (\wb -> getReferenceScript wb refScriptFp) - (toCardanoEra era) + refScript <- + inEonForEra + (pure ReferenceScriptNone) + (\wb -> getReferenceScript wb refScriptFp) + (toCardanoEra era) pure $ TxOut addr val datum refScript - toTxOutByronEra :: TxOutAnyEra -> ExceptT TxCmdError IO (TxOut CtxTx ByronEra) @@ -1040,9 +1261,10 @@ toTxOutByronEra (TxOutAnyEra addr' val' _ _) = do -- TODO: toTxOutInAnyEra eventually will not be needed because -- byron related functionality will be treated -- separately -toTxOutInAnyEra :: ShelleyBasedEra era - -> TxOutAnyEra - -> ExceptT TxCmdError IO (TxOut CtxTx era) +toTxOutInAnyEra + :: ShelleyBasedEra era + -> TxOutAnyEra + -> ExceptT TxCmdError IO (TxOut CtxTx era) toTxOutInAnyEra era (TxOutAnyEra addr' val' mDatumHash refScriptFp) = do let cEra = toCardanoEra era addr <- hoistEither $ toAddressInAnyEra cEra addr' @@ -1054,13 +1276,15 @@ toTxOutInAnyEra era (TxOutAnyEra addr' val' mDatumHash refScriptFp) = do (\wa -> toTxAlonzoDatum wa mDatumHash) era - refScript <- caseShelleyToAlonzoOrBabbageEraOnwards - (const (pure ReferenceScriptNone)) - (\wb -> getReferenceScript wb refScriptFp) - era + refScript <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const (pure ReferenceScriptNone)) + (\wb -> getReferenceScript wb refScriptFp) + era pure $ TxOut addr val datum refScript -getReferenceScript :: () +getReferenceScript + :: () => BabbageEraOnwards era -> ReferenceScriptAnyEra -> ExceptT TxCmdError IO (ReferenceScript era) @@ -1068,7 +1292,8 @@ getReferenceScript w = \case ReferenceScriptAnyEraNone -> return ReferenceScriptNone ReferenceScriptAnyEra fp -> ReferenceScript w <$> firstExceptT TxCmdScriptFileError (readFileScriptInAnyLang fp) -toTxAlonzoDatum :: () +toTxAlonzoDatum + :: () => AlonzoEraOnwards era -> TxOutDatumAnyEra -> ExceptT TxCmdError IO (TxOutDatum CtxTx era) @@ -1093,31 +1318,33 @@ toTxAlonzoDatum supp cliDatum = -- given reference input (since we don't have the script in this case). To avoid asking -- for the policy id twice (in the build command) we can potentially query the UTxO and -- access the script (and therefore the policy id). -createTxMintValue :: forall era. ShelleyBasedEra era - -> (Value, [ScriptWitness WitCtxMint era]) - -> Either TxCmdError (TxMintValue BuildTx era) +createTxMintValue + :: forall era + . ShelleyBasedEra era + -> (Value, [ScriptWitness WitCtxMint era]) + -> Either TxCmdError (TxMintValue BuildTx era) createTxMintValue era (val, scriptWitnesses) = if List.null (valueToList val) && List.null scriptWitnesses - then return TxMintNone - else do - caseShelleyToAllegraOrMaryEraOnwards - (const (txFeatureMismatchPure (toCardanoEra era) TxFeatureMintValue)) - (\w -> do - -- The set of policy ids for which we need witnesses: - let witnessesNeededSet :: Set PolicyId - witnessesNeededSet = - Set.fromList [ pid | (AssetId pid _, _) <- valueToList val ] - - let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) - witnessesProvidedMap = Map.fromList $ gatherMintingWitnesses scriptWitnesses - witnessesProvidedSet = Map.keysSet witnessesProvidedMap - - -- Check not too many, nor too few: - validateAllWitnessesProvided witnessesNeededSet witnessesProvidedSet - validateNoUnnecessaryWitnesses witnessesNeededSet witnessesProvidedSet - return (TxMintValue w val (BuildTxWith witnessesProvidedMap)) - ) - era + then return TxMintNone + else do + caseShelleyToAllegraOrMaryEraOnwards + (const (txFeatureMismatchPure (toCardanoEra era) TxFeatureMintValue)) + ( \w -> do + -- The set of policy ids for which we need witnesses: + let witnessesNeededSet :: Set PolicyId + witnessesNeededSet = + Set.fromList [pid | (AssetId pid _, _) <- valueToList val] + + let witnessesProvidedMap :: Map PolicyId (ScriptWitness WitCtxMint era) + witnessesProvidedMap = Map.fromList $ gatherMintingWitnesses scriptWitnesses + witnessesProvidedSet = Map.keysSet witnessesProvidedMap + + -- Check not too many, nor too few: + validateAllWitnessesProvided witnessesNeededSet witnessesProvidedSet + validateNoUnnecessaryWitnesses witnessesNeededSet witnessesProvidedSet + return (TxMintValue w val (BuildTxWith witnessesProvidedMap)) + ) + era where gatherMintingWitnesses :: [ScriptWitness WitCtxMint era] @@ -1131,25 +1358,24 @@ createTxMintValue era (val, scriptWitnesses) = validateAllWitnessesProvided witnessesNeeded witnessesProvided | null witnessesMissing = return () | otherwise = Left (TxCmdPolicyIdsMissing witnessesMissing (toList witnessesProvided)) - where - witnessesMissing = Set.elems (witnessesNeeded Set.\\ witnessesProvided) + where + witnessesMissing = Set.elems (witnessesNeeded Set.\\ witnessesProvided) validateNoUnnecessaryWitnesses witnessesNeeded witnessesProvided | null witnessesExtra = return () | otherwise = Left (TxCmdPolicyIdsExcess witnessesExtra) - where - witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded) + where + witnessesExtra = Set.elems (witnessesProvided Set.\\ witnessesNeeded) scriptWitnessPolicyId :: ScriptWitness witctx era -> Maybe PolicyId scriptWitnessPolicyId (SimpleScriptWitness _ (SScript script)) = - Just . scriptPolicyId $ SimpleScript script + Just . scriptPolicyId $ SimpleScript script scriptWitnessPolicyId (SimpleScriptWitness _ (SReferenceScript _ mPid)) = - PolicyId <$> mPid + PolicyId <$> mPid scriptWitnessPolicyId (PlutusScriptWitness _ version (PScript script) _ _ _) = - Just . scriptPolicyId $ PlutusScript version script + Just . scriptPolicyId $ PlutusScript version script scriptWitnessPolicyId (PlutusScriptWitness _ _ (PReferenceScript _ mPid) _ _ _) = - PolicyId <$> mPid - + PolicyId <$> mPid readValueScriptWitnesses :: ShelleyBasedEra era @@ -1163,211 +1389,225 @@ readValueScriptWitnesses era (v, sWitFiles) = do -- Transaction signing -- -runTransactionSignCmd :: () +runTransactionSignCmd + :: () => Cmd.TransactionSignCmdArgs -> ExceptT TxCmdError IO () runTransactionSignCmd - Cmd.TransactionSignCmdArgs - { txOrTxBodyFile = txOrTxBody - , witnessSigningData = witnessSigningData - , mNetworkId = mNetworkId - , outTxFile = outTxFile - } = do - sks <- forM witnessSigningData $ \d -> - lift (readWitnessSigningData d) - & onLeft (left . TxCmdReadWitnessSigningDataError) - - let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks + Cmd.TransactionSignCmdArgs + { txOrTxBodyFile = txOrTxBody + , witnessSigningData = witnessSigningData + , mNetworkId = mNetworkId + , outTxFile = outTxFile + } = do + sks <- forM witnessSigningData $ \d -> + lift (readWitnessSigningData d) + & onLeft (left . TxCmdReadWitnessSigningDataError) - case txOrTxBody of - InputTxFile (File inputTxFilePath) -> do - inputTxFile <- liftIO $ fileOrPipe inputTxFilePath - anyTx <- lift (readFileTx inputTxFile) & onLeft (left . TxCmdTextEnvCddlError) + let (sksByron, sksShelley) = partitionSomeWitnesses $ map categoriseSomeSigningWitness sks - InAnyShelleyBasedEra sbe tx <- pure anyTx + case txOrTxBody of + InputTxFile (File inputTxFilePath) -> do + inputTxFile <- liftIO $ fileOrPipe inputTxFilePath + anyTx <- lift (readFileTx inputTxFile) & onLeft (left . TxCmdTextEnvCddlError) - let (txbody, existingTxKeyWits) = getTxBodyAndWitnesses tx + InAnyShelleyBasedEra sbe tx <- pure anyTx - byronWitnesses <- - pure (mkShelleyBootstrapWitnesses sbe mNetworkId txbody sksByron) - & onLeft (left . TxCmdBootstrapWitnessError) + let (txbody, existingTxKeyWits) = getTxBodyAndWitnesses tx - let newShelleyKeyWits = map (makeShelleyKeyWitness sbe txbody) sksShelley - allKeyWits = existingTxKeyWits ++ newShelleyKeyWits ++ byronWitnesses - signedTx = makeSignedTransaction allKeyWits txbody + byronWitnesses <- + pure (mkShelleyBootstrapWitnesses sbe mNetworkId txbody sksByron) + & onLeft (left . TxCmdBootstrapWitnessError) - lift (writeTxFileTextEnvelopeCddl sbe outTxFile signedTx) - & onLeft (left . TxCmdWriteFileError) + let newShelleyKeyWits = map (makeShelleyKeyWitness sbe txbody) sksShelley + allKeyWits = existingTxKeyWits ++ newShelleyKeyWits ++ byronWitnesses + signedTx = makeSignedTransaction allKeyWits txbody - InputTxBodyFile (File txbodyFilePath) -> do - txbodyFile <- liftIO $ fileOrPipe txbodyFilePath - unwitnessed <- firstExceptT TxCmdTextEnvCddlError . newExceptT - $ readFileTxBody txbodyFile + lift (writeTxFileTextEnvelopeCddl sbe outTxFile signedTx) + & onLeft (left . TxCmdWriteFileError) + InputTxBodyFile (File txbodyFilePath) -> do + txbodyFile <- liftIO $ fileOrPipe txbodyFilePath + unwitnessed <- + firstExceptT TxCmdTextEnvCddlError . newExceptT $ + readFileTxBody txbodyFile - case unwitnessed of - IncompleteCddlTxBody anyTxBody -> do - InAnyShelleyBasedEra sbe txbody <- pure anyTxBody + case unwitnessed of + IncompleteCddlTxBody anyTxBody -> do + InAnyShelleyBasedEra sbe txbody <- pure anyTxBody - -- Byron witnesses require the network ID. This can either be provided - -- directly or derived from a provided Byron address. - byronWitnesses <- firstExceptT TxCmdBootstrapWitnessError - . hoistEither - $ mkShelleyBootstrapWitnesses sbe mNetworkId txbody sksByron + -- Byron witnesses require the network ID. This can either be provided + -- directly or derived from a provided Byron address. + byronWitnesses <- + firstExceptT TxCmdBootstrapWitnessError + . hoistEither + $ mkShelleyBootstrapWitnesses sbe mNetworkId txbody sksByron - let shelleyKeyWitnesses = map (makeShelleyKeyWitness sbe txbody) sksShelley - tx = makeSignedTransaction (byronWitnesses ++ shelleyKeyWitnesses) txbody + let shelleyKeyWitnesses = map (makeShelleyKeyWitness sbe txbody) sksShelley + tx = makeSignedTransaction (byronWitnesses ++ shelleyKeyWitnesses) txbody - lift (writeTxFileTextEnvelopeCddl sbe outTxFile tx) - & onLeft (left . TxCmdWriteFileError) + lift (writeTxFileTextEnvelopeCddl sbe outTxFile tx) + & onLeft (left . TxCmdWriteFileError) -- ---------------------------------------------------------------------------- -- Transaction submission -- -runTransactionSubmitCmd :: () +runTransactionSubmitCmd + :: () => Cmd.TransactionSubmitCmdArgs -> ExceptT TxCmdError IO () runTransactionSubmitCmd - Cmd.TransactionSubmitCmdArgs - { nodeSocketPath - , consensusModeParams - , networkId - , txFile - } = do - txFileOrPipe <- liftIO $ fileOrPipe txFile - InAnyShelleyBasedEra era tx <- lift (readFileTx txFileOrPipe) & onLeft (left . TxCmdTextEnvCddlError) - let txInMode = TxInMode era tx - localNodeConnInfo = LocalNodeConnectInfo - { localConsensusModeParams = consensusModeParams - , localNodeNetworkId = networkId - , localNodeSocketPath = nodeSocketPath - } - - res <- liftIO $ submitTxToNodeLocal localNodeConnInfo txInMode - case res of - Net.Tx.SubmitSuccess -> liftIO $ Text.putStrLn "Transaction successfully submitted." - Net.Tx.SubmitFail reason -> - case reason of - TxValidationErrorInCardanoMode err -> left . TxCmdTxSubmitError . Text.pack $ show err - TxValidationEraMismatch mismatchErr -> left $ TxCmdTxSubmitErrorEraMismatch mismatchErr + Cmd.TransactionSubmitCmdArgs + { nodeSocketPath + , consensusModeParams + , networkId + , txFile + } = do + txFileOrPipe <- liftIO $ fileOrPipe txFile + InAnyShelleyBasedEra era tx <- + lift (readFileTx txFileOrPipe) & onLeft (left . TxCmdTextEnvCddlError) + let txInMode = TxInMode era tx + localNodeConnInfo = + LocalNodeConnectInfo + { localConsensusModeParams = consensusModeParams + , localNodeNetworkId = networkId + , localNodeSocketPath = nodeSocketPath + } + + res <- liftIO $ submitTxToNodeLocal localNodeConnInfo txInMode + case res of + Net.Tx.SubmitSuccess -> liftIO $ Text.putStrLn "Transaction successfully submitted." + Net.Tx.SubmitFail reason -> + case reason of + TxValidationErrorInCardanoMode err -> left . TxCmdTxSubmitError . Text.pack $ show err + TxValidationEraMismatch mismatchErr -> left $ TxCmdTxSubmitErrorEraMismatch mismatchErr -- ---------------------------------------------------------------------------- -- Transaction fee calculation -- -runTransactionCalculateMinFeeCmd :: () +runTransactionCalculateMinFeeCmd + :: () => Cmd.TransactionCalculateMinFeeCmdArgs -> ExceptT TxCmdError IO () runTransactionCalculateMinFeeCmd - Cmd.TransactionCalculateMinFeeCmdArgs - { txBodyFile = File txbodyFilePath - , protocolParamsFile = protocolParamsFile - , txShelleyWitnessCount = TxShelleyWitnessCount nShelleyKeyWitnesses - , txByronWitnessCount = TxByronWitnessCount nByronKeyWitnesses - , referenceScriptSize = ReferenceScriptSize sReferenceScript - , outputFormat - , outFile - } = do - - txbodyFile <- liftIO $ fileOrPipe txbodyFilePath - unwitnessed <- - firstExceptT TxCmdTextEnvCddlError . newExceptT - $ readFileTxBody txbodyFile - - let nShelleyKeyWitW32 = fromIntegral nShelleyKeyWitnesses - - InAnyShelleyBasedEra sbe txbody <- pure $ unIncompleteCddlTxBody unwitnessed - - lpparams <- - firstExceptT TxCmdProtocolParamsError - $ readProtocolParameters sbe protocolParamsFile - - let shelleyfee = evaluateTransactionFee sbe lpparams txbody nShelleyKeyWitW32 0 sReferenceScript - - let byronfee = shelleyBasedEraConstraints sbe $ calculateByronWitnessFees (lpparams ^. L.ppMinFeeAL) nByronKeyWitnesses - - let L.Coin fee = shelleyfee + byronfee - textToWrite = Text.pack ((show fee :: String) <> " Lovelace") - jsonToWrite = encodePretty $ Aeson.object ["fee" .= fee] - - case (newOutputFormat outputFormat outFile, outFile) of - (OutputFormatText, Nothing) -> - liftIO $ Text.putStrLn textToWrite - (OutputFormatText, Just file) -> - firstExceptT TxCmdWriteFileError . newExceptT $ writeTextFile file textToWrite - (OutputFormatJson, Nothing) -> - liftIO $ LBS.putStrLn jsonToWrite - (OutputFormatJson, Just file) -> - firstExceptT TxCmdWriteFileError . newExceptT $ writeLazyByteStringFile file jsonToWrite + Cmd.TransactionCalculateMinFeeCmdArgs + { txBodyFile = File txbodyFilePath + , protocolParamsFile = protocolParamsFile + , txShelleyWitnessCount = TxShelleyWitnessCount nShelleyKeyWitnesses + , txByronWitnessCount = TxByronWitnessCount nByronKeyWitnesses + , referenceScriptSize = ReferenceScriptSize sReferenceScript + , outputFormat + , outFile + } = do + txbodyFile <- liftIO $ fileOrPipe txbodyFilePath + unwitnessed <- + firstExceptT TxCmdTextEnvCddlError . newExceptT $ + readFileTxBody txbodyFile + + let nShelleyKeyWitW32 = fromIntegral nShelleyKeyWitnesses + + InAnyShelleyBasedEra sbe txbody <- pure $ unIncompleteCddlTxBody unwitnessed + + lpparams <- + firstExceptT TxCmdProtocolParamsError $ + readProtocolParameters sbe protocolParamsFile + + let shelleyfee = evaluateTransactionFee sbe lpparams txbody nShelleyKeyWitW32 0 sReferenceScript + + let byronfee = + shelleyBasedEraConstraints sbe $ + calculateByronWitnessFees (lpparams ^. L.ppMinFeeAL) nByronKeyWitnesses + + let L.Coin fee = shelleyfee + byronfee + textToWrite = Text.pack ((show fee :: String) <> " Lovelace") + jsonToWrite = encodePretty $ Aeson.object ["fee" .= fee] + + case (newOutputFormat outputFormat outFile, outFile) of + (OutputFormatText, Nothing) -> + liftIO $ Text.putStrLn textToWrite + (OutputFormatText, Just file) -> + firstExceptT TxCmdWriteFileError . newExceptT $ writeTextFile file textToWrite + (OutputFormatJson, Nothing) -> + liftIO $ LBS.putStrLn jsonToWrite + (OutputFormatJson, Just file) -> + firstExceptT TxCmdWriteFileError . newExceptT $ writeLazyByteStringFile file jsonToWrite -- Extra logic to handle byron witnesses. -- TODO: move this to Cardano.API.Fee.evaluateTransactionFee. -calculateByronWitnessFees :: () - => L.Coin -- ^ The tx fee per byte (from protocol parameters) - -> Int -- ^ The number of Byron key witnesses +calculateByronWitnessFees + :: () + => L.Coin + -- ^ The tx fee per byte (from protocol parameters) + -> Int + -- ^ The number of Byron key witnesses -> L.Coin calculateByronWitnessFees txFeePerByte byronwitcount = - L.Coin - $ toInteger txFeePerByte + L.Coin $ + toInteger txFeePerByte * toInteger byronwitcount * toInteger sizeByronKeyWitnesses - where - sizeByronKeyWitnesses = smallArray + keyObj + sigObj + ccodeObj + attrsObj - - smallArray = 1 + where + sizeByronKeyWitnesses = smallArray + keyObj + sigObj + ccodeObj + attrsObj - keyObj = 2 + keyLen - keyLen = 32 + smallArray = 1 - sigObj = 2 + sigLen - sigLen = 64 + keyObj = 2 + keyLen + keyLen = 32 - ccodeObj = 2 + ccodeLen - ccodeLen = 32 + sigObj = 2 + sigLen + sigLen = 64 - attrsObj = 2 + Data.Bytestring.length attributes + ccodeObj = 2 + ccodeLen + ccodeLen = 32 - -- We assume testnet network magic here to avoid having - -- to thread the actual network ID into this function - -- merely to calculate the fees of byron witnesses more accurately. - -- This may slightly over-estimate min fees for byron witnesses - -- in mainnet transaction by one Word32 per witness. - attributes = CBOR.serialize' $ - Byron.mkAttributes Byron.AddrAttributes { - Byron.aaVKDerivationPath = Nothing, - Byron.aaNetworkMagic = Byron.NetworkTestnet maxBound - } + attrsObj = 2 + Data.Bytestring.length attributes + -- We assume testnet network magic here to avoid having + -- to thread the actual network ID into this function + -- merely to calculate the fees of byron witnesses more accurately. + -- This may slightly over-estimate min fees for byron witnesses + -- in mainnet transaction by one Word32 per witness. + attributes = + CBOR.serialize' $ + Byron.mkAttributes + Byron.AddrAttributes + { Byron.aaVKDerivationPath = Nothing + , Byron.aaNetworkMagic = Byron.NetworkTestnet maxBound + } -- ---------------------------------------------------------------------------- -- Transaction fee calculation -- -runTransactionCalculateMinValueCmd :: () +runTransactionCalculateMinValueCmd + :: () => Cmd.TransactionCalculateMinValueCmdArgs era -> ExceptT TxCmdError IO () runTransactionCalculateMinValueCmd - Cmd.TransactionCalculateMinValueCmdArgs - { eon - , protocolParamsFile - , txOut - } = do - pp <- firstExceptT TxCmdProtocolParamsError (readProtocolParameters eon protocolParamsFile) - out <- toTxOutInShelleyBasedEra eon txOut - - let minValue = calculateMinimumUTxO eon out pp - liftIO . IO.print $ minValue - -runTransactionPolicyIdCmd :: () + Cmd.TransactionCalculateMinValueCmdArgs + { eon + , protocolParamsFile + , txOut + } = do + pp <- firstExceptT TxCmdProtocolParamsError (readProtocolParameters eon protocolParamsFile) + out <- toTxOutInShelleyBasedEra eon txOut + + let minValue = calculateMinimumUTxO eon out pp + liftIO . IO.print $ minValue + +runTransactionPolicyIdCmd + :: () => Cmd.TransactionPolicyIdCmdArgs -> ExceptT TxCmdError IO () runTransactionPolicyIdCmd - Cmd.TransactionPolicyIdCmdArgs - { scriptFile = File sFile - } = do - ScriptInAnyLang _ script <- firstExceptT TxCmdScriptFileError $ - readFileScriptInAnyLang sFile - liftIO . Text.putStrLn . serialiseToRawBytesHexText $ hashScript script + Cmd.TransactionPolicyIdCmdArgs + { scriptFile = File sFile + } = do + ScriptInAnyLang _ script <- + firstExceptT TxCmdScriptFileError $ + readFileScriptInAnyLang sFile + liftIO . Text.putStrLn . serialiseToRawBytesHexText $ hashScript script partitionSomeWitnesses :: [ByronOrShelleyWitness] @@ -1375,20 +1615,21 @@ partitionSomeWitnesses , [ShelleyWitnessSigningKey] ) partitionSomeWitnesses = reversePartitionedWits . foldl' go mempty - where - reversePartitionedWits (bw, skw) = - (reverse bw, reverse skw) + where + reversePartitionedWits (bw, skw) = + (reverse bw, reverse skw) - go (byronAcc, shelleyKeyAcc) byronOrShelleyWit = - case byronOrShelleyWit of - AByronWitness byronWit -> - (byronWit:byronAcc, shelleyKeyAcc) - AShelleyKeyWitness shelleyKeyWit -> - (byronAcc, shelleyKeyWit:shelleyKeyAcc) + go (byronAcc, shelleyKeyAcc) byronOrShelleyWit = + case byronOrShelleyWit of + AByronWitness byronWit -> + (byronWit : byronAcc, shelleyKeyAcc) + AShelleyKeyWitness shelleyKeyWit -> + (byronAcc, shelleyKeyWit : shelleyKeyAcc) -- | Construct a Shelley bootstrap witness (i.e. a Byron key witness in the -- Shelley era). -mkShelleyBootstrapWitness :: () +mkShelleyBootstrapWitness + :: () => ShelleyBasedEra era -> Maybe NetworkId -> TxBody era @@ -1403,7 +1644,8 @@ mkShelleyBootstrapWitness sbe _ txBody (ShelleyBootstrapWitnessSigningKeyData sk -- | Attempt to construct Shelley bootstrap witnesses until an error is -- encountered. -mkShelleyBootstrapWitnesses :: () +mkShelleyBootstrapWitnesses + :: () => ShelleyBasedEra era -> Maybe NetworkId -> TxBody era @@ -1412,136 +1654,150 @@ mkShelleyBootstrapWitnesses :: () mkShelleyBootstrapWitnesses sbe mnw txBody = mapM (mkShelleyBootstrapWitness sbe mnw txBody) - -- ---------------------------------------------------------------------------- -- Other misc small commands -- -runTransactionHashScriptDataCmd :: () +runTransactionHashScriptDataCmd + :: () => Cmd.TransactionHashScriptDataCmdArgs -> ExceptT TxCmdError IO () runTransactionHashScriptDataCmd - Cmd.TransactionHashScriptDataCmdArgs - { scriptDataOrFile - } = do - d <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile scriptDataOrFile - liftIO $ BS.putStrLn $ serialiseToRawBytesHex (hashScriptDataBytes d) + Cmd.TransactionHashScriptDataCmdArgs + { scriptDataOrFile + } = do + d <- firstExceptT TxCmdScriptDataError $ readScriptDataOrFile scriptDataOrFile + liftIO $ BS.putStrLn $ serialiseToRawBytesHex (hashScriptDataBytes d) -runTransactionTxIdCmd :: () +runTransactionTxIdCmd + :: () => Cmd.TransactionTxIdCmdArgs -> ExceptT TxCmdError IO () runTransactionTxIdCmd - Cmd.TransactionTxIdCmdArgs - { inputTxBodyOrTxFile - } = do - InAnyShelleyBasedEra _era txbody <- + Cmd.TransactionTxIdCmdArgs + { inputTxBodyOrTxFile + } = do + InAnyShelleyBasedEra _era txbody <- + case inputTxBodyOrTxFile of + InputTxBodyFile (File txbodyFilePath) -> do + txbodyFile <- liftIO $ fileOrPipe txbodyFilePath + unwitnessed <- + firstExceptT TxCmdTextEnvCddlError . newExceptT $ + readFileTxBody txbodyFile + return $ unIncompleteCddlTxBody unwitnessed + InputTxFile (File txFilePath) -> do + txFile <- liftIO $ fileOrPipe txFilePath + InAnyShelleyBasedEra era tx <- lift (readFileTx txFile) & onLeft (left . TxCmdTextEnvCddlError) + return . InAnyShelleyBasedEra era $ getTxBody tx + + liftIO $ BS.putStrLn $ serialiseToRawBytesHex (getTxId txbody) + +runTransactionViewCmd + :: () + => Cmd.TransactionViewCmdArgs + -> ExceptT TxCmdError IO () +runTransactionViewCmd + Cmd.TransactionViewCmdArgs + { outputFormat + , mOutFile + , inputTxBodyOrTxFile + } = case inputTxBodyOrTxFile of InputTxBodyFile (File txbodyFilePath) -> do txbodyFile <- liftIO $ fileOrPipe txbodyFilePath - unwitnessed <- firstExceptT TxCmdTextEnvCddlError . newExceptT - $ readFileTxBody txbodyFile - return $ unIncompleteCddlTxBody unwitnessed - + unwitnessed <- + firstExceptT TxCmdTextEnvCddlError . newExceptT $ + readFileTxBody txbodyFile + InAnyShelleyBasedEra era txbody <- pure $ unIncompleteCddlTxBody unwitnessed + -- Why are we differentiating between a transaction body and a transaction? + -- In the case of a transaction body, we /could/ simply call @makeSignedTransaction []@ + -- to get a transaction which would allow us to reuse friendlyTxBS. However, + -- this would mean that we'd have an empty list of witnesses mentioned in the output, which + -- is arguably not part of the transaction body. + firstExceptT TxCmdWriteFileError . newExceptT $ + case outputFormat of + ViewOutputFormatYaml -> friendlyTxBody FriendlyYaml mOutFile (toCardanoEra era) txbody + ViewOutputFormatJson -> friendlyTxBody FriendlyJson mOutFile (toCardanoEra era) txbody InputTxFile (File txFilePath) -> do txFile <- liftIO $ fileOrPipe txFilePath InAnyShelleyBasedEra era tx <- lift (readFileTx txFile) & onLeft (left . TxCmdTextEnvCddlError) - return . InAnyShelleyBasedEra era $ getTxBody tx - - liftIO $ BS.putStrLn $ serialiseToRawBytesHex (getTxId txbody) - -runTransactionViewCmd :: () - => Cmd.TransactionViewCmdArgs - -> ExceptT TxCmdError IO () -runTransactionViewCmd - Cmd.TransactionViewCmdArgs - { outputFormat - , mOutFile - , inputTxBodyOrTxFile - } = - case inputTxBodyOrTxFile of - InputTxBodyFile (File txbodyFilePath) -> do - txbodyFile <- liftIO $ fileOrPipe txbodyFilePath - unwitnessed <- firstExceptT TxCmdTextEnvCddlError . newExceptT - $ readFileTxBody txbodyFile - InAnyShelleyBasedEra era txbody <- pure $ unIncompleteCddlTxBody unwitnessed - -- Why are we differentiating between a transaction body and a transaction? - -- In the case of a transaction body, we /could/ simply call @makeSignedTransaction []@ - -- to get a transaction which would allow us to reuse friendlyTxBS. However, - -- this would mean that we'd have an empty list of witnesses mentioned in the output, which - -- is arguably not part of the transaction body. - firstExceptT TxCmdWriteFileError . newExceptT $ - case outputFormat of - ViewOutputFormatYaml -> friendlyTxBody FriendlyYaml mOutFile (toCardanoEra era) txbody - ViewOutputFormatJson -> friendlyTxBody FriendlyJson mOutFile (toCardanoEra era) txbody - InputTxFile (File txFilePath) -> do - txFile <- liftIO $ fileOrPipe txFilePath - InAnyShelleyBasedEra era tx <- lift (readFileTx txFile) & onLeft (left . TxCmdTextEnvCddlError) - firstExceptT TxCmdWriteFileError . newExceptT $ - case outputFormat of - ViewOutputFormatYaml -> friendlyTx FriendlyYaml mOutFile (toCardanoEra era) tx - ViewOutputFormatJson -> friendlyTx FriendlyJson mOutFile (toCardanoEra era) tx + firstExceptT TxCmdWriteFileError . newExceptT $ + case outputFormat of + ViewOutputFormatYaml -> friendlyTx FriendlyYaml mOutFile (toCardanoEra era) tx + ViewOutputFormatJson -> friendlyTx FriendlyJson mOutFile (toCardanoEra era) tx -- ---------------------------------------------------------------------------- -- Witness commands -- -runTransactionWitnessCmd :: () +runTransactionWitnessCmd + :: () => Cmd.TransactionWitnessCmdArgs -> ExceptT TxCmdError IO () runTransactionWitnessCmd - Cmd.TransactionWitnessCmdArgs - { txBodyFile = File txbodyFilePath - , witnessSigningData - , mNetworkId - , outFile - } = do - txbodyFile <- liftIO $ fileOrPipe txbodyFilePath - unwitnessed <- firstExceptT TxCmdTextEnvCddlError . newExceptT - $ readFileTxBody txbodyFile - case unwitnessed of - IncompleteCddlTxBody anyTxBody -> do - InAnyShelleyBasedEra sbe txbody <- pure anyTxBody - someWit <- firstExceptT TxCmdReadWitnessSigningDataError - . newExceptT $ readWitnessSigningData witnessSigningData - witness <- - case categoriseSomeSigningWitness someWit of - -- Byron witnesses require the network ID. This can either be provided - -- directly or derived from a provided Byron address. - AByronWitness bootstrapWitData -> - firstExceptT TxCmdBootstrapWitnessError - . hoistEither - $ mkShelleyBootstrapWitness sbe mNetworkId txbody bootstrapWitData - AShelleyKeyWitness skShelley -> - pure $ makeShelleyKeyWitness sbe txbody skShelley - - firstExceptT TxCmdWriteFileError . newExceptT - $ writeTxWitnessFileTextEnvelopeCddl sbe outFile witness - -runTransactionSignWitnessCmd :: () + Cmd.TransactionWitnessCmdArgs + { txBodyFile = File txbodyFilePath + , witnessSigningData + , mNetworkId + , outFile + } = do + txbodyFile <- liftIO $ fileOrPipe txbodyFilePath + unwitnessed <- + firstExceptT TxCmdTextEnvCddlError . newExceptT $ + readFileTxBody txbodyFile + case unwitnessed of + IncompleteCddlTxBody anyTxBody -> do + InAnyShelleyBasedEra sbe txbody <- pure anyTxBody + someWit <- + firstExceptT TxCmdReadWitnessSigningDataError + . newExceptT + $ readWitnessSigningData witnessSigningData + witness <- + case categoriseSomeSigningWitness someWit of + -- Byron witnesses require the network ID. This can either be provided + -- directly or derived from a provided Byron address. + AByronWitness bootstrapWitData -> + firstExceptT TxCmdBootstrapWitnessError + . hoistEither + $ mkShelleyBootstrapWitness sbe mNetworkId txbody bootstrapWitData + AShelleyKeyWitness skShelley -> + pure $ makeShelleyKeyWitness sbe txbody skShelley + + firstExceptT TxCmdWriteFileError . newExceptT $ + writeTxWitnessFileTextEnvelopeCddl sbe outFile witness + +runTransactionSignWitnessCmd + :: () => Cmd.TransactionSignWitnessCmdArgs -> ExceptT TxCmdError IO () runTransactionSignWitnessCmd - Cmd.TransactionSignWitnessCmdArgs - { txBodyFile = File txbodyFilePath - , witnessFiles = witnessFiles - , outFile = outFile - } = do - txbodyFile <- liftIO $ fileOrPipe txbodyFilePath - unwitnessed <- lift (readFileTxBody txbodyFile) & onLeft (left . TxCmdTextEnvCddlError) - case unwitnessed of - IncompleteCddlTxBody (InAnyShelleyBasedEra era txbody) -> do - -- TODO: Left off here. Remember we were never reading byron key witnesses anyways! - witnesses <- - sequence - [ do - InAnyShelleyBasedEra era' witness <- - lift (readFileTxKeyWitness file) & onLeft (left . TxCmdCddlWitnessError) - - case testEquality era era' of - Nothing -> left $ TxCmdWitnessEraMismatch (AnyCardanoEra $ toCardanoEra era) (AnyCardanoEra $ toCardanoEra era') witnessFile - Just Refl -> return witness - | witnessFile@(WitnessFile file) <- witnessFiles ] - - let tx = makeSignedTransaction witnesses txbody - - lift (writeTxFileTextEnvelopeCddl era outFile tx) & onLeft (left . TxCmdWriteFileError) + Cmd.TransactionSignWitnessCmdArgs + { txBodyFile = File txbodyFilePath + , witnessFiles = witnessFiles + , outFile = outFile + } = do + txbodyFile <- liftIO $ fileOrPipe txbodyFilePath + unwitnessed <- lift (readFileTxBody txbodyFile) & onLeft (left . TxCmdTextEnvCddlError) + case unwitnessed of + IncompleteCddlTxBody (InAnyShelleyBasedEra era txbody) -> do + -- TODO: Left off here. Remember we were never reading byron key witnesses anyways! + witnesses <- + sequence + [ do + InAnyShelleyBasedEra era' witness <- + lift (readFileTxKeyWitness file) & onLeft (left . TxCmdCddlWitnessError) + + case testEquality era era' of + Nothing -> + left $ + TxCmdWitnessEraMismatch + (AnyCardanoEra $ toCardanoEra era) + (AnyCardanoEra $ toCardanoEra era') + witnessFile + Just Refl -> return witness + | witnessFile@(WitnessFile file) <- witnessFiles + ] + + let tx = makeSignedTransaction witnesses txbody + + lift (writeTxFileTextEnvelopeCddl era outFile tx) & onLeft (left . TxCmdWriteFileError) diff --git a/cardano-cli/src/Cardano/CLI/Helpers.hs b/cardano-cli/src/Cardano/CLI/Helpers.hs index 78634e8c35..65c334fd67 100644 --- a/cardano-cli/src/Cardano/CLI/Helpers.hs +++ b/cardano-cli/src/Cardano/CLI/Helpers.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Helpers - ( HelpersError(..) + ( HelpersError (..) , printWarning , deprecationWarning , ensureNewFile @@ -14,15 +14,16 @@ module Cardano.CLI.Helpers , readCBOR , renderHelpersError , validateCBOR - ) where + ) +where import qualified Cardano.Api.Ledger as L -import Cardano.CLI.Pretty (Doc, pretty, pshow) import Cardano.Chain.Block (decCBORABlockOrBoundary) import qualified Cardano.Chain.Delegation as Delegation import qualified Cardano.Chain.Update as Update import qualified Cardano.Chain.UTxO as UTxO +import Cardano.CLI.Pretty (Doc, pretty, pshow) import Cardano.CLI.Types.Common import Codec.CBOR.Pretty (prettyHexEnc) @@ -79,20 +80,22 @@ printWarning warning = do ANSI.hSetSGR IO.stderr [SetColor Foreground Vivid Yellow] IO.hPutStrLn IO.stderr $ "WARNING: " <> warning ANSI.hSetSGR IO.stderr [Reset] - -- We need to flush, or otherwise what's on stdout may have the wrong colour - -- since it's likely sharing a console with stderr + -- We need to flush, or otherwise what's on stdout may have the wrong colour + -- since it's likely sharing a console with stderr IO.hFlush IO.stderr deprecationWarning :: String -> IO () -deprecationWarning cmd = printWarning $ - "This CLI command is deprecated. Please use " <> cmd <> " command instead." +deprecationWarning cmd = + printWarning $ + "This CLI command is deprecated. Please use " <> cmd <> " command instead." -- | Checks if a path exists and throws and error if it does. ensureNewFile :: (FilePath -> a -> IO ()) -> FilePath -> a -> ExceptT HelpersError IO () ensureNewFile writer outFile blob = do exists <- liftIO $ IO.doesPathExist outFile when exists $ - left $ OutputMustNotAlreadyExist outFile + left $ + OutputMustNotAlreadyExist outFile liftIO $ writer outFile blob ensureNewFileLBS :: FilePath -> ByteString -> ExceptT HelpersError IO () @@ -119,19 +122,15 @@ validateCBOR cborObject bs = CBORBlockByron epochSlots -> do void $ decodeCBOR bs (L.toPlainDecoder L.byronProtVer (decCBORABlockOrBoundary epochSlots)) Right "Valid Byron block." - CBORDelegationCertificateByron -> do void $ decodeCBOR bs (L.fromCBOR :: L.Decoder s Delegation.Certificate) Right "Valid Byron delegation certificate." - CBORTxByron -> do void $ decodeCBOR bs (L.fromCBOR :: L.Decoder s UTxO.Tx) Right "Valid Byron Tx." - CBORUpdateProposalByron -> do void $ decodeCBOR bs (L.fromCBOR :: L.Decoder s Update.Proposal) Right "Valid Byron update proposal." - CBORVoteByron -> do void $ decodeCBOR bs (L.fromCBOR :: L.Decoder s Update.Vote) Right "Valid Byron vote." diff --git a/cardano-cli/src/Cardano/CLI/IO/Lazy.hs b/cardano-cli/src/Cardano/CLI/IO/Lazy.hs index ef0182d899..20f24bbf51 100644 --- a/cardano-cli/src/Cardano/CLI/IO/Lazy.hs +++ b/cardano-cli/src/Cardano/CLI/IO/Lazy.hs @@ -8,7 +8,8 @@ module Cardano.CLI.IO.Lazy , traverseStateM , forM , forStateM - ) where + ) +where import Control.Monad.IO.Unlift (MonadIO (liftIO), MonadUnliftIO, UnliftIO (unliftIO), askUnliftIO) @@ -32,24 +33,24 @@ traverseM :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b] traverseM f as = do u <- askUnliftIO liftIO $ IO.unsafeInterleaveIO (go u as) - where - go _ [] = pure [] - go !u (v:vs) = do - !res <- unliftIO u (f v) - rest <- IO.unsafeInterleaveIO (go u vs) - pure (res:rest) + where + go _ [] = pure [] + go !u (v : vs) = do + !res <- unliftIO u (f v) + rest <- IO.unsafeInterleaveIO (go u vs) + pure (res : rest) traverseStateM :: forall m s a b. MonadUnliftIO m => s -> (s -> a -> m (s, b)) -> [a] -> m [b] traverseStateM s f as = do u <- askUnliftIO liftIO $ IO.unsafeInterleaveIO (go s u as) - where - go :: s -> UnliftIO m -> [a] -> IO [b] - go _ _ [] = pure [] - go t !u (v:vs) = do - (t', !res) <- unliftIO u (f t v) - rest <- IO.unsafeInterleaveIO (go t' u vs) - pure (res:rest) + where + go :: s -> UnliftIO m -> [a] -> IO [b] + go _ _ [] = pure [] + go t !u (v : vs) = do + (t', !res) <- unliftIO u (f t v) + rest <- IO.unsafeInterleaveIO (go t' u vs) + pure (res : rest) forM :: MonadUnliftIO m => [a] -> (a -> m b) -> m [b] forM = flip traverseM @@ -60,6 +61,7 @@ forStateM s as f = traverseStateM s f as -- Internal sequenceIO :: [IO a] -> IO [a] sequenceIO = IO.unsafeInterleaveIO . go - where go :: [IO a] -> IO [a] - go [] = return [] - go (fa:fas) = (:) <$> fa <*> IO.unsafeInterleaveIO (go fas) + where + go :: [IO a] -> IO [a] + go [] = return [] + go (fa : fas) = (:) <$> fa <*> IO.unsafeInterleaveIO (go fas) diff --git a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs index 1af621de34..f7310d4294 100644 --- a/cardano-cli/src/Cardano/CLI/Json/Friendly.hs +++ b/cardano-cli/src/Cardano/CLI/Json/Friendly.hs @@ -8,25 +8,30 @@ -- | User-friendly pretty-printing for textual user interfaces (TUI) module Cardano.CLI.Json.Friendly ( -- * Functions in IO - -- - -- Use them when writing to stdout or to files. + + -- + -- Use them when writing to stdout or to files. friendlyTx , friendlyTxBody , friendlyProposal + -- * Functions that are not in IO - -- - -- They are more low-level, but can be used in any context. - -- The '*Impl' functions give you access to the Aeson representation - -- of various structures. Then use 'friendlyBS' to format the Aeson - -- values to a ByteString, in a manner consistent with the IO functions - -- of this module. + + -- + -- They are more low-level, but can be used in any context. + -- The '*Impl' functions give you access to the Aeson representation + -- of various structures. Then use 'friendlyBS' to format the Aeson + -- values to a ByteString, in a manner consistent with the IO functions + -- of this module. , friendlyBS , friendlyTxImpl , friendlyTxBodyImpl , friendlyProposalImpl + -- * Ubiquitous types - , FriendlyFormat(..) - ) where + , FriendlyFormat (..) + ) +where import Cardano.Api as Api import Cardano.Api.Byron (KeyWitness (ByronKeyWitness)) @@ -69,8 +74,8 @@ import GHC.Unicode (isAlphaNum) data FriendlyFormat = FriendlyJson | FriendlyYaml -friendly :: - (MonadIO m, Aeson.ToJSON a) +friendly + :: (MonadIO m, Aeson.ToJSON a) => FriendlyFormat -> Maybe (File () Out) -> a @@ -78,8 +83,9 @@ friendly :: friendly FriendlyJson mOutFile = writeLazyByteStringOutput mOutFile . Aeson.encodePretty' jsonConfig friendly FriendlyYaml mOutFile = writeByteStringOutput mOutFile . Yaml.encodePretty yamlConfig -friendlyBS :: () - => (Aeson.ToJSON a) +friendlyBS + :: () + => Aeson.ToJSON a => FriendlyFormat -> a -> BS.ByteString @@ -87,35 +93,43 @@ friendlyBS FriendlyJson a = BS.concat . LBS.toChunks $ Aeson.encodePretty' jsonC friendlyBS FriendlyYaml a = Yaml.encodePretty yamlConfig a jsonConfig :: Aeson.Config -jsonConfig = Aeson.defConfig {Aeson.confCompare = compare} +jsonConfig = Aeson.defConfig{Aeson.confCompare = compare} yamlConfig :: Yaml.Config yamlConfig = Yaml.defConfig & setConfCompare compare -friendlyTx :: - (MonadIO m) +friendlyTx + :: MonadIO m => FriendlyFormat -> Maybe (File () Out) -> CardanoEra era -> Tx era -> m (Either (FileError e) ()) friendlyTx format mOutFile era = - cardanoEraConstraints era (\tx -> do pairs <- runWarningIO $ friendlyTxImpl era tx - friendly format mOutFile $ object pairs) + cardanoEraConstraints + era + ( \tx -> do + pairs <- runWarningIO $ friendlyTxImpl era tx + friendly format mOutFile $ object pairs + ) -friendlyTxBody :: - (MonadIO m) +friendlyTxBody + :: MonadIO m => FriendlyFormat -> Maybe (File () Out) -> CardanoEra era -> TxBody era -> m (Either (FileError e) ()) friendlyTxBody format mOutFile era = - cardanoEraConstraints era (\tx -> do pairs <- runWarningIO $ friendlyTxBodyImpl era tx - friendly format mOutFile $ object pairs) + cardanoEraConstraints + era + ( \tx -> do + pairs <- runWarningIO $ friendlyTxBodyImpl era tx + friendly format mOutFile $ object pairs + ) -friendlyProposal :: - (MonadIO m) +friendlyProposal + :: MonadIO m => FriendlyFormat -> Maybe (File () Out) -> ConwayEraOnwards era @@ -128,22 +142,25 @@ friendlyProposal format mOutFile era = friendlyProposalImpl :: ConwayEraOnwards era -> Proposal era -> [Aeson.Pair] friendlyProposalImpl era - (Proposal - (L.ProposalProcedure - { L.pProcDeposit - , L.pProcReturnAddr - , L.pProcGovAction - , L.pProcAnchor - } - ) - ) = conwayEraOnwardsConstraints era - [ "deposit" .= pProcDeposit - , "return address" .= pProcReturnAddr - , "governance action" .= pProcGovAction - , "anchor" .= pProcAnchor - ] + ( Proposal + ( L.ProposalProcedure + { L.pProcDeposit + , L.pProcReturnAddr + , L.pProcGovAction + , L.pProcAnchor + } + ) + ) = + conwayEraOnwardsConstraints + era + [ "deposit" .= pProcDeposit + , "return address" .= pProcReturnAddr + , "governance action" .= pProcGovAction + , "anchor" .= pProcAnchor + ] -friendlyTxImpl :: MonadWarning m +friendlyTxImpl + :: MonadWarning m => CardanoEra era -> Tx era -> m [Aeson.Pair] @@ -153,116 +170,139 @@ friendlyTxImpl era (Tx body witnesses) = friendlyKeyWitness :: KeyWitness era -> Aeson.Value friendlyKeyWitness = object - . \case + . \case ByronKeyWitness txInWitness -> ["Byron witness" .= textShow txInWitness] ShelleyBootstrapWitness _era bootstrapWitness -> ["bootstrap witness" .= textShow bootstrapWitness] ShelleyKeyWitness _era (L.WitVKey key signature) -> ["key" .= textShow key, "signature" .= textShow signature] -friendlyTxBodyImpl :: MonadWarning m +friendlyTxBodyImpl + :: MonadWarning m => CardanoEra era -> TxBody era -> m [Aeson.Pair] friendlyTxBodyImpl era - tb@(TxBody - -- Enumerating the fields, so that we are warned by GHC when we add a new one - (TxBodyContent - txIns - txInsCollateral - txInsReference - txOuts - txTotalCollateral - txReturnCollateral - txFee - txValidityLowerBound - txValidityUpperBound - txMetadata - txAuxScripts - txExtraKeyWits - _txProtocolParams - txWithdrawals - txCertificates - txUpdateProposal - txMintValue - _txScriptValidity - txProposalProcedures - txVotingProcedures - txCurrentTreasuryValue - txTreasuryDonation)) = - do redeemerDetails <- redeemerIfShelleyBased era tb - return $ cardanoEraConstraints era - ( redeemerDetails ++ - [ "auxiliary scripts" .= friendlyAuxScripts txAuxScripts - , "certificates" .= forEraInEon era Null (`friendlyCertificates` txCertificates) - , "collateral inputs" .= friendlyCollateralInputs txInsCollateral - , "era" .= era - , "fee" .= friendlyFee txFee - , "inputs" .= friendlyInputs txIns - , "metadata" .= friendlyMetadata txMetadata - , "mint" .= friendlyMintValue txMintValue - , "outputs" .= map (friendlyTxOut era) txOuts - , "reference inputs" .= friendlyReferenceInputs txInsReference - , "total collateral" .= friendlyTotalCollateral txTotalCollateral - , "return collateral" .= friendlyReturnCollateral era txReturnCollateral - , "required signers (payment key hashes needed for scripts)" .= - friendlyExtraKeyWits txExtraKeyWits - , "update proposal" .= friendlyUpdateProposal txUpdateProposal - , "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound) - , "withdrawals" .= friendlyWithdrawals txWithdrawals - , "governance actions" .= - (inEonForEra - Null - (\(cOnwards :: ConwayEraOnwards era) -> - case txProposalProcedures of - Nothing -> Null - Just (Featured _ TxProposalProceduresNone) -> Null - Just (Featured _ (TxProposalProcedures lProposals _witnesses)) -> - friendlyLedgerProposals cOnwards $ toList lProposals) - era) - , "voters" .= - (inEonForEra - Null - (\cOnwards -> - case txVotingProcedures of - Nothing -> Null - Just (Featured _ TxVotingProceduresNone) -> Null - Just (Featured _ (TxVotingProcedures votes _witnesses)) -> - friendlyVotingProcedures cOnwards votes) - era) - , "currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue) - , "treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation) - ]) - where - friendlyLedgerProposals :: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value + tb@( TxBody + -- Enumerating the fields, so that we are warned by GHC when we add a new one + ( TxBodyContent + txIns + txInsCollateral + txInsReference + txOuts + txTotalCollateral + txReturnCollateral + txFee + txValidityLowerBound + txValidityUpperBound + txMetadata + txAuxScripts + txExtraKeyWits + _txProtocolParams + txWithdrawals + txCertificates + txUpdateProposal + txMintValue + _txScriptValidity + txProposalProcedures + txVotingProcedures + txCurrentTreasuryValue + txTreasuryDonation + ) + ) = + do + redeemerDetails <- redeemerIfShelleyBased era tb + return $ + cardanoEraConstraints + era + ( redeemerDetails + ++ [ "auxiliary scripts" .= friendlyAuxScripts txAuxScripts + , "certificates" .= forEraInEon era Null (`friendlyCertificates` txCertificates) + , "collateral inputs" .= friendlyCollateralInputs txInsCollateral + , "era" .= era + , "fee" .= friendlyFee txFee + , "inputs" .= friendlyInputs txIns + , "metadata" .= friendlyMetadata txMetadata + , "mint" .= friendlyMintValue txMintValue + , "outputs" .= map (friendlyTxOut era) txOuts + , "reference inputs" .= friendlyReferenceInputs txInsReference + , "total collateral" .= friendlyTotalCollateral txTotalCollateral + , "return collateral" .= friendlyReturnCollateral era txReturnCollateral + , "required signers (payment key hashes needed for scripts)" + .= friendlyExtraKeyWits txExtraKeyWits + , "update proposal" .= friendlyUpdateProposal txUpdateProposal + , "validity range" .= friendlyValidityRange era (txValidityLowerBound, txValidityUpperBound) + , "withdrawals" .= friendlyWithdrawals txWithdrawals + , "governance actions" + .= ( inEonForEra + Null + ( \(cOnwards :: ConwayEraOnwards era) -> + case txProposalProcedures of + Nothing -> Null + Just (Featured _ TxProposalProceduresNone) -> Null + Just (Featured _ (TxProposalProcedures lProposals _witnesses)) -> + friendlyLedgerProposals cOnwards $ toList lProposals + ) + era + ) + , "voters" + .= ( inEonForEra + Null + ( \cOnwards -> + case txVotingProcedures of + Nothing -> Null + Just (Featured _ TxVotingProceduresNone) -> Null + Just (Featured _ (TxVotingProcedures votes _witnesses)) -> + friendlyVotingProcedures cOnwards votes + ) + era + ) + , "currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue) + , "treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation) + ] + ) + where + friendlyLedgerProposals + :: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value friendlyLedgerProposals cOnwards proposalProcedures = Array $ Vector.fromList $ map (friendlyLedgerProposal cOnwards) proposalProcedures -friendlyLedgerProposal :: ConwayEraOnwards era -> L.ProposalProcedure (ShelleyLedgerEra era) -> Aeson.Value +friendlyLedgerProposal + :: ConwayEraOnwards era -> L.ProposalProcedure (ShelleyLedgerEra era) -> Aeson.Value friendlyLedgerProposal cOnwards proposalProcedure = object $ friendlyProposalImpl cOnwards (Proposal proposalProcedure) -friendlyVotingProcedures :: ConwayEraOnwards era -> L.VotingProcedures (ShelleyLedgerEra era) -> Aeson.Value +friendlyVotingProcedures + :: ConwayEraOnwards era -> L.VotingProcedures (ShelleyLedgerEra era) -> Aeson.Value friendlyVotingProcedures cOnwards x = conwayEraOnwardsConstraints cOnwards $ toJSON x redeemerIfShelleyBased :: MonadWarning m => CardanoEra era -> TxBody era -> m [Aeson.Pair] redeemerIfShelleyBased era tb = - caseByronOrShelleyBasedEra (return []) - (\shEra -> do redeemerInfo <- friendlyRedeemer shEra tb - return [ "redeemers" .= redeemerInfo ]) era + caseByronOrShelleyBasedEra + (return []) + ( \shEra -> do + redeemerInfo <- friendlyRedeemer shEra tb + return ["redeemers" .= redeemerInfo] + ) + era friendlyRedeemer :: MonadWarning m => ShelleyBasedEra era -> TxBody era -> m Aeson.Value friendlyRedeemer _ (ShelleyTxBody _ _ _ TxBodyNoScriptData _ _) = return Aeson.Null friendlyRedeemer _ (ShelleyTxBody _ _ _ (TxBodyScriptData _ _ r) _ _) = encodingToJSON $ L.toCBOR r - where encodingToJSON :: MonadWarning m => Encoding -> m Aeson.Value - encodingToJSON e = eitherToWarning Aeson.Null $ first ("Error decoding redeemer: " ++) $ - fromFlatTerm (decodeValue True) $ toFlatTerm e + where + encodingToJSON :: MonadWarning m => Encoding -> m Aeson.Value + encodingToJSON e = + eitherToWarning Aeson.Null $ + first ("Error decoding redeemer: " ++) $ + fromFlatTerm (decodeValue True) $ + toFlatTerm e friendlyTotalCollateral :: TxTotalCollateral era -> Aeson.Value friendlyTotalCollateral TxTotalCollateralNone = Aeson.Null friendlyTotalCollateral (TxTotalCollateral _ coll) = toJSON coll -friendlyReturnCollateral :: () +friendlyReturnCollateral + :: () => CardanoEra era -> TxReturnCollateral CtxTx era -> Aeson.Value @@ -283,12 +323,12 @@ friendlyValidityRange era = \case (lowerBound, upperBound) | isLowerBoundSupported || isUpperBoundSupported -> object - [ "lower bound" .= - case lowerBound of - TxValidityNoLowerBound -> Null - TxValidityLowerBound _ s -> toJSON s - , "upper bound" .= - case upperBound of + [ "lower bound" + .= case lowerBound of + TxValidityNoLowerBound -> Null + TxValidityLowerBound _ s -> toJSON s + , "upper bound" + .= case upperBound of TxValidityUpperBound _ s -> toJSON s ] | otherwise -> Null @@ -301,9 +341,9 @@ friendlyWithdrawals TxWithdrawalsNone = Null friendlyWithdrawals (TxWithdrawals _ withdrawals) = array [ object $ - "address" .= serialiseAddress addr : - "amount" .= friendlyLovelace amount : - friendlyStakeAddress addr + "address" .= serialiseAddress addr + : "amount" .= friendlyLovelace amount + : friendlyStakeAddress addr | (addr, amount, _) <- withdrawals ] @@ -315,32 +355,33 @@ friendlyStakeAddress (StakeAddress net cred) = friendlyTxOut :: CardanoEra era -> TxOut CtxTx era -> Aeson.Value friendlyTxOut era (TxOut addr amount mdatum script) = - cardanoEraConstraints era $ object $ - case addr of - AddressInEra ByronAddressInAnyEra byronAdr -> - [ "address era" .= String "Byron" - , "address" .= serialiseAddress byronAdr - , "amount" .= friendlyTxOutValue amount - ] - AddressInEra (ShelleyAddressInEra _) saddr@(ShelleyAddress net cred stake) -> - let preAlonzo = - friendlyPaymentCredential (fromShelleyPaymentCredential cred) : - [ "address era" .= Aeson.String "Shelley" - , "network" .= net - , "address" .= serialiseAddress saddr - , "amount" .= friendlyTxOutValue amount - , "stake reference" .= friendlyStakeReference (fromShelleyStakeReference stake) - ] - datum = ["datum" .= d | d <- maybeToList $ renderDatum mdatum] - sinceAlonzo = ["reference script" .= script] - in preAlonzo ++ datum ++ sinceAlonzo - where - renderDatum :: TxOutDatum CtxTx era -> Maybe Aeson.Value - renderDatum = \case - TxOutDatumNone -> Nothing - TxOutDatumHash _ h -> Just $ toJSON h - TxOutDatumInTx _ sData -> Just $ scriptDataToJson ScriptDataJsonDetailedSchema sData - TxOutDatumInline _ sData -> Just $ scriptDataToJson ScriptDataJsonDetailedSchema sData + cardanoEraConstraints era $ + object $ + case addr of + AddressInEra ByronAddressInAnyEra byronAdr -> + [ "address era" .= String "Byron" + , "address" .= serialiseAddress byronAdr + , "amount" .= friendlyTxOutValue amount + ] + AddressInEra (ShelleyAddressInEra _) saddr@(ShelleyAddress net cred stake) -> + let preAlonzo = + friendlyPaymentCredential (fromShelleyPaymentCredential cred) + : [ "address era" .= Aeson.String "Shelley" + , "network" .= net + , "address" .= serialiseAddress saddr + , "amount" .= friendlyTxOutValue amount + , "stake reference" .= friendlyStakeReference (fromShelleyStakeReference stake) + ] + datum = ["datum" .= d | d <- maybeToList $ renderDatum mdatum] + sinceAlonzo = ["reference script" .= script] + in preAlonzo ++ datum ++ sinceAlonzo + where + renderDatum :: TxOutDatum CtxTx era -> Maybe Aeson.Value + renderDatum = \case + TxOutDatumNone -> Nothing + TxOutDatumHash _ h -> Just $ toJSON h + TxOutDatumInTx _ sData -> Just $ scriptDataToJson ScriptDataJsonDetailedSchema sData + TxOutDatumInline _ sData -> Just $ scriptDataToJson ScriptDataJsonDetailedSchema sData friendlyStakeReference :: StakeAddressReference -> Aeson.Value friendlyStakeReference = \case @@ -354,13 +395,13 @@ friendlyUpdateProposal = \case TxUpdateProposal _ (UpdateProposal parameterUpdates epoch) -> object [ "epoch" .= epoch - , "updates" .= - [ object - [ "genesis key hash" .= genesisKeyHash - , "update" .= friendlyProtocolParametersUpdate parameterUpdate - ] - | (genesisKeyHash, parameterUpdate) <- Map.assocs parameterUpdates - ] + , "updates" + .= [ object + [ "genesis key hash" .= genesisKeyHash + , "update" .= friendlyProtocolParametersUpdate parameterUpdate + ] + | (genesisKeyHash, parameterUpdate) <- Map.assocs parameterUpdates + ] ] friendlyProtocolParametersUpdate :: ProtocolParametersUpdate -> Aeson.Value @@ -391,41 +432,41 @@ friendlyProtocolParametersUpdate , protocolUpdatePrices , protocolUpdateUTxOCostPerByte } = - object . catMaybes $ - [ protocolUpdateProtocolVersion <&> \(major, minor) -> - "protocol version" .= (textShow major <> "." <> textShow minor) - , protocolUpdateDecentralization <&> - ("decentralization parameter" .=) . friendlyRational - , protocolUpdateExtraPraosEntropy <&> - ("extra entropy" .=) . maybe "reset" toJSON - , protocolUpdateMaxBlockHeaderSize <&> ("max block header size" .=) - , protocolUpdateMaxBlockBodySize<&> ("max block body size" .=) - , protocolUpdateMaxTxSize <&> ("max transaction size" .=) - , protocolUpdateTxFeeFixed <&> ("transaction fee constant" .=) - , protocolUpdateTxFeePerByte <&> ("transaction fee linear per byte" .=) - , protocolUpdateMinUTxOValue <&> ("min UTxO value" .=) . friendlyLovelace - , protocolUpdateStakeAddressDeposit <&> - ("key registration deposit" .=) . friendlyLovelace - , protocolUpdateStakePoolDeposit <&> - ("pool registration deposit" .=) . friendlyLovelace - , protocolUpdateMinPoolCost <&> ("min pool cost" .=) . friendlyLovelace - , protocolUpdatePoolRetireMaxEpoch <&> ("pool retirement epoch boundary" .=) - , protocolUpdateStakePoolTargetNum <&> ("number of pools" .=) - , protocolUpdatePoolPledgeInfluence <&> - ("pool influence" .=) . friendlyRational - , protocolUpdateMonetaryExpansion <&> - ("monetary expansion" .=) . friendlyRational - , protocolUpdateTreasuryCut <&> ("treasury expansion" .=) . friendlyRational - , protocolUpdateCollateralPercent <&> - ("collateral inputs share" .=) . (<> "%") . textShow - , protocolUpdateMaxBlockExUnits <&> ("max block execution units" .=) - , protocolUpdateMaxCollateralInputs <&> ("max collateral inputs" .=) - , protocolUpdateMaxTxExUnits <&> ("max transaction execution units" .=) - , protocolUpdateMaxValueSize <&> ("max value size" .=) - , protocolUpdatePrices <&> ("execution prices" .=) . friendlyPrices - , protocolUpdateUTxOCostPerByte <&> - ("UTxO storage cost per byte" .=) . friendlyLovelace - ] + object . catMaybes $ + [ protocolUpdateProtocolVersion <&> \(major, minor) -> + "protocol version" .= (textShow major <> "." <> textShow minor) + , protocolUpdateDecentralization + <&> ("decentralization parameter" .=) . friendlyRational + , protocolUpdateExtraPraosEntropy + <&> ("extra entropy" .=) . maybe "reset" toJSON + , protocolUpdateMaxBlockHeaderSize <&> ("max block header size" .=) + , protocolUpdateMaxBlockBodySize <&> ("max block body size" .=) + , protocolUpdateMaxTxSize <&> ("max transaction size" .=) + , protocolUpdateTxFeeFixed <&> ("transaction fee constant" .=) + , protocolUpdateTxFeePerByte <&> ("transaction fee linear per byte" .=) + , protocolUpdateMinUTxOValue <&> ("min UTxO value" .=) . friendlyLovelace + , protocolUpdateStakeAddressDeposit + <&> ("key registration deposit" .=) . friendlyLovelace + , protocolUpdateStakePoolDeposit + <&> ("pool registration deposit" .=) . friendlyLovelace + , protocolUpdateMinPoolCost <&> ("min pool cost" .=) . friendlyLovelace + , protocolUpdatePoolRetireMaxEpoch <&> ("pool retirement epoch boundary" .=) + , protocolUpdateStakePoolTargetNum <&> ("number of pools" .=) + , protocolUpdatePoolPledgeInfluence + <&> ("pool influence" .=) . friendlyRational + , protocolUpdateMonetaryExpansion + <&> ("monetary expansion" .=) . friendlyRational + , protocolUpdateTreasuryCut <&> ("treasury expansion" .=) . friendlyRational + , protocolUpdateCollateralPercent + <&> ("collateral inputs share" .=) . (<> "%") . textShow + , protocolUpdateMaxBlockExUnits <&> ("max block execution units" .=) + , protocolUpdateMaxCollateralInputs <&> ("max collateral inputs" .=) + , protocolUpdateMaxTxExUnits <&> ("max transaction execution units" .=) + , protocolUpdateMaxValueSize <&> ("max value size" .=) + , protocolUpdatePrices <&> ("execution prices" .=) . friendlyPrices + , protocolUpdateUTxOCostPerByte + <&> ("UTxO storage cost per byte" .=) . friendlyLovelace + ] friendlyPrices :: ExecutionUnitPrices -> Aeson.Value friendlyPrices ExecutionUnitPrices{priceExecutionMemory, priceExecutionSteps} = @@ -440,8 +481,9 @@ friendlyCertificates sbe = \case TxCertificates _ cs _ -> array $ map (friendlyCertificate sbe) cs friendlyCertificate :: ShelleyBasedEra era -> Certificate era -> Aeson.Value -friendlyCertificate sbe = shelleyBasedEraConstraints sbe $ - object . (: []) . renderCertificate sbe +friendlyCertificate sbe = + shelleyBasedEraConstraints sbe $ + object . (: []) . renderCertificate sbe renderCertificate :: ShelleyBasedEra era -> Certificate era -> (Aeson.Key, Aeson.Value) renderCertificate sbe = \case @@ -449,149 +491,172 @@ renderCertificate sbe = \case shelleyBasedEraConstraints sbe $ case c of L.ShelleyTxCertDelegCert (L.ShelleyRegCert cred) -> - "stake address registration" .= cred + "stake address registration" .= cred L.ShelleyTxCertDelegCert (L.ShelleyUnRegCert cred) -> "stake address deregistration" .= cred L.ShelleyTxCertDelegCert (L.ShelleyDelegCert cred poolId) -> - "stake address delegation" .= object - [ "credential" .= cred - , "pool" .= poolId - ] + "stake address delegation" + .= object + [ "credential" .= cred + , "pool" .= poolId + ] L.ShelleyTxCertPool (L.RetirePool poolId retirementEpoch) -> - "stake pool retirement" .= object - [ "pool" .= StakePoolKeyHash poolId - , "epoch" .= retirementEpoch - ] + "stake pool retirement" + .= object + [ "pool" .= StakePoolKeyHash poolId + , "epoch" .= retirementEpoch + ] L.ShelleyTxCertPool (L.RegPool poolParams) -> "stake pool registration" .= poolParams L.ShelleyTxCertGenesisDeleg (L.GenesisDelegCert genesisKeyHash delegateKeyHash vrfKeyHash) -> - "genesis key delegation" .= object - [ "genesis key hash" .= genesisKeyHash - , "delegate key hash" .= delegateKeyHash - , "VRF key hash" .= vrfKeyHash - ] + "genesis key delegation" + .= object + [ "genesis key hash" .= genesisKeyHash + , "delegate key hash" .= delegateKeyHash + , "VRF key hash" .= vrfKeyHash + ] L.ShelleyTxCertMir (L.MIRCert pot target) -> - "MIR" .= object - [ "pot" .= friendlyMirPot pot - , friendlyMirTarget sbe target - ] - + "MIR" + .= object + [ "pot" .= friendlyMirPot pot + , friendlyMirTarget sbe target + ] ConwayCertificate w cert -> conwayEraOnwardsConstraints w $ case cert of L.RegDRepTxCert credential coin mAnchor -> - "Drep registration certificate" .= object - [ "deposit" .= coin - , "certificate" .= conwayToObject w credential - , "anchor" .= mAnchor - ] + "Drep registration certificate" + .= object + [ "deposit" .= coin + , "certificate" .= conwayToObject w credential + , "anchor" .= mAnchor + ] L.UnRegDRepTxCert credential coin -> - "Drep unregistration certificate" .= object - [ "refund" .= coin - , "certificate" .= conwayToObject w credential - ] + "Drep unregistration certificate" + .= object + [ "refund" .= coin + , "certificate" .= conwayToObject w credential + ] L.AuthCommitteeHotKeyTxCert coldCred hotCred - | L.ScriptHashObj sh <- coldCred -> - "Cold committee authorization" .= object - [ "script hash" .= sh ] - | L.ScriptHashObj sh <- hotCred -> - "Hot committee authorization" .= object - [ "script hash" .= sh] - | L.KeyHashObj ck@L.KeyHash{} <- coldCred - , L.KeyHashObj hk@L.KeyHash{} <- hotCred -> - "Constitutional committee member hot key registration" .= object - [ "cold key hash" .= ck - , "hot key hash" .= hk - ] + | L.ScriptHashObj sh <- coldCred -> + "Cold committee authorization" + .= object + ["script hash" .= sh] + | L.ScriptHashObj sh <- hotCred -> + "Hot committee authorization" + .= object + ["script hash" .= sh] + | L.KeyHashObj ck@L.KeyHash{} <- coldCred + , L.KeyHashObj hk@L.KeyHash{} <- hotCred -> + "Constitutional committee member hot key registration" + .= object + [ "cold key hash" .= ck + , "hot key hash" .= hk + ] L.ResignCommitteeColdTxCert cred anchor -> case cred of L.ScriptHashObj sh -> - "Cold committee resignation" .= object - [ "script hash" .= sh - , "anchor" .= anchor - ] + "Cold committee resignation" + .= object + [ "script hash" .= sh + , "anchor" .= anchor + ] L.KeyHashObj ck@L.KeyHash{} -> - "Constitutional committee cold key resignation" .= object - [ "cold key hash" .= ck - ] + "Constitutional committee cold key resignation" + .= object + [ "cold key hash" .= ck + ] L.RegTxCert stakeCredential -> - "Stake address registration" .= object - [ "stake credential" .= stakeCredential - ] + "Stake address registration" + .= object + [ "stake credential" .= stakeCredential + ] L.UnRegTxCert stakeCredential -> - "Stake address deregistration" .= object - [ "stake credential" .= stakeCredential - ] + "Stake address deregistration" + .= object + [ "stake credential" .= stakeCredential + ] L.RegDepositTxCert stakeCredential deposit -> - "Stake address registration" .= object - [ "stake credential" .= stakeCredential - , "deposit" .= deposit - ] + "Stake address registration" + .= object + [ "stake credential" .= stakeCredential + , "deposit" .= deposit + ] L.UnRegDepositTxCert stakeCredential refund -> - "Stake address deregistration" .= object - [ "stake credential" .= stakeCredential - , "refund" .= refund - ] + "Stake address deregistration" + .= object + [ "stake credential" .= stakeCredential + , "refund" .= refund + ] L.DelegTxCert stakeCredential delegatee -> - "Stake address delegation" .= object - [ "stake credential" .= stakeCredential - , "delegatee" .= delegateeJson sbe delegatee - ] + "Stake address delegation" + .= object + [ "stake credential" .= stakeCredential + , "delegatee" .= delegateeJson sbe delegatee + ] L.RegDepositDelegTxCert stakeCredential delegatee deposit -> - "Stake address registration and delegation" .= object - [ "stake credential" .= stakeCredential - , "delegatee" .= delegateeJson sbe delegatee - , "deposit" .= deposit - ] + "Stake address registration and delegation" + .= object + [ "stake credential" .= stakeCredential + , "delegatee" .= delegateeJson sbe delegatee + , "deposit" .= deposit + ] L.RegPoolTxCert poolParams -> - "Pool registration" .= object - [ "pool params" .= poolParams - ] + "Pool registration" + .= object + [ "pool params" .= poolParams + ] L.RetirePoolTxCert kh@L.KeyHash{} epoch -> - "Pool retirement" .= object - [ "stake pool key hash" .= kh - , "epoch" .= epoch - ] + "Pool retirement" + .= object + [ "stake pool key hash" .= kh + , "epoch" .= epoch + ] L.UpdateDRepTxCert drepCredential mbAnchor -> - "Drep certificate update" .= object - [ "Drep credential" .= drepCredential - , "anchor " .= mbAnchor - ] - where - conwayToObject :: () - => ConwayEraOnwards era - -> L.Credential 'L.DRepRole (L.EraCrypto (ShelleyLedgerEra era)) - -> Aeson.Value - conwayToObject w' = - conwayEraOnwardsConstraints w' $ - object . \case - L.ScriptHashObj sHash -> ["scriptHash" .= sHash] - L.KeyHashObj keyHash -> ["keyHash" .= keyHash] - - delegateeJson :: ( L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto) - => ShelleyBasedEra era -> L.Delegatee (L.EraCrypto (ShelleyLedgerEra era)) -> Aeson.Value - delegateeJson _ = object . \case + "Drep certificate update" + .= object + [ "Drep credential" .= drepCredential + , "anchor " .= mbAnchor + ] + where + conwayToObject + :: () + => ConwayEraOnwards era + -> L.Credential 'L.DRepRole (L.EraCrypto (ShelleyLedgerEra era)) + -> Aeson.Value + conwayToObject w' = + conwayEraOnwardsConstraints w' $ + object . \case + L.ScriptHashObj sHash -> ["scriptHash" .= sHash] + L.KeyHashObj keyHash -> ["keyHash" .= keyHash] + + delegateeJson + :: L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + => ShelleyBasedEra era -> L.Delegatee (L.EraCrypto (ShelleyLedgerEra era)) -> Aeson.Value + delegateeJson _ = + object . \case L.DelegStake hk@L.KeyHash{} -> - [ "delegatee type" .= String "stake" - , "key hash" .= hk - ] + [ "delegatee type" .= String "stake" + , "key hash" .= hk + ] L.DelegVote drep -> do ["delegatee type" .= String "vote", "DRep" .= drep] L.DelegStakeVote kh drep -> - ["delegatee type" .= String "stake vote" - , "key hash" .= kh - , "DRep" .= drep - ] + [ "delegatee type" .= String "stake vote" + , "key hash" .= kh + , "DRep" .= drep + ] -friendlyMirTarget :: ShelleyBasedEra era -> L.MIRTarget (L.EraCrypto (ShelleyLedgerEra era)) -> Aeson.Pair +friendlyMirTarget + :: ShelleyBasedEra era -> L.MIRTarget (L.EraCrypto (ShelleyLedgerEra era)) -> Aeson.Pair friendlyMirTarget sbe = \case L.StakeAddressesMIR addresses -> - "target stake addresses" .= - [ object - [ friendlyStakeCredential credential - , "amount" .= friendlyLovelace (L.Coin 0 `L.addDeltaCoin` lovelace) - ] - | (credential, lovelace) <- Map.toList (shelleyBasedEraConstraints sbe addresses) - ] + "target stake addresses" + .= [ object + [ friendlyStakeCredential credential + , "amount" .= friendlyLovelace (L.Coin 0 `L.addDeltaCoin` lovelace) + ] + | (credential, lovelace) <- Map.toList (shelleyBasedEraConstraints sbe addresses) + ] L.SendToOppositePotMIR amount -> "MIR amount" .= friendlyLovelace amount friendlyStakeCredential @@ -614,7 +679,6 @@ friendlyMirPot = \case L.ReservesMIR -> "reserves" L.TreasuryMIR -> "treasury" - friendlyRational :: Rational -> Aeson.Value friendlyRational r = String $ @@ -642,13 +706,15 @@ friendlyTxOutValue = \case TxOutValueByron lovelace -> friendlyLovelace lovelace TxOutValueShelleyBased sbe v -> friendlyLedgerValue sbe v -friendlyLedgerValue :: () +friendlyLedgerValue + :: () => ShelleyBasedEra era -> L.Value (ShelleyLedgerEra era) -> Aeson.Value friendlyLedgerValue sbe v = friendlyValue sbe $ Api.fromLedgerValue sbe v -friendlyValue :: () +friendlyValue + :: () => ShelleyBasedEra era -> Api.Value -> Aeson.Value @@ -661,7 +727,6 @@ friendlyValue _ v = | bundle <- bundles ] where - ValueNestedRep bundles = valueToNestedRep v friendlyPolicyId = ("policy " <>) . serialiseToRawBytesHexText diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands.hs index abf1badf1a..9197893bb3 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands.hs @@ -3,7 +3,8 @@ module Cardano.CLI.Legacy.Commands ( LegacyCmds (..) , renderLegacyCommand - ) where + ) +where import Cardano.CLI.Legacy.Commands.Address import Cardano.CLI.Legacy.Commands.Genesis @@ -19,16 +20,16 @@ import Cardano.CLI.Legacy.Commands.Transaction import Data.Text (Text) data LegacyCmds - = LegacyAddressCmds LegacyAddressCmds - | LegacyGenesisCmds LegacyGenesisCmds - | LegacyGovernanceCmds LegacyGovernanceCmds - | LegacyKeyCmds LegacyKeyCmds - | LegacyNodeCmds LegacyNodeCmds - | LegacyQueryCmds LegacyQueryCmds - | LegacyStakeAddressCmds LegacyStakeAddressCmds - | LegacyStakePoolCmds LegacyStakePoolCmds - | LegacyTextViewCmds LegacyTextViewCmds - | LegacyTransactionCmds LegacyTransactionCmds + = LegacyAddressCmds LegacyAddressCmds + | LegacyGenesisCmds LegacyGenesisCmds + | LegacyGovernanceCmds LegacyGovernanceCmds + | LegacyKeyCmds LegacyKeyCmds + | LegacyNodeCmds LegacyNodeCmds + | LegacyQueryCmds LegacyQueryCmds + | LegacyStakeAddressCmds LegacyStakeAddressCmds + | LegacyStakePoolCmds LegacyStakePoolCmds + | LegacyTextViewCmds LegacyTextViewCmds + | LegacyTransactionCmds LegacyTransactionCmds renderLegacyCommand :: LegacyCmds -> Text renderLegacyCommand = \case diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Address.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Address.hs index 94960e675d..30bc8c59fc 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Address.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Address.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Commands.Address ( LegacyAddressCmds (..) , renderLegacyAddressCmds - ) where + ) +where import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -36,7 +37,7 @@ data LegacyAddressCmds renderLegacyAddressCmds :: LegacyAddressCmds -> Text renderLegacyAddressCmds = \case - AddressKeyGen {} -> "address key-gen" - AddressKeyHash {} -> "address key-hash" - AddressBuild {} -> "address build" - AddressInfo {} -> "address info" + AddressKeyGen{} -> "address key-gen" + AddressKeyHash{} -> "address key-hash" + AddressBuild{} -> "address build" + AddressInfo{} -> "address info" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Genesis.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Genesis.hs index 5672353844..637b2ff803 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Genesis.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Commands.Genesis ( LegacyGenesisCmds (..) , renderLegacyGenesisCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley @@ -38,7 +39,8 @@ data LegacyGenesisCmds FilePath FilePath (Maybe FilePath) - | GenesisCreateStaked + | -- | Relay specification filepath + GenesisCreateStaked KeyOutputFormat GenesisDir Word @@ -52,7 +54,7 @@ data LegacyGenesisCmds Word Word Word - (Maybe FilePath) -- ^ Relay specification filepath + (Maybe FilePath) | GenesisKeyGenGenesis (VerificationKeyFile Out) (SigningKeyFile Out) @@ -82,14 +84,14 @@ data LegacyGenesisCmds renderLegacyGenesisCmds :: LegacyGenesisCmds -> Text renderLegacyGenesisCmds = \case - GenesisCreate {} -> "genesis create" - GenesisCreateCardano {} -> "genesis create-cardano" - GenesisCreateStaked {} -> "genesis create-staked" - GenesisKeyGenGenesis {} -> "genesis key-gen-genesis" - GenesisKeyGenDelegate {} -> "genesis key-gen-delegate" - GenesisKeyGenUTxO {} -> "genesis key-gen-utxo" - GenesisCmdKeyHash {} -> "genesis key-hash" - GenesisVerKey {} -> "genesis get-ver-key" - GenesisTxIn {} -> "genesis initial-txin" - GenesisAddr {} -> "genesis initial-addr" - GenesisHashFile {} -> "genesis hash" + GenesisCreate{} -> "genesis create" + GenesisCreateCardano{} -> "genesis create-cardano" + GenesisCreateStaked{} -> "genesis create-staked" + GenesisKeyGenGenesis{} -> "genesis key-gen-genesis" + GenesisKeyGenDelegate{} -> "genesis key-gen-delegate" + GenesisKeyGenUTxO{} -> "genesis key-gen-utxo" + GenesisCmdKeyHash{} -> "genesis key-hash" + GenesisVerKey{} -> "genesis get-ver-key" + GenesisTxIn{} -> "genesis initial-txin" + GenesisAddr{} -> "genesis initial-addr" + GenesisHashFile{} -> "genesis hash" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Governance.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Governance.hs index b81dc4ec30..2ba3634873 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Governance.hs @@ -35,33 +35,42 @@ data LegacyGovernanceCmds (VerificationKeyOrHashOrFile VrfKey) (File () Out) | GovernanceUpdateProposal - (File () Out) EpochNo + (File () Out) + EpochNo [VerificationKeyFile In] ProtocolParametersUpdate (Maybe FilePath) | GovernanceCreatePoll - Text -- ^ Prompt - [Text] -- ^ Choices - (Maybe Word) -- ^ Nonce + Text + -- ^ Prompt + [Text] + -- ^ Choices + (Maybe Word) + -- ^ Nonce (File GovernancePoll Out) | GovernanceAnswerPoll - (File GovernancePoll In) -- ^ Poll file - (Maybe Word) -- ^ Answer index - (Maybe (File () Out)) -- ^ Tx file + (File GovernancePoll In) + -- ^ Poll file + (Maybe Word) + -- ^ Answer index + (Maybe (File () Out)) + -- ^ Tx file | GovernanceVerifyPoll - (File GovernancePoll In) -- ^ Poll file - (File (Tx ()) In) -- ^ Tx file - (Maybe (File () Out)) -- ^ Tx file + (File GovernancePoll In) + -- ^ Poll file + (File (Tx ()) In) + -- ^ Tx file + (Maybe (File () Out)) + -- ^ Tx file deriving Show renderLegacyGovernanceCmds :: LegacyGovernanceCmds -> Text renderLegacyGovernanceCmds = \case - GovernanceGenesisKeyDelegationCertificate {} -> "governance create-genesis-key-delegation-certificate" - GovernanceCreateMirCertificateStakeAddressesCmd {} -> "governance create-mir-certificate stake-addresses" - GovernanceCreateMirCertificateTransferToTreasuryCmd {} -> "governance create-mir-certificate transfer-to-treasury" - GovernanceCreateMirCertificateTransferToReservesCmd {} -> "governance create-mir-certificate transfer-to-reserves" - GovernanceUpdateProposal {} -> "governance create-update-proposal" + GovernanceGenesisKeyDelegationCertificate{} -> "governance create-genesis-key-delegation-certificate" + GovernanceCreateMirCertificateStakeAddressesCmd{} -> "governance create-mir-certificate stake-addresses" + GovernanceCreateMirCertificateTransferToTreasuryCmd{} -> "governance create-mir-certificate transfer-to-treasury" + GovernanceCreateMirCertificateTransferToReservesCmd{} -> "governance create-mir-certificate transfer-to-reserves" + GovernanceUpdateProposal{} -> "governance create-update-proposal" GovernanceCreatePoll{} -> "governance create-poll" GovernanceAnswerPoll{} -> "governance answer-poll" GovernanceVerifyPoll{} -> "governance verify-poll" - diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Key.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Key.hs index bb26e5d067..8614e67490 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Key.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Commands.Key ( LegacyKeyCmds (..) , renderLegacyKeyCmds - ) where + ) +where import Cardano.Api.Shelley @@ -31,7 +32,8 @@ data LegacyKeyCmds (SomeKeyFile In) (File () Out) | KeyConvertITNExtendedKeyCmd - (SomeKeyFile In) (File () Out) + (SomeKeyFile In) + (File () Out) | KeyConvertITNBip32KeyCmd (SomeKeyFile In) (File () Out) @@ -43,11 +45,11 @@ data LegacyKeyCmds renderLegacyKeyCmds :: LegacyKeyCmds -> Text renderLegacyKeyCmds = \case - KeyVerificationKeyCmd {} -> "key verification-key" - KeyNonExtendedKeyCmd {} -> "key non-extended-key" - KeyConvertByronKeyCmd {} -> "key convert-byron-key" - KeyConvertByronGenesisVKeyCmd {} -> "key convert-byron-genesis-vkey" - KeyConvertITNKeyCmd {} -> "key convert-itn-key" - KeyConvertITNExtendedKeyCmd {} -> "key convert-itn-extended-key" - KeyConvertITNBip32KeyCmd {} -> "key convert-itn-bip32-key" - KeyConvertCardanoAddressKeyCmd {} -> "key convert-cardano-address-key" + KeyVerificationKeyCmd{} -> "key verification-key" + KeyNonExtendedKeyCmd{} -> "key non-extended-key" + KeyConvertByronKeyCmd{} -> "key convert-byron-key" + KeyConvertByronGenesisVKeyCmd{} -> "key convert-byron-genesis-vkey" + KeyConvertITNKeyCmd{} -> "key convert-itn-key" + KeyConvertITNExtendedKeyCmd{} -> "key convert-itn-extended-key" + KeyConvertITNBip32KeyCmd{} -> "key convert-itn-bip32-key" + KeyConvertCardanoAddressKeyCmd{} -> "key convert-cardano-address-key" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Node.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Node.hs index d110e8093d..59c9d6f5b3 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Node.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Node.hs @@ -4,26 +4,27 @@ module Cardano.CLI.Legacy.Commands.Node ( LegacyNodeCmds (..) , renderLegacyNodeCmds - ) where + ) +where import qualified Cardano.CLI.EraBased.Commands.Node as Cmd import Data.Text (Text) data LegacyNodeCmds - = LegacyNodeKeyGenColdCmd !Cmd.NodeKeyGenColdCmdArgs - | LegacyNodeKeyGenKESCmd !Cmd.NodeKeyGenKESCmdArgs - | LegacyNodeKeyGenVRFCmd !Cmd.NodeKeyGenVRFCmdArgs - | LegacyNodeKeyHashVRFCmd !Cmd.NodeKeyHashVRFCmdArgs - | LegacyNodeNewCounterCmd !Cmd.NodeNewCounterCmdArgs - | LegacyNodeIssueOpCertCmd !Cmd.NodeIssueOpCertCmdArgs + = LegacyNodeKeyGenColdCmd !Cmd.NodeKeyGenColdCmdArgs + | LegacyNodeKeyGenKESCmd !Cmd.NodeKeyGenKESCmdArgs + | LegacyNodeKeyGenVRFCmd !Cmd.NodeKeyGenVRFCmdArgs + | LegacyNodeKeyHashVRFCmd !Cmd.NodeKeyHashVRFCmdArgs + | LegacyNodeNewCounterCmd !Cmd.NodeNewCounterCmdArgs + | LegacyNodeIssueOpCertCmd !Cmd.NodeIssueOpCertCmdArgs deriving Show renderLegacyNodeCmds :: LegacyNodeCmds -> Text renderLegacyNodeCmds = \case - LegacyNodeKeyGenColdCmd {} -> "node key-gen" - LegacyNodeKeyGenKESCmd {} -> "node key-gen-KES" - LegacyNodeKeyGenVRFCmd {} -> "node key-gen-VRF" - LegacyNodeKeyHashVRFCmd {} -> "node key-hash-VRF" - LegacyNodeNewCounterCmd {} -> "node new-counter" - LegacyNodeIssueOpCertCmd {} -> "node issue-op-cert" + LegacyNodeKeyGenColdCmd{} -> "node key-gen" + LegacyNodeKeyGenKESCmd{} -> "node key-gen-KES" + LegacyNodeKeyGenVRFCmd{} -> "node key-gen-VRF" + LegacyNodeKeyHashVRFCmd{} -> "node key-hash-VRF" + LegacyNodeNewCounterCmd{} -> "node new-counter" + LegacyNodeIssueOpCertCmd{} -> "node issue-op-cert" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs index 2681d62c78..437f8155d7 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Query.hs @@ -21,7 +21,8 @@ module Cardano.CLI.Legacy.Commands.Query , LegacyQueryTxMempoolCmdArgs (..) , LegacyQuerySlotNumberCmdArgs (..) , renderLegacyQueryCmds - ) where + ) +where import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -33,160 +34,175 @@ import Data.Time.Clock import GHC.Generics data LegacyQueryCmds - = QueryLeadershipScheduleCmd !LegacyQueryLeadershipScheduleCmdArgs - | QueryProtocolParametersCmd !LegacyQueryProtocolParametersCmdArgs - | QueryTipCmd !LegacyQueryTipCmdArgs - | QueryStakePoolsCmd !LegacyQueryStakePoolsCmdArgs - | QueryStakeDistributionCmd !LegacyQueryStakeDistributionCmdArgs - | QueryStakeAddressInfoCmd !LegacyQueryStakeAddressInfoCmdArgs - | QueryUTxOCmd !LegacyQueryUTxOCmdArgs - | QueryLedgerStateCmd !LegacyQueryLedgerStateCmdArgs - | QueryProtocolStateCmd !LegacyQueryProtocolStateCmdArgs - | QueryStakeSnapshotCmd !LegacyQueryStakeSnapshotCmdArgs - | QueryKesPeriodInfoCmd !LegacyQueryKesPeriodInfoCmdArgs - | QueryPoolStateCmd !LegacyQueryPoolStateCmdArgs - | QueryTxMempoolCmd !LegacyQueryTxMempoolCmdArgs - | QuerySlotNumberCmd !LegacyQuerySlotNumberCmdArgs + = QueryLeadershipScheduleCmd !LegacyQueryLeadershipScheduleCmdArgs + | QueryProtocolParametersCmd !LegacyQueryProtocolParametersCmdArgs + | QueryTipCmd !LegacyQueryTipCmdArgs + | QueryStakePoolsCmd !LegacyQueryStakePoolsCmdArgs + | QueryStakeDistributionCmd !LegacyQueryStakeDistributionCmdArgs + | QueryStakeAddressInfoCmd !LegacyQueryStakeAddressInfoCmdArgs + | QueryUTxOCmd !LegacyQueryUTxOCmdArgs + | QueryLedgerStateCmd !LegacyQueryLedgerStateCmdArgs + | QueryProtocolStateCmd !LegacyQueryProtocolStateCmdArgs + | QueryStakeSnapshotCmd !LegacyQueryStakeSnapshotCmdArgs + | QueryKesPeriodInfoCmd !LegacyQueryKesPeriodInfoCmdArgs + | QueryPoolStateCmd !LegacyQueryPoolStateCmdArgs + | QueryTxMempoolCmd !LegacyQueryTxMempoolCmdArgs + | QuerySlotNumberCmd !LegacyQuerySlotNumberCmdArgs deriving (Generic, Show) data LegacyQueryLeadershipScheduleCmdArgs = LegacyQueryLeadershipScheduleCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , genesisFp :: !GenesisFile - , poolColdVerKeyFile :: !(VerificationKeyOrHashOrFile StakePoolKey) - , vrkSkeyFp :: !(SigningKeyFile In) - , whichSchedule :: !EpochLeadershipSchedule - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , genesisFp :: !GenesisFile + , poolColdVerKeyFile :: !(VerificationKeyOrHashOrFile StakePoolKey) + , vrkSkeyFp :: !(SigningKeyFile In) + , whichSchedule :: !EpochLeadershipSchedule + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryProtocolParametersCmdArgs = LegacyQueryProtocolParametersCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryConstitutionHashCmdArgs = LegacyQueryConstitutionHashCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryTipCmdArgs = LegacyQueryTipCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryStakePoolsCmdArgs = LegacyQueryStakePoolsCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryStakeDistributionCmdArgs = LegacyQueryStakeDistributionCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryStakeAddressInfoCmdArgs = LegacyQueryStakeAddressInfoCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , addr :: !StakeAddress - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , addr :: !StakeAddress + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryUTxOCmdArgs = LegacyQueryUTxOCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , queryFilter :: !QueryUTxOFilter - , networkId :: !NetworkId - , format :: Maybe OutputFormatJsonOrText - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , queryFilter :: !QueryUTxOFilter + , networkId :: !NetworkId + , format :: Maybe OutputFormatJsonOrText + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryLedgerStateCmdArgs = LegacyQueryLedgerStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryProtocolStateCmdArgs = LegacyQueryProtocolStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryStakeSnapshotCmdArgs = LegacyQueryStakeSnapshotCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryKesPeriodInfoCmdArgs = LegacyQueryKesPeriodInfoCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , nodeOpCertFp :: !(File () In) -- ^ Node operational certificate - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , nodeOpCertFp :: !(File () In) + -- ^ Node operational certificate + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryPoolStateCmdArgs = LegacyQueryPoolStateCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) - , mOutFile :: !(Maybe (File () Out)) - } deriving (Generic, Show) + , networkId :: !NetworkId + , allOrOnlyPoolIds :: !(AllOrOnly (Hash StakePoolKey)) + , mOutFile :: !(Maybe (File () Out)) + } + deriving (Generic, Show) data LegacyQueryTxMempoolCmdArgs = LegacyQueryTxMempoolCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , query :: !TxMempoolQuery - , mOutFile :: !(Maybe (File () Out)) + , networkId :: !NetworkId + , query :: !TxMempoolQuery + , mOutFile :: !(Maybe (File () Out)) } deriving (Generic, Show) data LegacyQuerySlotNumberCmdArgs = LegacyQuerySlotNumberCmdArgs - { nodeSocketPath :: !SocketPath + { nodeSocketPath :: !SocketPath , consensusModeParams :: !ConsensusModeParams - , networkId :: !NetworkId - , utcTime :: !UTCTime - } deriving (Generic, Show) + , networkId :: !NetworkId + , utcTime :: !UTCTime + } + deriving (Generic, Show) renderLegacyQueryCmds :: LegacyQueryCmds -> Text renderLegacyQueryCmds = \case - QueryLeadershipScheduleCmd {} -> "query leadership-schedule" - QueryProtocolParametersCmd {} -> "query protocol-parameters " - QueryTipCmd {} -> "query tip" - QueryStakePoolsCmd {} -> "query stake-pools" - QueryStakeDistributionCmd {} -> "query stake-distribution" - QueryStakeAddressInfoCmd {} -> "query stake-address-info" - QueryUTxOCmd {} -> "query utxo" - QueryLedgerStateCmd {} -> "query ledger-state" - QueryProtocolStateCmd {} -> "query protocol-state" - QueryStakeSnapshotCmd {} -> "query stake-snapshot" - QueryKesPeriodInfoCmd {} -> "query kes-period-info" - QueryPoolStateCmd {} -> "query pool-state" + QueryLeadershipScheduleCmd{} -> "query leadership-schedule" + QueryProtocolParametersCmd{} -> "query protocol-parameters " + QueryTipCmd{} -> "query tip" + QueryStakePoolsCmd{} -> "query stake-pools" + QueryStakeDistributionCmd{} -> "query stake-distribution" + QueryStakeAddressInfoCmd{} -> "query stake-address-info" + QueryUTxOCmd{} -> "query utxo" + QueryLedgerStateCmd{} -> "query ledger-state" + QueryProtocolStateCmd{} -> "query protocol-state" + QueryStakeSnapshotCmd{} -> "query stake-snapshot" + QueryKesPeriodInfoCmd{} -> "query kes-period-info" + QueryPoolStateCmd{} -> "query pool-state" QueryTxMempoolCmd (LegacyQueryTxMempoolCmdArgs _ _ _ txMempoolQuery _) -> "query tx-mempool" <> renderTxMempoolQuery txMempoolQuery - QuerySlotNumberCmd {} -> "query slot-number" - where - renderTxMempoolQuery = \case - TxMempoolQueryTxExists tx -> "tx-exists " <> serialiseToRawBytesHexText tx - TxMempoolQueryNextTx -> "next-tx" - TxMempoolQueryInfo -> "info" + QuerySlotNumberCmd{} -> "query slot-number" + where + renderTxMempoolQuery = \case + TxMempoolQueryTxExists tx -> "tx-exists " <> serialiseToRawBytesHexText tx + TxMempoolQueryNextTx -> "next-tx" + TxMempoolQueryInfo -> "info" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakeAddress.hs index 50f2dc9156..8f1a4cbe35 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakeAddress.hs @@ -5,7 +5,8 @@ module Cardano.CLI.Legacy.Commands.StakeAddress ( LegacyStakeAddressCmds (..) , renderLegacyStakeAddressCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley @@ -48,9 +49,9 @@ data LegacyStakeAddressCmds renderLegacyStakeAddressCmds :: LegacyStakeAddressCmds -> Text renderLegacyStakeAddressCmds = \case - StakeAddressKeyGenCmd {} -> "stake-address key-gen" - StakeAddressKeyHashCmd {} -> "stake-address key-hash" - StakeAddressBuildCmd {} -> "stake-address build" - StakeAddressRegistrationCertificateCmd {} -> "stake-address registration-certificate" - StakeAddressDelegationCertificateCmd {} -> "stake-address delegation-certificate" - StakeAddressDeregistrationCertificateCmd {} -> "stake-address deregistration-certificate" + StakeAddressKeyGenCmd{} -> "stake-address key-gen" + StakeAddressKeyHashCmd{} -> "stake-address key-hash" + StakeAddressBuildCmd{} -> "stake-address build" + StakeAddressRegistrationCertificateCmd{} -> "stake-address registration-certificate" + StakeAddressDelegationCertificateCmd{} -> "stake-address delegation-certificate" + StakeAddressDeregistrationCertificateCmd{} -> "stake-address deregistration-certificate" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakePool.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakePool.hs index faaa8e730a..e688e93bff 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakePool.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/StakePool.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Commands.StakePool ( LegacyStakePoolCmds (..) , renderLegacyStakePoolCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -59,11 +60,11 @@ data LegacyStakePoolCmds renderLegacyStakePoolCmds :: LegacyStakePoolCmds -> Text renderLegacyStakePoolCmds = \case - StakePoolDeregistrationCertificateCmd {} -> + StakePoolDeregistrationCertificateCmd{} -> "stake-pool deregistration-certificate" - StakePoolIdCmd {} -> + StakePoolIdCmd{} -> "stake-pool id" - StakePoolMetadataHashCmd {} -> + StakePoolMetadataHashCmd{} -> "stake-pool metadata-hash" - StakePoolRegistrationCertificateCmd {} -> + StakePoolRegistrationCertificateCmd{} -> "stake-pool registration-certificate" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/TextView.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/TextView.hs index 15c0174696..6e0b82f095 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/TextView.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/TextView.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Commands.TextView ( LegacyTextViewCmds (..) , renderLegacyTextViewCmds - ) where + ) +where import Cardano.Api.Shelley diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs index 35e16e0bf5..b05c4c5bd5 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Commands/Transaction.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Commands.Transaction ( LegacyTransactionCmds (..) , renderLegacyTransactionCmds - ) where + ) +where import Cardano.Api.Ledger (Coin) import Cardano.Api.Shelley @@ -50,14 +51,14 @@ data LegacyTransactionCmds (Maybe ProtocolParamsFile) (Maybe UpdateProposalFile) (TxBodyFile Out) - - -- | Like 'TransactionBuildRaw' but without the fee, and with a change output. - | TransactionBuildCmd + | -- | Like 'TransactionBuildRaw' but without the fee, and with a change output. + TransactionBuildCmd SocketPath (EraInEon ShelleyBasedEra) ConsensusModeParams NetworkId - (Maybe ScriptValidity) -- ^ Mark script as expected to pass or fail validation + (Maybe ScriptValidity) + -- ^ Mark script as expected to pass or fail validation (Maybe Word) -- ^ Override the required number of tx witnesses [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] @@ -116,7 +117,8 @@ data LegacyTransactionCmds FilePath | TransactionPolicyIdCmd ScriptFile - | TransactionCalculateMinFeeCmd + | -- | The total size in bytes of the transaction reference scripts. + TransactionCalculateMinFeeCmd (TxBodyFile In) ProtocolParamsFile TxShelleyWitnessCount @@ -124,7 +126,6 @@ data LegacyTransactionCmds ReferenceScriptSize (Maybe OutputFormatJsonOrText) (Maybe (File () Out)) - -- ^ The total size in bytes of the transaction reference scripts. | TransactionCalculateMinValueCmd (EraInEon ShelleyBasedEra) ProtocolParamsFile @@ -140,15 +141,15 @@ data LegacyTransactionCmds renderLegacyTransactionCmds :: LegacyTransactionCmds -> Text renderLegacyTransactionCmds = \case - TransactionBuildCmd {} -> "transaction build" - TransactionBuildRawCmd {} -> "transaction build-raw" - TransactionSignCmd {} -> "transaction sign" - TransactionWitnessCmd {} -> "transaction witness" - TransactionSignWitnessCmd {} -> "transaction sign-witness" - TransactionSubmitCmd {} -> "transaction submit" - TransactionPolicyIdCmd {} -> "transaction policyid" - TransactionCalculateMinFeeCmd {} -> "transaction calculate-min-fee" - TransactionCalculateMinValueCmd {} -> "transaction calculate-min-value" - TransactionHashScriptDataCmd {} -> "transaction hash-script-data" - TransactionTxIdCmd {} -> "transaction txid" - TransactionViewCmd {} -> "transaction view" + TransactionBuildCmd{} -> "transaction build" + TransactionBuildRawCmd{} -> "transaction build-raw" + TransactionSignCmd{} -> "transaction sign" + TransactionWitnessCmd{} -> "transaction witness" + TransactionSignWitnessCmd{} -> "transaction sign-witness" + TransactionSubmitCmd{} -> "transaction submit" + TransactionPolicyIdCmd{} -> "transaction policyid" + TransactionCalculateMinFeeCmd{} -> "transaction calculate-min-fee" + TransactionCalculateMinValueCmd{} -> "transaction calculate-min-value" + TransactionHashScriptDataCmd{} -> "transaction hash-script-data" + TransactionTxIdCmd{} -> "transaction txid" + TransactionViewCmd{} -> "transaction view" diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs index 69766ffb52..ecce2d8162 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Options.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Options.hs @@ -13,13 +13,13 @@ module Cardano.CLI.Legacy.Options -- * Field parser and renderers , parseTxIn - , pLegacyCardanoEra , pLegacyShelleyBasedEra , pKeyRegistDeposit , pStakePoolRegistrationParserRequirements , pStakePoolVerificationKeyOrHashOrFile - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) import Cardano.Api.Ledger (Coin (..)) @@ -62,251 +62,287 @@ import Prettyprinter (line) parseLegacyCmds :: EnvCli -> Parser LegacyCmds parseLegacyCmds envCli = - Opt.hsubparser $ mconcat - [ Opt.metavar "Legacy commands" - , Opt.commandGroup "Legacy commands" - , Opt.command "address" - $ Opt.info (LegacyAddressCmds <$> pAddressCmds envCli) - $ Opt.progDesc "Payment address commands" - , Opt.command "stake-address" - $ Opt.info (LegacyStakeAddressCmds <$> pStakeAddressCmds envCli) - $ Opt.progDesc "Stake address commands" - , Opt.command "key" - $ Opt.info (LegacyKeyCmds <$> pKeyCmds) - $ Opt.progDesc "Key utility commands" - , Opt.command "transaction" - $ Opt.info (LegacyTransactionCmds <$> pTransaction envCli) - $ Opt.progDesc "Transaction commands" - , Opt.command "node" - $ Opt.info (LegacyNodeCmds <$> pNodeCmds) - $ Opt.progDesc "Node operation commands" - , Opt.command "stake-pool" - $ Opt.info (LegacyStakePoolCmds <$> pStakePoolCmds envCli) - $ Opt.progDesc "Stake pool commands" - , Opt.command "query" - $ Opt.info (LegacyQueryCmds <$> pQueryCmds envCli) . Opt.progDesc - $ mconcat - [ "Node query commands. Will query the local node whose Unix domain socket " - , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." - ] - , Opt.command "genesis" - $ Opt.info (LegacyGenesisCmds <$> pGenesisCmds envCli) - $ Opt.progDesc "Genesis block commands" - , Opt.command "governance" - $ Opt.info (LegacyGovernanceCmds <$> pGovernanceCmds envCli) - $ Opt.progDesc "Governance commands" - , Opt.command "text-view" - $ Opt.info (LegacyTextViewCmds <$> pTextViewCmds) . Opt.progDesc - $ mconcat - [ "Commands for dealing with Shelley TextView files. " - , "Transactions, addresses etc are stored on disk as TextView files." - ] - ] + Opt.hsubparser $ + mconcat + [ Opt.metavar "Legacy commands" + , Opt.commandGroup "Legacy commands" + , Opt.command "address" $ + Opt.info (LegacyAddressCmds <$> pAddressCmds envCli) $ + Opt.progDesc "Payment address commands" + , Opt.command "stake-address" $ + Opt.info (LegacyStakeAddressCmds <$> pStakeAddressCmds envCli) $ + Opt.progDesc "Stake address commands" + , Opt.command "key" $ + Opt.info (LegacyKeyCmds <$> pKeyCmds) $ + Opt.progDesc "Key utility commands" + , Opt.command "transaction" $ + Opt.info (LegacyTransactionCmds <$> pTransaction envCli) $ + Opt.progDesc "Transaction commands" + , Opt.command "node" $ + Opt.info (LegacyNodeCmds <$> pNodeCmds) $ + Opt.progDesc "Node operation commands" + , Opt.command "stake-pool" $ + Opt.info (LegacyStakePoolCmds <$> pStakePoolCmds envCli) $ + Opt.progDesc "Stake pool commands" + , Opt.command "query" $ + Opt.info (LegacyQueryCmds <$> pQueryCmds envCli) . Opt.progDesc $ + mconcat + [ "Node query commands. Will query the local node whose Unix domain socket " + , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." + ] + , Opt.command "genesis" $ + Opt.info (LegacyGenesisCmds <$> pGenesisCmds envCli) $ + Opt.progDesc "Genesis block commands" + , Opt.command "governance" $ + Opt.info (LegacyGovernanceCmds <$> pGovernanceCmds envCli) $ + Opt.progDesc "Governance commands" + , Opt.command "text-view" $ + Opt.info (LegacyTextViewCmds <$> pTextViewCmds) . Opt.progDesc $ + mconcat + [ "Commands for dealing with Shelley TextView files. " + , "Transactions, addresses etc are stored on disk as TextView files." + ] + ] pTextViewCmds :: Parser LegacyTextViewCmds pTextViewCmds = asum - [ subParser "decode-cbor" - (Opt.info (TextViewInfo <$> pCBORInFile <*> pMaybeOutputFile) - $ Opt.progDesc "Print a TextView file as decoded CBOR." - ) + [ subParser + "decode-cbor" + ( Opt.info (TextViewInfo <$> pCBORInFile <*> pMaybeOutputFile) $ + Opt.progDesc "Print a TextView file as decoded CBOR." + ) ] pAddressCmds :: EnvCli -> Parser LegacyAddressCmds pAddressCmds envCli = - asum - [ subParser "key-gen" - (Opt.info pAddressKeyGen $ Opt.progDesc "Create an address key pair.") - , subParser "key-hash" - (Opt.info pAddressKeyHash $ Opt.progDesc "Print the hash of an address key.") - , subParser "build" - (Opt.info pAddressBuild $ Opt.progDesc "Build a Shelley payment address, with optional delegation to a stake address.") - , subParser "info" - (Opt.info pAddressInfo $ Opt.progDesc "Print information about an address.") - ] - where - pAddressKeyGen :: Parser LegacyAddressCmds - pAddressKeyGen = - AddressKeyGen - <$> pKeyOutputFormat - <*> pAddressKeyType - <*> pVerificationKeyFileOut - <*> pSigningKeyFileOut - - pAddressKeyHash :: Parser LegacyAddressCmds - pAddressKeyHash = - AddressKeyHash - <$> pPaymentVerificationKeyTextOrFile - <*> pMaybeOutputFile + asum + [ subParser + "key-gen" + (Opt.info pAddressKeyGen $ Opt.progDesc "Create an address key pair.") + , subParser + "key-hash" + (Opt.info pAddressKeyHash $ Opt.progDesc "Print the hash of an address key.") + , subParser + "build" + ( Opt.info pAddressBuild $ + Opt.progDesc "Build a Shelley payment address, with optional delegation to a stake address." + ) + , subParser + "info" + (Opt.info pAddressInfo $ Opt.progDesc "Print information about an address.") + ] + where + pAddressKeyGen :: Parser LegacyAddressCmds + pAddressKeyGen = + AddressKeyGen + <$> pKeyOutputFormat + <*> pAddressKeyType + <*> pVerificationKeyFileOut + <*> pSigningKeyFileOut + + pAddressKeyHash :: Parser LegacyAddressCmds + pAddressKeyHash = + AddressKeyHash + <$> pPaymentVerificationKeyTextOrFile + <*> pMaybeOutputFile - pAddressBuild :: Parser LegacyAddressCmds - pAddressBuild = AddressBuild + pAddressBuild :: Parser LegacyAddressCmds + pAddressBuild = + AddressBuild <$> pPaymentVerifier <*> Opt.optional (pStakeIdentifier Nothing) <*> pNetworkId envCli <*> pMaybeOutputFile - pAddressInfo :: Parser LegacyAddressCmds - pAddressInfo = AddressInfo <$> pAddress <*> pMaybeOutputFile + pAddressInfo :: Parser LegacyAddressCmds + pAddressInfo = AddressInfo <$> pAddress <*> pMaybeOutputFile pStakeAddressCmds :: EnvCli -> Parser LegacyStakeAddressCmds pStakeAddressCmds envCli = - asum - [ subParser "key-gen" - $ Opt.info pStakeAddressKeyGenCmd - $ Opt.progDesc "Create a stake address key pair" - , subParser "build" - $ Opt.info pStakeAddressBuildCmd - $ Opt.progDesc "Build a stake address" - , subParser "key-hash" - $ Opt.info pStakeAddressKeyHashCmd - $ Opt.progDesc "Print the hash of a stake address key." - , subParser "registration-certificate" - $ Opt.info pStakeAddressRegistrationCertificateCmd - $ Opt.progDesc "Create a stake address registration certificate" - , subParser "deregistration-certificate" - $ Opt.info pStakeAddressDeregistrationCertificateCmd - $ Opt.progDesc "Create a stake address deregistration certificate" - , subParser "delegation-certificate" - $ Opt.info pStakeAddressStakeDelegationCertificateCmd - $ Opt.progDesc "Create a stake address pool delegation certificate" - ] - where - pStakeAddressKeyGenCmd :: Parser LegacyStakeAddressCmds - pStakeAddressKeyGenCmd = - StakeAddressKeyGenCmd - <$> pKeyOutputFormat - <*> pVerificationKeyFileOut - <*> pSigningKeyFileOut - - pStakeAddressKeyHashCmd :: Parser LegacyStakeAddressCmds - pStakeAddressKeyHashCmd = - StakeAddressKeyHashCmd - <$> pStakeVerificationKeyOrFile Nothing - <*> pMaybeOutputFile + asum + [ subParser "key-gen" $ + Opt.info pStakeAddressKeyGenCmd $ + Opt.progDesc "Create a stake address key pair" + , subParser "build" $ + Opt.info pStakeAddressBuildCmd $ + Opt.progDesc "Build a stake address" + , subParser "key-hash" $ + Opt.info pStakeAddressKeyHashCmd $ + Opt.progDesc "Print the hash of a stake address key." + , subParser "registration-certificate" $ + Opt.info pStakeAddressRegistrationCertificateCmd $ + Opt.progDesc "Create a stake address registration certificate" + , subParser "deregistration-certificate" $ + Opt.info pStakeAddressDeregistrationCertificateCmd $ + Opt.progDesc "Create a stake address deregistration certificate" + , subParser "delegation-certificate" $ + Opt.info pStakeAddressStakeDelegationCertificateCmd $ + Opt.progDesc "Create a stake address pool delegation certificate" + ] + where + pStakeAddressKeyGenCmd :: Parser LegacyStakeAddressCmds + pStakeAddressKeyGenCmd = + StakeAddressKeyGenCmd + <$> pKeyOutputFormat + <*> pVerificationKeyFileOut + <*> pSigningKeyFileOut + + pStakeAddressKeyHashCmd :: Parser LegacyStakeAddressCmds + pStakeAddressKeyHashCmd = + StakeAddressKeyHashCmd + <$> pStakeVerificationKeyOrFile Nothing + <*> pMaybeOutputFile - pStakeAddressBuildCmd :: Parser LegacyStakeAddressCmds - pStakeAddressBuildCmd = - StakeAddressBuildCmd - <$> pStakeVerifier Nothing - <*> pNetworkId envCli - <*> pMaybeOutputFile + pStakeAddressBuildCmd :: Parser LegacyStakeAddressCmds + pStakeAddressBuildCmd = + StakeAddressBuildCmd + <$> pStakeVerifier Nothing + <*> pNetworkId envCli + <*> pMaybeOutputFile - pStakeAddressRegistrationCertificateCmd :: Parser LegacyStakeAddressCmds - pStakeAddressRegistrationCertificateCmd = - StakeAddressRegistrationCertificateCmd - <$> pAnyShelleyBasedEra envCli - <*> pStakeIdentifier Nothing - <*> optional pKeyRegistDeposit - <*> pOutputFile + pStakeAddressRegistrationCertificateCmd :: Parser LegacyStakeAddressCmds + pStakeAddressRegistrationCertificateCmd = + StakeAddressRegistrationCertificateCmd + <$> pAnyShelleyBasedEra envCli + <*> pStakeIdentifier Nothing + <*> optional pKeyRegistDeposit + <*> pOutputFile - pStakeAddressDeregistrationCertificateCmd :: Parser LegacyStakeAddressCmds - pStakeAddressDeregistrationCertificateCmd = - StakeAddressDeregistrationCertificateCmd - <$> pAnyShelleyBasedEra envCli - <*> pStakeIdentifier Nothing - <*> optional pKeyRegistDeposit - <*> pOutputFile + pStakeAddressDeregistrationCertificateCmd :: Parser LegacyStakeAddressCmds + pStakeAddressDeregistrationCertificateCmd = + StakeAddressDeregistrationCertificateCmd + <$> pAnyShelleyBasedEra envCli + <*> pStakeIdentifier Nothing + <*> optional pKeyRegistDeposit + <*> pOutputFile - pStakeAddressStakeDelegationCertificateCmd :: Parser LegacyStakeAddressCmds - pStakeAddressStakeDelegationCertificateCmd = - StakeAddressDelegationCertificateCmd - <$> pAnyShelleyBasedEra envCli - <*> pStakeIdentifier Nothing - <*> pStakePoolVerificationKeyOrHashOrFile Nothing - <*> pOutputFile + pStakeAddressStakeDelegationCertificateCmd :: Parser LegacyStakeAddressCmds + pStakeAddressStakeDelegationCertificateCmd = + StakeAddressDelegationCertificateCmd + <$> pAnyShelleyBasedEra envCli + <*> pStakeIdentifier Nothing + <*> pStakePoolVerificationKeyOrHashOrFile Nothing + <*> pOutputFile pTransaction :: EnvCli -> Parser LegacyTransactionCmds pTransaction envCli = asum - [ subParser "build-raw" - $ Opt.info pTransactionBuildRaw $ Opt.progDescDoc $ Just $ mconcat - [ pretty @String "Build a transaction (low-level, inconvenient)" - , line - , line - , H.yellow $ mconcat - [ "Please note the order of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] - ] - , subParser "build" - $ Opt.info pTransactionBuild $ Opt.progDescDoc $ Just $ mconcat - [ pretty @String "Build a balanced transaction (automatically calculates fees)" - , line - , line - , H.yellow $ mconcat - [ "Please note " - , H.underline "the order" - , " of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] - ] - , subParser "sign" + [ subParser "build-raw" $ + Opt.info pTransactionBuildRaw $ + Opt.progDescDoc $ + Just $ + mconcat + [ pretty @String "Build a transaction (low-level, inconvenient)" + , line + , line + , H.yellow $ + mconcat + [ "Please note the order of some cmd options is crucial. If used incorrectly may produce " + , "undesired tx body. See nested [] notation above for details." + ] + ] + , subParser "build" $ + Opt.info pTransactionBuild $ + Opt.progDescDoc $ + Just $ + mconcat + [ pretty @String "Build a balanced transaction (automatically calculates fees)" + , line + , line + , H.yellow $ + mconcat + [ "Please note " + , H.underline "the order" + , " of some cmd options is crucial. If used incorrectly may produce " + , "undesired tx body. See nested [] notation above for details." + ] + ] + , subParser + "sign" (Opt.info pTransactionSign $ Opt.progDesc "Sign a transaction") - , subParser "witness" + , subParser + "witness" (Opt.info pTransactionCreateWitness $ Opt.progDesc "Create a transaction witness") - , subParser "assemble" - (Opt.info pTransactionAssembleTxBodyWit - $ Opt.progDesc "Assemble a tx body and witness(es) to form a transaction") + , subParser + "assemble" + ( Opt.info pTransactionAssembleTxBodyWit $ + Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" + ) , pSignWitnessBackwardCompatible - , subParser "submit" - (Opt.info pTransactionSubmit . Opt.progDesc $ - mconcat - [ "Submit a transaction to the local node whose Unix domain socket " - , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." - ] - ) - , subParser "policyid" - (Opt.info pTransactionPolicyId $ Opt.progDesc "Calculate the PolicyId from the monetary policy script.") - , subParser "calculate-min-fee" + , subParser + "submit" + ( Opt.info pTransactionSubmit . Opt.progDesc $ + mconcat + [ "Submit a transaction to the local node whose Unix domain socket " + , "is obtained from the CARDANO_NODE_SOCKET_PATH environment variable." + ] + ) + , subParser + "policyid" + ( Opt.info pTransactionPolicyId $ + Opt.progDesc "Calculate the PolicyId from the monetary policy script." + ) + , subParser + "calculate-min-fee" (Opt.info pTransactionCalculateMinFee $ Opt.progDesc "Calculate the minimum fee for a transaction.") - , subParser "calculate-min-required-utxo" - (Opt.info pTransactionCalculateMinReqUTxO $ Opt.progDesc "Calculate the minimum required UTxO for a transaction output.") + , subParser + "calculate-min-required-utxo" + ( Opt.info pTransactionCalculateMinReqUTxO $ + Opt.progDesc "Calculate the minimum required UTxO for a transaction output." + ) , pCalculateMinRequiredUtxoBackwardCompatible - , subParser "hash-script-data" + , subParser + "hash-script-data" (Opt.info pTxHashScriptData $ Opt.progDesc "Calculate the hash of script data.") - , subParser "txid" + , subParser + "txid" (Opt.info pTransactionId $ Opt.progDesc "Print a transaction identifier.") , subParser "view" $ - Opt.info pTransactionView $ Opt.progDesc "Print a transaction." + Opt.info pTransactionView $ + Opt.progDesc "Print a transaction." ] where -- Backwards compatible parsers calcMinValueInfo :: ParserInfo LegacyTransactionCmds calcMinValueInfo = - Opt.info pTransactionCalculateMinReqUTxO - $ Opt.progDesc "DEPRECATED: Use 'calculate-min-required-utxo' instead." + Opt.info pTransactionCalculateMinReqUTxO $ + Opt.progDesc "DEPRECATED: Use 'calculate-min-required-utxo' instead." pCalculateMinRequiredUtxoBackwardCompatible :: Parser LegacyTransactionCmds pCalculateMinRequiredUtxoBackwardCompatible = - Opt.subparser - $ Opt.command "calculate-min-value" calcMinValueInfo <> Opt.internal + Opt.subparser $ + Opt.command "calculate-min-value" calcMinValueInfo <> Opt.internal assembleInfo :: ParserInfo LegacyTransactionCmds assembleInfo = - Opt.info pTransactionAssembleTxBodyWit - $ Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" + Opt.info pTransactionAssembleTxBodyWit $ + Opt.progDesc "Assemble a tx body and witness(es) to form a transaction" pSignWitnessBackwardCompatible :: Parser LegacyTransactionCmds pSignWitnessBackwardCompatible = - Opt.subparser - $ Opt.command "sign-witness" assembleInfo <> Opt.internal + Opt.subparser $ + Opt.command "sign-witness" assembleInfo <> Opt.internal pScriptValidity :: Parser ScriptValidity - pScriptValidity = asum - [ Opt.flag' ScriptValid $ mconcat - [ Opt.long "script-valid" - , Opt.help "Assertion that the script is valid. (default)" - ] - , Opt.flag' ScriptInvalid $ mconcat - [ Opt.long "script-invalid" - , Opt.help $ mconcat - [ "Assertion that the script is invalid. " - , "If a transaction is submitted with such a script, " - , "the script will fail and the collateral will be taken." - ] + pScriptValidity = + asum + [ Opt.flag' ScriptValid $ + mconcat + [ Opt.long "script-valid" + , Opt.help "Assertion that the script is valid. (default)" + ] + , Opt.flag' ScriptInvalid $ + mconcat + [ Opt.long "script-invalid" + , Opt.help $ + mconcat + [ "Assertion that the script is invalid. " + , "If a transaction is submitted with such a script, " + , "the script will fail and the collateral will be taken." + ] + ] ] - ] pTransactionBuild :: Parser LegacyTransactionCmds pTransactionBuild = @@ -331,10 +367,12 @@ pTransaction envCli = <*> many (pCertificateFile AutoBalance) <*> many (pWithdrawal AutoBalance) <*> pTxMetadataJsonSchema - <*> many (pScriptFor - "auxiliary-script-file" - Nothing - "Filepath of auxiliary script(s)") + <*> many + ( pScriptFor + "auxiliary-script-file" + Nothing + "Filepath of auxiliary script(s)" + ) <*> many pMetadataFile <*> optional pUpdateProposalFile <*> pVoteFiles ShelleyBasedEraConway AutoBalance @@ -344,11 +382,13 @@ pTransaction envCli = pChangeAddress :: Parser TxOutChangeAddress pChangeAddress = - fmap TxOutChangeAddress $ Opt.option (readerFromParsecParser parseAddressAny) $ mconcat - [ Opt.long "change-address" - , Opt.metavar "ADDRESS" - , Opt.help "Address where ADA in excess of the tx fee will go to." - ] + fmap TxOutChangeAddress $ + Opt.option (readerFromParsecParser parseAddressAny) $ + mconcat + [ Opt.long "change-address" + , Opt.metavar "ADDRESS" + , Opt.help "Address where ADA in excess of the tx fee will go to." + ] pTransactionBuildRaw :: Parser LegacyTransactionCmds pTransactionBuildRaw = @@ -366,7 +406,7 @@ pTransaction envCli = <*> optional pInvalidBefore <*> optional pLegacyInvalidHereafter <*> pTxFee - <*> many (pCertificateFile ManualBalance ) + <*> many (pCertificateFile ManualBalance) <*> many (pWithdrawal ManualBalance) <*> pTxMetadataJsonSchema <*> many (pScriptFor "auxiliary-script-file" Nothing "Filepath of auxiliary script(s)") @@ -375,7 +415,7 @@ pTransaction envCli = <*> optional pUpdateProposalFile <*> pTxBodyFileOut - pTransactionSign :: Parser LegacyTransactionCmds + pTransactionSign :: Parser LegacyTransactionCmds pTransactionSign = TransactionSignCmd <$> pInputTxOrTxBodyFile @@ -422,9 +462,9 @@ pTransaction envCli = <*> (optional $ pOutputFormatJsonOrText "calculate-min-fee") <*> optional pOutputFile -- Deprecated options: - <* optional pNetworkIdDeprecated - <* optional pTxInCountDeprecated - <* optional pTxOutCountDeprecated + <* optional pNetworkIdDeprecated + <* optional pTxInCountDeprecated + <* optional pTxOutCountDeprecated pTransactionCalculateMinReqUTxO :: Parser LegacyTransactionCmds pTransactionCalculateMinReqUTxO = @@ -435,13 +475,13 @@ pTransaction envCli = pTxHashScriptData :: Parser LegacyTransactionCmds pTxHashScriptData = - fmap TransactionHashScriptDataCmd - $ pScriptDataOrFile - "script-data" - "The script data." - "The script data file." + fmap TransactionHashScriptDataCmd $ + pScriptDataOrFile + "script-data" + "The script data." + "The script data file." - pTransactionId :: Parser LegacyTransactionCmds + pTransactionId :: Parser LegacyTransactionCmds pTransactionId = TransactionTxIdCmd <$> pInputTxOrTxBodyFile @@ -456,730 +496,773 @@ pTransaction envCli = pNodeCmds :: Parser LegacyNodeCmds pNodeCmds = asum - [ 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" - ] + [ 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 LegacyNodeCmds - pKeyGenOperator = - fmap Cmd.LegacyNodeKeyGenColdCmd $ - Cmd.NodeKeyGenColdCmdArgs - <$> pKeyOutputFormat - <*> pColdVerificationKeyFile - <*> pColdSigningKeyFile - <*> pOperatorCertIssueCounterFile - - pKeyGenKES :: Parser LegacyNodeCmds - pKeyGenKES = - fmap Cmd.LegacyNodeKeyGenKESCmd $ - Cmd.NodeKeyGenKESCmdArgs - <$> pKeyOutputFormat - <*> pVerificationKeyFileOut - <*> pSigningKeyFileOut - - pKeyGenVRF :: Parser LegacyNodeCmds - pKeyGenVRF = - fmap Cmd.LegacyNodeKeyGenVRFCmd $ - Cmd.NodeKeyGenVRFCmdArgs - <$> pKeyOutputFormat - <*> pVerificationKeyFileOut - <*> pSigningKeyFileOut - - pKeyHashVRF :: Parser LegacyNodeCmds - pKeyHashVRF = - fmap Cmd.LegacyNodeKeyHashVRFCmd $ - Cmd.NodeKeyHashVRFCmdArgs - <$> pVerificationKeyOrFileIn AsVrfKey - <*> pMaybeOutputFile - - pNewCounter :: Parser LegacyNodeCmds - pNewCounter = - fmap Cmd.LegacyNodeNewCounterCmd $ - Cmd.NodeNewCounterCmdArgs - <$> pColdVerificationKeyOrFile Nothing - <*> pCounterValue - <*> pOperatorCertIssueCounterFile - - pCounterValue :: Parser Word - pCounterValue = - Opt.option Opt.auto $ mconcat + where + pKeyGenOperator :: Parser LegacyNodeCmds + pKeyGenOperator = + fmap Cmd.LegacyNodeKeyGenColdCmd $ + Cmd.NodeKeyGenColdCmdArgs + <$> pKeyOutputFormat + <*> pColdVerificationKeyFile + <*> pColdSigningKeyFile + <*> pOperatorCertIssueCounterFile + + pKeyGenKES :: Parser LegacyNodeCmds + pKeyGenKES = + fmap Cmd.LegacyNodeKeyGenKESCmd $ + Cmd.NodeKeyGenKESCmdArgs + <$> pKeyOutputFormat + <*> pVerificationKeyFileOut + <*> pSigningKeyFileOut + + pKeyGenVRF :: Parser LegacyNodeCmds + pKeyGenVRF = + fmap Cmd.LegacyNodeKeyGenVRFCmd $ + Cmd.NodeKeyGenVRFCmdArgs + <$> pKeyOutputFormat + <*> pVerificationKeyFileOut + <*> pSigningKeyFileOut + + pKeyHashVRF :: Parser LegacyNodeCmds + pKeyHashVRF = + fmap Cmd.LegacyNodeKeyHashVRFCmd $ + Cmd.NodeKeyHashVRFCmdArgs + <$> pVerificationKeyOrFileIn AsVrfKey + <*> pMaybeOutputFile + + pNewCounter :: Parser LegacyNodeCmds + pNewCounter = + fmap Cmd.LegacyNodeNewCounterCmd $ + Cmd.NodeNewCounterCmdArgs + <$> pColdVerificationKeyOrFile Nothing + <*> pCounterValue + <*> pOperatorCertIssueCounterFile + + pCounterValue :: Parser Word + pCounterValue = + Opt.option Opt.auto $ + mconcat [ Opt.long "counter-value" , Opt.metavar "INT" , Opt.help "The next certificate issue counter value to use." ] - pIssueOpCert :: Parser LegacyNodeCmds - pIssueOpCert = - fmap Cmd.LegacyNodeIssueOpCertCmd $ - Cmd.NodeIssueOpCertCmdArgs - <$> pKesVerificationKeyOrFile - <*> pColdSigningKeyFile - <*> pOperatorCertIssueCounterFile - <*> pKesPeriod - <*> pOutputFile + pIssueOpCert :: Parser LegacyNodeCmds + pIssueOpCert = + fmap Cmd.LegacyNodeIssueOpCertCmd $ + Cmd.NodeIssueOpCertCmdArgs + <$> pKesVerificationKeyOrFile + <*> pColdSigningKeyFile + <*> pOperatorCertIssueCounterFile + <*> pKesPeriod + <*> pOutputFile pStakePoolCmds :: EnvCli -> Parser LegacyStakePoolCmds -pStakePoolCmds envCli = +pStakePoolCmds envCli = asum - [ subParser "registration-certificate" - $ Opt.info (pStakePoolRegistrationCertificiateCmd envCli) - $ Opt.progDesc "Create a stake pool registration certificate" - , subParser "deregistration-certificate" - $ Opt.info (pStakePoolDeregistrationCertificateCmd envCli) - $ Opt.progDesc "Create a stake pool deregistration certificate" - , subParser "id" - $ Opt.info pStakePoolId - $ Opt.progDesc "Build pool id from the offline key" - , subParser "metadata-hash" - $ Opt.info pStakePoolMetadataHashCmd - $ Opt.progDesc "Print the hash of pool metadata." + [ subParser "registration-certificate" $ + Opt.info (pStakePoolRegistrationCertificiateCmd envCli) $ + Opt.progDesc "Create a stake pool registration certificate" + , subParser "deregistration-certificate" $ + Opt.info (pStakePoolDeregistrationCertificateCmd envCli) $ + Opt.progDesc "Create a stake pool deregistration certificate" + , subParser "id" $ + Opt.info pStakePoolId $ + Opt.progDesc "Build pool id from the offline key" + , subParser "metadata-hash" $ + Opt.info pStakePoolMetadataHashCmd $ + Opt.progDesc "Print the hash of pool metadata." ] - where - pStakePoolId :: Parser LegacyStakePoolCmds - pStakePoolId = - StakePoolIdCmd - <$> pStakePoolVerificationKeyOrFile Nothing - <*> pPoolIdOutputFormat - <*> pMaybeOutputFile + where + pStakePoolId :: Parser LegacyStakePoolCmds + pStakePoolId = + StakePoolIdCmd + <$> pStakePoolVerificationKeyOrFile Nothing + <*> pPoolIdOutputFormat + <*> pMaybeOutputFile - pStakePoolMetadataHashCmd :: Parser LegacyStakePoolCmds - pStakePoolMetadataHashCmd = - StakePoolMetadataHashCmd - <$> pPoolMetadataFile - <*> pMaybeOutputFile + pStakePoolMetadataHashCmd :: Parser LegacyStakePoolCmds + pStakePoolMetadataHashCmd = + StakePoolMetadataHashCmd + <$> pPoolMetadataFile + <*> pMaybeOutputFile pQueryCmds :: EnvCli -> Parser LegacyQueryCmds pQueryCmds envCli = asum - [ subParser "protocol-parameters" - $ Opt.info pQueryProtocolParameters - $ Opt.progDesc "Get the node's current protocol parameters" - , subParser "tip" - $ Opt.info pQueryTip - $ Opt.progDesc "Get the node's current tip (slot no, hash, block no)" - , subParser "stake-pools" - $ Opt.info pQueryStakePools - $ Opt.progDesc "Get the node's current set of stake pool ids" - , subParser "stake-distribution" - $ Opt.info pQueryStakeDistribution - $ Opt.progDesc "Get the node's current aggregated stake distribution" - , subParser "stake-address-info" - $ Opt.info pQueryStakeAddressInfo - $ Opt.progDesc $ mconcat - [ "Get the current delegations and reward accounts filtered by stake address." - ] - , subParser "utxo" - $ Opt.info pQueryUTxO - $ Opt.progDesc $ mconcat - [ "Get a portion of the current UTxO: by tx in, by address or the whole." - ] - , subParser "ledger-state" - $ Opt.info pQueryLedgerState - $ Opt.progDesc $ mconcat - [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)" - ] - , subParser "protocol-state" - $ Opt.info pQueryProtocolState - $ Opt.progDesc $ mconcat - [ "Dump the current protocol state of the node (Ledger.ChainDepState -- advanced command)" - ] - , subParser "stake-snapshot" - $ Opt.info pQueryStakeSnapshot - $ Opt.progDesc $ mconcat - [ "Obtain the three stake snapshots for a pool, plus the total active stake (advanced command)" - ] - , hiddenSubParser "pool-params" - $ Opt.info pQueryPoolState - $ Opt.progDesc $ mconcat - [ "DEPRECATED. Use query pool-state instead. Dump the pool parameters " - , "(Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)" - ] - , subParser "leadership-schedule" - $ Opt.info pLeadershipSchedule - $ Opt.progDesc "Get the slots the node is expected to mint a block in (advanced command)" - , subParser "kes-period-info" - $ Opt.info pKesPeriodInfo - $ Opt.progDesc "Get information about the current KES period and your node's operational certificate." - , subParser "pool-state" - $ Opt.info pQueryPoolState - $ Opt.progDesc "Dump the pool state" - , subParser "tx-mempool" - $ Opt.info pQueryTxMempool - $ Opt.progDesc "Local Mempool info" - , subParser "slot-number" - $ Opt.info pQuerySlotNumber - $ Opt.progDesc "Query slot number for UTC timestamp" + [ subParser "protocol-parameters" $ + Opt.info pQueryProtocolParameters $ + Opt.progDesc "Get the node's current protocol parameters" + , subParser "tip" $ + Opt.info pQueryTip $ + Opt.progDesc "Get the node's current tip (slot no, hash, block no)" + , subParser "stake-pools" $ + Opt.info pQueryStakePools $ + Opt.progDesc "Get the node's current set of stake pool ids" + , subParser "stake-distribution" $ + Opt.info pQueryStakeDistribution $ + Opt.progDesc "Get the node's current aggregated stake distribution" + , subParser "stake-address-info" $ + Opt.info pQueryStakeAddressInfo $ + Opt.progDesc $ + mconcat + [ "Get the current delegations and reward accounts filtered by stake address." + ] + , subParser "utxo" $ + Opt.info pQueryUTxO $ + Opt.progDesc $ + mconcat + [ "Get a portion of the current UTxO: by tx in, by address or the whole." + ] + , subParser "ledger-state" $ + Opt.info pQueryLedgerState $ + Opt.progDesc $ + mconcat + [ "Dump the current ledger state of the node (Ledger.NewEpochState -- advanced command)" + ] + , subParser "protocol-state" $ + Opt.info pQueryProtocolState $ + Opt.progDesc $ + mconcat + [ "Dump the current protocol state of the node (Ledger.ChainDepState -- advanced command)" + ] + , subParser "stake-snapshot" $ + Opt.info pQueryStakeSnapshot $ + Opt.progDesc $ + mconcat + [ "Obtain the three stake snapshots for a pool, plus the total active stake (advanced command)" + ] + , hiddenSubParser "pool-params" $ + Opt.info pQueryPoolState $ + Opt.progDesc $ + mconcat + [ "DEPRECATED. Use query pool-state instead. Dump the pool parameters " + , "(Ledger.NewEpochState.esLState._delegationState._pState._pParams -- advanced command)" + ] + , subParser "leadership-schedule" $ + Opt.info pLeadershipSchedule $ + Opt.progDesc "Get the slots the node is expected to mint a block in (advanced command)" + , subParser "kes-period-info" $ + Opt.info pKesPeriodInfo $ + Opt.progDesc "Get information about the current KES period and your node's operational certificate." + , subParser "pool-state" $ + Opt.info pQueryPoolState $ + Opt.progDesc "Dump the pool state" + , subParser "tx-mempool" $ + Opt.info pQueryTxMempool $ + Opt.progDesc "Local Mempool info" + , subParser "slot-number" $ + Opt.info pQuerySlotNumber $ + Opt.progDesc "Query slot number for UTC timestamp" ] - where - pQueryProtocolParameters :: Parser LegacyQueryCmds - pQueryProtocolParameters = - fmap QueryProtocolParametersCmd $ - LegacyQueryProtocolParametersCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile - - pQueryTip :: Parser LegacyQueryCmds - pQueryTip = - fmap QueryTipCmd $ - LegacyQueryTipCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile - - pQueryUTxO :: Parser LegacyQueryCmds - pQueryUTxO = - fmap QueryUTxOCmd $ - LegacyQueryUTxOCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pQueryUTxOFilter - <*> pNetworkId envCli - <*> (optional $ pOutputFormatJsonOrText "utxo") - <*> pMaybeOutputFile - - pQueryStakePools :: Parser LegacyQueryCmds - pQueryStakePools = - fmap QueryStakePoolsCmd $ - LegacyQueryStakePoolsCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> (optional $ pOutputFormatJsonOrText "stake-pools") - <*> pMaybeOutputFile - - pQueryStakeDistribution :: Parser LegacyQueryCmds - pQueryStakeDistribution = - fmap QueryStakeDistributionCmd $ - LegacyQueryStakeDistributionCmdArgs + where + pQueryProtocolParameters :: Parser LegacyQueryCmds + pQueryProtocolParameters = + fmap QueryProtocolParametersCmd $ + LegacyQueryProtocolParametersCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile + + pQueryTip :: Parser LegacyQueryCmds + pQueryTip = + fmap QueryTipCmd $ + LegacyQueryTipCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile + + pQueryUTxO :: Parser LegacyQueryCmds + pQueryUTxO = + fmap QueryUTxOCmd $ + LegacyQueryUTxOCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pQueryUTxOFilter + <*> pNetworkId envCli + <*> (optional $ pOutputFormatJsonOrText "utxo") + <*> pMaybeOutputFile + + pQueryStakePools :: Parser LegacyQueryCmds + pQueryStakePools = + fmap QueryStakePoolsCmd $ + LegacyQueryStakePoolsCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> (optional $ pOutputFormatJsonOrText "stake-pools") + <*> pMaybeOutputFile + + pQueryStakeDistribution :: Parser LegacyQueryCmds + pQueryStakeDistribution = + fmap QueryStakeDistributionCmd $ + LegacyQueryStakeDistributionCmdArgs <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli <*> (optional $ pOutputFormatJsonOrText "stake-distribution") <*> pMaybeOutputFile - pQueryStakeAddressInfo :: Parser LegacyQueryCmds - pQueryStakeAddressInfo = - fmap QueryStakeAddressInfoCmd $ - LegacyQueryStakeAddressInfoCmdArgs + pQueryStakeAddressInfo :: Parser LegacyQueryCmds + pQueryStakeAddressInfo = + fmap QueryStakeAddressInfoCmd $ + LegacyQueryStakeAddressInfoCmdArgs <$> pSocketPath envCli <*> pConsensusModeParams <*> pFilterByStakeAddress <*> pNetworkId envCli <*> pMaybeOutputFile - pQueryLedgerState :: Parser LegacyQueryCmds - pQueryLedgerState = - fmap QueryLedgerStateCmd $ - LegacyQueryLedgerStateCmdArgs + pQueryLedgerState :: Parser LegacyQueryCmds + pQueryLedgerState = + fmap QueryLedgerStateCmd $ + LegacyQueryLedgerStateCmdArgs <$> pSocketPath envCli <*> pConsensusModeParams <*> pNetworkId envCli <*> pMaybeOutputFile - pQueryProtocolState :: Parser LegacyQueryCmds - pQueryProtocolState = - fmap QueryProtocolStateCmd $ - LegacyQueryProtocolStateCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pMaybeOutputFile - - pAllStakePoolsOrOnly :: Parser (AllOrOnly (Hash StakePoolKey)) - pAllStakePoolsOrOnly = pAll <|> pOnly - where pAll :: Parser (AllOrOnly (Hash StakePoolKey)) - pAll = Opt.flag' All $ mconcat - [ Opt.long "all-stake-pools" - , Opt.help "Query for all stake pools" - ] - pOnly :: Parser (AllOrOnly (Hash StakePoolKey)) - pOnly = Only <$> some (pStakePoolVerificationKeyHash Nothing) - - pQueryStakeSnapshot :: Parser LegacyQueryCmds - pQueryStakeSnapshot = - fmap QueryStakeSnapshotCmd $ - LegacyQueryStakeSnapshotCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pAllStakePoolsOrOnly - <*> pMaybeOutputFile - - pQueryPoolState :: Parser LegacyQueryCmds - pQueryPoolState = - fmap QueryPoolStateCmd $ - LegacyQueryPoolStateCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pAllStakePoolsOrOnly - <*> pMaybeOutputFile - - pQueryTxMempool :: Parser LegacyQueryCmds - pQueryTxMempool = - fmap QueryTxMempoolCmd $ - LegacyQueryTxMempoolCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pTxMempoolQuery - <*> pMaybeOutputFile - where - pTxMempoolQuery :: Parser TxMempoolQuery - pTxMempoolQuery = asum - [ subParser "info" - $ Opt.info (pure TxMempoolQueryInfo) - $ Opt.progDesc "Ask the node about the current mempool's capacity and sizes" - , subParser "next-tx" - $ Opt.info (pure TxMempoolQueryNextTx) - $ Opt.progDesc "Requests the next transaction from the mempool's current list" - , subParser "tx-exists" - $ Opt.info (TxMempoolQueryTxExists <$> argument Opt.str (metavar "TX_ID")) - $ Opt.progDesc "Query if a particular transaction exists in the mempool" + pQueryProtocolState :: Parser LegacyQueryCmds + pQueryProtocolState = + fmap QueryProtocolStateCmd $ + LegacyQueryProtocolStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pMaybeOutputFile + + pAllStakePoolsOrOnly :: Parser (AllOrOnly (Hash StakePoolKey)) + pAllStakePoolsOrOnly = pAll <|> pOnly + where + pAll :: Parser (AllOrOnly (Hash StakePoolKey)) + pAll = + Opt.flag' All $ + mconcat + [ Opt.long "all-stake-pools" + , Opt.help "Query for all stake pools" ] - pLeadershipSchedule :: Parser LegacyQueryCmds - pLeadershipSchedule = - fmap QueryLeadershipScheduleCmd $ - LegacyQueryLeadershipScheduleCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pGenesisFile "Shelley genesis filepath" - <*> pStakePoolVerificationKeyOrHashOrFile Nothing - <*> pVrfSigningKeyFile - <*> pWhichLeadershipSchedule - <*> (optional $ pOutputFormatJsonOrText "leadership-schedule") - <*> pMaybeOutputFile - - pKesPeriodInfo :: Parser LegacyQueryCmds - pKesPeriodInfo = - fmap QueryKesPeriodInfoCmd $ - LegacyQueryKesPeriodInfoCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pOperationalCertificateFile - <*> pMaybeOutputFile - - pQuerySlotNumber :: Parser LegacyQueryCmds - pQuerySlotNumber = - fmap QuerySlotNumberCmd $ - LegacyQuerySlotNumberCmdArgs - <$> pSocketPath envCli - <*> pConsensusModeParams - <*> pNetworkId envCli - <*> pUtcTimestamp - where - pUtcTimestamp = - convertTime <$> (Opt.strArgument . mconcat) - [ Opt.metavar "TIMESTAMP" - , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" - ] + pOnly :: Parser (AllOrOnly (Hash StakePoolKey)) + pOnly = Only <$> some (pStakePoolVerificationKeyHash Nothing) + + pQueryStakeSnapshot :: Parser LegacyQueryCmds + pQueryStakeSnapshot = + fmap QueryStakeSnapshotCmd $ + LegacyQueryStakeSnapshotCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pAllStakePoolsOrOnly + <*> pMaybeOutputFile + pQueryPoolState :: Parser LegacyQueryCmds + pQueryPoolState = + fmap QueryPoolStateCmd $ + LegacyQueryPoolStateCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pAllStakePoolsOrOnly + <*> pMaybeOutputFile + + pQueryTxMempool :: Parser LegacyQueryCmds + pQueryTxMempool = + fmap QueryTxMempoolCmd $ + LegacyQueryTxMempoolCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pTxMempoolQuery + <*> pMaybeOutputFile + where + pTxMempoolQuery :: Parser TxMempoolQuery + pTxMempoolQuery = + asum + [ subParser "info" $ + Opt.info (pure TxMempoolQueryInfo) $ + Opt.progDesc "Ask the node about the current mempool's capacity and sizes" + , subParser "next-tx" $ + Opt.info (pure TxMempoolQueryNextTx) $ + Opt.progDesc "Requests the next transaction from the mempool's current list" + , subParser "tx-exists" $ + Opt.info (TxMempoolQueryTxExists <$> argument Opt.str (metavar "TX_ID")) $ + Opt.progDesc "Query if a particular transaction exists in the mempool" + ] + pLeadershipSchedule :: Parser LegacyQueryCmds + pLeadershipSchedule = + fmap QueryLeadershipScheduleCmd $ + LegacyQueryLeadershipScheduleCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pGenesisFile "Shelley genesis filepath" + <*> pStakePoolVerificationKeyOrHashOrFile Nothing + <*> pVrfSigningKeyFile + <*> pWhichLeadershipSchedule + <*> (optional $ pOutputFormatJsonOrText "leadership-schedule") + <*> pMaybeOutputFile + + pKesPeriodInfo :: Parser LegacyQueryCmds + pKesPeriodInfo = + fmap QueryKesPeriodInfoCmd $ + LegacyQueryKesPeriodInfoCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pOperationalCertificateFile + <*> pMaybeOutputFile + + pQuerySlotNumber :: Parser LegacyQueryCmds + pQuerySlotNumber = + fmap QuerySlotNumberCmd $ + LegacyQuerySlotNumberCmdArgs + <$> pSocketPath envCli + <*> pConsensusModeParams + <*> pNetworkId envCli + <*> pUtcTimestamp + where + pUtcTimestamp = + convertTime + <$> (Opt.strArgument . mconcat) + [ Opt.metavar "TIMESTAMP" + , Opt.help "UTC timestamp in YYYY-MM-DDThh:mm:ssZ format" + ] -- TODO: Conway era - move to Cardano.CLI.Conway.Parsers pGovernanceCmds :: EnvCli -> Parser LegacyGovernanceCmds pGovernanceCmds envCli = asum - [ subParser "create-mir-certificate" - $ Opt.info (pLegacyMIRPayStakeAddresses <|> 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" - , subParser "create-poll" - $ Opt.info pGovernanceCreatePoll - $ Opt.progDesc "Create an SPO poll" - , subParser "answer-poll" - $ Opt.info pGovernanceAnswerPoll - $ Opt.progDesc "Answer an SPO poll" - , subParser "verify-poll" - $ Opt.info pGovernanceVerifyPoll - $ Opt.progDesc "Verify an answer to a given SPO poll" + [ subParser "create-mir-certificate" $ + Opt.info (pLegacyMIRPayStakeAddresses <|> 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" + , subParser "create-poll" $ + Opt.info pGovernanceCreatePoll $ + Opt.progDesc "Create an SPO poll" + , subParser "answer-poll" $ + Opt.info pGovernanceAnswerPoll $ + Opt.progDesc "Answer an SPO poll" + , subParser "verify-poll" $ + Opt.info pGovernanceVerifyPoll $ + Opt.progDesc "Verify an answer to a given SPO poll" ] - where - mirCertParsers :: Parser LegacyGovernanceCmds - mirCertParsers = asum - [ subParser "stake-addresses" - $ Opt.info pLegacyMIRPayStakeAddresses - $ Opt.progDesc "Create an MIR certificate to pay stake addresses" - , subParser "transfer-to-treasury" - $ Opt.info pLegacyMIRTransferToTreasury - $ Opt.progDesc "Create an MIR certificate to transfer from the reserves pot to the treasury pot" - , subParser "transfer-to-rewards" - $ Opt.info pLegacyMIRTransferToReserves - $ Opt.progDesc "Create an MIR certificate to transfer from the treasury pot to the reserves pot" + where + mirCertParsers :: Parser LegacyGovernanceCmds + mirCertParsers = + asum + [ subParser "stake-addresses" $ + Opt.info pLegacyMIRPayStakeAddresses $ + Opt.progDesc "Create an MIR certificate to pay stake addresses" + , subParser "transfer-to-treasury" $ + Opt.info pLegacyMIRTransferToTreasury $ + Opt.progDesc "Create an MIR certificate to transfer from the reserves pot to the treasury pot" + , subParser "transfer-to-rewards" $ + Opt.info pLegacyMIRTransferToReserves $ + Opt.progDesc "Create an MIR certificate to transfer from the treasury pot to the reserves pot" ] - pLegacyMIRPayStakeAddresses :: Parser LegacyGovernanceCmds - pLegacyMIRPayStakeAddresses = - GovernanceCreateMirCertificateStakeAddressesCmd - <$> pAnyShelleyToBabbageEra envCli - <*> pMIRPot - <*> some (pStakeAddress Nothing) - <*> some pRewardAmt - <*> pOutputFile + pLegacyMIRPayStakeAddresses :: Parser LegacyGovernanceCmds + pLegacyMIRPayStakeAddresses = + GovernanceCreateMirCertificateStakeAddressesCmd + <$> pAnyShelleyToBabbageEra envCli + <*> pMIRPot + <*> some (pStakeAddress Nothing) + <*> some pRewardAmt + <*> pOutputFile - pLegacyMIRTransferToTreasury :: Parser LegacyGovernanceCmds - pLegacyMIRTransferToTreasury = - GovernanceCreateMirCertificateTransferToTreasuryCmd - <$> pAnyShelleyToBabbageEra envCli - <*> pTransferAmt - <*> pOutputFile + pLegacyMIRTransferToTreasury :: Parser LegacyGovernanceCmds + pLegacyMIRTransferToTreasury = + GovernanceCreateMirCertificateTransferToTreasuryCmd + <$> pAnyShelleyToBabbageEra envCli + <*> pTransferAmt + <*> pOutputFile - pLegacyMIRTransferToReserves :: Parser LegacyGovernanceCmds - pLegacyMIRTransferToReserves = - GovernanceCreateMirCertificateTransferToReservesCmd - <$> pAnyShelleyToBabbageEra envCli - <*> pTransferAmt - <*> pOutputFile + pLegacyMIRTransferToReserves :: Parser LegacyGovernanceCmds + pLegacyMIRTransferToReserves = + GovernanceCreateMirCertificateTransferToReservesCmd + <$> pAnyShelleyToBabbageEra envCli + <*> pTransferAmt + <*> pOutputFile - pGovernanceGenesisKeyDelegationCertificate :: Parser LegacyGovernanceCmds - pGovernanceGenesisKeyDelegationCertificate = - GovernanceGenesisKeyDelegationCertificate - <$> pAnyShelleyToBabbageEra envCli - <*> pGenesisVerificationKeyOrHashOrFile - <*> pGenesisDelegateVerificationKeyOrHashOrFile - <*> pVrfVerificationKeyOrHashOrFile - <*> pOutputFile + pGovernanceGenesisKeyDelegationCertificate :: Parser LegacyGovernanceCmds + pGovernanceGenesisKeyDelegationCertificate = + GovernanceGenesisKeyDelegationCertificate + <$> pAnyShelleyToBabbageEra envCli + <*> pGenesisVerificationKeyOrHashOrFile + <*> pGenesisDelegateVerificationKeyOrHashOrFile + <*> pVrfVerificationKeyOrHashOrFile + <*> pOutputFile - pUpdateProposal :: Parser LegacyGovernanceCmds - pUpdateProposal = - GovernanceUpdateProposal - <$> pOutputFile - <*> pEpochNoUpdateProp - <*> some pGenesisVerificationKeyFile - <*> pProtocolParametersUpdate - <*> optional pCostModels - - pGovernanceCreatePoll :: Parser LegacyGovernanceCmds - pGovernanceCreatePoll = - GovernanceCreatePoll - <$> pPollQuestion - <*> some pPollAnswer - <*> optional pPollNonce - <*> pOutputFile + pUpdateProposal :: Parser LegacyGovernanceCmds + pUpdateProposal = + GovernanceUpdateProposal + <$> pOutputFile + <*> pEpochNoUpdateProp + <*> some pGenesisVerificationKeyFile + <*> pProtocolParametersUpdate + <*> optional pCostModels + + pGovernanceCreatePoll :: Parser LegacyGovernanceCmds + pGovernanceCreatePoll = + GovernanceCreatePoll + <$> pPollQuestion + <*> some pPollAnswer + <*> optional pPollNonce + <*> pOutputFile - pGovernanceAnswerPoll :: Parser LegacyGovernanceCmds - pGovernanceAnswerPoll = - GovernanceAnswerPoll - <$> pPollFile - <*> optional pPollAnswerIndex - <*> optional pOutputFile + pGovernanceAnswerPoll :: Parser LegacyGovernanceCmds + pGovernanceAnswerPoll = + GovernanceAnswerPoll + <$> pPollFile + <*> optional pPollAnswerIndex + <*> optional pOutputFile - pGovernanceVerifyPoll :: Parser LegacyGovernanceCmds - pGovernanceVerifyPoll = - GovernanceVerifyPoll - <$> pPollFile - <*> pPollTxFile - <*> optional pOutputFile + pGovernanceVerifyPoll :: Parser LegacyGovernanceCmds + pGovernanceVerifyPoll = + GovernanceVerifyPoll + <$> pPollFile + <*> pPollTxFile + <*> optional pOutputFile pGenesisCmds :: EnvCli -> Parser LegacyGenesisCmds pGenesisCmds envCli = asum - [ subParser "key-gen-genesis" - $ Opt.info pGenesisKeyGen - $ Opt.progDesc "Create a Shelley genesis key pair" - , subParser "key-gen-delegate" - $ Opt.info pGenesisDelegateKeyGen - $ Opt.progDesc "Create a Shelley genesis delegate key pair" - , subParser "key-gen-utxo" - $ Opt.info pGenesisUTxOKeyGen - $ Opt.progDesc "Create a Shelley genesis UTxO key pair" - , subParser "key-hash" - $ Opt.info pGenesisKeyHash - $ Opt.progDesc "Print the identifier (hash) of a public key" - , subParser "get-ver-key" - $ Opt.info pGenesisVerKey - $ Opt.progDesc "Derive the verification key from a signing key" - , subParser "initial-addr" - $ Opt.info pGenesisAddr - $ Opt.progDesc "Get the address for an initial UTxO based on the verification key" - , subParser "initial-txin" - $ Opt.info pGenesisTxIn - $ Opt.progDesc "Get the TxIn for an initial UTxO based on the verification key" - , subParser "create-cardano" - $ Opt.info pGenesisCreateCardano - $ Opt.progDesc - $ mconcat - [ "Create a Byron and Shelley genesis file from a genesis " - , "template and genesis/delegation/spending keys." - ] - , subParser "create" - $ Opt.info pGenesisCreate - $ Opt.progDesc - $ mconcat - [ "Create a Shelley genesis file from a genesis " - , "template and genesis/delegation/spending keys." - ] - , subParser "create-staked" - $ Opt.info pGenesisCreateStaked - $ Opt.progDesc - $ mconcat - [ "Create a staked Shelley genesis file from a genesis " - , "template and genesis/delegation/spending keys." - ] - , subParser "hash" - $ Opt.info pGenesisHash - $ Opt.progDesc "Compute the hash of a genesis file" + [ subParser "key-gen-genesis" $ + Opt.info pGenesisKeyGen $ + Opt.progDesc "Create a Shelley genesis key pair" + , subParser "key-gen-delegate" $ + Opt.info pGenesisDelegateKeyGen $ + Opt.progDesc "Create a Shelley genesis delegate key pair" + , subParser "key-gen-utxo" $ + Opt.info pGenesisUTxOKeyGen $ + Opt.progDesc "Create a Shelley genesis UTxO key pair" + , subParser "key-hash" $ + Opt.info pGenesisKeyHash $ + Opt.progDesc "Print the identifier (hash) of a public key" + , subParser "get-ver-key" $ + Opt.info pGenesisVerKey $ + Opt.progDesc "Derive the verification key from a signing key" + , subParser "initial-addr" $ + Opt.info pGenesisAddr $ + Opt.progDesc "Get the address for an initial UTxO based on the verification key" + , subParser "initial-txin" $ + Opt.info pGenesisTxIn $ + Opt.progDesc "Get the TxIn for an initial UTxO based on the verification key" + , subParser "create-cardano" $ + Opt.info pGenesisCreateCardano $ + Opt.progDesc $ + mconcat + [ "Create a Byron and Shelley genesis file from a genesis " + , "template and genesis/delegation/spending keys." + ] + , subParser "create" $ + Opt.info pGenesisCreate $ + Opt.progDesc $ + mconcat + [ "Create a Shelley genesis file from a genesis " + , "template and genesis/delegation/spending keys." + ] + , subParser "create-staked" $ + Opt.info pGenesisCreateStaked $ + Opt.progDesc $ + mconcat + [ "Create a staked Shelley genesis file from a genesis " + , "template and genesis/delegation/spending keys." + ] + , subParser "hash" $ + Opt.info pGenesisHash $ + Opt.progDesc "Compute the hash of a genesis file" ] - where - pGenesisKeyGen :: Parser LegacyGenesisCmds - pGenesisKeyGen = - GenesisKeyGenGenesis - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut - - pGenesisDelegateKeyGen :: Parser LegacyGenesisCmds - pGenesisDelegateKeyGen = - GenesisKeyGenDelegate - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut - <*> pOperatorCertIssueCounterFile - - pGenesisUTxOKeyGen :: Parser LegacyGenesisCmds - pGenesisUTxOKeyGen = - GenesisKeyGenUTxO - <$> pVerificationKeyFileOut - <*> pSigningKeyFileOut - - pGenesisKeyHash :: Parser LegacyGenesisCmds - pGenesisKeyHash = - GenesisCmdKeyHash - <$> pVerificationKeyFileIn - - pGenesisVerKey :: Parser LegacyGenesisCmds - pGenesisVerKey = - GenesisVerKey - <$> pVerificationKeyFileOut - <*> pSigningKeyFileIn - - pGenesisAddr :: Parser LegacyGenesisCmds - pGenesisAddr = - GenesisAddr - <$> pVerificationKeyFileIn - <*> pNetworkId envCli - <*> pMaybeOutputFile + where + pGenesisKeyGen :: Parser LegacyGenesisCmds + pGenesisKeyGen = + GenesisKeyGenGenesis + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut + + pGenesisDelegateKeyGen :: Parser LegacyGenesisCmds + pGenesisDelegateKeyGen = + GenesisKeyGenDelegate + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut + <*> pOperatorCertIssueCounterFile + + pGenesisUTxOKeyGen :: Parser LegacyGenesisCmds + pGenesisUTxOKeyGen = + GenesisKeyGenUTxO + <$> pVerificationKeyFileOut + <*> pSigningKeyFileOut + + pGenesisKeyHash :: Parser LegacyGenesisCmds + pGenesisKeyHash = + GenesisCmdKeyHash + <$> pVerificationKeyFileIn + + pGenesisVerKey :: Parser LegacyGenesisCmds + pGenesisVerKey = + GenesisVerKey + <$> pVerificationKeyFileOut + <*> pSigningKeyFileIn + + pGenesisAddr :: Parser LegacyGenesisCmds + pGenesisAddr = + GenesisAddr + <$> pVerificationKeyFileIn + <*> pNetworkId envCli + <*> pMaybeOutputFile - pGenesisTxIn :: Parser LegacyGenesisCmds - pGenesisTxIn = - GenesisTxIn - <$> pVerificationKeyFileIn - <*> pNetworkId envCli - <*> pMaybeOutputFile + pGenesisTxIn :: Parser LegacyGenesisCmds + pGenesisTxIn = + GenesisTxIn + <$> pVerificationKeyFileIn + <*> pNetworkId envCli + <*> pMaybeOutputFile - pGenesisCreateCardano :: Parser LegacyGenesisCmds - pGenesisCreateCardano = - GenesisCreateCardano - <$> pGenesisDir - <*> pGenesisNumGenesisKeys - <*> pGenesisNumUTxOKeys - <*> pMaybeSystemStart - <*> pInitialSupplyNonDelegated - <*> (BlockCount <$> pSecurityParam) - <*> pSlotLength - <*> pSlotCoefficient - <*> pNetworkId envCli - <*> parseFilePath - "byron-template" - "JSON file with genesis defaults for each byron." - <*> parseFilePath - "shelley-template" - "JSON file with genesis defaults for each shelley." - <*> parseFilePath - "alonzo-template" - "JSON file with genesis defaults for alonzo." - <*> parseFilePath - "conway-template" - "JSON file with genesis defaults for conway." - <*> pNodeConfigTemplate - - pGenesisCreate :: Parser LegacyGenesisCmds - pGenesisCreate = - GenesisCreate - <$> pKeyOutputFormat - <*> pGenesisDir - <*> pGenesisNumGenesisKeys - <*> pGenesisNumUTxOKeys - <*> pMaybeSystemStart - <*> pInitialSupplyNonDelegated - <*> pNetworkId envCli + pGenesisCreateCardano :: Parser LegacyGenesisCmds + pGenesisCreateCardano = + GenesisCreateCardano + <$> pGenesisDir + <*> pGenesisNumGenesisKeys + <*> pGenesisNumUTxOKeys + <*> pMaybeSystemStart + <*> pInitialSupplyNonDelegated + <*> (BlockCount <$> pSecurityParam) + <*> pSlotLength + <*> pSlotCoefficient + <*> pNetworkId envCli + <*> parseFilePath + "byron-template" + "JSON file with genesis defaults for each byron." + <*> parseFilePath + "shelley-template" + "JSON file with genesis defaults for each shelley." + <*> parseFilePath + "alonzo-template" + "JSON file with genesis defaults for alonzo." + <*> parseFilePath + "conway-template" + "JSON file with genesis defaults for conway." + <*> pNodeConfigTemplate + + pGenesisCreate :: Parser LegacyGenesisCmds + pGenesisCreate = + GenesisCreate + <$> pKeyOutputFormat + <*> pGenesisDir + <*> pGenesisNumGenesisKeys + <*> pGenesisNumUTxOKeys + <*> pMaybeSystemStart + <*> pInitialSupplyNonDelegated + <*> pNetworkId envCli - pGenesisCreateStaked :: Parser LegacyGenesisCmds - pGenesisCreateStaked = - GenesisCreateStaked - <$> pKeyOutputFormat - <*> pGenesisDir - <*> pGenesisNumGenesisKeys - <*> pGenesisNumUTxOKeys - <*> pGenesisNumPools - <*> pGenesisNumStDelegs - <*> pMaybeSystemStart - <*> pInitialSupplyNonDelegated - <*> pInitialSupplyDelegated - <*> pNetworkId envCli - <*> pBulkPoolCredFiles - <*> pBulkPoolsPerFile - <*> pStuffedUtxoCount - <*> Opt.optional pRelayJsonFp - - pGenesisHash :: Parser LegacyGenesisCmds - pGenesisHash = - GenesisHashFile <$> pGenesisFile "The genesis file." - - pGenesisDir :: Parser GenesisDir - pGenesisDir = - fmap GenesisDir $ Opt.strOption $ mconcat - [ Opt.long "genesis-dir" - , Opt.metavar "DIR" - , Opt.help "The genesis directory containing the genesis template and required genesis/delegation/spending keys." - ] + pGenesisCreateStaked :: Parser LegacyGenesisCmds + pGenesisCreateStaked = + GenesisCreateStaked + <$> pKeyOutputFormat + <*> pGenesisDir + <*> pGenesisNumGenesisKeys + <*> pGenesisNumUTxOKeys + <*> pGenesisNumPools + <*> pGenesisNumStDelegs + <*> pMaybeSystemStart + <*> pInitialSupplyNonDelegated + <*> pInitialSupplyDelegated + <*> pNetworkId envCli + <*> pBulkPoolCredFiles + <*> pBulkPoolsPerFile + <*> pStuffedUtxoCount + <*> Opt.optional pRelayJsonFp + + pGenesisHash :: Parser LegacyGenesisCmds + pGenesisHash = + GenesisHashFile <$> pGenesisFile "The genesis file." + + pGenesisDir :: Parser GenesisDir + pGenesisDir = + fmap GenesisDir $ + Opt.strOption $ + mconcat + [ Opt.long "genesis-dir" + , Opt.metavar "DIR" + , Opt.help + "The genesis directory containing the genesis template and required genesis/delegation/spending keys." + ] - pMaybeSystemStart :: Parser (Maybe SystemStart) - pMaybeSystemStart = - Opt.optional $ fmap (SystemStart . convertTime) $ Opt.strOption $ mconcat - [ Opt.long "start-time" - , Opt.metavar "UTC-TIME" - , Opt.help "The genesis start time in YYYY-MM-DDThh:mm:ssZ format. If unspecified, will be the current time +30 seconds." - ] + pMaybeSystemStart :: Parser (Maybe SystemStart) + pMaybeSystemStart = + Opt.optional $ + fmap (SystemStart . convertTime) $ + Opt.strOption $ + mconcat + [ Opt.long "start-time" + , Opt.metavar "UTC-TIME" + , Opt.help + "The genesis start time in YYYY-MM-DDThh:mm:ssZ format. If unspecified, will be the current time +30 seconds." + ] - pGenesisNumGenesisKeys :: Parser Word - pGenesisNumGenesisKeys = - Opt.option Opt.auto $ mconcat + pGenesisNumGenesisKeys :: Parser Word + pGenesisNumGenesisKeys = + Opt.option Opt.auto $ + mconcat [ Opt.long "gen-genesis-keys" , Opt.metavar "INT" , Opt.help "The number of genesis keys to make [default is 3]." , Opt.value 3 ] - pNodeConfigTemplate :: Parser (Maybe FilePath) - pNodeConfigTemplate = optional $ parseFilePath "node-config-template" "the node config template" + pNodeConfigTemplate :: Parser (Maybe FilePath) + pNodeConfigTemplate = optional $ parseFilePath "node-config-template" "the node config template" - pGenesisNumUTxOKeys :: Parser Word - pGenesisNumUTxOKeys = - Opt.option Opt.auto $ mconcat + pGenesisNumUTxOKeys :: Parser Word + pGenesisNumUTxOKeys = + Opt.option Opt.auto $ + mconcat [ Opt.long "gen-utxo-keys" , Opt.metavar "INT" , Opt.help "The number of UTxO keys to make [default is 0]." , Opt.value 0 ] - pGenesisNumPools :: Parser Word - pGenesisNumPools = - Opt.option Opt.auto $ mconcat + pGenesisNumPools :: Parser Word + pGenesisNumPools = + Opt.option Opt.auto $ + mconcat [ Opt.long "gen-pools" , Opt.metavar "INT" , Opt.help "The number of stake pool credential sets to make [default is 0]." , Opt.value 0 ] - pGenesisNumStDelegs :: Parser Word - pGenesisNumStDelegs = - Opt.option Opt.auto $ mconcat + pGenesisNumStDelegs :: Parser Word + pGenesisNumStDelegs = + Opt.option Opt.auto $ + mconcat [ Opt.long "gen-stake-delegs" , Opt.metavar "INT" , Opt.help "The number of stake delegator credential sets to make [default is 0]." , Opt.value 0 ] - pStuffedUtxoCount :: Parser Word - pStuffedUtxoCount = - Opt.option Opt.auto $ mconcat + pStuffedUtxoCount :: Parser Word + pStuffedUtxoCount = + Opt.option Opt.auto $ + mconcat [ Opt.long "num-stuffed-utxo" , Opt.metavar "INT" , Opt.help "The number of fake UTxO entries to generate [default is 0]." , Opt.value 0 ] - pRelayJsonFp :: Parser FilePath - pRelayJsonFp = - Opt.strOption $ mconcat + pRelayJsonFp :: Parser FilePath + pRelayJsonFp = + Opt.strOption $ + mconcat [ Opt.long "relay-specification-file" , Opt.metavar "FILE" , Opt.help "JSON file specified the relays of each stake pool." , Opt.completer (Opt.bashCompleter "file") ] - pInitialSupplyNonDelegated :: Parser (Maybe Coin) - pInitialSupplyNonDelegated = - Opt.optional $ fmap Coin $ Opt.option Opt.auto $ mconcat - [ Opt.long "supply" - , Opt.metavar "LOVELACE" - , Opt.help "The initial coin supply in Lovelace which will be evenly distributed across initial, non-delegating stake holders." - ] + pInitialSupplyNonDelegated :: Parser (Maybe Coin) + pInitialSupplyNonDelegated = + Opt.optional $ + fmap Coin $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "supply" + , Opt.metavar "LOVELACE" + , Opt.help + "The initial coin supply in Lovelace which will be evenly distributed across initial, non-delegating stake holders." + ] - pInitialSupplyDelegated :: Parser Coin - pInitialSupplyDelegated = - fmap (Coin . fromMaybe 0) $ Opt.optional $ Opt.option Opt.auto $ mconcat - [ Opt.long "supply-delegated" - , Opt.metavar "LOVELACE" - , Opt.help "The initial coin supply in Lovelace which will be evenly distributed across initial, delegating stake holders." - , Opt.value 0 - ] + pInitialSupplyDelegated :: Parser Coin + pInitialSupplyDelegated = + fmap (Coin . fromMaybe 0) $ + Opt.optional $ + Opt.option Opt.auto $ + mconcat + [ Opt.long "supply-delegated" + , Opt.metavar "LOVELACE" + , Opt.help + "The initial coin supply in Lovelace which will be evenly distributed across initial, delegating stake holders." + , Opt.value 0 + ] - pSecurityParam :: Parser Word64 - pSecurityParam = - Opt.option Opt.auto $ mconcat + pSecurityParam :: Parser Word64 + pSecurityParam = + Opt.option Opt.auto $ + mconcat [ Opt.long "security-param" , Opt.metavar "INT" , Opt.help "Security parameter for genesis file [default is 108]." , Opt.value 108 ] - pSlotLength :: Parser Word - pSlotLength = - Opt.option Opt.auto $ mconcat + pSlotLength :: Parser Word + pSlotLength = + Opt.option Opt.auto $ + mconcat [ Opt.long "slot-length" , Opt.metavar "INT" , Opt.help "slot length (ms) parameter for genesis file [default is 1000]." , Opt.value 1000 ] - - pSlotCoefficient :: Parser Rational - pSlotCoefficient = - Opt.option readRationalUnitInterval $ mconcat + pSlotCoefficient :: Parser Rational + pSlotCoefficient = + Opt.option readRationalUnitInterval $ + mconcat [ Opt.long "slot-coefficient" , Opt.metavar "RATIONAL" , Opt.help "Slot Coefficient for genesis file [default is .05]." , Opt.value 0.05 ] - pBulkPoolCredFiles :: Parser Word - pBulkPoolCredFiles = - Opt.option Opt.auto $ mconcat + pBulkPoolCredFiles :: Parser Word + pBulkPoolCredFiles = + Opt.option Opt.auto $ + mconcat [ Opt.long "bulk-pool-cred-files" , Opt.metavar "INT" , Opt.help "Generate bulk pool credential files [default is 0]." , Opt.value 0 ] - pBulkPoolsPerFile :: Parser Word - pBulkPoolsPerFile = - Opt.option Opt.auto $ mconcat + pBulkPoolsPerFile :: Parser Word + pBulkPoolsPerFile = + Opt.option Opt.auto $ + mconcat [ Opt.long "bulk-pools-per-file" , Opt.metavar "INT" , Opt.help "Each bulk pool to contain this many pool credential sets [default is 0]." @@ -1212,65 +1295,81 @@ pStakePoolDeregistrationCertificateCmd envCli = pLegacyCardanoEra :: EnvCli -> Parser AnyCardanoEra pLegacyCardanoEra envCli = - asum $ mconcat - [ [ Opt.flag' (AnyCardanoEra ByronEra) $ mconcat - [ Opt.long "byron-era" - , Opt.help "Specify the Byron era" - ] - , Opt.flag' (AnyCardanoEra ShelleyEra) $ mconcat - [ Opt.long "shelley-era" - , Opt.help "Specify the Shelley era" - ] - , Opt.flag' (AnyCardanoEra AllegraEra) $ mconcat - [ Opt.long "allegra-era" - , Opt.help "Specify the Allegra era" - ] - , Opt.flag' (AnyCardanoEra MaryEra) $ mconcat - [ Opt.long "mary-era" - , Opt.help "Specify the Mary era" - ] - , Opt.flag' (AnyCardanoEra AlonzoEra) $ mconcat - [ Opt.long "alonzo-era" - , Opt.help "Specify the Alonzo era" - ] - , Opt.flag' (AnyCardanoEra BabbageEra) $ mconcat - [ Opt.long "babbage-era" - , Opt.help "Specify the Babbage era (default)" + asum $ + mconcat + [ + [ Opt.flag' (AnyCardanoEra ByronEra) $ + mconcat + [ Opt.long "byron-era" + , Opt.help "Specify the Byron era" + ] + , Opt.flag' (AnyCardanoEra ShelleyEra) $ + mconcat + [ Opt.long "shelley-era" + , Opt.help "Specify the Shelley era" + ] + , Opt.flag' (AnyCardanoEra AllegraEra) $ + mconcat + [ Opt.long "allegra-era" + , Opt.help "Specify the Allegra era" + ] + , Opt.flag' (AnyCardanoEra MaryEra) $ + mconcat + [ Opt.long "mary-era" + , Opt.help "Specify the Mary era" + ] + , Opt.flag' (AnyCardanoEra AlonzoEra) $ + mconcat + [ Opt.long "alonzo-era" + , Opt.help "Specify the Alonzo era" + ] + , Opt.flag' (AnyCardanoEra BabbageEra) $ + mconcat + [ Opt.long "babbage-era" + , Opt.help "Specify the Babbage era (default)" + ] ] + , maybeToList $ pure <$> envCliAnyCardanoEra envCli + , -- TODO is this default needed anymore? + pure $ pure defaultCardanoEra ] - , maybeToList $ pure <$> envCliAnyCardanoEra envCli - -- TODO is this default needed anymore? - , pure $ pure defaultCardanoEra - ] - where - defaultCardanoEra = defaultShelleyBasedEra & \(EraInEon era) -> - let cera = toCardanoEra era - in cardanoEraConstraints cera (AnyCardanoEra cera) + where + defaultCardanoEra = + defaultShelleyBasedEra & \(EraInEon era) -> + let cera = toCardanoEra era + in cardanoEraConstraints cera (AnyCardanoEra cera) pLegacyShelleyBasedEra :: EnvCli -> Parser (EraInEon ShelleyBasedEra) pLegacyShelleyBasedEra envCli = - asum $ mconcat - [ [ Opt.flag' (EraInEon ShelleyBasedEraShelley) $ mconcat - [ Opt.long "shelley-era" - , Opt.help "Specify the Shelley era" - ] - , Opt.flag' (EraInEon ShelleyBasedEraAllegra) $ mconcat - [ Opt.long "allegra-era" - , Opt.help "Specify the Allegra era" - ] - , Opt.flag' (EraInEon ShelleyBasedEraMary) $ mconcat - [ Opt.long "mary-era" - , Opt.help "Specify the Mary era" - ] - , Opt.flag' (EraInEon ShelleyBasedEraAlonzo) $ mconcat - [ Opt.long "alonzo-era" - , Opt.help "Specify the Alonzo era" - ] - , Opt.flag' (EraInEon ShelleyBasedEraBabbage) $ mconcat - [ Opt.long "babbage-era" - , Opt.help "Specify the Babbage era (default)" + asum $ + mconcat + [ + [ Opt.flag' (EraInEon ShelleyBasedEraShelley) $ + mconcat + [ Opt.long "shelley-era" + , Opt.help "Specify the Shelley era" + ] + , Opt.flag' (EraInEon ShelleyBasedEraAllegra) $ + mconcat + [ Opt.long "allegra-era" + , Opt.help "Specify the Allegra era" + ] + , Opt.flag' (EraInEon ShelleyBasedEraMary) $ + mconcat + [ Opt.long "mary-era" + , Opt.help "Specify the Mary era" + ] + , Opt.flag' (EraInEon ShelleyBasedEraAlonzo) $ + mconcat + [ Opt.long "alonzo-era" + , Opt.help "Specify the Alonzo era" + ] + , Opt.flag' (EraInEon ShelleyBasedEraBabbage) $ + mconcat + [ Opt.long "babbage-era" + , Opt.help "Specify the Babbage era (default)" + ] ] + , maybeToList $ pure <$> envCliAnyShelleyBasedEra envCli + , pure $ pure defaultShelleyBasedEra ] - , maybeToList $ pure <$> envCliAnyShelleyBasedEra envCli - , pure $ pure defaultShelleyBasedEra - ] diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Options/Key.hs b/cardano-cli/src/Cardano/CLI/Legacy/Options/Key.hs index f460c4bb48..6008e55c68 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Options/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Options/Key.hs @@ -5,7 +5,8 @@ module Cardano.CLI.Legacy.Options.Key ( pKeyCmds - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) @@ -21,68 +22,68 @@ import qualified Options.Applicative as Opt pKeyCmds :: Parser LegacyKeyCmds pKeyCmds = asum - [ subParser "verification-key" - $ Opt.info pKeyVerificationKeyCmd - $ Opt.progDesc - $ mconcat - [ "Get a verification key from a signing key. This " - , " supports all key types." - ] - , subParser "non-extended-key" - $ Opt.info pKeyNonExtendedKeyCmd - $ Opt.progDesc - $ mconcat - [ "Get a non-extended verification key from an " - , "extended verification key. This supports all " - , "extended key types." - ] - , subParser "convert-byron-key" - $ Opt.info pKeyConvertByronKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert a Byron payment, genesis or genesis " - , "delegate key (signing or verification) to a " - , "corresponding Shelley-format key." - ] - , subParser "convert-byron-genesis-vkey" - $ Opt.info pKeyConvertByronGenesisVKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert a Base64-encoded Byron genesis " - , "verification key to a Shelley genesis " - , "verification key" - ] - , subParser "convert-itn-key" - $ Opt.info pKeyConvertITNKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert an Incentivized Testnet (ITN) non-extended " - , "(Ed25519) signing or verification key to a " - , "corresponding Shelley stake key" - ] - , subParser "convert-itn-extended-key" - $ Opt.info pKeyConvertITNExtendedKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert an Incentivized Testnet (ITN) extended " - , "(Ed25519Extended) signing key to a corresponding " - , "Shelley stake signing key" - ] - , subParser "convert-itn-bip32-key" - $ Opt.info pKeyConvertITNBip32KeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert an Incentivized Testnet (ITN) BIP32 " - , "(Ed25519Bip32) signing key to a corresponding " - , "Shelley stake signing key" - ] - , subParser "convert-cardano-address-key" - $ Opt.info pKeyConvertCardanoAddressKeyCmd - $ Opt.progDesc - $ mconcat - [ "Convert a cardano-address extended signing key " - , "to a corresponding Shelley-format key." - ] + [ subParser "verification-key" $ + Opt.info pKeyVerificationKeyCmd $ + Opt.progDesc $ + mconcat + [ "Get a verification key from a signing key. This " + , " supports all key types." + ] + , subParser "non-extended-key" $ + Opt.info pKeyNonExtendedKeyCmd $ + Opt.progDesc $ + mconcat + [ "Get a non-extended verification key from an " + , "extended verification key. This supports all " + , "extended key types." + ] + , subParser "convert-byron-key" $ + Opt.info pKeyConvertByronKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert a Byron payment, genesis or genesis " + , "delegate key (signing or verification) to a " + , "corresponding Shelley-format key." + ] + , subParser "convert-byron-genesis-vkey" $ + Opt.info pKeyConvertByronGenesisVKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert a Base64-encoded Byron genesis " + , "verification key to a Shelley genesis " + , "verification key" + ] + , subParser "convert-itn-key" $ + Opt.info pKeyConvertITNKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert an Incentivized Testnet (ITN) non-extended " + , "(Ed25519) signing or verification key to a " + , "corresponding Shelley stake key" + ] + , subParser "convert-itn-extended-key" $ + Opt.info pKeyConvertITNExtendedKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert an Incentivized Testnet (ITN) extended " + , "(Ed25519Extended) signing key to a corresponding " + , "Shelley stake signing key" + ] + , subParser "convert-itn-bip32-key" $ + Opt.info pKeyConvertITNBip32KeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert an Incentivized Testnet (ITN) BIP32 " + , "(Ed25519Bip32) signing key to a corresponding " + , "Shelley stake signing key" + ] + , subParser "convert-cardano-address-key" $ + Opt.info pKeyConvertCardanoAddressKeyCmd $ + Opt.progDesc $ + mconcat + [ "Convert a cardano-address extended signing key " + , "to a corresponding Shelley-format key." + ] ] pKeyVerificationKeyCmd :: Parser LegacyKeyCmds @@ -107,65 +108,76 @@ pKeyConvertByronKeyCmd = pPassword :: Parser Text pPassword = - Opt.strOption $ mconcat - [ Opt.long "password" - , Opt.metavar "TEXT" - , Opt.help "Password for signing key (if applicable)." - ] + Opt.strOption $ + mconcat + [ Opt.long "password" + , Opt.metavar "TEXT" + , Opt.help "Password for signing key (if applicable)." + ] pByronKeyType :: Parser ByronKeyType pByronKeyType = asum - [ Opt.flag' (ByronPaymentKey NonLegacyByronKeyFormat) $ mconcat - [ Opt.long "byron-payment-key-type" - , Opt.help "Use a Byron-era payment key." - ] - , Opt.flag' (ByronPaymentKey LegacyByronKeyFormat) $ mconcat - [ Opt.long "legacy-byron-payment-key-type" - , Opt.help "Use a Byron-era payment key, in legacy SL format." - ] - , Opt.flag' (ByronGenesisKey NonLegacyByronKeyFormat) $ mconcat - [ Opt.long "byron-genesis-key-type" - , Opt.help "Use a Byron-era genesis key." - ] - , Opt.flag' (ByronGenesisKey LegacyByronKeyFormat) $ mconcat - [ Opt.long "legacy-byron-genesis-key-type" - , Opt.help "Use a Byron-era genesis key, in legacy SL format." - ] - , Opt.flag' (ByronDelegateKey NonLegacyByronKeyFormat) $ mconcat - [ Opt.long "byron-genesis-delegate-key-type" - , Opt.help "Use a Byron-era genesis delegate key." - ] - , Opt.flag' (ByronDelegateKey LegacyByronKeyFormat) $ mconcat - [ Opt.long "legacy-byron-genesis-delegate-key-type" - , Opt.help "Use a Byron-era genesis delegate key, in legacy SL format." - ] + [ Opt.flag' (ByronPaymentKey NonLegacyByronKeyFormat) $ + mconcat + [ Opt.long "byron-payment-key-type" + , Opt.help "Use a Byron-era payment key." + ] + , Opt.flag' (ByronPaymentKey LegacyByronKeyFormat) $ + mconcat + [ Opt.long "legacy-byron-payment-key-type" + , Opt.help "Use a Byron-era payment key, in legacy SL format." + ] + , Opt.flag' (ByronGenesisKey NonLegacyByronKeyFormat) $ + mconcat + [ Opt.long "byron-genesis-key-type" + , Opt.help "Use a Byron-era genesis key." + ] + , Opt.flag' (ByronGenesisKey LegacyByronKeyFormat) $ + mconcat + [ Opt.long "legacy-byron-genesis-key-type" + , Opt.help "Use a Byron-era genesis key, in legacy SL format." + ] + , Opt.flag' (ByronDelegateKey NonLegacyByronKeyFormat) $ + mconcat + [ Opt.long "byron-genesis-delegate-key-type" + , Opt.help "Use a Byron-era genesis delegate key." + ] + , Opt.flag' (ByronDelegateKey LegacyByronKeyFormat) $ + mconcat + [ Opt.long "legacy-byron-genesis-delegate-key-type" + , Opt.help "Use a Byron-era genesis delegate key, in legacy SL format." + ] ] pByronKeyFile :: Parser (SomeKeyFile In) pByronKeyFile = asum - [ ASigningKeyFile <$> pByronSigningKeyFile + [ ASigningKeyFile <$> pByronSigningKeyFile , AVerificationKeyFile <$> pByronVerificationKeyFile ] pByronSigningKeyFile :: Parser (SigningKeyFile In) pByronSigningKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "byron-signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the Byron-format signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "byron-signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the Byron-format signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pByronVerificationKeyFile :: Parser (VerificationKeyFile In) pByronVerificationKeyFile = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "byron-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the Byron-format verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "byron-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the Byron-format verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pKeyConvertByronGenesisVKeyCmd :: Parser LegacyKeyCmds pKeyConvertByronGenesisVKeyCmd = @@ -175,11 +187,13 @@ pKeyConvertByronGenesisVKeyCmd = pByronGenesisVKeyBase64 :: Parser VerificationKeyBase64 pByronGenesisVKeyBase64 = - fmap VerificationKeyBase64 $ Opt.strOption $ mconcat - [ Opt.long "byron-genesis-verification-key" - , Opt.metavar "BASE64" - , Opt.help "Base64 string for the Byron genesis verification key." - ] + fmap VerificationKeyBase64 $ + Opt.strOption $ + mconcat + [ Opt.long "byron-genesis-verification-key" + , Opt.metavar "BASE64" + , Opt.help "Base64 string for the Byron genesis verification key." + ] pKeyConvertITNKeyCmd :: Parser LegacyKeyCmds pKeyConvertITNKeyCmd = @@ -208,21 +222,25 @@ pITNKeyFIle = pITNSigningKeyFile :: Parser (SomeKeyFile direction) pITNSigningKeyFile = - fmap (ASigningKeyFile . File) $ Opt.strOption $ mconcat - [ Opt.long "itn-signing-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the ITN signing key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap (ASigningKeyFile . File) $ + Opt.strOption $ + mconcat + [ Opt.long "itn-signing-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the ITN signing key." + , Opt.completer (Opt.bashCompleter "file") + ] pITNVerificationKeyFile :: Parser (SomeKeyFile direction) pITNVerificationKeyFile = - fmap (AVerificationKeyFile . File) $ Opt.strOption $ mconcat - [ Opt.long "itn-verification-key-file" - , Opt.metavar "FILE" - , Opt.help "Filepath of the ITN verification key." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap (AVerificationKeyFile . File) $ + Opt.strOption $ + mconcat + [ Opt.long "itn-verification-key-file" + , Opt.metavar "FILE" + , Opt.help "Filepath of the ITN verification key." + , Opt.completer (Opt.bashCompleter "file") + ] pKeyConvertCardanoAddressKeyCmd :: Parser LegacyKeyCmds pKeyConvertCardanoAddressKeyCmd = @@ -234,32 +252,39 @@ pKeyConvertCardanoAddressKeyCmd = pCardanoAddressKeyType :: Parser CardanoAddressKeyType pCardanoAddressKeyType = asum - [ Opt.flag' CardanoAddressCommitteeColdKey $ mconcat - [ Opt.long "cc-cold-key" - , Opt.help "Use a committee cold key." - ] - , Opt.flag' CardanoAddressCommitteeHotKey $ mconcat - [ Opt.long "cc-hot-key" - , Opt.help "Use a committee hot key." - ] - , Opt.flag' CardanoAddressDRepKey $ mconcat - [ Opt.long "drep-key" - , Opt.help "Use a DRep key." - ] - , Opt.flag' CardanoAddressShelleyPaymentKey $ mconcat - [ Opt.long "shelley-payment-key" - , Opt.help "Use a Shelley-era extended payment key." - ] - , Opt.flag' CardanoAddressShelleyStakeKey $ mconcat - [ Opt.long "shelley-stake-key" - , Opt.help "Use a Shelley-era extended stake key." - ] - , Opt.flag' CardanoAddressIcarusPaymentKey $ mconcat - [ Opt.long "icarus-payment-key" - , Opt.help "Use a Byron-era extended payment key formatted in the Icarus style." - ] - , Opt.flag' CardanoAddressByronPaymentKey $ mconcat - [ Opt.long "byron-payment-key" - , Opt.help "Use a Byron-era extended payment key formatted in the deprecated Byron style." - ] + [ Opt.flag' CardanoAddressCommitteeColdKey $ + mconcat + [ Opt.long "cc-cold-key" + , Opt.help "Use a committee cold key." + ] + , Opt.flag' CardanoAddressCommitteeHotKey $ + mconcat + [ Opt.long "cc-hot-key" + , Opt.help "Use a committee hot key." + ] + , Opt.flag' CardanoAddressDRepKey $ + mconcat + [ Opt.long "drep-key" + , Opt.help "Use a DRep key." + ] + , Opt.flag' CardanoAddressShelleyPaymentKey $ + mconcat + [ Opt.long "shelley-payment-key" + , Opt.help "Use a Shelley-era extended payment key." + ] + , Opt.flag' CardanoAddressShelleyStakeKey $ + mconcat + [ Opt.long "shelley-stake-key" + , Opt.help "Use a Shelley-era extended stake key." + ] + , Opt.flag' CardanoAddressIcarusPaymentKey $ + mconcat + [ Opt.long "icarus-payment-key" + , Opt.help "Use a Byron-era extended payment key formatted in the Icarus style." + ] + , Opt.flag' CardanoAddressByronPaymentKey $ + mconcat + [ Opt.long "byron-payment-key" + , Opt.help "Use a Byron-era extended payment key formatted in the deprecated Byron style." + ] ] diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run.hs index 6626fc1dfd..3337c7bcd0 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run.hs @@ -2,7 +2,8 @@ module Cardano.CLI.Legacy.Run ( runLegacyCmds - ) where + ) +where import Cardano.CLI.Legacy.Options import Cardano.CLI.Legacy.Run.Address @@ -22,13 +23,13 @@ import Control.Monad.Trans.Except.Extra (firstExceptT) runLegacyCmds :: LegacyCmds -> ExceptT CmdError IO () runLegacyCmds = \case - LegacyAddressCmds cmd -> firstExceptT CmdAddressError $ runLegacyAddressCmds cmd - LegacyGenesisCmds cmd -> firstExceptT CmdGenesisError $ runLegacyGenesisCmds cmd - LegacyGovernanceCmds cmd -> firstExceptT CmdGovernanceCmdError $ runLegacyGovernanceCmds cmd - LegacyKeyCmds cmd -> firstExceptT CmdKeyError $ runLegacyKeyCmds cmd - LegacyNodeCmds cmd -> firstExceptT CmdNodeError $ runLegacyNodeCmds cmd - LegacyQueryCmds cmd -> firstExceptT CmdQueryError $ runLegacyQueryCmds cmd + LegacyAddressCmds cmd -> firstExceptT CmdAddressError $ runLegacyAddressCmds cmd + LegacyGenesisCmds cmd -> firstExceptT CmdGenesisError $ runLegacyGenesisCmds cmd + LegacyGovernanceCmds cmd -> firstExceptT CmdGovernanceCmdError $ runLegacyGovernanceCmds cmd + LegacyKeyCmds cmd -> firstExceptT CmdKeyError $ runLegacyKeyCmds cmd + LegacyNodeCmds cmd -> firstExceptT CmdNodeError $ runLegacyNodeCmds cmd + LegacyQueryCmds cmd -> firstExceptT CmdQueryError $ runLegacyQueryCmds cmd LegacyStakeAddressCmds cmd -> firstExceptT CmdStakeAddressError $ runLegacyStakeAddressCmds cmd - LegacyStakePoolCmds cmd -> firstExceptT CmdStakePoolError $ runLegacyStakePoolCmds cmd - LegacyTextViewCmds cmd -> firstExceptT CmdTextViewError $ runLegacyTextViewCmds cmd - LegacyTransactionCmds cmd -> firstExceptT CmdTransactionError $ runLegacyTransactionCmds cmd + LegacyStakePoolCmds cmd -> firstExceptT CmdStakePoolError $ runLegacyStakePoolCmds cmd + LegacyTextViewCmds cmd -> firstExceptT CmdTextViewError $ runLegacyTextViewCmds cmd + LegacyTransactionCmds cmd -> firstExceptT CmdTransactionError $ runLegacyTransactionCmds cmd diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Address.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Address.hs index bde7d168aa..d9bcd20868 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Address.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Address.hs @@ -7,7 +7,8 @@ module Cardano.CLI.Legacy.Run.Address ( runLegacyAddressCmds - ) where + ) +where import Cardano.Api @@ -34,7 +35,8 @@ runLegacyAddressCmds = \case AddressInfo txt mOFp -> runLegacyAddressInfoCmd txt mOFp & firstExceptT AddressCmdAddressInfoError -runLegacyAddressKeyGenCmd :: () +runLegacyAddressKeyGenCmd + :: () => KeyOutputFormat -> AddressKeyType -> VerificationKeyFile Out @@ -42,13 +44,15 @@ runLegacyAddressKeyGenCmd :: () -> ExceptT AddressCmdError IO () runLegacyAddressKeyGenCmd = runAddressKeyGenCmd -runLegacyAddressKeyHashCmd :: () +runLegacyAddressKeyHashCmd + :: () => VerificationKeyTextOrFile -> Maybe (File () Out) -> ExceptT AddressCmdError IO () runLegacyAddressKeyHashCmd = runAddressKeyHashCmd -runLegacyAddressBuildCmd :: () +runLegacyAddressBuildCmd + :: () => PaymentVerifier -> Maybe StakeIdentifier -> NetworkId @@ -56,7 +60,8 @@ runLegacyAddressBuildCmd :: () -> ExceptT AddressCmdError IO () runLegacyAddressBuildCmd = runAddressBuildCmd -runLegacyAddressInfoCmd :: () +runLegacyAddressInfoCmd + :: () => Text -> Maybe (File () Out) -> ExceptT AddressInfoError IO () diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Genesis.hs index 2068141d0f..6f0364bbf5 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Genesis.hs @@ -2,12 +2,12 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} - {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Cardano.CLI.Legacy.Run.Genesis ( runLegacyGenesisCmds - ) where + ) +where import Cardano.Api import Cardano.Api.Ledger (Coin (..)) @@ -47,13 +47,15 @@ runLegacyGenesisCmds = \case GenesisHashFile gf -> runLegacyGenesisHashFileCmd gf -runLegacyGenesisKeyGenGenesisCmd :: () +runLegacyGenesisKeyGenGenesisCmd + :: () => VerificationKeyFile Out -> SigningKeyFile Out -> ExceptT GenesisCmdError IO () runLegacyGenesisKeyGenGenesisCmd vk sk = CreateTestnetData.runGenesisKeyGenGenesisCmd $ GenesisKeyGenGenesisCmdArgs vk sk -runLegacyGenesisKeyGenDelegateCmd :: () +runLegacyGenesisKeyGenDelegateCmd + :: () => VerificationKeyFile Out -> SigningKeyFile Out -> OpCertCounterFile Out @@ -66,7 +68,8 @@ runLegacyGenesisKeyGenDelegateCmd vkf skf okf = , Cmd.opCertCounterPath = okf } -runLegacyGenesisKeyGenUTxOCmd :: () +runLegacyGenesisKeyGenUTxOCmd + :: () => VerificationKeyFile Out -> SigningKeyFile Out -> ExceptT GenesisCmdError IO () @@ -80,8 +83,8 @@ runLegacyGenesisKeyGenUTxOCmd vk sk = runLegacyGenesisKeyHashCmd :: VerificationKeyFile In -> ExceptT GenesisCmdError IO () runLegacyGenesisKeyHashCmd = runGenesisKeyHashCmd -runLegacyGenesisVerKeyCmd :: - VerificationKeyFile Out +runLegacyGenesisVerKeyCmd + :: VerificationKeyFile Out -> SigningKeyFile In -> ExceptT GenesisCmdError IO () runLegacyGenesisVerKeyCmd vk sk = @@ -91,7 +94,8 @@ runLegacyGenesisVerKeyCmd vk sk = , Cmd.signingKeyPath = sk } -runLegacyGenesisTxInCmd :: () +runLegacyGenesisTxInCmd + :: () => VerificationKeyFile In -> NetworkId -> Maybe (File () Out) @@ -104,7 +108,8 @@ runLegacyGenesisTxInCmd vkt nid mOf = , Cmd.mOutFile = mOf } -runLegacyGenesisAddrCmd :: () +runLegacyGenesisAddrCmd + :: () => VerificationKeyFile In -> NetworkId -> Maybe (File () Out) @@ -117,11 +122,14 @@ runLegacyGenesisAddrCmd vkf nid mOf = , Cmd.mOutFile = mOf } -runLegacyGenesisCreateCmd :: () +runLegacyGenesisCreateCmd + :: () => KeyOutputFormat -> GenesisDir - -> Word -- ^ num genesis & delegate keys to make - -> Word -- ^ num utxo keys to make + -> Word + -- ^ num genesis & delegate keys to make + -> Word + -- ^ num utxo keys to make -> Maybe SystemStart -> Maybe Coin -> NetworkId @@ -129,93 +137,136 @@ runLegacyGenesisCreateCmd :: () runLegacyGenesisCreateCmd fmt genDir nGenKeys nUTxOKeys mStart mSupply network = runGenesisCreateCmd Cmd.GenesisCreateCmdArgs - { Cmd.keyOutputFormat = fmt - , Cmd.genesisDir = genDir - , Cmd.numGenesisKeys = nGenKeys - , Cmd.numUTxOKeys = nUTxOKeys - , Cmd.mSystemStart = mStart - , Cmd.mSupply = mSupply - , Cmd.network = network - } + { Cmd.keyOutputFormat = fmt + , Cmd.genesisDir = genDir + , Cmd.numGenesisKeys = nGenKeys + , Cmd.numUTxOKeys = nUTxOKeys + , Cmd.mSystemStart = mStart + , Cmd.mSupply = mSupply + , Cmd.network = network + } -runLegacyGenesisCreateCardanoCmd :: () +runLegacyGenesisCreateCardanoCmd + :: () => GenesisDir - -> Word -- ^ num genesis & delegate keys to make - -> Word -- ^ num utxo keys to make + -> Word + -- ^ num genesis & delegate keys to make + -> Word + -- ^ num utxo keys to make -> Maybe SystemStart -> Maybe Coin -> BlockCount - -> Word -- ^ slot length in ms + -> Word + -- ^ slot length in ms -> Rational -> NetworkId - -> FilePath -- ^ Byron Genesis - -> FilePath -- ^ Shelley Genesis - -> FilePath -- ^ Alonzo Genesis - -> FilePath -- ^ Conway Genesis + -> FilePath + -- ^ Byron Genesis + -> FilePath + -- ^ Shelley Genesis + -> FilePath + -- ^ Alonzo Genesis + -> FilePath + -- ^ Conway Genesis -> Maybe FilePath -> ExceptT GenesisCmdError IO () runLegacyGenesisCreateCardanoCmd - genDir nGenKeys nUTxOKeys mStart mSupply security slotLength slotCoeff - network byronGenesis shelleyGenesis alonzoGenesis conwayGenesis mNodeCfg - = runGenesisCreateCardanoCmd - Cmd.GenesisCreateCardanoCmdArgs - { Cmd.genesisDir = genDir - , Cmd.numGenesisKeys = nGenKeys - , Cmd.numUTxOKeys = nUTxOKeys - , Cmd.mSystemStart = mStart - , Cmd.mSupply = mSupply - , Cmd.security = security - , Cmd.slotLength = slotLength - , Cmd.slotCoeff = slotCoeff - , Cmd.network = network - , Cmd.byronGenesisTemplate = byronGenesis - , Cmd.shelleyGenesisTemplate = shelleyGenesis - , Cmd.alonzoGenesisTemplate = alonzoGenesis - , Cmd.conwayGenesisTemplate = conwayGenesis - , Cmd.mNodeConfigTemplate = mNodeCfg - } + genDir + nGenKeys + nUTxOKeys + mStart + mSupply + security + slotLength + slotCoeff + network + byronGenesis + shelleyGenesis + alonzoGenesis + conwayGenesis + mNodeCfg = + runGenesisCreateCardanoCmd + Cmd.GenesisCreateCardanoCmdArgs + { Cmd.genesisDir = genDir + , Cmd.numGenesisKeys = nGenKeys + , Cmd.numUTxOKeys = nUTxOKeys + , Cmd.mSystemStart = mStart + , Cmd.mSupply = mSupply + , Cmd.security = security + , Cmd.slotLength = slotLength + , Cmd.slotCoeff = slotCoeff + , Cmd.network = network + , Cmd.byronGenesisTemplate = byronGenesis + , Cmd.shelleyGenesisTemplate = shelleyGenesis + , Cmd.alonzoGenesisTemplate = alonzoGenesis + , Cmd.conwayGenesisTemplate = conwayGenesis + , Cmd.mNodeConfigTemplate = mNodeCfg + } -runLegacyGenesisCreateStakedCmd :: () - => KeyOutputFormat -- ^ key output format +runLegacyGenesisCreateStakedCmd + :: () + => KeyOutputFormat + -- ^ key output format -> GenesisDir - -> Word -- ^ num genesis & delegate keys to make - -> Word -- ^ num utxo keys to make - -> Word -- ^ num pools to make - -> Word -- ^ num delegators to make + -> Word + -- ^ num genesis & delegate keys to make + -> Word + -- ^ num utxo keys to make + -> Word + -- ^ num pools to make + -> Word + -- ^ num delegators to make -> Maybe SystemStart - -> Maybe Coin -- ^ supply going to non-delegators - -> Coin -- ^ supply going to delegators + -> Maybe Coin + -- ^ supply going to non-delegators + -> Coin + -- ^ supply going to delegators -> NetworkId - -> Word -- ^ bulk credential files to write - -> Word -- ^ pool credentials per bulk file - -> Word -- ^ num stuffed UTxO entries - -> Maybe FilePath -- ^ Specified stake pool relays + -> Word + -- ^ bulk credential files to write + -> Word + -- ^ pool credentials per bulk file + -> Word + -- ^ num stuffed UTxO entries + -> Maybe FilePath + -- ^ Specified stake pool relays -> ExceptT GenesisCmdError IO () runLegacyGenesisCreateStakedCmd - keyOutputFormat genesisDir numGenesisKeys numUTxOKeys numPools - numStakeDelegators mSystemStart mNonDelegatedSupply delegatedSupply - network numBulkPoolCredFiles numBulkPoolsPerFile numStuffedUtxo - mStakePoolRelaySpecFile - = runGenesisCreateStakedCmd - Cmd.GenesisCreateStakedCmdArgs - { Cmd.keyOutputFormat = keyOutputFormat - , Cmd.genesisDir = genesisDir - , Cmd.numGenesisKeys = numGenesisKeys - , Cmd.numUTxOKeys = numUTxOKeys - , Cmd.numPools = numPools - , Cmd.numStakeDelegators = numStakeDelegators - , Cmd.mSystemStart = mSystemStart - , Cmd.mNonDelegatedSupply = mNonDelegatedSupply - , Cmd.delegatedSupply = delegatedSupply - , Cmd.network = network - , Cmd.numBulkPoolCredFiles = numBulkPoolCredFiles - , Cmd.numBulkPoolsPerFile = numBulkPoolsPerFile - , Cmd.numStuffedUtxo = numStuffedUtxo - , Cmd.mStakePoolRelaySpecFile = mStakePoolRelaySpecFile - } + keyOutputFormat + genesisDir + numGenesisKeys + numUTxOKeys + numPools + numStakeDelegators + mSystemStart + mNonDelegatedSupply + delegatedSupply + network + numBulkPoolCredFiles + numBulkPoolsPerFile + numStuffedUtxo + mStakePoolRelaySpecFile = + runGenesisCreateStakedCmd + Cmd.GenesisCreateStakedCmdArgs + { Cmd.keyOutputFormat = keyOutputFormat + , Cmd.genesisDir = genesisDir + , Cmd.numGenesisKeys = numGenesisKeys + , Cmd.numUTxOKeys = numUTxOKeys + , Cmd.numPools = numPools + , Cmd.numStakeDelegators = numStakeDelegators + , Cmd.mSystemStart = mSystemStart + , Cmd.mNonDelegatedSupply = mNonDelegatedSupply + , Cmd.delegatedSupply = delegatedSupply + , Cmd.network = network + , Cmd.numBulkPoolCredFiles = numBulkPoolCredFiles + , Cmd.numBulkPoolsPerFile = numBulkPoolsPerFile + , Cmd.numStuffedUtxo = numStuffedUtxo + , Cmd.mStakePoolRelaySpecFile = mStakePoolRelaySpecFile + } -- | Hash a genesis file -runLegacyGenesisHashFileCmd :: () +runLegacyGenesisHashFileCmd + :: () => GenesisFile -> ExceptT GenesisCmdError IO () runLegacyGenesisHashFileCmd = runGenesisHashFileCmd diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Governance.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Governance.hs index f8c092dd6d..7856541064 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Governance.hs @@ -7,7 +7,8 @@ module Cardano.CLI.Legacy.Run.Governance ( runLegacyGovernanceCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -48,7 +49,8 @@ runLegacyGovernanceCmds = \case GovernanceVerifyPoll poll metadata mOutFile -> runLegacyGovernanceVerifyPoll poll metadata mOutFile -runLegacyGovernanceCreatePoll :: () +runLegacyGovernanceCreatePoll + :: () => Text -> [Text] -> Maybe Word @@ -57,14 +59,15 @@ runLegacyGovernanceCreatePoll :: () runLegacyGovernanceCreatePoll prompt choices nonce outFile = runGovernanceCreatePollCmd Cmd.GovernanceCreatePollCmdArgs - { eon = BabbageEraOnwardsBabbage + { eon = BabbageEraOnwardsBabbage , prompt , choices , nonce , outFile } -runLegacyGovernanceAnswerPoll :: () +runLegacyGovernanceAnswerPoll + :: () => File GovernancePoll In -> Maybe Word -> Maybe (File () Out) @@ -72,13 +75,14 @@ runLegacyGovernanceAnswerPoll :: () runLegacyGovernanceAnswerPoll pollFile answerIndex mOutFile = runGovernanceAnswerPollCmd Cmd.GovernanceAnswerPollCmdArgs - { eon = BabbageEraOnwardsBabbage + { eon = BabbageEraOnwardsBabbage , pollFile , answerIndex , mOutFile } -runLegacyGovernanceVerifyPoll :: () +runLegacyGovernanceVerifyPoll + :: () => File GovernancePoll In -> File (Tx ()) In -> Maybe (File () Out) @@ -86,7 +90,7 @@ runLegacyGovernanceVerifyPoll :: () runLegacyGovernanceVerifyPoll pollFile txFile mOutFile = runGovernanceVerifyPollCmd Cmd.GovernanceVerifyPollCmdArgs - { eon = BabbageEraOnwardsBabbage + { eon = BabbageEraOnwardsBabbage , pollFile , txFile , mOutFile @@ -95,8 +99,10 @@ runLegacyGovernanceVerifyPoll pollFile txFile mOutFile = runLegacyGovernanceMIRCertificatePayStakeAddrs :: EraInEon ShelleyToBabbageEra -> L.MIRPot - -> [StakeAddress] -- ^ Stake addresses - -> [L.Coin] -- ^ Corresponding reward amounts (same length) + -> [StakeAddress] + -- ^ Stake addresses + -> [L.Coin] + -- ^ Corresponding reward amounts (same length) -> File () Out -> ExceptT GovernanceCmdError IO () runLegacyGovernanceMIRCertificatePayStakeAddrs (EraInEon w) = @@ -124,7 +130,8 @@ runLegacyGovernanceUpdateProposal -> [VerificationKeyFile In] -- ^ Genesis verification keys -> ProtocolParametersUpdate - -> Maybe FilePath -- ^ Cost models file path + -> Maybe FilePath + -- ^ Cost models file path -> ExceptT GovernanceCmdError IO () runLegacyGovernanceUpdateProposal upFile eNo genVerKeyFiles upPprams mCostModelFp = do finalUpPprams <- case mCostModelFp of @@ -132,23 +139,27 @@ runLegacyGovernanceUpdateProposal upFile eNo genVerKeyFiles upPprams mCostModelF Just fp -> do costModelsBs <- handleIOExceptT (GovernanceCmdCostModelReadError . FileIOError fp) $ LB.readFile fp - cModels <- pure (eitherDecode costModelsBs) - & onLeft (left . GovernanceCmdCostModelsJsonDecodeErr fp . Text.pack) + cModels <- + pure (eitherDecode costModelsBs) + & onLeft (left . GovernanceCmdCostModelsJsonDecodeErr fp . Text.pack) let costModels = fromAlonzoCostModels cModels when (null costModels) $ left (GovernanceCmdEmptyCostModel fp) - return $ upPprams {protocolUpdateCostModels = costModels} + return $ upPprams{protocolUpdateCostModels = costModels} when (finalUpPprams == mempty) $ left GovernanceCmdEmptyUpdateProposalError - genVKeys <- sequence - [ firstExceptT GovernanceCmdTextEnvReadError . newExceptT $ readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile - | vkeyFile <- genVerKeyFiles - ] + genVKeys <- + sequence + [ firstExceptT GovernanceCmdTextEnvReadError . newExceptT $ + readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile + | vkeyFile <- genVerKeyFiles + ] let genKeyHashes = fmap verificationKeyHash genVKeys upProp = makeShelleyUpdateProposal finalUpPprams genKeyHashes eNo - firstExceptT GovernanceCmdTextEnvWriteError . newExceptT - $ writeLazyByteStringFile upFile $ textEnvelopeToJSON Nothing upProp + firstExceptT GovernanceCmdTextEnvWriteError . newExceptT $ + writeLazyByteStringFile upFile $ + textEnvelopeToJSON Nothing upProp diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Key.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Key.hs index 42becd300b..4a454f7142 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Key.hs @@ -3,7 +3,8 @@ module Cardano.CLI.Legacy.Run.Key ( runLegacyKeyCmds - ) where + ) +where import Cardano.Api @@ -15,7 +16,8 @@ import Cardano.CLI.Types.Errors.KeyCmdError import Data.Text (Text) -runLegacyKeyCmds :: () +runLegacyKeyCmds + :: () => LegacyKeyCmds -> ExceptT KeyCmdError IO () runLegacyKeyCmds = \case @@ -36,7 +38,8 @@ runLegacyKeyCmds = \case KeyConvertCardanoAddressKeyCmd keyType skfOld skfNew -> runLegacyConvertCardanoAddressKeyCmd keyType skfOld skfNew -runLegacyVerificationKeyCmd :: () +runLegacyVerificationKeyCmd + :: () => SigningKeyFile In -> VerificationKeyFile Out -> ExceptT KeyCmdError IO () @@ -44,7 +47,8 @@ runLegacyVerificationKeyCmd skf vkf = runVerificationKeyCmd $ Cmd.KeyVerificationKeyCmdArgs skf vkf -runLegacyNonExtendedKeyCmd :: () +runLegacyNonExtendedKeyCmd + :: () => VerificationKeyFile In -> VerificationKeyFile Out -> ExceptT KeyCmdError IO () @@ -52,19 +56,26 @@ runLegacyNonExtendedKeyCmd evkf vkf = runNonExtendedKeyCmd $ Cmd.KeyNonExtendedKeyCmdArgs evkf vkf -runLegacyConvertByronKeyCmd :: () - => Maybe Text -- ^ Password (if applicable) +runLegacyConvertByronKeyCmd + :: () + => Maybe Text + -- ^ Password (if applicable) -> ByronKeyType - -> SomeKeyFile In -- ^ Input file: old format - -> File () Out -- ^ Output file: new format + -> SomeKeyFile In + -- ^ Input file: old format + -> File () Out + -- ^ Output file: new format -> ExceptT KeyCmdError IO () runLegacyConvertByronKeyCmd mPassword keytype skfOld skfNew = runConvertByronKeyCmd $ Cmd.KeyConvertByronKeyCmdArgs mPassword keytype skfOld skfNew -runLegacyConvertByronGenesisVKeyCmd :: () - => VerificationKeyBase64 -- ^ Input key raw old format - -> File () Out -- ^ Output file: new format +runLegacyConvertByronGenesisVKeyCmd + :: () + => VerificationKeyBase64 + -- ^ Input key raw old format + -> File () Out + -- ^ Output file: new format -> ExceptT KeyCmdError IO () runLegacyConvertByronGenesisVKeyCmd oldVk newVkf = runConvertByronGenesisVKeyCmd $ @@ -74,7 +85,8 @@ runLegacyConvertByronGenesisVKeyCmd oldVk newVkf = -- ITN verification/signing key conversion to Haskell verficiation/signing keys -------------------------------------------------------------------------------- -runLegacyConvertITNStakeKeyCmd :: () +runLegacyConvertITNStakeKeyCmd + :: () => SomeKeyFile In -> File () Out -> ExceptT KeyCmdError IO () @@ -82,7 +94,8 @@ runLegacyConvertITNStakeKeyCmd itnKeyFile outFile = runConvertITNKeyCmd $ Cmd.KeyConvertITNKeyCmdArgs itnKeyFile outFile -runLegacyConvertITNExtendedKeyCmd :: () +runLegacyConvertITNExtendedKeyCmd + :: () => SomeKeyFile In -> File () Out -> ExceptT KeyCmdError IO () @@ -90,7 +103,8 @@ runLegacyConvertITNExtendedKeyCmd itnPrivKeyFile outFile = runConvertITNExtendedKeyCmd $ Cmd.KeyConvertITNExtendedKeyCmdArgs itnPrivKeyFile outFile -runLegacyConvertITNBip32KeyCmd :: () +runLegacyConvertITNBip32KeyCmd + :: () => SomeKeyFile In -> File () Out -> ExceptT KeyCmdError IO () @@ -98,7 +112,8 @@ runLegacyConvertITNBip32KeyCmd itnPrivKeyFile outFile = runConvertITNBip32KeyCmd $ Cmd.KeyConvertITNBip32KeyCmdArgs itnPrivKeyFile outFile -runLegacyConvertCardanoAddressKeyCmd :: () +runLegacyConvertCardanoAddressKeyCmd + :: () => CardanoAddressKeyType -> SigningKeyFile In -> File () Out diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Node.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Node.hs index f2ea190791..ac16054de0 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Node.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Node.hs @@ -3,7 +3,8 @@ module Cardano.CLI.Legacy.Run.Node ( runLegacyNodeCmds - ) where + ) +where import qualified Cardano.CLI.EraBased.Commands.Node as Cmd import Cardano.CLI.EraBased.Run.Node @@ -14,43 +15,50 @@ import Control.Monad.Trans.Except (ExceptT) {- HLINT ignore "Reduce duplication" -} -runLegacyNodeCmds :: () +runLegacyNodeCmds + :: () => LegacyNodeCmds -> ExceptT NodeCmdError IO () runLegacyNodeCmds = \case - LegacyNodeKeyGenColdCmd args -> runLegacyNodeKeyGenColdCmd args - LegacyNodeKeyGenKESCmd args -> runLegacyNodeKeyGenKesCmd args - LegacyNodeKeyGenVRFCmd args -> runLegacyNodeKeyGenVrfCmd args - LegacyNodeKeyHashVRFCmd args -> runLegacyNodeKeyHashVrfCmd args - LegacyNodeNewCounterCmd args -> runLegacyNodeNewCounterCmd args + LegacyNodeKeyGenColdCmd args -> runLegacyNodeKeyGenColdCmd args + LegacyNodeKeyGenKESCmd args -> runLegacyNodeKeyGenKesCmd args + LegacyNodeKeyGenVRFCmd args -> runLegacyNodeKeyGenVrfCmd args + LegacyNodeKeyHashVRFCmd args -> runLegacyNodeKeyHashVrfCmd args + LegacyNodeNewCounterCmd args -> runLegacyNodeNewCounterCmd args LegacyNodeIssueOpCertCmd args -> runLegacyNodeIssueOpCertCmd args -runLegacyNodeKeyGenColdCmd :: () +runLegacyNodeKeyGenColdCmd + :: () => Cmd.NodeKeyGenColdCmdArgs -> ExceptT NodeCmdError IO () runLegacyNodeKeyGenColdCmd = runNodeKeyGenColdCmd -runLegacyNodeKeyGenKesCmd :: () +runLegacyNodeKeyGenKesCmd + :: () => Cmd.NodeKeyGenKESCmdArgs -> ExceptT NodeCmdError IO () runLegacyNodeKeyGenKesCmd = runNodeKeyGenKesCmd -runLegacyNodeKeyGenVrfCmd :: () +runLegacyNodeKeyGenVrfCmd + :: () => Cmd.NodeKeyGenVRFCmdArgs -> ExceptT NodeCmdError IO () runLegacyNodeKeyGenVrfCmd = runNodeKeyGenVrfCmd -runLegacyNodeKeyHashVrfCmd :: () +runLegacyNodeKeyHashVrfCmd + :: () => Cmd.NodeKeyHashVRFCmdArgs -> ExceptT NodeCmdError IO () runLegacyNodeKeyHashVrfCmd = runNodeKeyHashVrfCmd -runLegacyNodeNewCounterCmd :: () +runLegacyNodeNewCounterCmd + :: () => Cmd.NodeNewCounterCmdArgs -> ExceptT NodeCmdError IO () runLegacyNodeNewCounterCmd = runNodeNewCounterCmd -runLegacyNodeIssueOpCertCmd :: () +runLegacyNodeIssueOpCertCmd + :: () => Cmd.NodeIssueOpCertCmdArgs -> ExceptT NodeCmdError IO () runLegacyNodeIssueOpCertCmd = runNodeIssueOpCertCmd diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs index 7504915dcd..cf554583c7 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Query.hs @@ -1,13 +1,13 @@ -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} - {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Cardano.CLI.Legacy.Run.Query ( runLegacyQueryCmds - ) where + ) +where import qualified Cardano.CLI.EraBased.Commands.Query as EraBased import qualified Cardano.CLI.EraBased.Run.Query as EraBased @@ -19,113 +19,132 @@ import Control.Monad.Trans.Except runLegacyQueryCmds :: Cmd.LegacyQueryCmds -> ExceptT QueryCmdError IO () runLegacyQueryCmds = \case - Cmd.QueryLeadershipScheduleCmd args -> runLegacyQueryLeadershipScheduleCmd args - Cmd.QueryProtocolParametersCmd args -> runLegacyQueryProtocolParametersCmd args - Cmd.QueryTipCmd args -> runLegacyQueryTipCmd args - Cmd.QueryStakePoolsCmd args -> runLegacyQueryStakePoolsCmd args - Cmd.QueryStakeDistributionCmd args -> runLegacyQueryStakeDistributionCmd args - Cmd.QueryStakeAddressInfoCmd args -> runLegacyQueryStakeAddressInfoCmd args - Cmd.QueryLedgerStateCmd args -> runLegacyQueryLedgerStateCmd args - Cmd.QueryStakeSnapshotCmd args -> runLegacyQueryStakeSnapshotCmd args - Cmd.QueryProtocolStateCmd args -> runLegacyQueryProtocolStateCmd args - Cmd.QueryUTxOCmd args -> runLegacyQueryUTxOCmd args - Cmd.QueryKesPeriodInfoCmd args -> runLegacyQueryKesPeriodInfoCmd args - Cmd.QueryPoolStateCmd args -> runLegacyQueryPoolStateCmd args - Cmd.QueryTxMempoolCmd args -> runLegacyQueryTxMempoolCmd args - Cmd.QuerySlotNumberCmd args -> runLegacyQuerySlotNumberCmd args - -runLegacyQueryProtocolParametersCmd :: () + Cmd.QueryLeadershipScheduleCmd args -> runLegacyQueryLeadershipScheduleCmd args + Cmd.QueryProtocolParametersCmd args -> runLegacyQueryProtocolParametersCmd args + Cmd.QueryTipCmd args -> runLegacyQueryTipCmd args + Cmd.QueryStakePoolsCmd args -> runLegacyQueryStakePoolsCmd args + Cmd.QueryStakeDistributionCmd args -> runLegacyQueryStakeDistributionCmd args + Cmd.QueryStakeAddressInfoCmd args -> runLegacyQueryStakeAddressInfoCmd args + Cmd.QueryLedgerStateCmd args -> runLegacyQueryLedgerStateCmd args + Cmd.QueryStakeSnapshotCmd args -> runLegacyQueryStakeSnapshotCmd args + Cmd.QueryProtocolStateCmd args -> runLegacyQueryProtocolStateCmd args + Cmd.QueryUTxOCmd args -> runLegacyQueryUTxOCmd args + Cmd.QueryKesPeriodInfoCmd args -> runLegacyQueryKesPeriodInfoCmd args + Cmd.QueryPoolStateCmd args -> runLegacyQueryPoolStateCmd args + Cmd.QueryTxMempoolCmd args -> runLegacyQueryTxMempoolCmd args + Cmd.QuerySlotNumberCmd args -> runLegacyQuerySlotNumberCmd args + +runLegacyQueryProtocolParametersCmd + :: () => Cmd.LegacyQueryProtocolParametersCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryProtocolParametersCmd Cmd.LegacyQueryProtocolParametersCmdArgs {..} = - EraBased.runQueryProtocolParametersCmd EraBased.QueryProtocolParametersCmdArgs {..} +runLegacyQueryProtocolParametersCmd Cmd.LegacyQueryProtocolParametersCmdArgs{..} = + EraBased.runQueryProtocolParametersCmd EraBased.QueryProtocolParametersCmdArgs{..} -runLegacyQueryTipCmd :: () +runLegacyQueryTipCmd + :: () => Cmd.LegacyQueryTipCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryTipCmd Cmd.LegacyQueryTipCmdArgs {..} = - EraBased.runQueryTipCmd EraBased.QueryTipCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryTipCmd Cmd.LegacyQueryTipCmdArgs{..} = + EraBased.runQueryTipCmd EraBased.QueryTipCmdArgs{target = Consensus.VolatileTip, ..} -- | Query the UTxO, filtered by a given set of addresses, from a Shelley node -- via the local state query protocol. -runLegacyQueryUTxOCmd :: () +runLegacyQueryUTxOCmd + :: () => Cmd.LegacyQueryUTxOCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryUTxOCmd Cmd.LegacyQueryUTxOCmdArgs {..} = - EraBased.runQueryUTxOCmd EraBased.QueryUTxOCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryUTxOCmd Cmd.LegacyQueryUTxOCmdArgs{..} = + EraBased.runQueryUTxOCmd EraBased.QueryUTxOCmdArgs{target = Consensus.VolatileTip, ..} -runLegacyQueryKesPeriodInfoCmd :: () +runLegacyQueryKesPeriodInfoCmd + :: () => Cmd.LegacyQueryKesPeriodInfoCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryKesPeriodInfoCmd Cmd.LegacyQueryKesPeriodInfoCmdArgs {..} = - EraBased.runQueryKesPeriodInfoCmd EraBased.QueryKesPeriodInfoCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryKesPeriodInfoCmd Cmd.LegacyQueryKesPeriodInfoCmdArgs{..} = + EraBased.runQueryKesPeriodInfoCmd + EraBased.QueryKesPeriodInfoCmdArgs{target = Consensus.VolatileTip, ..} -- | Query the current and future parameters for a stake pool, including the retirement date. -- Any of these may be empty (in which case a null will be displayed). --- -runLegacyQueryPoolStateCmd :: () +runLegacyQueryPoolStateCmd + :: () => Cmd.LegacyQueryPoolStateCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryPoolStateCmd Cmd.LegacyQueryPoolStateCmdArgs {..} = - EraBased.runQueryPoolStateCmd EraBased.QueryPoolStateCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryPoolStateCmd Cmd.LegacyQueryPoolStateCmdArgs{..} = + EraBased.runQueryPoolStateCmd EraBased.QueryPoolStateCmdArgs{target = Consensus.VolatileTip, ..} -- | Query the local mempool state -runLegacyQueryTxMempoolCmd :: () +runLegacyQueryTxMempoolCmd + :: () => Cmd.LegacyQueryTxMempoolCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryTxMempoolCmd Cmd.LegacyQueryTxMempoolCmdArgs {..} = - EraBased.runQueryTxMempoolCmd EraBased.QueryTxMempoolCmdArgs {..} +runLegacyQueryTxMempoolCmd Cmd.LegacyQueryTxMempoolCmdArgs{..} = + EraBased.runQueryTxMempoolCmd EraBased.QueryTxMempoolCmdArgs{..} -runLegacyQuerySlotNumberCmd :: () +runLegacyQuerySlotNumberCmd + :: () => Cmd.LegacyQuerySlotNumberCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQuerySlotNumberCmd Cmd.LegacyQuerySlotNumberCmdArgs {..} = - EraBased.runQuerySlotNumberCmd EraBased.QuerySlotNumberCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQuerySlotNumberCmd Cmd.LegacyQuerySlotNumberCmdArgs{..} = + EraBased.runQuerySlotNumberCmd EraBased.QuerySlotNumberCmdArgs{target = Consensus.VolatileTip, ..} -- | Obtain stake snapshot information for a pool, plus information about the total active stake. -- This information can be used for leader slot calculation, for example, and has been requested by SPOs. -- Obtaining the information directly is significantly more time and memory efficient than using a full ledger state dump. -runLegacyQueryStakeSnapshotCmd :: () +runLegacyQueryStakeSnapshotCmd + :: () => Cmd.LegacyQueryStakeSnapshotCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakeSnapshotCmd Cmd.LegacyQueryStakeSnapshotCmdArgs {..} = - EraBased.runQueryStakeSnapshotCmd EraBased.QueryStakeSnapshotCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryStakeSnapshotCmd Cmd.LegacyQueryStakeSnapshotCmdArgs{..} = + EraBased.runQueryStakeSnapshotCmd + EraBased.QueryStakeSnapshotCmdArgs{target = Consensus.VolatileTip, ..} -runLegacyQueryLedgerStateCmd :: () +runLegacyQueryLedgerStateCmd + :: () => Cmd.LegacyQueryLedgerStateCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryLedgerStateCmd Cmd.LegacyQueryLedgerStateCmdArgs {..} = - EraBased.runQueryLedgerStateCmd EraBased.QueryLedgerStateCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryLedgerStateCmd Cmd.LegacyQueryLedgerStateCmdArgs{..} = + EraBased.runQueryLedgerStateCmd + EraBased.QueryLedgerStateCmdArgs{target = Consensus.VolatileTip, ..} -runLegacyQueryProtocolStateCmd :: () +runLegacyQueryProtocolStateCmd + :: () => Cmd.LegacyQueryProtocolStateCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryProtocolStateCmd Cmd.LegacyQueryProtocolStateCmdArgs {..} = - EraBased.runQueryProtocolStateCmd EraBased.QueryProtocolStateCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryProtocolStateCmd Cmd.LegacyQueryProtocolStateCmdArgs{..} = + EraBased.runQueryProtocolStateCmd + EraBased.QueryProtocolStateCmdArgs{target = Consensus.VolatileTip, ..} -- | Query the current delegations and reward accounts, filtered by a given -- set of addresses, from a Shelley node via the local state query protocol. - -runLegacyQueryStakeAddressInfoCmd :: () +runLegacyQueryStakeAddressInfoCmd + :: () => Cmd.LegacyQueryStakeAddressInfoCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakeAddressInfoCmd Cmd.LegacyQueryStakeAddressInfoCmdArgs {..} = - EraBased.runQueryStakeAddressInfoCmd EraBased.QueryStakeAddressInfoCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryStakeAddressInfoCmd Cmd.LegacyQueryStakeAddressInfoCmdArgs{..} = + EraBased.runQueryStakeAddressInfoCmd + EraBased.QueryStakeAddressInfoCmdArgs{target = Consensus.VolatileTip, ..} -runLegacyQueryStakePoolsCmd :: () +runLegacyQueryStakePoolsCmd + :: () => Cmd.LegacyQueryStakePoolsCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakePoolsCmd Cmd.LegacyQueryStakePoolsCmdArgs {..} = - EraBased.runQueryStakePoolsCmd EraBased.QueryStakePoolsCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryStakePoolsCmd Cmd.LegacyQueryStakePoolsCmdArgs{..} = + EraBased.runQueryStakePoolsCmd EraBased.QueryStakePoolsCmdArgs{target = Consensus.VolatileTip, ..} -runLegacyQueryStakeDistributionCmd :: () +runLegacyQueryStakeDistributionCmd + :: () => Cmd.LegacyQueryStakeDistributionCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryStakeDistributionCmd Cmd.LegacyQueryStakeDistributionCmdArgs {..} = - EraBased.runQueryStakeDistributionCmd EraBased.QueryStakeDistributionCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryStakeDistributionCmd Cmd.LegacyQueryStakeDistributionCmdArgs{..} = + EraBased.runQueryStakeDistributionCmd + EraBased.QueryStakeDistributionCmdArgs{target = Consensus.VolatileTip, ..} -runLegacyQueryLeadershipScheduleCmd :: () +runLegacyQueryLeadershipScheduleCmd + :: () => Cmd.LegacyQueryLeadershipScheduleCmdArgs -> ExceptT QueryCmdError IO () -runLegacyQueryLeadershipScheduleCmd Cmd.LegacyQueryLeadershipScheduleCmdArgs {..} = - EraBased.runQueryLeadershipScheduleCmd EraBased.QueryLeadershipScheduleCmdArgs {target = Consensus.VolatileTip, ..} +runLegacyQueryLeadershipScheduleCmd Cmd.LegacyQueryLeadershipScheduleCmdArgs{..} = + EraBased.runQueryLeadershipScheduleCmd + EraBased.QueryLeadershipScheduleCmdArgs{target = Consensus.VolatileTip, ..} diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/StakeAddress.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/StakeAddress.hs index c6e9059cb8..87fa7df8a7 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/StakeAddress.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/StakeAddress.hs @@ -3,7 +3,8 @@ module Cardano.CLI.Legacy.Run.StakeAddress ( runLegacyStakeAddressCmds - ) where + ) +where import Cardano.Api import Cardano.Api.Ledger (Coin) @@ -17,7 +18,8 @@ import Cardano.CLI.Types.Key import Control.Monad (void) -runLegacyStakeAddressCmds :: () +runLegacyStakeAddressCmds + :: () => LegacyStakeAddressCmds -> ExceptT StakeAddressCmdError IO () runLegacyStakeAddressCmds = \case @@ -34,7 +36,8 @@ runLegacyStakeAddressCmds = \case StakeAddressDeregistrationCertificateCmd anyEra stakeIdentifier mDeposit outputFp -> runLegacyStakeAddressDeregistrationCertificateCmd anyEra stakeIdentifier mDeposit outputFp -runLegacyStakeAddressKeyGenCmd :: () +runLegacyStakeAddressKeyGenCmd + :: () => KeyOutputFormat -> VerificationKeyFile Out -> SigningKeyFile Out @@ -42,14 +45,16 @@ runLegacyStakeAddressKeyGenCmd :: () runLegacyStakeAddressKeyGenCmd vk sk = void <$> runStakeAddressKeyGenCmd vk sk -runLegacyStakeAddressKeyHashCmd :: () +runLegacyStakeAddressKeyHashCmd + :: () => VerificationKeyOrFile StakeKey -> Maybe (File () Out) -> ExceptT StakeAddressCmdError IO () runLegacyStakeAddressKeyHashCmd = runStakeAddressKeyHashCmd -runLegacyStakeAddressBuildCmd :: () +runLegacyStakeAddressBuildCmd + :: () => StakeVerifier -> NetworkId -> Maybe (File () Out) @@ -57,16 +62,19 @@ runLegacyStakeAddressBuildCmd :: () runLegacyStakeAddressBuildCmd = runStakeAddressBuildCmd -runLegacyStakeAddressRegistrationCertificateCmd :: () +runLegacyStakeAddressRegistrationCertificateCmd + :: () => EraInEon ShelleyBasedEra -> StakeIdentifier - -> Maybe Coin -- ^ Deposit required in conway era + -> Maybe Coin + -- ^ Deposit required in conway era -> File () Out -> ExceptT StakeAddressCmdError IO () runLegacyStakeAddressRegistrationCertificateCmd (EraInEon sbe) = runStakeAddressRegistrationCertificateCmd sbe -runLegacyStakeAddresslDelegationCertificateCmd :: () +runLegacyStakeAddresslDelegationCertificateCmd + :: () => EraInEon ShelleyBasedEra -> StakeIdentifier -- ^ Delegator stake verification key, verification key file or script file. @@ -78,10 +86,12 @@ runLegacyStakeAddresslDelegationCertificateCmd :: () runLegacyStakeAddresslDelegationCertificateCmd (EraInEon sbe) = runStakeAddressStakeDelegationCertificateCmd sbe -runLegacyStakeAddressDeregistrationCertificateCmd :: () +runLegacyStakeAddressDeregistrationCertificateCmd + :: () => EraInEon ShelleyBasedEra -> StakeIdentifier - -> Maybe Coin -- ^ Deposit required in conway era + -> Maybe Coin + -- ^ Deposit required in conway era -> File () Out -> ExceptT StakeAddressCmdError IO () runLegacyStakeAddressDeregistrationCertificateCmd (EraInEon sbe) = diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/StakePool.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/StakePool.hs index 125dc43f5a..2849e4b903 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/StakePool.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/StakePool.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Legacy.Run.StakePool ( runLegacyStakePoolCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -17,7 +18,8 @@ import Cardano.CLI.Types.Common import Cardano.CLI.Types.Errors.StakePoolCmdError import Cardano.CLI.Types.Key (VerificationKeyOrFile) -runLegacyStakePoolCmds :: () +runLegacyStakePoolCmds + :: () => LegacyStakePoolCmds -> ExceptT StakePoolCmdError IO () runLegacyStakePoolCmds = \case @@ -27,13 +29,38 @@ runLegacyStakePoolCmds = \case runLegacyStakePoolIdCmd poolVerificationKeyOrFile outputFormat mOutFile StakePoolMetadataHashCmd poolMdFile mOutFile -> runLegacyStakePoolMetadataHashCmd poolMdFile mOutFile - StakePoolRegistrationCertificateCmd anyEra poolVerificationKeyOrFile vrfVkey poolPledge pCost pMrgn rwdVerFp ownerVerFps relays mbMetadata network outFile -> - runLegacyStakePoolRegistrationCertificateCmd anyEra poolVerificationKeyOrFile vrfVkey poolPledge pCost pMrgn rwdVerFp ownerVerFps relays mbMetadata network outFile + StakePoolRegistrationCertificateCmd + anyEra + poolVerificationKeyOrFile + vrfVkey + poolPledge + pCost + pMrgn + rwdVerFp + ownerVerFps + relays + mbMetadata + network + outFile -> + runLegacyStakePoolRegistrationCertificateCmd + anyEra + poolVerificationKeyOrFile + vrfVkey + poolPledge + pCost + pMrgn + rwdVerFp + ownerVerFps + relays + mbMetadata + network + outFile -- | Create a stake pool registration cert. -- TODO: Metadata and more stake pool relay support to be -- added in the future. -runLegacyStakePoolRegistrationCertificateCmd :: () +runLegacyStakePoolRegistrationCertificateCmd + :: () => EraInEon ShelleyBasedEra -> VerificationKeyOrFile StakePoolKey -- ^ Stake pool verification key. @@ -57,36 +84,37 @@ runLegacyStakePoolRegistrationCertificateCmd :: () -> File () Out -> ExceptT StakePoolCmdError IO () runLegacyStakePoolRegistrationCertificateCmd - inSbe - poolVerificationKeyOrFile - vrfVerificationKeyOrFile - poolPledge - poolCost - poolMargin - rewardStakeVerificationKeyOrFile - ownerStakeVerificationKeyOrFiles - relays - mbMetadata - network - outFile = - case inSbe of - EraInEon sbe -> - runStakePoolRegistrationCertificateCmd $ - Cmd.StakePoolRegistrationCertificateCmdArgs - sbe - poolVerificationKeyOrFile - vrfVerificationKeyOrFile - poolPledge - poolCost - poolMargin - rewardStakeVerificationKeyOrFile - ownerStakeVerificationKeyOrFiles - relays - mbMetadata - network - outFile + inSbe + poolVerificationKeyOrFile + vrfVerificationKeyOrFile + poolPledge + poolCost + poolMargin + rewardStakeVerificationKeyOrFile + ownerStakeVerificationKeyOrFiles + relays + mbMetadata + network + outFile = + case inSbe of + EraInEon sbe -> + runStakePoolRegistrationCertificateCmd $ + Cmd.StakePoolRegistrationCertificateCmdArgs + sbe + poolVerificationKeyOrFile + vrfVerificationKeyOrFile + poolPledge + poolCost + poolMargin + rewardStakeVerificationKeyOrFile + ownerStakeVerificationKeyOrFiles + relays + mbMetadata + network + outFile -runLegacyStakePoolDeregistrationCertificateCmd :: () +runLegacyStakePoolDeregistrationCertificateCmd + :: () => EraInEon ShelleyBasedEra -> VerificationKeyOrFile StakePoolKey -> L.EpochNo @@ -102,7 +130,8 @@ runLegacyStakePoolDeregistrationCertificateCmd inSbe poolVerificationKeyOrFile r retireEpoch outFile -runLegacyStakePoolIdCmd :: () +runLegacyStakePoolIdCmd + :: () => VerificationKeyOrFile StakePoolKey -> IdOutputFormat -> Maybe (File () Out) @@ -114,7 +143,8 @@ runLegacyStakePoolIdCmd poolVerificationKeyOrFile outputFormat mOutFile = outputFormat mOutFile -runLegacyStakePoolMetadataHashCmd :: () +runLegacyStakePoolMetadataHashCmd + :: () => StakePoolMetadataFile In -> Maybe (File () Out) -> ExceptT StakePoolCmdError IO () diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/TextView.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/TextView.hs index cc8a1e60b8..05a7c554d2 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/TextView.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/TextView.hs @@ -3,7 +3,8 @@ module Cardano.CLI.Legacy.Run.TextView ( runLegacyTextViewCmds - ) where + ) +where import Cardano.Api @@ -15,7 +16,8 @@ runLegacyTextViewCmds :: LegacyTextViewCmds -> ExceptT TextViewFileError IO () runLegacyTextViewCmds = \case TextViewInfo fpath mOutfile -> runLegacyTextViewInfoCmd fpath mOutfile -runLegacyTextViewInfoCmd :: () +runLegacyTextViewInfoCmd + :: () => FilePath -> Maybe (File () Out) -> ExceptT TextViewFileError IO () diff --git a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs index ceb81857c4..54ad5bb09c 100644 --- a/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs +++ b/cardano-cli/src/Cardano/CLI/Legacy/Run/Transaction.hs @@ -7,7 +7,8 @@ module Cardano.CLI.Legacy.Run.Transaction ( runLegacyTransactionCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Byron as Api @@ -25,65 +26,176 @@ import Data.Function runLegacyTransactionCmds :: LegacyTransactionCmds -> ExceptT TxCmdError IO () runLegacyTransactionCmds = \case - TransactionBuildCmd mNodeSocketPath era consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns - reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound - mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpProp mconwayVote - mNewConstitution mTreasuryDonation outputOptions -> do - runLegacyTransactionBuildCmd mNodeSocketPath era consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns - reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound - mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpProp mconwayVote - mNewConstitution mTreasuryDonation outputOptions - TransactionBuildRawCmd era mScriptValidity txins readOnlyRefIns txinsc mReturnColl - mTotColl reqSigners txouts mValue mLowBound mUpperBound fee certs wdrls - metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpProp out -> do - runLegacyTransactionBuildRawCmd era mScriptValidity txins readOnlyRefIns txinsc mReturnColl - mTotColl reqSigners txouts mValue mLowBound mUpperBound fee certs wdrls - metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpProp out + TransactionBuildCmd + mNodeSocketPath + era + consensusModeParams + nid + mScriptValidity + mOverrideWits + txins + readOnlyRefIns + reqSigners + txinsc + mReturnColl + mTotCollateral + txouts + changeAddr + mValue + mLowBound + mUpperBound + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mUpProp + mconwayVote + mNewConstitution + mTreasuryDonation + outputOptions -> do + runLegacyTransactionBuildCmd + mNodeSocketPath + era + consensusModeParams + nid + mScriptValidity + mOverrideWits + txins + readOnlyRefIns + reqSigners + txinsc + mReturnColl + mTotCollateral + txouts + changeAddr + mValue + mLowBound + mUpperBound + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mUpProp + mconwayVote + mNewConstitution + mTreasuryDonation + outputOptions + TransactionBuildRawCmd + era + mScriptValidity + txins + readOnlyRefIns + txinsc + mReturnColl + mTotColl + reqSigners + txouts + mValue + mLowBound + mUpperBound + fee + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mProtocolParamsFile + mUpProp + out -> do + runLegacyTransactionBuildRawCmd + era + mScriptValidity + txins + readOnlyRefIns + txinsc + mReturnColl + mTotColl + reqSigners + txouts + mValue + mLowBound + mUpperBound + fee + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mProtocolParamsFile + mUpProp + out TransactionSignCmd txinfile skfiles network txoutfile -> - runLegacyTransactionSignCmd txinfile skfiles network txoutfile + runLegacyTransactionSignCmd txinfile skfiles network txoutfile TransactionSubmitCmd mNodeSocketPath consensusModeParams network txFp -> - runLegacyTransactionSubmitCmd mNodeSocketPath consensusModeParams network txFp - TransactionCalculateMinFeeCmd txbody pParamsFile nShelleyKeyWitnesses nByronKeyWitnesses referenceScriptSize format mOutFile -> - runLegacyTransactionCalculateMinFeeCmd txbody pParamsFile nShelleyKeyWitnesses nByronKeyWitnesses referenceScriptSize format mOutFile + runLegacyTransactionSubmitCmd mNodeSocketPath consensusModeParams network txFp + TransactionCalculateMinFeeCmd + txbody + pParamsFile + nShelleyKeyWitnesses + nByronKeyWitnesses + referenceScriptSize + format + mOutFile -> + runLegacyTransactionCalculateMinFeeCmd + txbody + pParamsFile + nShelleyKeyWitnesses + nByronKeyWitnesses + referenceScriptSize + format + mOutFile TransactionCalculateMinValueCmd (EraInEon sbe) pParamsFile txOuts' -> - runLegacyTransactionCalculateMinValueCmd (AnyShelleyBasedEra sbe) pParamsFile txOuts' + runLegacyTransactionCalculateMinValueCmd (AnyShelleyBasedEra sbe) pParamsFile txOuts' TransactionHashScriptDataCmd scriptDataOrFile -> - runLegacyTransactionHashScriptDataCmd scriptDataOrFile + runLegacyTransactionHashScriptDataCmd scriptDataOrFile TransactionTxIdCmd txinfile -> - runLegacyTransactionTxIdCmd txinfile + runLegacyTransactionTxIdCmd txinfile TransactionViewCmd yamlOrJson mOutFile txinfile -> - runLegacyTransactionViewCmd yamlOrJson mOutFile txinfile + runLegacyTransactionViewCmd yamlOrJson mOutFile txinfile TransactionPolicyIdCmd sFile -> - runLegacyTransactionPolicyIdCmd sFile + runLegacyTransactionPolicyIdCmd sFile TransactionWitnessCmd txBodyfile witSignData mbNw outFile -> - runLegacyTransactionWitnessCmd txBodyfile witSignData mbNw outFile + runLegacyTransactionWitnessCmd txBodyfile witSignData mbNw outFile TransactionSignWitnessCmd txBodyFile witnessFile outFile -> - runLegacyTransactionSignWitnessCmd txBodyFile witnessFile outFile + runLegacyTransactionSignWitnessCmd txBodyFile witnessFile outFile -- ---------------------------------------------------------------------------- -- Building transactions -- -runLegacyTransactionBuildCmd :: () +runLegacyTransactionBuildCmd + :: () => SocketPath -> EraInEon ShelleyBasedEra -> ConsensusModeParams -> NetworkId -> Maybe ScriptValidity - -> Maybe Word -- ^ Override the required number of tx witnesses - -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] -- ^ Transaction inputs with optional spending scripts - -> [TxIn] -- ^ Read only reference inputs - -> [RequiredSigner] -- ^ Required signers - -> [TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - -> Maybe TxOutShelleyBasedEra -- ^ Return collateral - -> Maybe Coin -- ^ Total collateral + -> Maybe Word + -- ^ Override the required number of tx witnesses + -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] + -- ^ Transaction inputs with optional spending scripts + -> [TxIn] + -- ^ Read only reference inputs + -> [RequiredSigner] + -- ^ Required signers + -> [TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. + -> Maybe TxOutShelleyBasedEra + -- ^ Return collateral + -> Maybe Coin + -- ^ Total collateral -> [TxOutAnyEra] -> TxOutChangeAddress -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) - -> Maybe SlotNo -- ^ Validity lower bound - -> Maybe SlotNo -- ^ Validity upper bound + -> Maybe SlotNo + -- ^ Validity lower bound + -> Maybe SlotNo + -- ^ Validity upper bound -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] - -> [(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] -- ^ Withdrawals with potential script witness + -> [(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] + -- ^ Withdrawals with potential script witness -> TxMetadataJsonSchema -> [ScriptFile] -> [MetadataFile] @@ -94,28 +206,70 @@ runLegacyTransactionBuildCmd :: () -> TxBuildOutputOptions -> ExceptT TxCmdError IO () runLegacyTransactionBuildCmd - socketPath (EraInEon sbe) - consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns - reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound - mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpdateProposal voteFiles - proposalFiles - mTreasuryDonation - outputOptions = do - - mUpdateProposalFile <- - validateUpdateProposalFile (toCardanoEra sbe) mUpdateProposal - & hoistEither - & firstExceptT TxCmdNotSupportedInEraValidationError + socketPath + (EraInEon sbe) + consensusModeParams + nid + mScriptValidity + mOverrideWits + txins + readOnlyRefIns + reqSigners + txinsc + mReturnColl + mTotCollateral + txouts + changeAddr + mValue + mLowBound + mUpperBound + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mUpdateProposal + voteFiles + proposalFiles + mTreasuryDonation + outputOptions = do + mUpdateProposalFile <- + validateUpdateProposalFile (toCardanoEra sbe) mUpdateProposal + & hoistEither + & firstExceptT TxCmdNotSupportedInEraValidationError - let upperBound = TxValidityUpperBound sbe mUpperBound + let upperBound = TxValidityUpperBound sbe mUpperBound - runTransactionBuildCmd - ( Cmd.TransactionBuildCmdArgs sbe socketPath - consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns - reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound - upperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpdateProposalFile voteFiles - proposalFiles mTreasuryDonation outputOptions - ) + runTransactionBuildCmd + ( Cmd.TransactionBuildCmdArgs + sbe + socketPath + consensusModeParams + nid + mScriptValidity + mOverrideWits + txins + readOnlyRefIns + reqSigners + txinsc + mReturnColl + mTotCollateral + txouts + changeAddr + mValue + mLowBound + upperBound + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mUpdateProposalFile + voteFiles + proposalFiles + mTreasuryDonation + outputOptions + ) -- TODO: Neither QA nor Sam is using `cardano-cli byron transaction build-raw` -- for Byron era transactions. So we can parameterize this function on ShelleyBasedEra. @@ -124,20 +278,29 @@ runLegacyTransactionBuildCmd -- uses inputs, outputs and update proposals. NB: Update proposals are a separate -- thing in the Byron era so we need to figure out how we are handling that at the -- cli command level. -runLegacyTransactionBuildRawCmd :: () +runLegacyTransactionBuildRawCmd + :: () => AnyCardanoEra -> Maybe ScriptValidity -> [(TxIn, Maybe (ScriptWitnessFiles WitCtxTxIn))] - -> [TxIn] -- ^ Read only reference inputs - -> [TxIn] -- ^ Transaction inputs for collateral, only key witnesses, no scripts. - -> Maybe TxOutShelleyBasedEra -- ^ Return collateral - -> Maybe Coin -- ^ Total collateral + -> [TxIn] + -- ^ Read only reference inputs + -> [TxIn] + -- ^ Transaction inputs for collateral, only key witnesses, no scripts. + -> Maybe TxOutShelleyBasedEra + -- ^ Return collateral + -> Maybe Coin + -- ^ Total collateral -> [RequiredSigner] -> [TxOutAnyEra] - -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) -- ^ Multi-Asset value with script witness - -> Maybe SlotNo -- ^ Validity lower bound - -> Maybe SlotNo -- ^ Validity upper bound - -> Coin -- ^ Tx fee + -> Maybe (Value, [ScriptWitnessFiles WitCtxMint]) + -- ^ Multi-Asset value with script witness + -> Maybe SlotNo + -- ^ Validity lower bound + -> Maybe SlotNo + -- ^ Validity upper bound + -> Coin + -- ^ Tx fee -> [(CertificateFile, Maybe (ScriptWitnessFiles WitCtxStake))] -> [(StakeAddress, Coin, Maybe (ScriptWitnessFiles WitCtxStake))] -> TxMetadataJsonSchema @@ -147,84 +310,139 @@ runLegacyTransactionBuildRawCmd :: () -> Maybe UpdateProposalFile -> TxBodyFile Out -> ExceptT TxCmdError IO () -runLegacyTransactionBuildRawCmd (AnyCardanoEra ByronEra) _ txins _ _ _ - _ _ txouts _ _ _ _ _ _ - _ _ _ _ _ - outFile = do - let apiTxIns = [ ( txIn, BuildTxWith (KeyWitness KeyWitnessForSpending)) | (txIn, _) <- txins] - byronOuts <- mapM toTxOutByronEra txouts - case makeByronTransactionBody apiTxIns byronOuts of - Left err -> error $ "Error occurred while creating a Byron based UTxO transaction: " <> show err - Right txBody -> do - let noWitTx = makeSignedByronTransaction [] txBody - lift (Api.writeByronTxFileTextEnvelopeCddl outFile noWitTx) - & onLeft (left . TxCmdWriteFileError) - runLegacyTransactionBuildRawCmd - (AnyCardanoEra era) mScriptValidity txins readOnlyRefIns txinsc mReturnColl - mTotColl reqSigners txouts mValue mLowBound mUpperBound fee certs wdrls - metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpdateProposal - outFile = do - - caseByronOrShelleyBasedEra - (error "runLegacyTransactionBuildRawCmd: This should be impossible") - (\sbe -> do - mUpdateProposalFile <- validateUpdateProposalFile era mUpdateProposal - & hoistEither - & firstExceptT TxCmdNotSupportedInEraValidationError - - let upperBound = TxValidityUpperBound sbe mUpperBound + (AnyCardanoEra ByronEra) + _ + txins + _ + _ + _ + _ + _ + txouts + _ + _ + _ + _ + _ + _ + _ + _ + _ + _ + _ + outFile = do + let apiTxIns = [(txIn, BuildTxWith (KeyWitness KeyWitnessForSpending)) | (txIn, _) <- txins] + byronOuts <- mapM toTxOutByronEra txouts + case makeByronTransactionBody apiTxIns byronOuts of + Left err -> error $ "Error occurred while creating a Byron based UTxO transaction: " <> show err + Right txBody -> do + let noWitTx = makeSignedByronTransaction [] txBody + lift (Api.writeByronTxFileTextEnvelopeCddl outFile noWitTx) + & onLeft (left . TxCmdWriteFileError) +runLegacyTransactionBuildRawCmd + (AnyCardanoEra era) + mScriptValidity + txins + readOnlyRefIns + txinsc + mReturnColl + mTotColl + reqSigners + txouts + mValue + mLowBound + mUpperBound + fee + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mProtocolParamsFile + mUpdateProposal + outFile = do + caseByronOrShelleyBasedEra + (error "runLegacyTransactionBuildRawCmd: This should be impossible") + ( \sbe -> do + mUpdateProposalFile <- + validateUpdateProposalFile era mUpdateProposal + & hoistEither + & firstExceptT TxCmdNotSupportedInEraValidationError - runTransactionBuildRawCmd - ( Cmd.TransactionBuildRawCmdArgs - sbe mScriptValidity txins readOnlyRefIns txinsc mReturnColl - mTotColl reqSigners txouts mValue mLowBound upperBound fee certs wdrls - metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpdateProposalFile [] [] - Nothing - outFile - ) - ) - era + let upperBound = TxValidityUpperBound sbe mUpperBound + runTransactionBuildRawCmd + ( Cmd.TransactionBuildRawCmdArgs + sbe + mScriptValidity + txins + readOnlyRefIns + txinsc + mReturnColl + mTotColl + reqSigners + txouts + mValue + mLowBound + upperBound + fee + certs + wdrls + metadataSchema + scriptFiles + metadataFiles + mProtocolParamsFile + mUpdateProposalFile + [] + [] + Nothing + outFile + ) + ) + era -runLegacyTransactionSignCmd :: InputTxBodyOrTxFile - -> [WitnessSigningData] - -> Maybe NetworkId - -> TxFile Out - -> ExceptT TxCmdError IO () runLegacyTransactionSignCmd - txOrTxBody - witSigningData - mnw - outTxFile = - runTransactionSignCmd - ( Cmd.TransactionSignCmdArgs - txOrTxBody - witSigningData - mnw - outTxFile - ) + :: InputTxBodyOrTxFile + -> [WitnessSigningData] + -> Maybe NetworkId + -> TxFile Out + -> ExceptT TxCmdError IO () +runLegacyTransactionSignCmd + txOrTxBody + witSigningData + mnw + outTxFile = + runTransactionSignCmd + ( Cmd.TransactionSignCmdArgs + txOrTxBody + witSigningData + mnw + outTxFile + ) -runLegacyTransactionSubmitCmd :: () +runLegacyTransactionSubmitCmd + :: () => SocketPath -> ConsensusModeParams -> NetworkId -> FilePath -> ExceptT TxCmdError IO () runLegacyTransactionSubmitCmd - socketPath - consensusModeParams - network - txFilePath = - runTransactionSubmitCmd - ( Cmd.TransactionSubmitCmdArgs - socketPath - consensusModeParams - network - txFilePath - ) + socketPath + consensusModeParams + network + txFilePath = + runTransactionSubmitCmd + ( Cmd.TransactionSubmitCmdArgs + socketPath + consensusModeParams + network + txFilePath + ) -runLegacyTransactionCalculateMinFeeCmd :: () +runLegacyTransactionCalculateMinFeeCmd + :: () => TxBodyFile In -> ProtocolParamsFile -> TxShelleyWitnessCount @@ -234,41 +452,42 @@ runLegacyTransactionCalculateMinFeeCmd :: () -> Maybe (File () Out) -> ExceptT TxCmdError IO () runLegacyTransactionCalculateMinFeeCmd - txbodyFile - pParamsFile - txShelleyWitnessCount - txByronWitnessCount - referenceScriptSize - outputFormat - outFile = - runTransactionCalculateMinFeeCmd - ( Cmd.TransactionCalculateMinFeeCmdArgs - txbodyFile - pParamsFile - txShelleyWitnessCount - txByronWitnessCount - referenceScriptSize - outputFormat - outFile - ) + txbodyFile + pParamsFile + txShelleyWitnessCount + txByronWitnessCount + referenceScriptSize + outputFormat + outFile = + runTransactionCalculateMinFeeCmd + ( Cmd.TransactionCalculateMinFeeCmdArgs + txbodyFile + pParamsFile + txShelleyWitnessCount + txByronWitnessCount + referenceScriptSize + outputFormat + outFile + ) -runLegacyTransactionCalculateMinValueCmd :: () +runLegacyTransactionCalculateMinValueCmd + :: () => AnyShelleyBasedEra -> ProtocolParamsFile -> TxOutShelleyBasedEra -> ExceptT TxCmdError IO () runLegacyTransactionCalculateMinValueCmd - (AnyShelleyBasedEra era) - pParamsFile - txOut = - runTransactionCalculateMinValueCmd - ( Cmd.TransactionCalculateMinValueCmdArgs - era - pParamsFile - txOut - ) + (AnyShelleyBasedEra era) + pParamsFile + txOut = + runTransactionCalculateMinValueCmd + ( Cmd.TransactionCalculateMinValueCmdArgs + era + pParamsFile + txOut + ) -runLegacyTransactionPolicyIdCmd :: ScriptFile -> ExceptT TxCmdError IO () +runLegacyTransactionPolicyIdCmd :: ScriptFile -> ExceptT TxCmdError IO () runLegacyTransactionPolicyIdCmd scriptFile = runTransactionPolicyIdCmd ( Cmd.TransactionPolicyIdCmdArgs @@ -289,49 +508,52 @@ runLegacyTransactionTxIdCmd txfile = txfile ) -runLegacyTransactionViewCmd :: ViewOutputFormat -> Maybe (File () Out) -> InputTxBodyOrTxFile -> ExceptT TxCmdError IO () runLegacyTransactionViewCmd - yamlOrJson - mOutFile - inputTxBodyOrTxFile = - runTransactionViewCmd - ( Cmd.TransactionViewCmdArgs - yamlOrJson - mOutFile - inputTxBodyOrTxFile - ) + :: ViewOutputFormat -> Maybe (File () Out) -> InputTxBodyOrTxFile -> ExceptT TxCmdError IO () +runLegacyTransactionViewCmd + yamlOrJson + mOutFile + inputTxBodyOrTxFile = + runTransactionViewCmd + ( Cmd.TransactionViewCmdArgs + yamlOrJson + mOutFile + inputTxBodyOrTxFile + ) -runLegacyTransactionWitnessCmd :: () +runLegacyTransactionWitnessCmd + :: () => TxBodyFile In -> WitnessSigningData -> Maybe NetworkId -> File () Out -> ExceptT TxCmdError IO () runLegacyTransactionWitnessCmd - txbodyFile - witSignData - mbNw - outFile = - runTransactionWitnessCmd - ( Cmd.TransactionWitnessCmdArgs - txbodyFile - witSignData - mbNw - outFile - ) + txbodyFile + witSignData + mbNw + outFile = + runTransactionWitnessCmd + ( Cmd.TransactionWitnessCmdArgs + txbodyFile + witSignData + mbNw + outFile + ) -runLegacyTransactionSignWitnessCmd :: () +runLegacyTransactionSignWitnessCmd + :: () => TxBodyFile In -> [WitnessFile] -> File () Out -> ExceptT TxCmdError IO () runLegacyTransactionSignWitnessCmd - txbodyFile - witnessFiles - outFile = - runTransactionSignWitnessCmd - ( Cmd.TransactionSignWitnessCmdArgs - txbodyFile - witnessFiles - outFile - ) + txbodyFile + witnessFiles + outFile = + runTransactionSignWitnessCmd + ( Cmd.TransactionSignWitnessCmdArgs + txbodyFile + witnessFiles + outFile + ) diff --git a/cardano-cli/src/Cardano/CLI/Options.hs b/cardano-cli/src/Cardano/CLI/Options.hs index 357cf13d57..039cc1455e 100644 --- a/cardano-cli/src/Cardano/CLI/Options.hs +++ b/cardano-cli/src/Cardano/CLI/Options.hs @@ -6,7 +6,8 @@ module Cardano.CLI.Options ( opts , pref - ) where + ) +where import Cardano.Api (ShelleyBasedEra (..)) @@ -28,22 +29,25 @@ import qualified Prettyprinter as PP opts :: EnvCli -> ParserInfo ClientCommand opts envCli = - Opt.info (parseClientCommand envCli <**> Opt.helper) $ mconcat - [ Opt.fullDesc - , Opt.header $ mconcat - [ "cardano-cli - General purpose command-line utility to interact with cardano-node." - , " Provides specific commands to manage keys, addresses, build & submit transactions," - , " certificates, etc." + Opt.info (parseClientCommand envCli <**> Opt.helper) $ + mconcat + [ Opt.fullDesc + , Opt.header $ + mconcat + [ "cardano-cli - General purpose command-line utility to interact with cardano-node." + , " Provides specific commands to manage keys, addresses, build & submit transactions," + , " certificates, etc." + ] ] - ] pref :: ParserPrefs pref = - Opt.prefs $ mconcat - [ showHelpOnEmpty - , helpEmbedBriefDesc PP.align - , helpRenderHelp customRenderHelp - ] + Opt.prefs $ + mconcat + [ showHelpOnEmpty + , helpEmbedBriefDesc PP.align + , helpRenderHelp customRenderHelp + ] parseClientCommand :: EnvCli -> Parser ClientCommand parseClientCommand envCli = @@ -53,8 +57,8 @@ parseClientCommand envCli = -- so we list it first. [ parseAnyEra envCli , parseLegacy envCli - -- , parseTopLevelLatest envCli -- TODO restore this when the governance command group is fully operational - , parseTopLevelLegacy envCli + , -- , parseTopLevelLatest envCli -- TODO restore this when the governance command group is fully operational + parseTopLevelLegacy envCli , parseByron envCli , parseHash , parsePing @@ -66,11 +70,12 @@ parseClientCommand envCli = parseByron :: EnvCli -> Parser ClientCommand parseByron mNetworkId = fmap ByronCommand $ - subparser $ mconcat - [ commandGroup "Byron specific commands" - , metavar "Byron specific commands" - , command' "byron" "Byron specific commands" $ parseByronCommands mNetworkId - ] + subparser $ + mconcat + [ commandGroup "Byron specific commands" + , metavar "Byron specific commands" + , command' "byron" "Byron specific commands" $ parseByronCommands mNetworkId + ] parseHash :: Parser ClientCommand parseHash = HashCmds <$> pHashCmds @@ -86,9 +91,9 @@ parseAnyEra envCli = AnyEraCommand <$> pAnyEraCommand envCli parseLegacy :: EnvCli -> Parser ClientCommand parseLegacy envCli = - subParser "legacy" - $ Opt.info (LegacyCmds <$> parseLegacyCmds envCli) - $ Opt.progDesc "Legacy commands" + subParser "legacy" $ + Opt.info (LegacyCmds <$> parseLegacyCmds envCli) $ + Opt.progDesc "Legacy commands" _parseTopLevelLatest :: EnvCli -> Parser ClientCommand _parseTopLevelLatest envCli = @@ -103,22 +108,23 @@ parseTopLevelLegacy envCli = LegacyCmds <$> parseLegacyCmds envCli parseDisplayVersion :: ParserInfo a -> Parser ClientCommand parseDisplayVersion allParserInfo = asum - [ subparser $ mconcat - [ commandGroup "Miscellaneous commands" - , metavar "Miscellaneous commands" - , command' - "help" - "Show all help" - (pure (Help pref allParserInfo)) - , command' - "version" - "Show the cardano-cli version" - (pure DisplayVersion) - ] - - , flag' DisplayVersion $ mconcat - [ long "version" - , help "Show the cardano-cli version" - , hidden - ] + [ subparser $ + mconcat + [ commandGroup "Miscellaneous commands" + , metavar "Miscellaneous commands" + , command' + "help" + "Show all help" + (pure (Help pref allParserInfo)) + , command' + "version" + "Show the cardano-cli version" + (pure DisplayVersion) + ] + , flag' DisplayVersion $ + mconcat + [ long "version" + , help "Show the cardano-cli version" + , hidden + ] ] diff --git a/cardano-cli/src/Cardano/CLI/Options/Debug.hs b/cardano-cli/src/Cardano/CLI/Options/Debug.hs index f5255ab785..019216f9b1 100644 --- a/cardano-cli/src/Cardano/CLI/Options/Debug.hs +++ b/cardano-cli/src/Cardano/CLI/Options/Debug.hs @@ -8,7 +8,8 @@ module Cardano.CLI.Options.Debug ( parseDebugCmds - ) where + ) +where import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -23,41 +24,46 @@ import qualified Options.Applicative as Opt parseDebugCmds :: EnvCli -> Parser DebugCmds parseDebugCmds envCli = - Opt.hsubparser $ mconcat - [ Opt.metavar "debug commands" - , Opt.commandGroup "debug commands" - , Opt.command "debug" - $ Opt.info (pDebugCmds envCli) - $ Opt.progDesc "Debug commands" - ] + Opt.hsubparser $ + mconcat + [ Opt.metavar "debug commands" + , Opt.commandGroup "debug commands" + , Opt.command "debug" $ + Opt.info (pDebugCmds envCli) $ + Opt.progDesc "Debug commands" + ] pDebugCmds :: EnvCli -> Parser DebugCmds pDebugCmds envCli = - asum - [ subParser "log-epoch-state" - $ Opt.info pLogEpochStateCmdArgs - $ Opt.progDesc - $ mconcat - [ "Log epoch state of a running node." - , " This command will connect to a local node and log the epoch state to a file." - , " The log file format is line delimited JSON." - , " The command will not terminate." - ] - ] - where - pLogEpochStateCmdArgs :: Parser DebugCmds - pLogEpochStateCmdArgs = - fmap DebugLogEpochStateCmd $ - LogEpochStateCmdArgs - <$> pSocketPath envCli - <*> pNodeConfigurationFileIn - <*> pFileOutDirection "out-file" "Output filepath of the log file. The log file format is line delimited JSON." + asum + [ subParser "log-epoch-state" $ + Opt.info pLogEpochStateCmdArgs $ + Opt.progDesc $ + mconcat + [ "Log epoch state of a running node." + , " This command will connect to a local node and log the epoch state to a file." + , " The log file format is line delimited JSON." + , " The command will not terminate." + ] + ] + where + pLogEpochStateCmdArgs :: Parser DebugCmds + pLogEpochStateCmdArgs = + fmap DebugLogEpochStateCmd $ + LogEpochStateCmdArgs + <$> pSocketPath envCli + <*> pNodeConfigurationFileIn + <*> pFileOutDirection + "out-file" + "Output filepath of the log file. The log file format is line delimited JSON." pNodeConfigurationFileIn :: Parser (NodeConfigFile In) pNodeConfigurationFileIn = - fmap File $ Opt.strOption $ mconcat - [ Opt.long "node-configuration-file" - , Opt.metavar "FILE" - , Opt.help "Input filepath of the node configuration file." - , Opt.completer (Opt.bashCompleter "file") - ] + fmap File $ + Opt.strOption $ + mconcat + [ Opt.long "node-configuration-file" + , Opt.metavar "FILE" + , Opt.help "Input filepath of the node configuration file." + , Opt.completer (Opt.bashCompleter "file") + ] diff --git a/cardano-cli/src/Cardano/CLI/Options/Hash.hs b/cardano-cli/src/Cardano/CLI/Options/Hash.hs index 97dc264b74..80ef0602d6 100644 --- a/cardano-cli/src/Cardano/CLI/Options/Hash.hs +++ b/cardano-cli/src/Cardano/CLI/Options/Hash.hs @@ -3,7 +3,8 @@ module Cardano.CLI.Options.Hash ( pHashCmds - ) where + ) +where import qualified Cardano.CLI.Commands.Hash as Cmd import Cardano.CLI.EraBased.Options.Common @@ -16,9 +17,9 @@ pHashCmds :: Parser Cmd.HashCmds pHashCmds = subParser "hash" $ Opt.info - (asum [ pHashAnchorDataCmd , pHashScriptCmd ]) - ( Opt.progDesc - $ mconcat + (asum [pHashAnchorDataCmd, pHashScriptCmd]) + ( Opt.progDesc $ + mconcat [ "Compute the hash to pass to the various --*-hash arguments of commands." ] ) @@ -27,24 +28,26 @@ pHashAnchorDataCmd :: Parser Cmd.HashCmds pHashAnchorDataCmd = do subParser "anchor-data" $ Opt.info - ( fmap Cmd.HashAnchorDataCmd - (Cmd.HashAnchorDataCmdArgs - <$> pAnchorDataHashSource - <*> optional pOutputFile)) + ( fmap + Cmd.HashAnchorDataCmd + ( Cmd.HashAnchorDataCmdArgs + <$> pAnchorDataHashSource + <*> optional pOutputFile + ) + ) $ Opt.progDesc "Compute the hash of some anchor data (to then pass it to other commands)." pAnchorDataHashSource :: Parser Cmd.AnchorDataHashSource pAnchorDataHashSource = asum - [ - Cmd.AnchorDataHashSourceText + [ Cmd.AnchorDataHashSourceText <$> Opt.strOption - ( mconcat - [ Opt.long "text" - , Opt.metavar "TEXT" - , Opt.help "Text to hash as UTF-8" - ] - ) + ( mconcat + [ Opt.long "text" + , Opt.metavar "TEXT" + , Opt.help "Text to hash as UTF-8" + ] + ) , Cmd.AnchorDataHashSourceBinaryFile <$> pFileInDirection "file-binary" "Binary file to hash" , Cmd.AnchorDataHashSourceTextFile @@ -55,8 +58,11 @@ pHashScriptCmd :: Parser Cmd.HashCmds pHashScriptCmd = do subParser "script" $ Opt.info - ( fmap Cmd.HashScriptCmd - (Cmd.HashScriptCmdArgs - <$> pScript - <*> optional pOutputFile)) + ( fmap + Cmd.HashScriptCmd + ( Cmd.HashScriptCmdArgs + <$> pScript + <*> optional pOutputFile + ) + ) $ Opt.progDesc "Compute the hash of a script (to then pass it to other commands)." diff --git a/cardano-cli/src/Cardano/CLI/Options/Ping.hs b/cardano-cli/src/Cardano/CLI/Options/Ping.hs index e903099873..55ff5ef1a4 100644 --- a/cardano-cli/src/Cardano/CLI/Options/Ping.hs +++ b/cardano-cli/src/Cardano/CLI/Options/Ping.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Options.Ping ( parsePingCmd - ) where + ) +where import Cardano.CLI.Commands.Ping import qualified Cardano.Network.Ping as CNP @@ -14,80 +15,97 @@ import qualified Options.Applicative as Opt import qualified Prettyprinter as PP parsePingCmd :: Opt.Parser PingCmd -parsePingCmd = Opt.hsubparser $ mconcat - [ Opt.metavar "ping" - , Opt.command "ping" $ Opt.info pPing $ Opt.progDescDoc $ Just $ mconcat - [ PP.pretty @String "Ping a cardano node either using node-to-node or node-to-client protocol. " - , PP.pretty @String "It negotiates a handshake and keeps sending keep alive messages." - ] - ] +parsePingCmd = + Opt.hsubparser $ + mconcat + [ Opt.metavar "ping" + , Opt.command "ping" $ + Opt.info pPing $ + Opt.progDescDoc $ + Just $ + mconcat + [ PP.pretty @String "Ping a cardano node either using node-to-node or node-to-client protocol. " + , PP.pretty @String "It negotiates a handshake and keeps sending keep alive messages." + ] + ] pHost :: Opt.Parser String pHost = - Opt.strOption $ mconcat - [ Opt.long "host" - , Opt.short 'h' - , Opt.metavar "HOST" - , Opt.help "Hostname/IP, e.g. relay.iohk.example." - ] + Opt.strOption $ + mconcat + [ Opt.long "host" + , Opt.short 'h' + , Opt.metavar "HOST" + , Opt.help "Hostname/IP, e.g. relay.iohk.example." + ] pUnixSocket :: Opt.Parser String pUnixSocket = - Opt.strOption $ mconcat - [ Opt.long "unixsock" - , Opt.short 'u' - , Opt.metavar "SOCKET" - , Opt.help "Unix socket, e.g. file.socket." - ] + Opt.strOption $ + mconcat + [ Opt.long "unixsock" + , Opt.short 'u' + , Opt.metavar "SOCKET" + , Opt.help "Unix socket, e.g. file.socket." + ] pEndPoint :: Opt.Parser EndPoint pEndPoint = fmap HostEndPoint pHost <|> fmap UnixSockEndPoint pUnixSocket pPing :: Opt.Parser PingCmd -pPing = PingCmd - <$> ( Opt.option Opt.auto $ mconcat - [ Opt.long "count" - , Opt.short 'c' - , Opt.metavar "COUNT" - , Opt.help $ mconcat - [ "Stop after sending count requests and receiving count responses. " - , "If this option is not specified, ping will operate until interrupted. " - ] - , Opt.value maxBound - ] - ) - <*> pEndPoint - <*> ( Opt.strOption $ mconcat - [ Opt.long "port" - , Opt.short 'p' - , Opt.metavar "PORT" - , Opt.help "Port number, e.g. 1234." - , Opt.value "3001" - ] - ) - <*> ( Opt.option Opt.auto $ mconcat - [ Opt.long "magic" - , Opt.short 'm' - , Opt.metavar "MAGIC" - , Opt.help "Network magic." - , Opt.value CNP.mainnetMagic - ] - ) - <*> ( Opt.switch $ mconcat - [ Opt.long "json" - , Opt.short 'j' - , Opt.help "JSON output flag." - ] - ) - <*> ( Opt.switch $ mconcat - [ Opt.long "quiet" - , Opt.short 'q' - , Opt.help "Quiet flag, CSV/JSON only output" - ] - ) - <*> ( Opt.switch $ mconcat - [ Opt.long "query-versions" - , Opt.short 'Q' - , Opt.help "Query the supported protocol versions using the handshake protocol and terminate the connection." - ] - ) +pPing = + PingCmd + <$> ( Opt.option Opt.auto $ + mconcat + [ Opt.long "count" + , Opt.short 'c' + , Opt.metavar "COUNT" + , Opt.help $ + mconcat + [ "Stop after sending count requests and receiving count responses. " + , "If this option is not specified, ping will operate until interrupted. " + ] + , Opt.value maxBound + ] + ) + <*> pEndPoint + <*> ( Opt.strOption $ + mconcat + [ Opt.long "port" + , Opt.short 'p' + , Opt.metavar "PORT" + , Opt.help "Port number, e.g. 1234." + , Opt.value "3001" + ] + ) + <*> ( Opt.option Opt.auto $ + mconcat + [ Opt.long "magic" + , Opt.short 'm' + , Opt.metavar "MAGIC" + , Opt.help "Network magic." + , Opt.value CNP.mainnetMagic + ] + ) + <*> ( Opt.switch $ + mconcat + [ Opt.long "json" + , Opt.short 'j' + , Opt.help "JSON output flag." + ] + ) + <*> ( Opt.switch $ + mconcat + [ Opt.long "quiet" + , Opt.short 'q' + , Opt.help "Quiet flag, CSV/JSON only output" + ] + ) + <*> ( Opt.switch $ + mconcat + [ Opt.long "query-versions" + , Opt.short 'Q' + , Opt.help + "Query the supported protocol versions using the handshake protocol and terminate the connection." + ] + ) diff --git a/cardano-cli/src/Cardano/CLI/Orphans.hs b/cardano-cli/src/Cardano/CLI/Orphans.hs index 361a8fce4b..c7bf205d83 100644 --- a/cardano-cli/src/Cardano/CLI/Orphans.hs +++ b/cardano-cli/src/Cardano/CLI/Orphans.hs @@ -2,7 +2,8 @@ module Cardano.CLI.Orphans ( - ) where + ) +where import Cardano.Api @@ -13,7 +14,7 @@ import Data.Aeson -- TODO upstream this orphaned instance to the ledger instance (L.EraTxOut ledgerera, L.EraGov ledgerera) => ToJSON (L.NewEpochState ledgerera) where - toJSON (L.NewEpochState nesEL nesBprev nesBCur nesEs nesRu nesPd _stashedAvvm)= + toJSON (L.NewEpochState nesEL nesBprev nesBCur nesEs nesRu nesPd _stashedAvvm) = object [ "currentEpoch" .= nesEL , "priorBlocks" .= nesBprev diff --git a/cardano-cli/src/Cardano/CLI/Parser.hs b/cardano-cli/src/Cardano/CLI/Parser.hs index f0d7c21812..51119ec0dd 100644 --- a/cardano-cli/src/Cardano/CLI/Parser.hs +++ b/cardano-cli/src/Cardano/CLI/Parser.hs @@ -13,7 +13,8 @@ module Cardano.CLI.Parser , readViewOutputFormat , readURIOfMaxLength , eDNSName - ) where + ) +where import qualified Cardano.Api.Ledger as L @@ -36,10 +37,11 @@ readIdOutputFormat = do "hex" -> pure IdOutputFormatHex "bech32" -> pure IdOutputFormatBech32 _ -> - fail $ mconcat - [ "Invalid output format: " <> show s - , ". Accepted output formats are \"hex\" and \"bech32\"." - ] + fail $ + mconcat + [ "Invalid output format: " <> show s + , ". Accepted output formats are \"hex\" and \"bech32\"." + ] readKeyOutputFormat :: Opt.ReadM KeyOutputFormat readKeyOutputFormat = do @@ -48,10 +50,11 @@ readKeyOutputFormat = do "text-envelope" -> pure KeyOutputFormatTextEnvelope "bech32" -> pure KeyOutputFormatBech32 _ -> - fail $ mconcat - [ "Invalid key output format: " <> show s - , ". Accepted output formats are \"text-envelope\" and \"bech32\"." - ] + fail $ + mconcat + [ "Invalid key output format: " <> show s + , ". Accepted output formats are \"text-envelope\" and \"bech32\"." + ] readTxViewOutputFormat :: Opt.ReadM ViewOutputFormat readTxViewOutputFormat = readViewOutputFormat "transaction" @@ -63,10 +66,13 @@ readViewOutputFormat kind = do "json" -> pure ViewOutputFormatJson "yaml" -> pure ViewOutputFormatYaml _ -> - fail $ mconcat - [ "Invalid ", kind, " output format: " <> show s - , ". Accepted output formats are \"json\" and \"yaml\"." - ] + fail $ + mconcat + [ "Invalid " + , kind + , " output format: " <> show s + , ". Accepted output formats are \"json\" and \"yaml\"." + ] readGovernanceActionViewOutputFormat :: Opt.ReadM ViewOutputFormat readGovernanceActionViewOutputFormat = readViewOutputFormat "governance action view" @@ -82,24 +88,26 @@ readStringOfMaxLength maxLen = do if strLen <= maxLen then pure s else - fail $ mconcat - [ "The provided string must have at most 64 characters, but it has " - , show strLen - , " characters." - ] + fail $ + mconcat + [ "The provided string must have at most 64 characters, but it has " + , show strLen + , " characters." + ] readRationalUnitInterval :: Opt.ReadM Rational readRationalUnitInterval = readRational >>= checkUnitInterval - where - checkUnitInterval :: Rational -> Opt.ReadM Rational - checkUnitInterval q - | q >= 0 && q <= 1 = return q - | otherwise = fail "Please enter a value in the range [0,1]" + where + checkUnitInterval :: Rational -> Opt.ReadM Rational + checkUnitInterval q + | q >= 0 && q <= 1 = return q + | otherwise = fail "Please enter a value in the range [0,1]" readFractionAsRational :: Opt.ReadM Rational readFractionAsRational = readerFromAttoParser fractionalAsRational - where fractionalAsRational :: Atto.Parser Rational - fractionalAsRational = (%) <$> (Atto.decimal @Integer <* Atto.char '/') <*> Atto.decimal @Integer + where + fractionalAsRational :: Atto.Parser Rational + fractionalAsRational = (%) <$> (Atto.decimal @Integer <* Atto.char '/') <*> Atto.decimal @Integer readRational :: Opt.ReadM Rational readRational = diff --git a/cardano-cli/src/Cardano/CLI/Pretty.hs b/cardano-cli/src/Cardano/CLI/Pretty.hs index 652e330a3f..500a32dbee 100644 --- a/cardano-cli/src/Cardano/CLI/Pretty.hs +++ b/cardano-cli/src/Cardano/CLI/Pretty.hs @@ -1,7 +1,6 @@ module Cardano.CLI.Pretty ( putLn , hPutLn - -- Re-exported functions from Cardano.Api related to pretty-printing , black , blue @@ -19,18 +18,18 @@ module Cardano.CLI.Pretty , (<+>) , hsep , vsep - , MonadIO(..) + , MonadIO (..) , Ann - , ShowOf(..) + , ShowOf (..) , Doc - , Pretty(..) + , Pretty (..) + ) +where - ) where +import Cardano.Api (Ann, Doc, MonadIO (..), Pretty (..), ShowOf (..), black, blue, cyan, + docToLazyText, docToString, docToText, green, hsep, magenta, prettyException, + pshow, red, vsep, white, yellow, (<+>)) -import Cardano.Api (black, blue, cyan, docToLazyText, docToString, - docToText, green, magenta, prettyException, pshow, - red, white, yellow, (<+>), hsep, vsep, MonadIO(..), - Ann, ShowOf(..), Doc, Pretty(..)) import qualified Control.Concurrent.QSem as IO import Control.Exception (bracket_) import qualified Data.Text.Lazy.IO as TextLazy diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index 4ba7e9fd12..7a3939faeb 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -8,13 +8,13 @@ module Cardano.CLI.Read ( -- * Metadata - MetadataError(..) + MetadataError (..) , renderMetadataError , readFileTxMetadata , readTxMetadata -- * Script - , ScriptWitnessError(..) + , ScriptWitnessError (..) , renderScriptWitnessError , readScriptDataOrFile , readScriptWitness @@ -24,38 +24,38 @@ module Cardano.CLI.Read , deserialiseScriptInAnyLang , readFileScriptInAnyLang - -- * Script data (datums and redeemers) - , ScriptDataError(..) + -- * Script data (datums and redeemers) + , ScriptDataError (..) , readScriptDatumOrFile , readScriptRedeemerOrFile , renderScriptDataError - -- * Tx - , CddlError(..) - , CddlTx(..) - , IncompleteCddlTxBody(..) + -- * Tx + , CddlError (..) + , CddlTx (..) + , IncompleteCddlTxBody (..) , readFileTx , readFileTxBody , readCddlTx -- For testing purposes - -- * Tx witnesses - , ReadWitnessSigningDataError(..) + -- * Tx witnesses + , ReadWitnessSigningDataError (..) , renderReadWitnessSigningDataError - , SomeSigningWitness(..) - , ByronOrShelleyWitness(..) - , ShelleyBootstrapWitnessSigningKeyData(..) - , CddlWitnessError(..) + , SomeSigningWitness (..) + , ByronOrShelleyWitness (..) + , ShelleyBootstrapWitnessSigningKeyData (..) + , CddlWitnessError (..) , readFileTxKeyWitness , readWitnessSigningData - -- * Required signer - , RequiredSignerError(..) + -- * Required signer + , RequiredSignerError (..) , categoriseSomeSigningWitness , readRequiredSigner - -- * Governance related - , ConstitutionError(..) - , ProposalError(..) + -- * Governance related + , ConstitutionError (..) + , ProposalError (..) , VoteError (..) , readTxGovernanceActions , constitutionHashSourceToHash @@ -63,39 +63,36 @@ module Cardano.CLI.Read , CostModelsError (..) , readCostModels - -- * FileOrPipe + -- * FileOrPipe , FileOrPipe , fileOrPipe , fileOrPipePath , fileOrPipeCache , readFileOrPipe - -- * Stake credentials + -- * Stake credentials , getStakeCredentialFromVerifier , getStakeCredentialFromIdentifier , getStakeAddressFromVerifier - , readVotingProceduresFiles , readSingleVote - -- * DRep credentials + -- * DRep credentials , getDRepCredentialFromVerKeyHashOrFile - - , ReadSafeHashError(..) + , ReadSafeHashError (..) , readHexAsSafeHash , readSafeHash - , scriptHashReader - -- * Update proposals + -- * Update proposals , readTxUpdateProposal - -- * Vote related + -- * Vote related , readVoteDelegationTarget - , readVerificationKeyOrHashOrFileOrScript , readVerificationKeySource - ) where + ) +where import Cardano.Api as Api import qualified Cardano.Api.Ledger as L @@ -150,30 +147,39 @@ renderMetadataError = \case MetadataErrorFile fileErr -> prettyError fileErr MetadataErrorJsonParseError fp jsonErr -> - "Invalid JSON format in file: " <> pshow fp <> - "\nJSON parse error: " <> pretty jsonErr + "Invalid JSON format in file: " + <> pshow fp + <> "\nJSON parse error: " + <> pretty jsonErr MetadataErrorConversionError fp metadataErr -> - "Error reading metadata at: " <> pshow fp <> - "\n" <> prettyError metadataErr + "Error reading metadata at: " + <> pshow fp + <> "\n" + <> prettyError metadataErr MetadataErrorValidationError fp errs -> mconcat [ "Error validating transaction metadata at: " <> pretty fp <> "\n" - , mconcat $ List.intersperse "\n" - [ "key " <> pshow k <> ":" <> prettyError valErr - | (k, valErr) <- errs - ] + , mconcat $ + List.intersperse + "\n" + [ "key " <> pshow k <> ":" <> prettyError valErr + | (k, valErr) <- errs + ] ] MetadataErrorDecodeError fp metadataErr -> - "Error decoding CBOR metadata at: " <> pshow fp <> - " Error: " <> pshow metadataErr + "Error decoding CBOR metadata at: " + <> pshow fp + <> " Error: " + <> pshow metadataErr -readTxMetadata :: ShelleyBasedEra era - -> TxMetadataJsonSchema - -> [MetadataFile] - -> IO (Either MetadataError (TxMetadataInEra era)) +readTxMetadata + :: ShelleyBasedEra era + -> TxMetadataJsonSchema + -> [MetadataFile] + -> IO (Either MetadataError (TxMetadataInEra era)) readTxMetadata _ _ [] = return $ Right TxMetadataNone readTxMetadata era schema files = runExceptT $ do - metadata <- mapM (readFileTxMetadata schema) files + metadata <- mapM (readFileTxMetadata schema) files pure $ TxMetadataInEra era $ mconcat metadata readFileTxMetadata @@ -181,23 +187,33 @@ readFileTxMetadata -> MetadataFile -> ExceptT MetadataError IO TxMetadata readFileTxMetadata mapping (MetadataFileJSON fp) = do - bs <- handleIOExceptT (MetadataErrorFile . FileIOError (unFile fp)) - $ LBS.readFile (unFile fp) - v <- firstExceptT (MetadataErrorJsonParseError (unFile fp)) - $ hoistEither $ Aeson.eitherDecode' bs - txMetadata' <- firstExceptT (MetadataErrorConversionError (unFile fp)) - . hoistEither $ metadataFromJson mapping v + bs <- + handleIOExceptT (MetadataErrorFile . FileIOError (unFile fp)) $ + LBS.readFile (unFile fp) + v <- + firstExceptT (MetadataErrorJsonParseError (unFile fp)) $ + hoistEither $ + Aeson.eitherDecode' bs + txMetadata' <- + firstExceptT (MetadataErrorConversionError (unFile fp)) + . hoistEither + $ metadataFromJson mapping v firstExceptT (MetadataErrorValidationError (unFile fp)) - . hoistEither $ do + . hoistEither + $ do validateTxMetadata txMetadata' return txMetadata' readFileTxMetadata _ (MetadataFileCBOR fp) = do - bs <- handleIOExceptT (MetadataErrorFile . FileIOError (unFile fp)) - $ BS.readFile (unFile fp) - txMetadata' <- firstExceptT (MetadataErrorDecodeError (unFile fp)) - . hoistEither $ deserialiseFromCBOR AsTxMetadata bs + bs <- + handleIOExceptT (MetadataErrorFile . FileIOError (unFile fp)) $ + BS.readFile (unFile fp) + txMetadata' <- + firstExceptT (MetadataErrorDecodeError (unFile fp)) + . hoistEither + $ deserialiseFromCBOR AsTxMetadata bs firstExceptT (MetadataErrorValidationError (unFile fp)) - . hoistEither $ do + . hoistEither + $ do validateTxMetadata txMetadata' return txMetadata' @@ -217,16 +233,25 @@ renderScriptWitnessError = \case ScriptWitnessErrorFile err -> prettyError err ScriptWitnessErrorScriptLanguageNotSupportedInEra (AnyScriptLanguage lang) anyEra -> - "The script language " <> pshow lang <> " is not supported in the " <> - pretty anyEra <> " era." + "The script language " + <> pshow lang + <> " is not supported in the " + <> pretty anyEra + <> " era." ScriptWitnessErrorExpectedSimple file (AnyScriptLanguage lang) -> - pretty file <> ": expected a script in the simple script language, " <> - "but it is actually using " <> pshow lang <> ". Alternatively, to use " <> - "a Plutus script, you must also specify the redeemer " <> - "(datum if appropriate) and script execution units." + pretty file + <> ": expected a script in the simple script language, " + <> "but it is actually using " + <> pshow lang + <> ". Alternatively, to use " + <> "a Plutus script, you must also specify the redeemer " + <> "(datum if appropriate) and script execution units." ScriptWitnessErrorExpectedPlutus file (AnyScriptLanguage lang) -> - pretty file <> ": expected a script in the Plutus script language, " <> - "but it is actually using " <> pshow lang <> "." + pretty file + <> ": expected a script in the Plutus script language, " + <> "but it is actually using " + <> pshow lang + <> "." ScriptWitnessErrorReferenceScriptsNotSupportedInEra anyEra -> "Reference scripts not supported in era: " <> pshow anyEra ScriptWitnessErrorScriptData sDataError -> @@ -239,8 +264,8 @@ readScriptWitnessFiles readScriptWitnessFiles era = mapM readSwitFile where readSwitFile (tIn, Just switFile) = do - sWit <- readScriptWitness era switFile - return (tIn, Just sWit) + sWit <- readScriptWitness era switFile + return (tIn, Just sWit) readSwitFile (tIn, Nothing) = return (tIn, Nothing) readScriptWitnessFilesTuple @@ -250,8 +275,8 @@ readScriptWitnessFilesTuple readScriptWitnessFilesTuple era = mapM readSwitFile where readSwitFile (tIn, b, Just switFile) = do - sWit <- readScriptWitness era switFile - return (tIn, b, Just sWit) + sWit <- readScriptWitness era switFile + return (tIn, b, Just sWit) readSwitFile (tIn, b, Nothing) = return (tIn, b, Nothing) readScriptWitness @@ -259,113 +284,147 @@ readScriptWitness -> ScriptWitnessFiles witctx -> ExceptT ScriptWitnessError IO (ScriptWitness witctx era) readScriptWitness era (SimpleScriptWitnessFile (File scriptFile)) = do - script@(ScriptInAnyLang lang _) <- firstExceptT ScriptWitnessErrorFile $ - readFileScriptInAnyLang scriptFile - ScriptInEra langInEra script' <- validateScriptSupportedInEra era script - case script' of - SimpleScript sscript -> - return . SimpleScriptWitness langInEra $ SScript sscript - - -- If the supplied cli flags were for a simple script (i.e. the user did - -- not supply the datum, redeemer or ex units), but the script file turns - -- out to be a valid plutus script, then we must fail. - PlutusScript{} -> - left $ ScriptWitnessErrorExpectedSimple - scriptFile - (AnyScriptLanguage lang) - -readScriptWitness era (PlutusScriptWitnessFiles - (File scriptFile) - datumOrFile - redeemerOrFile - execUnits) = do - script@(ScriptInAnyLang lang _) <- firstExceptT ScriptWitnessErrorFile $ - readFileScriptInAnyLang scriptFile - ScriptInEra langInEra script' <- validateScriptSupportedInEra era script + script@(ScriptInAnyLang lang _) <- + firstExceptT ScriptWitnessErrorFile $ + readFileScriptInAnyLang scriptFile + ScriptInEra langInEra script' <- validateScriptSupportedInEra era script + case script' of + SimpleScript sscript -> + return . SimpleScriptWitness langInEra $ SScript sscript + -- If the supplied cli flags were for a simple script (i.e. the user did + -- not supply the datum, redeemer or ex units), but the script file turns + -- out to be a valid plutus script, then we must fail. + PlutusScript{} -> + left $ + ScriptWitnessErrorExpectedSimple + scriptFile + (AnyScriptLanguage lang) +readScriptWitness + era + ( PlutusScriptWitnessFiles + (File scriptFile) + datumOrFile + redeemerOrFile + execUnits + ) = do + script@(ScriptInAnyLang lang _) <- + firstExceptT ScriptWitnessErrorFile $ + readFileScriptInAnyLang scriptFile + ScriptInEra langInEra script' <- validateScriptSupportedInEra era script case script' of PlutusScript version pscript -> do - datum <- firstExceptT ScriptWitnessErrorScriptData - $ readScriptDatumOrFile datumOrFile - redeemer <- firstExceptT ScriptWitnessErrorScriptData - $ readScriptRedeemerOrFile redeemerOrFile - return $ PlutusScriptWitness - langInEra version (PScript pscript) - datum - redeemer - execUnits + datum <- + firstExceptT ScriptWitnessErrorScriptData $ + readScriptDatumOrFile datumOrFile + redeemer <- + firstExceptT ScriptWitnessErrorScriptData $ + readScriptRedeemerOrFile redeemerOrFile + return $ + PlutusScriptWitness + langInEra + version + (PScript pscript) + datum + redeemer + execUnits -- If the supplied cli flags were for a plutus script (i.e. the user did -- supply the datum, redeemer and ex units), but the script file turns -- out to be a valid simple script, then we must fail. SimpleScript{} -> - left $ ScriptWitnessErrorExpectedPlutus - scriptFile - (AnyScriptLanguage lang) - -readScriptWitness era (PlutusReferenceScriptWitnessFiles refTxIn - anyScrLang@(AnyScriptLanguage anyScriptLanguage) - datumOrFile redeemerOrFile execUnits mPid) = do - caseShelleyToAlonzoOrBabbageEraOnwards - ( const $ left - $ ScriptWitnessErrorReferenceScriptsNotSupportedInEra - $ cardanoEraConstraints (toCardanoEra era) (AnyShelleyBasedEra era) - ) - ( const $ - case scriptLanguageSupportedInEra era anyScriptLanguage of - Just sLangInEra -> - case languageOfScriptLanguageInEra sLangInEra of - SimpleScriptLanguage -> - -- TODO: We likely need another datatype eg data ReferenceScriptWitness lang - -- in order to make this branch unrepresentable. - error "readScriptWitness: Should not be possible to specify a simple script" - PlutusScriptLanguage version -> do - datum <- firstExceptT ScriptWitnessErrorScriptData - $ readScriptDatumOrFile datumOrFile - redeemer <- firstExceptT ScriptWitnessErrorScriptData - $ readScriptRedeemerOrFile redeemerOrFile - return $ PlutusScriptWitness - sLangInEra - version - (PReferenceScript refTxIn (unPolicyId <$> mPid)) - datum redeemer execUnits - Nothing -> - left $ ScriptWitnessErrorScriptLanguageNotSupportedInEra anyScrLang (anyCardanoEra $ toCardanoEra era) - ) - era -readScriptWitness era (SimpleReferenceScriptWitnessFiles refTxIn - anyScrLang@(AnyScriptLanguage anyScriptLanguage) mPid) = do - caseShelleyToAlonzoOrBabbageEraOnwards - ( const $ left - $ ScriptWitnessErrorReferenceScriptsNotSupportedInEra - $ cardanoEraConstraints (toCardanoEra era) (AnyShelleyBasedEra era) - ) - ( const $ - case scriptLanguageSupportedInEra era anyScriptLanguage of - Just sLangInEra -> - case languageOfScriptLanguageInEra sLangInEra of - SimpleScriptLanguage -> - return . SimpleScriptWitness sLangInEra - $ SReferenceScript refTxIn (unPolicyId <$> mPid) - PlutusScriptLanguage{} -> - error "readScriptWitness: Should not be possible to specify a plutus script" - Nothing -> - left $ ScriptWitnessErrorScriptLanguageNotSupportedInEra - anyScrLang - (anyCardanoEra $ toCardanoEra era) - ) - era - -validateScriptSupportedInEra :: ShelleyBasedEra era - -> ScriptInAnyLang - -> ExceptT ScriptWitnessError IO (ScriptInEra era) + left $ + ScriptWitnessErrorExpectedPlutus + scriptFile + (AnyScriptLanguage lang) +readScriptWitness + era + ( PlutusReferenceScriptWitnessFiles + refTxIn + anyScrLang@(AnyScriptLanguage anyScriptLanguage) + datumOrFile + redeemerOrFile + execUnits + mPid + ) = do + caseShelleyToAlonzoOrBabbageEraOnwards + ( const $ + left $ + ScriptWitnessErrorReferenceScriptsNotSupportedInEra $ + cardanoEraConstraints (toCardanoEra era) (AnyShelleyBasedEra era) + ) + ( const $ + case scriptLanguageSupportedInEra era anyScriptLanguage of + Just sLangInEra -> + case languageOfScriptLanguageInEra sLangInEra of + SimpleScriptLanguage -> + -- TODO: We likely need another datatype eg data ReferenceScriptWitness lang + -- in order to make this branch unrepresentable. + error "readScriptWitness: Should not be possible to specify a simple script" + PlutusScriptLanguage version -> do + datum <- + firstExceptT ScriptWitnessErrorScriptData $ + readScriptDatumOrFile datumOrFile + redeemer <- + firstExceptT ScriptWitnessErrorScriptData $ + readScriptRedeemerOrFile redeemerOrFile + return $ + PlutusScriptWitness + sLangInEra + version + (PReferenceScript refTxIn (unPolicyId <$> mPid)) + datum + redeemer + execUnits + Nothing -> + left $ + ScriptWitnessErrorScriptLanguageNotSupportedInEra anyScrLang (anyCardanoEra $ toCardanoEra era) + ) + era +readScriptWitness + era + ( SimpleReferenceScriptWitnessFiles + refTxIn + anyScrLang@(AnyScriptLanguage anyScriptLanguage) + mPid + ) = do + caseShelleyToAlonzoOrBabbageEraOnwards + ( const $ + left $ + ScriptWitnessErrorReferenceScriptsNotSupportedInEra $ + cardanoEraConstraints (toCardanoEra era) (AnyShelleyBasedEra era) + ) + ( const $ + case scriptLanguageSupportedInEra era anyScriptLanguage of + Just sLangInEra -> + case languageOfScriptLanguageInEra sLangInEra of + SimpleScriptLanguage -> + return . SimpleScriptWitness sLangInEra $ + SReferenceScript refTxIn (unPolicyId <$> mPid) + PlutusScriptLanguage{} -> + error "readScriptWitness: Should not be possible to specify a plutus script" + Nothing -> + left $ + ScriptWitnessErrorScriptLanguageNotSupportedInEra + anyScrLang + (anyCardanoEra $ toCardanoEra era) + ) + era + +validateScriptSupportedInEra + :: ShelleyBasedEra era + -> ScriptInAnyLang + -> ExceptT ScriptWitnessError IO (ScriptInEra era) validateScriptSupportedInEra era script@(ScriptInAnyLang lang _) = - case toScriptInEra era script of - Nothing -> left $ ScriptWitnessErrorScriptLanguageNotSupportedInEra - (AnyScriptLanguage lang) (anyCardanoEra $ toCardanoEra era) - Just script' -> pure script' - -data ScriptDataError = - ScriptDataErrorFile (FileError ()) + case toScriptInEra era script of + Nothing -> + left $ + ScriptWitnessErrorScriptLanguageNotSupportedInEra + (AnyScriptLanguage lang) + (anyCardanoEra $ toCardanoEra era) + Just script' -> pure script' + +data ScriptDataError + = ScriptDataErrorFile (FileError ()) | ScriptDataErrorJsonParse !FilePath !String | ScriptDataErrorConversion !FilePath !ScriptDataJsonError | ScriptDataErrorValidation !FilePath !ScriptDataRangeError @@ -377,32 +436,35 @@ renderScriptDataError :: ScriptDataError -> Doc ann renderScriptDataError = \case ScriptDataErrorFile err -> prettyError err - ScriptDataErrorJsonParse fp jsonErr-> + ScriptDataErrorJsonParse fp jsonErr -> "Invalid JSON format in file: " <> pshow fp <> "\nJSON parse error: " <> pretty jsonErr - ScriptDataErrorConversion fp sDataJsonErr-> + ScriptDataErrorConversion fp sDataJsonErr -> "Error reading metadata at: " <> pshow fp <> "\n" <> prettyError sDataJsonErr - ScriptDataErrorValidation fp sDataRangeErr-> + ScriptDataErrorValidation fp sDataRangeErr -> "Error validating script data at: " <> pshow fp <> ":\n" <> prettyError sDataRangeErr - ScriptDataErrorMetadataDecode fp decoderErr-> + ScriptDataErrorMetadataDecode fp decoderErr -> "Error decoding CBOR metadata at: " <> pshow fp <> " Error: " <> pshow decoderErr ScriptDataErrorJsonBytes e -> prettyError e - -readScriptDatumOrFile :: ScriptDatumOrFile witctx - -> ExceptT ScriptDataError IO (ScriptDatum witctx) -readScriptDatumOrFile (ScriptDatumOrFileForTxIn df) = ScriptDatumForTxIn <$> - readScriptDataOrFile df -readScriptDatumOrFile InlineDatumPresentAtTxIn = pure InlineScriptDatum -readScriptDatumOrFile NoScriptDatumOrFileForMint = pure NoScriptDatumForMint -readScriptDatumOrFile NoScriptDatumOrFileForStake = pure NoScriptDatumForStake - -readScriptRedeemerOrFile :: ScriptRedeemerOrFile - -> ExceptT ScriptDataError IO ScriptRedeemer +readScriptDatumOrFile + :: ScriptDatumOrFile witctx + -> ExceptT ScriptDataError IO (ScriptDatum witctx) +readScriptDatumOrFile (ScriptDatumOrFileForTxIn df) = + ScriptDatumForTxIn + <$> readScriptDataOrFile df +readScriptDatumOrFile InlineDatumPresentAtTxIn = pure InlineScriptDatum +readScriptDatumOrFile NoScriptDatumOrFileForMint = pure NoScriptDatumForMint +readScriptDatumOrFile NoScriptDatumOrFileForStake = pure NoScriptDatumForStake + +readScriptRedeemerOrFile + :: ScriptRedeemerOrFile + -> ExceptT ScriptDataError IO ScriptRedeemer readScriptRedeemerOrFile = readScriptDataOrFile -readScriptDataOrFile :: ScriptDataOrFile - -> ExceptT ScriptDataError IO HashableScriptData +readScriptDataOrFile + :: ScriptDataOrFile + -> ExceptT ScriptDataError IO HashableScriptData readScriptDataOrFile (ScriptDataValue d) = return d readScriptDataOrFile (ScriptDataJsonFile fp) = do sDataBs <- handleIOExceptT (ScriptDataErrorFile . FileIOError fp) $ LBS.readFile fp @@ -410,13 +472,16 @@ readScriptDataOrFile (ScriptDataJsonFile fp) = do hoistEither . first ScriptDataErrorJsonBytes $ scriptDataJsonToHashable ScriptDataJsonDetailedSchema sDataValue - readScriptDataOrFile (ScriptDataCborFile fp) = do origBs <- handleIOExceptT (ScriptDataErrorFile . FileIOError fp) (BS.readFile fp) - hSd <- firstExceptT (ScriptDataErrorMetadataDecode fp) - $ hoistEither $ deserialiseFromCBOR AsHashableScriptData origBs - firstExceptT (ScriptDataErrorValidation fp) - $ hoistEither $ validateScriptData $ getScriptData hSd + hSd <- + firstExceptT (ScriptDataErrorMetadataDecode fp) $ + hoistEither $ + deserialiseFromCBOR AsHashableScriptData origBs + firstExceptT (ScriptDataErrorValidation fp) $ + hoistEither $ + validateScriptData $ + getScriptData hSd return hSd readVerificationKeyOrHashOrFileOrScript @@ -459,53 +524,52 @@ readVerificationKeySource asType extractHash = \case -- wrapping the binary representation of any of the supported script languages, -- or alternatively it can be a JSON format file for one of the simple script -- language versions. --- readFileScriptInAnyLang :: MonadIOTransError (FileError ScriptDecodeError) t m => FilePath -> t m ScriptInAnyLang readFileScriptInAnyLang file = do scriptBytes <- handleIOExceptionsLiftWith (FileIOError file) . liftIO $ BS.readFile file - modifyError (FileError file) $ hoistEither $ - deserialiseScriptInAnyLang scriptBytes - + modifyError (FileError file) $ + hoistEither $ + deserialiseScriptInAnyLang scriptBytes -deserialiseScriptInAnyLang :: BS.ByteString - -> Either ScriptDecodeError ScriptInAnyLang +deserialiseScriptInAnyLang + :: BS.ByteString + -> Either ScriptDecodeError ScriptInAnyLang deserialiseScriptInAnyLang bs = - -- Accept either the text envelope format wrapping the binary serialisation, - -- or accept the simple script language in its JSON format. - -- - case deserialiseFromJSON AsTextEnvelope bs of - Left _ -> - -- In addition to the TextEnvelope format, we also try to - -- deserialize the JSON representation of SimpleScripts. - case Aeson.eitherDecodeStrict' bs of - Left err -> Left (ScriptDecodeSimpleScriptError $ JsonDecodeError err) - Right script -> Right $ ScriptInAnyLang SimpleScriptLanguage $ SimpleScript script - - Right te -> - case deserialiseFromTextEnvelopeAnyOf textEnvTypes te of - Left err -> Left (ScriptDecodeTextEnvelopeError err) - Right script -> Right script - - where - -- TODO: Think of a way to get type checker to warn when there is a missing - -- script version. - textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang] - textEnvTypes = - [ FromSomeType (AsScript AsSimpleScript) - (ScriptInAnyLang SimpleScriptLanguage) - - , FromSomeType (AsScript AsPlutusScriptV1) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1)) - - , FromSomeType (AsScript AsPlutusScriptV2) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2)) - - , FromSomeType (AsScript AsPlutusScriptV3) - (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) - ] + -- Accept either the text envelope format wrapping the binary serialisation, + -- or accept the simple script language in its JSON format. + -- + case deserialiseFromJSON AsTextEnvelope bs of + Left _ -> + -- In addition to the TextEnvelope format, we also try to + -- deserialize the JSON representation of SimpleScripts. + case Aeson.eitherDecodeStrict' bs of + Left err -> Left (ScriptDecodeSimpleScriptError $ JsonDecodeError err) + Right script -> Right $ ScriptInAnyLang SimpleScriptLanguage $ SimpleScript script + Right te -> + case deserialiseFromTextEnvelopeAnyOf textEnvTypes te of + Left err -> Left (ScriptDecodeTextEnvelopeError err) + Right script -> Right script + where + -- TODO: Think of a way to get type checker to warn when there is a missing + -- script version. + textEnvTypes :: [FromSomeType HasTextEnvelope ScriptInAnyLang] + textEnvTypes = + [ FromSomeType + (AsScript AsSimpleScript) + (ScriptInAnyLang SimpleScriptLanguage) + , FromSomeType + (AsScript AsPlutusScriptV1) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV1)) + , FromSomeType + (AsScript AsPlutusScriptV2) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV2)) + , FromSomeType + (AsScript AsPlutusScriptV3) + (ScriptInAnyLang (PlutusScriptLanguage PlutusScriptV3)) + ] -- Tx & TxBody @@ -520,8 +584,8 @@ readFileTx file = do InAnyShelleyBasedEra sbe tx <- pure $ unCddlTx cddlTx return $ Right $ inAnyShelleyBasedEra sbe tx -newtype IncompleteCddlTxBody = - IncompleteCddlTxBody { unIncompleteCddlTxBody :: InAnyShelleyBasedEra TxBody } +newtype IncompleteCddlTxBody + = IncompleteCddlTxBody {unIncompleteCddlTxBody :: InAnyShelleyBasedEra TxBody} readFileTxBody :: FileOrPipe -> IO (Either (FileError TextEnvelopeCddlError) IncompleteCddlTxBody) readFileTxBody file = do @@ -532,45 +596,51 @@ readFileTxBody file = do InAnyShelleyBasedEra sbe tx <- pure $ unCddlTx cddlTx return $ Right $ IncompleteCddlTxBody $ inAnyShelleyBasedEra sbe $ getTxBody tx -data CddlError = CddlErrorTextEnv - !(FileError TextEnvelopeError) - !(FileError TextEnvelopeCddlError) - | CddlIOError (FileError TextEnvelopeError) - deriving Show +data CddlError + = CddlErrorTextEnv + !(FileError TextEnvelopeError) + !(FileError TextEnvelopeCddlError) + | CddlIOError (FileError TextEnvelopeError) + deriving Show instance Error CddlError where prettyError = \case CddlErrorTextEnv textEnvErr cddlErr -> - "Failed to decode the ledger's CDDL serialisation format. " <> - "TextEnvelope error: " <> prettyError textEnvErr <> "\n" <> - "TextEnvelopeCddl error: " <> prettyError cddlErr + "Failed to decode the ledger's CDDL serialisation format. " + <> "TextEnvelope error: " + <> prettyError textEnvErr + <> "\n" + <> "TextEnvelopeCddl error: " + <> prettyError cddlErr CddlIOError e -> prettyError e readCddlTx :: FileOrPipe -> IO (Either (FileError TextEnvelopeCddlError) CddlTx) readCddlTx = readFileOrPipeTextEnvelopeCddlAnyOf teTypes where - teTypes = [ FromCDDLTx "Witnessed Tx ShelleyEra" CddlTx - , FromCDDLTx "Witnessed Tx AllegraEra" CddlTx - , FromCDDLTx "Witnessed Tx MaryEra" CddlTx - , FromCDDLTx "Witnessed Tx AlonzoEra" CddlTx - , FromCDDLTx "Witnessed Tx BabbageEra" CddlTx - , FromCDDLTx "Witnessed Tx ConwayEra" CddlTx - , FromCDDLTx "Unwitnessed Tx ByronEra" CddlTx - , FromCDDLTx "Unwitnessed Tx ShelleyEra" CddlTx - , FromCDDLTx "Unwitnessed Tx AllegraEra" CddlTx - , FromCDDLTx "Unwitnessed Tx MaryEra" CddlTx - , FromCDDLTx "Unwitnessed Tx AlonzoEra" CddlTx - , FromCDDLTx "Unwitnessed Tx BabbageEra" CddlTx - , FromCDDLTx "Unwitnessed Tx ConwayEra" CddlTx - ] + teTypes = + [ FromCDDLTx "Witnessed Tx ShelleyEra" CddlTx + , FromCDDLTx "Witnessed Tx AllegraEra" CddlTx + , FromCDDLTx "Witnessed Tx MaryEra" CddlTx + , FromCDDLTx "Witnessed Tx AlonzoEra" CddlTx + , FromCDDLTx "Witnessed Tx BabbageEra" CddlTx + , FromCDDLTx "Witnessed Tx ConwayEra" CddlTx + , FromCDDLTx "Unwitnessed Tx ByronEra" CddlTx + , FromCDDLTx "Unwitnessed Tx ShelleyEra" CddlTx + , FromCDDLTx "Unwitnessed Tx AllegraEra" CddlTx + , FromCDDLTx "Unwitnessed Tx MaryEra" CddlTx + , FromCDDLTx "Unwitnessed Tx AlonzoEra" CddlTx + , FromCDDLTx "Unwitnessed Tx BabbageEra" CddlTx + , FromCDDLTx "Unwitnessed Tx ConwayEra" CddlTx + ] -- Tx witnesses -newtype CddlWitness = CddlWitness { unCddlWitness :: InAnyShelleyBasedEra KeyWitness} +newtype CddlWitness = CddlWitness {unCddlWitness :: InAnyShelleyBasedEra KeyWitness} -readFileTxKeyWitness :: FilePath - -> IO (Either CddlWitnessError (InAnyShelleyBasedEra KeyWitness)) +readFileTxKeyWitness + :: FilePath + -> IO (Either CddlWitnessError (InAnyShelleyBasedEra KeyWitness)) readFileTxKeyWitness fp = do file <- fileOrPipe fp eWitness <- readFileInAnyShelleyBasedEra AsKeyWitness file @@ -588,12 +658,14 @@ data CddlWitnessError instance Error CddlWitnessError where prettyError = \case CddlWitnessErrorTextEnv teErr cddlErr -> - "Failed to decode the ledger's CDDL serialisation format. TextEnvelope error: " <> - prettyError teErr <> "\n" <> "TextEnvelopeCddl error: " <> prettyError cddlErr + "Failed to decode the ledger's CDDL serialisation format. TextEnvelope error: " + <> prettyError teErr + <> "\n" + <> "TextEnvelopeCddl error: " + <> prettyError cddlErr CddlWitnessIOError fileE -> prettyError fileE - -- TODO: This is a stop gap to avoid modifying the TextEnvelope -- related functions. We intend to remove this after fully deprecating -- the cli's serialisation format @@ -618,37 +690,37 @@ readCddlWitness readCddlWitness fp = do readFileTextEnvelopeCddlAnyOf teTypes fp where - teTypes = [ FromCDDLWitness "TxWitness ShelleyEra" CddlWitness - , FromCDDLWitness "TxWitness AllegraEra" CddlWitness - , FromCDDLWitness "TxWitness MaryEra" CddlWitness - , FromCDDLWitness "TxWitness AlonzoEra" CddlWitness - , FromCDDLWitness "TxWitness BabbageEra" CddlWitness - , FromCDDLWitness "TxWitness ConwayEra" CddlWitness - ] + teTypes = + [ FromCDDLWitness "TxWitness ShelleyEra" CddlWitness + , FromCDDLWitness "TxWitness AllegraEra" CddlWitness + , FromCDDLWitness "TxWitness MaryEra" CddlWitness + , FromCDDLWitness "TxWitness AlonzoEra" CddlWitness + , FromCDDLWitness "TxWitness BabbageEra" CddlWitness + , FromCDDLWitness "TxWitness ConwayEra" CddlWitness + ] -- Witness handling data SomeSigningWitness - = AByronSigningWitness (SigningKey ByronKey) (Maybe (Address ByronAddr)) - | APaymentSigningWitness (SigningKey PaymentKey) - | APaymentExtendedSigningWitness (SigningKey PaymentExtendedKey) - | AStakeSigningWitness (SigningKey StakeKey) - | AStakeExtendedSigningWitness (SigningKey StakeExtendedKey) - | AStakePoolSigningWitness (SigningKey StakePoolKey) - | AGenesisSigningWitness (SigningKey GenesisKey) - | AGenesisExtendedSigningWitness (SigningKey GenesisExtendedKey) - | AGenesisDelegateSigningWitness (SigningKey GenesisDelegateKey) - | AGenesisDelegateExtendedSigningWitness (SigningKey GenesisDelegateExtendedKey) - | AGenesisUTxOSigningWitness (SigningKey GenesisUTxOKey) - | ADRepSigningWitness (SigningKey DRepKey) - | ADRepExtendedSigningWitness (SigningKey DRepExtendedKey) - | ACommitteeColdSigningWitness (SigningKey CommitteeColdKey) - | ACommitteeColdExtendedSigningWitness (SigningKey CommitteeColdExtendedKey) - | ACommitteeHotSigningWitness (SigningKey CommitteeHotKey) - | ACommitteeHotExtendedSigningWitness (SigningKey CommitteeHotExtendedKey) + = AByronSigningWitness (SigningKey ByronKey) (Maybe (Address ByronAddr)) + | APaymentSigningWitness (SigningKey PaymentKey) + | APaymentExtendedSigningWitness (SigningKey PaymentExtendedKey) + | AStakeSigningWitness (SigningKey StakeKey) + | AStakeExtendedSigningWitness (SigningKey StakeExtendedKey) + | AStakePoolSigningWitness (SigningKey StakePoolKey) + | AGenesisSigningWitness (SigningKey GenesisKey) + | AGenesisExtendedSigningWitness (SigningKey GenesisExtendedKey) + | AGenesisDelegateSigningWitness (SigningKey GenesisDelegateKey) + | AGenesisDelegateExtendedSigningWitness (SigningKey GenesisDelegateExtendedKey) + | AGenesisUTxOSigningWitness (SigningKey GenesisUTxOKey) + | ADRepSigningWitness (SigningKey DRepKey) + | ADRepExtendedSigningWitness (SigningKey DRepExtendedKey) + | ACommitteeColdSigningWitness (SigningKey CommitteeColdKey) + | ACommitteeColdExtendedSigningWitness (SigningKey CommitteeColdExtendedKey) + | ACommitteeHotSigningWitness (SigningKey CommitteeHotKey) + | ACommitteeHotExtendedSigningWitness (SigningKey CommitteeHotExtendedKey) deriving Show - -- | Data required for constructing a Shelley bootstrap witness. data ShelleyBootstrapWitnessSigningKeyData = ShelleyBootstrapWitnessSigningKeyData @@ -668,29 +740,29 @@ data ByronOrShelleyWitness categoriseSomeSigningWitness :: SomeSigningWitness -> ByronOrShelleyWitness categoriseSomeSigningWitness swsk = case swsk of - AByronSigningWitness sk addr -> AByronWitness (ShelleyBootstrapWitnessSigningKeyData sk addr) - APaymentSigningWitness sk -> AShelleyKeyWitness (WitnessPaymentKey sk) - APaymentExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessPaymentExtendedKey sk) - AStakeSigningWitness sk -> AShelleyKeyWitness (WitnessStakeKey sk) - AStakeExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessStakeExtendedKey sk) - AStakePoolSigningWitness sk -> AShelleyKeyWitness (WitnessStakePoolKey sk) - AGenesisSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisKey sk) - AGenesisExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisExtendedKey sk) - AGenesisDelegateSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisDelegateKey sk) - AGenesisDelegateExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisDelegateExtendedKey sk) - AGenesisUTxOSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisUTxOKey sk) - ADRepSigningWitness sk -> AShelleyKeyWitness (WitnessDRepKey sk) - ADRepExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessDRepExtendedKey sk) - ACommitteeColdSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeColdKey sk) - ACommitteeColdExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeColdExtendedKey sk) - ACommitteeHotSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeHotKey sk) - ACommitteeHotExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeHotExtendedKey sk) + AByronSigningWitness sk addr -> AByronWitness (ShelleyBootstrapWitnessSigningKeyData sk addr) + APaymentSigningWitness sk -> AShelleyKeyWitness (WitnessPaymentKey sk) + APaymentExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessPaymentExtendedKey sk) + AStakeSigningWitness sk -> AShelleyKeyWitness (WitnessStakeKey sk) + AStakeExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessStakeExtendedKey sk) + AStakePoolSigningWitness sk -> AShelleyKeyWitness (WitnessStakePoolKey sk) + AGenesisSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisKey sk) + AGenesisExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisExtendedKey sk) + AGenesisDelegateSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisDelegateKey sk) + AGenesisDelegateExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisDelegateExtendedKey sk) + AGenesisUTxOSigningWitness sk -> AShelleyKeyWitness (WitnessGenesisUTxOKey sk) + ADRepSigningWitness sk -> AShelleyKeyWitness (WitnessDRepKey sk) + ADRepExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessDRepExtendedKey sk) + ACommitteeColdSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeColdKey sk) + ACommitteeColdExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeColdExtendedKey sk) + ACommitteeHotSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeHotKey sk) + ACommitteeHotExtendedSigningWitness sk -> AShelleyKeyWitness (WitnessCommitteeHotExtendedKey sk) data ReadWitnessSigningDataError = ReadWitnessSigningDataSigningKeyDecodeError !(FileError InputDecodeError) | ReadWitnessSigningDataScriptError !(FileError JsonDecodeError) - | ReadWitnessSigningDataSigningKeyAndAddressMismatch - -- ^ A Byron address was specified alongside a non-Byron signing key. + | -- | A Byron address was specified alongside a non-Byron signing key. + ReadWitnessSigningDataSigningKeyAndAddressMismatch deriving Show -- | Render an error message for a 'ReadWitnessSigningDataError'. @@ -707,47 +779,48 @@ readWitnessSigningData :: WitnessSigningData -> IO (Either ReadWitnessSigningDataError SomeSigningWitness) readWitnessSigningData (KeyWitnessSigningData skFile mbByronAddr) = do - eRes <- first ReadWitnessSigningDataSigningKeyDecodeError - <$> readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile - return $ do - res <- eRes - case (res, mbByronAddr) of - (AByronSigningWitness _ _, Just _) -> pure res - (AByronSigningWitness _ _, Nothing) -> pure res - (_, Nothing) -> pure res - (_, Just _) -> - -- A Byron address should only be specified along with a Byron signing key. - Left ReadWitnessSigningDataSigningKeyAndAddressMismatch - where - -- If you update these variables, consider updating the ones with the same - -- names in Cardano.CLI.Types.Key - textEnvFileTypes = - [ FromSomeType (AsSigningKey AsByronKey ) (`AByronSigningWitness` mbByronAddr) - , FromSomeType (AsSigningKey AsPaymentKey ) APaymentSigningWitness - , FromSomeType (AsSigningKey AsPaymentExtendedKey ) APaymentExtendedSigningWitness - , FromSomeType (AsSigningKey AsStakeKey ) AStakeSigningWitness - , FromSomeType (AsSigningKey AsStakeExtendedKey ) AStakeExtendedSigningWitness - , FromSomeType (AsSigningKey AsStakePoolKey ) AStakePoolSigningWitness - , FromSomeType (AsSigningKey AsGenesisKey ) AGenesisSigningWitness - , FromSomeType (AsSigningKey AsGenesisExtendedKey ) AGenesisExtendedSigningWitness - , FromSomeType (AsSigningKey AsGenesisDelegateKey ) AGenesisDelegateSigningWitness - , FromSomeType (AsSigningKey AsGenesisDelegateExtendedKey ) AGenesisDelegateExtendedSigningWitness - , FromSomeType (AsSigningKey AsGenesisUTxOKey ) AGenesisUTxOSigningWitness - , FromSomeType (AsSigningKey AsDRepKey ) ADRepSigningWitness - , FromSomeType (AsSigningKey AsDRepExtendedKey ) ADRepExtendedSigningWitness - , FromSomeType (AsSigningKey AsCommitteeColdKey ) ACommitteeColdSigningWitness - , FromSomeType (AsSigningKey AsCommitteeColdExtendedKey ) ACommitteeColdExtendedSigningWitness - , FromSomeType (AsSigningKey AsCommitteeHotKey ) ACommitteeHotSigningWitness - , FromSomeType (AsSigningKey AsCommitteeHotExtendedKey ) ACommitteeHotExtendedSigningWitness - ] - - bech32FileTypes = - [ FromSomeType (AsSigningKey AsPaymentKey ) APaymentSigningWitness - , FromSomeType (AsSigningKey AsPaymentExtendedKey ) APaymentExtendedSigningWitness - , FromSomeType (AsSigningKey AsStakeKey ) AStakeSigningWitness - , FromSomeType (AsSigningKey AsStakeExtendedKey ) AStakeExtendedSigningWitness - , FromSomeType (AsSigningKey AsStakePoolKey ) AStakePoolSigningWitness - ] + eRes <- + first ReadWitnessSigningDataSigningKeyDecodeError + <$> readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile + return $ do + res <- eRes + case (res, mbByronAddr) of + (AByronSigningWitness _ _, Just _) -> pure res + (AByronSigningWitness _ _, Nothing) -> pure res + (_, Nothing) -> pure res + (_, Just _) -> + -- A Byron address should only be specified along with a Byron signing key. + Left ReadWitnessSigningDataSigningKeyAndAddressMismatch + where + -- If you update these variables, consider updating the ones with the same + -- names in Cardano.CLI.Types.Key + textEnvFileTypes = + [ FromSomeType (AsSigningKey AsByronKey) (`AByronSigningWitness` mbByronAddr) + , FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningWitness + , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningWitness + , FromSomeType (AsSigningKey AsStakeKey) AStakeSigningWitness + , FromSomeType (AsSigningKey AsStakeExtendedKey) AStakeExtendedSigningWitness + , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningWitness + , FromSomeType (AsSigningKey AsGenesisKey) AGenesisSigningWitness + , FromSomeType (AsSigningKey AsGenesisExtendedKey) AGenesisExtendedSigningWitness + , FromSomeType (AsSigningKey AsGenesisDelegateKey) AGenesisDelegateSigningWitness + , FromSomeType (AsSigningKey AsGenesisDelegateExtendedKey) AGenesisDelegateExtendedSigningWitness + , FromSomeType (AsSigningKey AsGenesisUTxOKey) AGenesisUTxOSigningWitness + , FromSomeType (AsSigningKey AsDRepKey) ADRepSigningWitness + , FromSomeType (AsSigningKey AsDRepExtendedKey) ADRepExtendedSigningWitness + , FromSomeType (AsSigningKey AsCommitteeColdKey) ACommitteeColdSigningWitness + , FromSomeType (AsSigningKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedSigningWitness + , FromSomeType (AsSigningKey AsCommitteeHotKey) ACommitteeHotSigningWitness + , FromSomeType (AsSigningKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedSigningWitness + ] + + bech32FileTypes = + [ FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningWitness + , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningWitness + , FromSomeType (AsSigningKey AsStakeKey) AStakeSigningWitness + , FromSomeType (AsSigningKey AsStakeExtendedKey) AStakeExtendedSigningWitness + , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningWitness + ] -- Required signers @@ -766,7 +839,8 @@ instance Error RequiredSignerError where readRequiredSigner :: RequiredSigner -> IO (Either RequiredSignerError (Hash PaymentKey)) readRequiredSigner (RequiredSignerHash h) = return $ Right h readRequiredSigner (RequiredSignerSkeyFile skFile) = do - eKeyWit <- first RequiredSignerErrorFile <$> readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile + eKeyWit <- + first RequiredSignerErrorFile <$> readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile return $ do keyWit <- eKeyWit case categoriseSomeSigningWitness keyWit of @@ -775,21 +849,21 @@ readRequiredSigner (RequiredSignerSkeyFile skFile) = do AShelleyKeyWitness skey -> return . getHash $ toShelleySigningKey skey where - textEnvFileTypes = - [ FromSomeType (AsSigningKey AsPaymentKey ) APaymentSigningWitness - , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningWitness - , FromSomeType (AsSigningKey AsStakePoolKey ) AStakePoolSigningWitness - , FromSomeType (AsSigningKey AsGenesisDelegateKey) AGenesisDelegateSigningWitness - ] - bech32FileTypes = [] - - getHash :: ShelleySigningKey -> Hash PaymentKey - getHash (ShelleyExtendedSigningKey sk) = - let extSKey = PaymentExtendedSigningKey sk - payVKey = castVerificationKey $ getVerificationKey extSKey + textEnvFileTypes = + [ FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningWitness + , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningWitness + , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningWitness + , FromSomeType (AsSigningKey AsGenesisDelegateKey) AGenesisDelegateSigningWitness + ] + bech32FileTypes = [] + + getHash :: ShelleySigningKey -> Hash PaymentKey + getHash (ShelleyExtendedSigningKey sk) = + let extSKey = PaymentExtendedSigningKey sk + payVKey = castVerificationKey $ getVerificationKey extSKey in verificationKeyHash payVKey - getHash (ShelleyNormalSigningKey sk) = - verificationKeyHash . getVerificationKey $ PaymentSigningKey sk + getHash (ShelleyNormalSigningKey sk) = + verificationKeyHash . getVerificationKey $ PaymentSigningKey sk data VoteError = VoteErrorFile (FileError TextEnvelopeError) @@ -814,8 +888,8 @@ readVotingProceduresFiles w = \case [] -> return $ return [] files -> runExceptT $ forM files (ExceptT . readSingleVote w) - -readTxUpdateProposal :: () +readTxUpdateProposal + :: () => ShelleyToBabbageEra era -> UpdateProposalFile -> ExceptT (FileError TextEnvelopeError) IO (TxUpdateProposal era) @@ -827,20 +901,23 @@ readTxUpdateProposal w (UpdateProposalFile upFp) = do -- not read vote files with multiple votes in them because this will -- complicate the code further in terms of contructing the redeemer map -- when it comes to script witnessed votes. -readSingleVote :: () +readSingleVote + :: () => ConwayEraOnwards era -> (VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake)) -> IO (Either VoteError (VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))) readSingleVote w (voteFp, mScriptWitFiles) = do - votProceds <- conwayEraOnwardsConstraints w - $ first VoteErrorFile <$> readFileTextEnvelope AsVotingProcedures voteFp + votProceds <- + conwayEraOnwardsConstraints w $ + first VoteErrorFile <$> readFileTextEnvelope AsVotingProcedures voteFp case mScriptWitFiles of Nothing -> pure $ (,Nothing) <$> votProceds sWitFile -> do let sbe = conwayEraOnwardsToShelleyBasedEra w runExceptT $ do - sWits <- firstExceptT VoteErrorScriptWitness - $ mapM (readScriptWitness sbe) sWitFile + sWits <- + firstExceptT VoteErrorScriptWitness $ + mapM (readScriptWitness sbe) sWitFile hoistEither $ (,sWits) <$> votProceds data ConstitutionError @@ -862,8 +939,13 @@ readTxGovernanceActions -> IO (Either ProposalError [(Proposal era, Maybe (ScriptWitness WitCtxStake era))]) readTxGovernanceActions _ [] = return $ Right [] readTxGovernanceActions era files = runExceptT $ do - w <- forShelleyBasedEraMaybeEon era - & hoistMaybe (ProposalNotSupportedInEra $ cardanoEraConstraints (toCardanoEra era) $ AnyCardanoEra (toCardanoEra era)) + w <- + forShelleyBasedEraMaybeEon era + & hoistMaybe + ( ProposalNotSupportedInEra $ + cardanoEraConstraints (toCardanoEra era) $ + AnyCardanoEra (toCardanoEra era) + ) newExceptT $ sequence <$> mapM (readProposal w) files readProposal @@ -871,30 +953,31 @@ readProposal -> (ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake)) -> IO (Either ProposalError (Proposal era, Maybe (ScriptWitness WitCtxStake era))) readProposal w (fp, mScriptWit) = do - prop <- conwayEraOnwardsConstraints w - $ first ProposalErrorFile <$> readFileTextEnvelope AsProposal fp - case mScriptWit of - Nothing -> pure $ (,Nothing) <$> prop - sWitFile -> do - let sbe = conwayEraOnwardsToShelleyBasedEra w - runExceptT $ do - sWit <- firstExceptT ProposalErrorScriptWitness - $ mapM (readScriptWitness sbe) sWitFile - hoistEither $ (,sWit) <$> prop - -constitutionHashSourceToHash :: () + prop <- + conwayEraOnwardsConstraints w $ + first ProposalErrorFile <$> readFileTextEnvelope AsProposal fp + case mScriptWit of + Nothing -> pure $ (,Nothing) <$> prop + sWitFile -> do + let sbe = conwayEraOnwardsToShelleyBasedEra w + runExceptT $ do + sWit <- + firstExceptT ProposalErrorScriptWitness $ + mapM (readScriptWitness sbe) sWitFile + hoistEither $ (,sWit) <$> prop + +constitutionHashSourceToHash + :: () => ConstitutionHashSource -> ExceptT ConstitutionError IO (L.SafeHash L.StandardCrypto L.AnchorData) constitutionHashSourceToHash constitutionHashSource = do case constitutionHashSource of - ConstitutionHashSourceFile fp -> do + ConstitutionHashSourceFile fp -> do cBs <- liftIO $ BS.readFile $ unFile fp _utf8EncodedText <- firstExceptT ConstitutionNotUnicodeError . hoistEither $ Text.decodeUtf8' cBs pure $ L.hashAnchorData $ L.AnchorData cBs - ConstitutionHashSourceText c -> do pure $ L.hashAnchorData $ L.AnchorData $ Text.encodeUtf8 c - ConstitutionHashSourceHash h -> pure h @@ -912,23 +995,23 @@ instance Error CostModelsError where "Error decoding JSON cost model at " <> pshow fp <> ": " <> pretty err <> formatExplanation CostModelsErrorEmpty fp -> "The decoded cost model was empty at: " <> pshow fp <> formatExplanation - where - formatExplanation = - vsep [ "" - , "The expected format of the cost models file is " - , "{" - , " \"PlutusV1\" : ," - , " \"PlutusV2\" : ," - , " \"PlutusV3\" : ," - , "}" - , "where each of the three entries may be ommited, and a is either an ordered list of parameter values like" - , "[205665, 812, 1, ...]" - , "or a map like" - , "{ \"addInteger-cpu-arguments-intercept\": 205665, \"addInteger-cpu-arguments-slope\": 812, \"addInteger-memory-arguments-intercept\": 1, ... }" - , "In both cases, the cost model must be complete, i.e. it must specify all parameters that are needed for the specific Plutus version." - , "It's not specified what will happen if you provide more parameters than necessary." - ] - + where + formatExplanation = + vsep + [ "" + , "The expected format of the cost models file is " + , "{" + , " \"PlutusV1\" : ," + , " \"PlutusV2\" : ," + , " \"PlutusV3\" : ," + , "}" + , "where each of the three entries may be ommited, and a is either an ordered list of parameter values like" + , "[205665, 812, 1, ...]" + , "or a map like" + , "{ \"addInteger-cpu-arguments-intercept\": 205665, \"addInteger-cpu-arguments-slope\": 812, \"addInteger-memory-arguments-intercept\": 1, ... }" + , "In both cases, the cost model must be complete, i.e. it must specify all parameters that are needed for the specific Plutus version." + , "It's not specified what will happen if you provide more parameters than necessary." + ] readCostModels :: File L.CostModels In @@ -953,14 +1036,14 @@ readFileInAnyShelleyBasedEra -> FileOrPipe -> IO (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra thing)) readFileInAnyShelleyBasedEra asThing = - readFileOrPipeTextEnvelopeAnyOf - [ FromSomeType (asThing AsShelleyEra) (InAnyShelleyBasedEra ShelleyBasedEraShelley) - , FromSomeType (asThing AsAllegraEra) (InAnyShelleyBasedEra ShelleyBasedEraAllegra) - , FromSomeType (asThing AsMaryEra) (InAnyShelleyBasedEra ShelleyBasedEraMary) - , FromSomeType (asThing AsAlonzoEra) (InAnyShelleyBasedEra ShelleyBasedEraAlonzo) - , FromSomeType (asThing AsBabbageEra) (InAnyShelleyBasedEra ShelleyBasedEraBabbage) - , FromSomeType (asThing AsConwayEra) (InAnyShelleyBasedEra ShelleyBasedEraConway) - ] + readFileOrPipeTextEnvelopeAnyOf + [ FromSomeType (asThing AsShelleyEra) (InAnyShelleyBasedEra ShelleyBasedEraShelley) + , FromSomeType (asThing AsAllegraEra) (InAnyShelleyBasedEra ShelleyBasedEraAllegra) + , FromSomeType (asThing AsMaryEra) (InAnyShelleyBasedEra ShelleyBasedEraMary) + , FromSomeType (asThing AsAlonzoEra) (InAnyShelleyBasedEra ShelleyBasedEraAlonzo) + , FromSomeType (asThing AsBabbageEra) (InAnyShelleyBasedEra ShelleyBasedEraBabbage) + , FromSomeType (asThing AsConwayEra) (InAnyShelleyBasedEra ShelleyBasedEraConway) + ] -- | We need a type for handling files that may be actually be things like -- pipes. Currently the CLI makes no guarantee that a "file" will only @@ -971,9 +1054,8 @@ readFileInAnyShelleyBasedEra asThing = -- from pipes, but at present that's not an issue. data FileOrPipe = FileOrPipe FilePath (IORef (Maybe LBS.ByteString)) - instance Show FileOrPipe where - show (FileOrPipe fp _) = show fp + show (FileOrPipe fp _) = show fp fileOrPipe :: FilePath -> IO FileOrPipe fileOrPipe fp = FileOrPipe fp <$> newIORef Nothing @@ -991,39 +1073,41 @@ fileOrPipeCache (FileOrPipe _ c) = readIORef c -- contents of the file or pipe, and is blocking. readFileOrPipe :: FileOrPipe -> IO LBS.ByteString readFileOrPipe (FileOrPipe fp cacheRef) = do - cached <- readIORef cacheRef - case cached of - Just dat -> pure dat - Nothing -> bracket + cached <- readIORef cacheRef + case cached of + Just dat -> pure dat + Nothing -> + bracket (openFileBlocking fp ReadMode) hClose - (\handle -> do - -- An arbitrary block size. - let blockSize = 4096 - let go acc = do - next <- BS.hGet handle blockSize - if BS.null next - then pure acc - else go (acc <> Builder.byteString next) - contents <- go mempty - let dat = Builder.toLazyByteString contents - -- If our file is not seekable, it's likely a pipe, so we need to - -- save the result for subsequent calls - seekable <- hIsSeekable handle - unless seekable (writeIORef cacheRef (Just dat)) - pure dat) + ( \handle -> do + -- An arbitrary block size. + let blockSize = 4096 + let go acc = do + next <- BS.hGet handle blockSize + if BS.null next + then pure acc + else go (acc <> Builder.byteString next) + contents <- go mempty + let dat = Builder.toLazyByteString contents + -- If our file is not seekable, it's likely a pipe, so we need to + -- save the result for subsequent calls + seekable <- hIsSeekable handle + unless seekable (writeIORef cacheRef (Just dat)) + pure dat + ) readFileOrPipeTextEnvelopeAnyOf :: [FromSomeType HasTextEnvelope b] -> FileOrPipe -> IO (Either (FileError TextEnvelopeError) b) readFileOrPipeTextEnvelopeAnyOf types file = do - let path = fileOrPipePath file - runExceptT $ do - content <- handleIOExceptT (FileIOError path) $ readFileOrPipe file - firstExceptT (FileError path) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecode' content - deserialiseFromTextEnvelopeAnyOf types te + let path = fileOrPipePath file + runExceptT $ do + content <- handleIOExceptT (FileIOError path) $ readFileOrPipe file + firstExceptT (FileError path) $ hoistEither $ do + te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecode' content + deserialiseFromTextEnvelopeAnyOf types te readFileOrPipeTextEnvelopeCddlAnyOf :: [FromSomeTypeCDDL TextEnvelope b] @@ -1042,14 +1126,17 @@ readTextEnvelopeCddlFromFileOrPipe readTextEnvelopeCddlFromFileOrPipe file = do let path = fileOrPipePath file runExceptT $ do - bs <- handleIOExceptT (FileIOError path) $ - readFileOrPipe file + bs <- + handleIOExceptT (FileIOError path) $ + readFileOrPipe file firstExceptT (FileError path . TextEnvelopeCddlAesonDecodeError path) - . hoistEither $ Aeson.eitherDecode' bs + . hoistEither + $ Aeson.eitherDecode' bs ---------------------------------------------------------------------------------------------------- -getStakeCredentialFromVerifier :: () +getStakeCredentialFromVerifier + :: () => StakeVerifier -> ExceptT StakeCredentialError IO StakeCredential getStakeCredentialFromVerifier = \case @@ -1058,27 +1145,30 @@ getStakeCredentialFromVerifier = \case readFileScriptInAnyLang sFile & firstExceptT StakeCredentialScriptDecodeError pure $ StakeCredentialByScript $ hashScript script - StakeVerifierKey stakeVerKeyOrFile -> do - stakeVerKeyHash <- modifyError StakeCredentialInputDecodeError $ - readVerificationKeyOrHashOrFile AsStakeKey stakeVerKeyOrFile + stakeVerKeyHash <- + modifyError StakeCredentialInputDecodeError $ + readVerificationKeyOrHashOrFile AsStakeKey stakeVerKeyOrFile pure $ StakeCredentialByKey stakeVerKeyHash -getStakeCredentialFromIdentifier :: () +getStakeCredentialFromIdentifier + :: () => StakeIdentifier -> ExceptT StakeCredentialError IO StakeCredential getStakeCredentialFromIdentifier = \case StakeIdentifierAddress stakeAddr -> pure $ stakeAddressCredential stakeAddr StakeIdentifierVerifier stakeVerifier -> getStakeCredentialFromVerifier stakeVerifier -getStakeAddressFromVerifier :: () +getStakeAddressFromVerifier + :: () => NetworkId -> StakeVerifier -> ExceptT StakeCredentialError IO StakeAddress getStakeAddressFromVerifier networkId stakeVerifier = makeStakeAddress networkId <$> getStakeCredentialFromVerifier stakeVerifier -getDRepCredentialFromVerKeyHashOrFile :: () +getDRepCredentialFromVerKeyHashOrFile + :: () => MonadIOTransError (FileError InputDecodeError) t m => VerificationKeyOrHashOrFile DRepKey -> t m (L.Credential L.DRepRole L.StandardCrypto) @@ -1099,7 +1189,8 @@ renderReadSafeHashError = \case ReadSafeHashErrorInvalidHash err -> "Error reading anchor data hash: " <> err -readHexAsSafeHash :: () +readHexAsSafeHash + :: () => Text -> Either ReadSafeHashError (L.SafeHash L.StandardCrypto L.AnchorData) readHexAsSafeHash hex = do @@ -1120,13 +1211,14 @@ readSafeHash = scriptHashReader :: Opt.ReadM ScriptHash scriptHashReader = Opt.eitherReader $ Right . fromString -readVoteDelegationTarget :: () +readVoteDelegationTarget + :: () => VoteDelegationTarget -> ExceptT DelegationError IO (L.DRep L.StandardCrypto) readVoteDelegationTarget voteDelegationTarget = case voteDelegationTarget of VoteDelegationTargetOfDRep drepHashSource -> - modifyError DelegationDRepReadError $ + modifyError DelegationDRepReadError $ L.DRepCredential <$> readDRepCredential drepHashSource VoteDelegationTargetOfAbstain -> pure L.DRepAlwaysAbstain diff --git a/cardano-cli/src/Cardano/CLI/Render.hs b/cardano-cli/src/Cardano/CLI/Render.hs index a52b8a2a25..2d35178cc6 100644 --- a/cardano-cli/src/Cardano/CLI/Render.hs +++ b/cardano-cli/src/Cardano/CLI/Render.hs @@ -2,7 +2,8 @@ module Cardano.CLI.Render ( customRenderHelp - ) where + ) +where import Cardano.Api (textShow) @@ -27,33 +28,37 @@ cliHelpTraceEnabled = IO.unsafePerformIO $ do -- tools can be used to inspect tracing that aids in describing the structure of the output -- document. customRenderHelp :: Int -> ParserHelp -> String -customRenderHelp = if cliHelpTraceEnabled - then customRenderHelpAsHtml - else customRenderHelpAsAnsi +customRenderHelp = + if cliHelpTraceEnabled + then customRenderHelpAsHtml + else customRenderHelpAsAnsi customRenderHelpAsHtml :: Int -> ParserHelp -> String -customRenderHelpAsHtml cols - = T.unpack - . wrapper - . renderSimplyDecorated id renderElement - . treeForm - . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0)) - . helpText - where - renderElement :: Ann -> Text -> Text - renderElement ann x = if cliHelpTraceEnabled +customRenderHelpAsHtml cols = + T.unpack + . wrapper + . renderSimplyDecorated id renderElement + . treeForm + . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0)) + . helpText + where + renderElement :: Ann -> Text -> Text + renderElement ann x = + if cliHelpTraceEnabled then case ann of AnnTrace _ name -> "" <> x <> "" AnnStyle _ -> x else x - wrapper = if cliHelpTraceEnabled - then id - . ("\n" <>) - . ("\n" <>) - . ("
\n" <>)
-        . (<> "\n")
-        . (<> "\n")
-        . (<> "\n
") + wrapper = + if cliHelpTraceEnabled + then + id + . ("\n" <>) + . ("\n" <>) + . ("
\n" <>)
+          . (<> "\n")
+          . (<> "\n")
+          . (<> "\n
") else id customRenderHelpAsAnsi :: Int -> ParserHelp -> String diff --git a/cardano-cli/src/Cardano/CLI/Run.hs b/cardano-cli/src/Cardano/CLI/Run.hs index 66a6e2d889..638bad7c7c 100644 --- a/cardano-cli/src/Cardano/CLI/Run.hs +++ b/cardano-cli/src/Cardano/CLI/Run.hs @@ -4,24 +4,25 @@ -- | Dispatch for running all the CLI commands module Cardano.CLI.Run - ( ClientCommand(..) + ( ClientCommand (..) , ClientCommandErrors , renderClientCommandError , runClientCommand - ) where + ) +where import Cardano.Api import Cardano.CLI.Byron.Run (ByronClientCmdError, renderByronClientCmdError, runByronClientCommand) import Cardano.CLI.Commands -import Cardano.CLI.Run.Hash (runHashCmds) import Cardano.CLI.EraBased.Commands import Cardano.CLI.EraBased.Run import Cardano.CLI.Legacy.Commands import Cardano.CLI.Legacy.Run (runLegacyCmds) import Cardano.CLI.Render (customRenderHelp) import Cardano.CLI.Run.Debug +import Cardano.CLI.Run.Hash (runHashCmds) import Cardano.CLI.Run.Ping (PingClientCmdError (..), renderPingClientCmdError, runPingCmd) import Cardano.CLI.Types.Errors.CmdError @@ -83,38 +84,46 @@ renderClientCommandError = \case runDisplayVersion :: ExceptT ClientCommandErrors IO () runDisplayVersion = do - liftIO . Text.putStrLn $ mconcat - [ "cardano-cli ", renderVersion version - , " - ", Text.pack os, "-", Text.pack arch - , " - ", Text.pack compilerName, "-", renderVersion compilerVersion - , "\ngit rev ", $(gitRev) - ] - where - renderVersion = Text.pack . showVersion - + liftIO . Text.putStrLn $ + mconcat + [ "cardano-cli " + , renderVersion version + , " - " + , Text.pack os + , "-" + , Text.pack arch + , " - " + , Text.pack compilerName + , "-" + , renderVersion compilerVersion + , "\ngit rev " + , $(gitRev) + ] + where + renderVersion = Text.pack . showVersion helpAll :: ParserPrefs -> String -> [String] -> ParserInfo a -> IO () helpAll pprefs progn rnames parserInfo = do IO.putStrLn $ customRenderHelp 80 (usage_help parserInfo) IO.putStrLn "" go (infoParser parserInfo) - where - go :: Parser a -> IO () - go p = case p of - NilP _ -> return () - OptP optP -> case optMain optP of - CmdReader _ cs -> do - forM_ cs $ \(c, subParserInfo) -> - helpAll pprefs progn (c:rnames) subParserInfo - _ -> return () - AltP pa pb -> go pa >> go pb - MultP pf px -> go pf >> go px - BindP pa _ -> go pa - usage_help i = - mconcat - [ usageHelp (pure . parserUsage pprefs (infoParser i) . L.unwords $ progn : reverse rnames) - , descriptionHelp (infoProgDesc i) - ] + where + go :: Parser a -> IO () + go p = case p of + NilP _ -> return () + OptP optP -> case optMain optP of + CmdReader _ cs -> do + forM_ cs $ \(c, subParserInfo) -> + helpAll pprefs progn (c : rnames) subParserInfo + _ -> return () + AltP pa pb -> go pa >> go pb + MultP pf px -> go pf >> go px + BindP pa _ -> go pa + usage_help i = + mconcat + [ usageHelp (pure . parserUsage pprefs (infoParser i) . L.unwords $ progn : reverse rnames) + , descriptionHelp (infoProgDesc i) + ] runHelp :: ParserPrefs -> ParserInfo a -> ExceptT ClientCommandErrors IO () runHelp pprefs allParserInfo = liftIO $ helpAll pprefs "cardano-cli" [] allParserInfo diff --git a/cardano-cli/src/Cardano/CLI/Run/Debug.hs b/cardano-cli/src/Cardano/CLI/Run/Debug.hs index 72353c82dc..3b45f9243a 100644 --- a/cardano-cli/src/Cardano/CLI/Run/Debug.hs +++ b/cardano-cli/src/Cardano/CLI/Run/Debug.hs @@ -1,11 +1,12 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Run.Debug - ( DebugCmdError(..) + ( DebugCmdError (..) , runLogEpochStateCmd , runDebugCmds , renderDebugCmdError - ) where + ) +where import Cardano.CLI.Commands.Debug import Cardano.CLI.Run.Debug.LogEpochState diff --git a/cardano-cli/src/Cardano/CLI/Run/Debug/LogEpochState.hs b/cardano-cli/src/Cardano/CLI/Run/Debug/LogEpochState.hs index af6106b8ed..d89e8a5d09 100644 --- a/cardano-cli/src/Cardano/CLI/Run/Debug/LogEpochState.hs +++ b/cardano-cli/src/Cardano/CLI/Run/Debug/LogEpochState.hs @@ -4,7 +4,8 @@ module Cardano.CLI.Run.Debug.LogEpochState ( runLogEpochStateCmd - ) where + ) +where import Cardano.Api import qualified Cardano.Api as Api @@ -20,25 +21,28 @@ runLogEpochStateCmd :: LogEpochStateCmdArgs -> IO () runLogEpochStateCmd - LogEpochStateCmdArgs - { nodeSocketPath - , configurationFile - , outputFilePath = File outputFilePath - } = do - LBS.appendFile outputFilePath "" + LogEpochStateCmdArgs + { nodeSocketPath + , configurationFile + , outputFilePath = File outputFilePath + } = do + LBS.appendFile outputFilePath "" - result <- runExceptT $ foldEpochState - configurationFile - nodeSocketPath - Api.QuickValidation - (EpochNo maxBound) - () - (\(AnyNewEpochState sbe nes) _ _ -> do - liftIO $ LBS.appendFile outputFilePath - $ shelleyBasedEraConstraints sbe (Aeson.encode nes) <> "\n" - pure ConditionNotMet - ) + result <- + runExceptT $ + foldEpochState + configurationFile + nodeSocketPath + Api.QuickValidation + (EpochNo maxBound) + () + ( \(AnyNewEpochState sbe nes) _ _ -> do + liftIO $ + LBS.appendFile outputFilePath $ + shelleyBasedEraConstraints sbe (Aeson.encode nes) <> "\n" + pure ConditionNotMet + ) - case result of - Right _ -> pure () - Left e -> IO.hPutStrLn IO.stderr $ "Error: " <> show e + case result of + Right _ -> pure () + Left e -> IO.hPutStrLn IO.stderr $ "Error: " <> show e diff --git a/cardano-cli/src/Cardano/CLI/Run/Hash.hs b/cardano-cli/src/Cardano/CLI/Run/Hash.hs index 99e50f2b4f..301df84fe2 100644 --- a/cardano-cli/src/Cardano/CLI/Run/Hash.hs +++ b/cardano-cli/src/Cardano/CLI/Run/Hash.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -9,7 +8,8 @@ module Cardano.CLI.Run.Hash ( runHashCmds - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -24,17 +24,19 @@ import Data.Function import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as Text -runHashCmds :: () +runHashCmds + :: () => Cmd.HashCmds -> ExceptT HashCmdError IO () runHashCmds = \case Cmd.HashAnchorDataCmd args -> runHashAnchorDataCmd args - Cmd.HashScriptCmd args -> runHashScriptCmd args + Cmd.HashScriptCmd args -> runHashScriptCmd args -runHashAnchorDataCmd :: () +runHashAnchorDataCmd + :: () => Cmd.HashAnchorDataCmdArgs -> ExceptT HashCmdError IO () -runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs { toHash, mOutFile } = +runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs{toHash, mOutFile} = case toHash of Cmd.AnchorDataHashSourceBinaryFile fp -> do let path = unFile fp @@ -49,22 +51,25 @@ runHashAnchorDataCmd Cmd.HashAnchorDataCmdArgs { toHash, mOutFile } = Cmd.AnchorDataHashSourceText text -> do let hash = L.hashAnchorData $ L.AnchorData $ Text.encodeUtf8 text writeHash hash - where - writeHash :: L.SafeHash L.StandardCrypto i -> ExceptT HashCmdError IO () - writeHash hash = do - firstExceptT HashWriteFileError $ - newExceptT $ writeTextOutput mOutFile text - where - text = hashToTextAsHex . L.extractHash $ hash + where + writeHash :: L.SafeHash L.StandardCrypto i -> ExceptT HashCmdError IO () + writeHash hash = do + firstExceptT HashWriteFileError $ + newExceptT $ + writeTextOutput mOutFile text + where + text = hashToTextAsHex . L.extractHash $ hash -runHashScriptCmd :: () +runHashScriptCmd + :: () => Cmd.HashScriptCmdArgs -> ExceptT HashCmdError IO () -runHashScriptCmd Cmd.HashScriptCmdArgs { Cmd.toHash = File toHash, mOutFile } = do +runHashScriptCmd Cmd.HashScriptCmdArgs{Cmd.toHash = File toHash, mOutFile} = do ScriptInAnyLang _ script <- readFileScriptInAnyLang toHash & firstExceptT (HashReadScriptError toHash) firstExceptT HashWriteFileError . newExceptT - . writeTextOutput mOutFile . serialiseToRawBytesHexText $ hashScript script - + . writeTextOutput mOutFile + . serialiseToRawBytesHexText + $ hashScript script diff --git a/cardano-cli/src/Cardano/CLI/Run/Ping.hs b/cardano-cli/src/Cardano/CLI/Run/Ping.hs index 8133aac498..6180963bf7 100644 --- a/cardano-cli/src/Cardano/CLI/Run/Ping.hs +++ b/cardano-cli/src/Cardano/CLI/Run/Ping.hs @@ -3,10 +3,11 @@ {- HLINT ignore "Move brackets to avoid $" -} module Cardano.CLI.Run.Ping - ( PingClientCmdError(..) + ( PingClientCmdError (..) , renderPingClientCmdError , runPingCmd - ) where + ) +where import Cardano.CLI.Commands.Ping import Cardano.CLI.Pretty @@ -40,22 +41,25 @@ maybeUnixSockEndPoint = \case HostEndPoint _ -> Nothing UnixSockEndPoint sock -> Just sock -pingClient :: Tracer IO CNP.LogMsg -> Tracer IO String -> PingCmd -> [CNP.NodeVersion] -> AddrInfo -> IO () +pingClient + :: Tracer IO CNP.LogMsg -> Tracer IO String -> PingCmd -> [CNP.NodeVersion] -> AddrInfo -> IO () pingClient stdout stderr cmd = CNP.pingClient stdout stderr opts - where opts = CNP.PingOpts - { CNP.pingOptsQuiet = pingCmdQuiet cmd - , CNP.pingOptsJson = pingCmdJson cmd - , CNP.pingOptsCount = pingCmdCount cmd - , CNP.pingOptsHost = maybeHostEndPoint (pingCmdEndPoint cmd) - , CNP.pingOptsUnixSock = maybeUnixSockEndPoint (pingCmdEndPoint cmd) - , CNP.pingOptsPort = pingCmdPort cmd - , CNP.pingOptsMagic = pingCmdMagic cmd - , CNP.pingOptsHandshakeQuery = pingOptsHandshakeQuery cmd - } + where + opts = + CNP.PingOpts + { CNP.pingOptsQuiet = pingCmdQuiet cmd + , CNP.pingOptsJson = pingCmdJson cmd + , CNP.pingOptsCount = pingCmdCount cmd + , CNP.pingOptsHost = maybeHostEndPoint (pingCmdEndPoint cmd) + , CNP.pingOptsUnixSock = maybeUnixSockEndPoint (pingCmdEndPoint cmd) + , CNP.pingOptsPort = pingCmdPort cmd + , CNP.pingOptsMagic = pingCmdMagic cmd + , CNP.pingOptsHandshakeQuery = pingOptsHandshakeQuery cmd + } runPingCmd :: PingCmd -> ExceptT PingClientCmdError IO () runPingCmd options = do - let hints = Socket.defaultHints { Socket.addrSocketType = Socket.Stream } + let hints = Socket.defaultHints{Socket.addrSocketType = Socket.Stream} msgQueue <- liftIO STM.newEmptyTMVarIO @@ -66,21 +70,28 @@ runPingCmd options = do addrs <- liftIO $ Socket.getAddrInfo (Just hints) (Just host) (Just (pingCmdPort options)) return (addrs, CNP.supportedNodeToNodeVersions $ pingCmdMagic options) UnixSockEndPoint fname -> do - let addr = Socket.AddrInfo - [] Socket.AF_UNIX Socket.Stream - Socket.defaultProtocol (Socket.SockAddrUnix fname) Nothing + let addr = + Socket.AddrInfo + [] + Socket.AF_UNIX + Socket.Stream + Socket.defaultProtocol + (Socket.SockAddrUnix fname) + Nothing return ([addr], CNP.supportedNodeToClientVersions $ pingCmdMagic options) -- Logger async thread handle laid <- liftIO . async $ CNP.logger msgQueue (pingCmdJson options) (pingOptsHandshakeQuery options) -- Ping client thread handles - caids <- forM addresses $ liftIO . async . pingClient (Tracer $ doLog msgQueue) (Tracer doErrLog) options versions + caids <- + forM addresses $ + liftIO . async . pingClient (Tracer $ doLog msgQueue) (Tracer doErrLog) options versions res <- L.zip addresses <$> mapM (liftIO . waitCatch) caids liftIO $ doLog msgQueue CNP.LogEnd liftIO $ wait laid -- Collect errors 'es' from failed pings and 'addrs' from successful pings. - let (es, addrs) = foldl' partition ([],[]) res + let (es, addrs) = foldl' partition ([], []) res -- Report any errors case (es, addrs) of @@ -89,19 +100,19 @@ runPingCmd options = do (_, _) -> do unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es liftIO IO.exitSuccess - - where - partition :: ([(AddrInfo, SomeException)], [AddrInfo]) - -> (AddrInfo, Either SomeException ()) - -> ([(AddrInfo, SomeException)], [AddrInfo]) - partition (es, as) (a, Left e) = ((a, e) : es, as) - partition (es, as) (a, Right _) = (es, a : as) - - doLog :: StrictTMVar IO CNP.LogMsg -> CNP.LogMsg -> IO () - doLog msgQueue msg = STM.atomically $ STM.putTMVar msgQueue msg - - doErrLog :: String -> IO () - doErrLog = IO.hPutStrLn IO.stderr + where + partition + :: ([(AddrInfo, SomeException)], [AddrInfo]) + -> (AddrInfo, Either SomeException ()) + -> ([(AddrInfo, SomeException)], [AddrInfo]) + partition (es, as) (a, Left e) = ((a, e) : es, as) + partition (es, as) (a, Right _) = (es, a : as) + + doLog :: StrictTMVar IO CNP.LogMsg -> CNP.LogMsg -> IO () + doLog msgQueue msg = STM.atomically $ STM.putTMVar msgQueue msg + + doErrLog :: String -> IO () + doErrLog = IO.hPutStrLn IO.stderr renderPingClientCmdError :: PingClientCmdError -> Doc ann renderPingClientCmdError = \case diff --git a/cardano-cli/src/Cardano/CLI/TopHandler.hs b/cardano-cli/src/Cardano/CLI/TopHandler.hs index 6192f3d836..2fd8d54e89 100644 --- a/cardano-cli/src/Cardano/CLI/TopHandler.hs +++ b/cardano-cli/src/Cardano/CLI/TopHandler.hs @@ -1,6 +1,7 @@ module Cardano.CLI.TopHandler ( toplevelExceptionHandler - ) where + ) +where -- The code in this module derives from multiple authors over many years. -- It is all under the BSD3 license below. @@ -51,7 +52,6 @@ import System.Environment import System.Exit import System.IO - -- | An exception handler to use for a program top level, as an alternative to -- the default top level handler provided by GHC. -- @@ -60,46 +60,45 @@ import System.IO -- > main :: IO () -- > main = toplevelExceptionHandler $ do -- > ... --- toplevelExceptionHandler :: IO a -> IO a toplevelExceptionHandler prog = do - -- Use line buffering in case we have to print big error messages, because - -- by default stderr to a terminal device is NoBuffering which is slow. - hSetBuffering stderr LineBuffering - catches prog [ - Handler rethrowAsyncExceptions - , Handler rethrowExitCode - , Handler handleSomeException - ] - where - -- Let async exceptions rise to the top for the default GHC top-handler. - -- This includes things like CTRL-C. - rethrowAsyncExceptions :: SomeAsyncException -> IO a - rethrowAsyncExceptions = throwIO - - -- We don't want to print ExitCode, and it should be handled by the default - -- top handler because that sets the actual OS process exit code. - rethrowExitCode :: ExitCode -> IO a - rethrowExitCode = throwIO + -- Use line buffering in case we have to print big error messages, because + -- by default stderr to a terminal device is NoBuffering which is slow. + hSetBuffering stderr LineBuffering + catches + prog + [ Handler rethrowAsyncExceptions + , Handler rethrowExitCode + , Handler handleSomeException + ] + where + -- Let async exceptions rise to the top for the default GHC top-handler. + -- This includes things like CTRL-C. + rethrowAsyncExceptions :: SomeAsyncException -> IO a + rethrowAsyncExceptions = throwIO - -- Print all other exceptions - handleSomeException :: SomeException -> IO a - handleSomeException e = do - hFlush stdout - progname <- getProgName - hPutStr stderr (renderSomeException progname e) - throwIO (ExitFailure 1) + -- We don't want to print ExitCode, and it should be handled by the default + -- top handler because that sets the actual OS process exit code. + rethrowExitCode :: ExitCode -> IO a + rethrowExitCode = throwIO - -- Print the human-readable output of 'displayException' if it differs - -- from the default output (of 'show'), so that the user/sysadmin - -- sees something readable in the log. - renderSomeException :: String -> SomeException -> String - renderSomeException progname e - | showOutput /= displayOutput - = showOutput ++ "\n\n" ++ progname ++ ": " ++ displayOutput + -- Print all other exceptions + handleSomeException :: SomeException -> IO a + handleSomeException e = do + hFlush stdout + progname <- getProgName + hPutStr stderr (renderSomeException progname e) + throwIO (ExitFailure 1) - | otherwise - = "\n" ++ progname ++ ": " ++ showOutput - where - showOutput = show e - displayOutput = displayException e + -- Print the human-readable output of 'displayException' if it differs + -- from the default output (of 'show'), so that the user/sysadmin + -- sees something readable in the log. + renderSomeException :: String -> SomeException -> String + renderSomeException progname e + | showOutput /= displayOutput = + showOutput ++ "\n\n" ++ progname ++ ": " ++ displayOutput + | otherwise = + "\n" ++ progname ++ ": " ++ showOutput + where + showOutput = show e + displayOutput = displayException e diff --git a/cardano-cli/src/Cardano/CLI/Types/Common.hs b/cardano-cli/src/Cardano/CLI/Types/Common.hs index 8a624276c8..63c6459017 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Common.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Common.hs @@ -6,30 +6,30 @@ {-# LANGUAGE StandaloneDeriving #-} module Cardano.CLI.Types.Common - ( AllOrOnly(..) - , AddressKeyType(..) + ( AllOrOnly (..) + , AddressKeyType (..) , BalanceTxExecUnits (..) - , BlockId(..) - , ByronKeyFormat(..) - , ByronKeyType(..) - , CardanoAddressKeyType(..) + , BlockId (..) + , ByronKeyFormat (..) + , ByronKeyType (..) + , CardanoAddressKeyType (..) , CBORObject (..) , CertificateFile (..) - , ConstitutionHashSource(..) - , ConstitutionText(..) - , ConstitutionUrl(..) - , CredentialGenerationMode(..) + , ConstitutionHashSource (..) + , ConstitutionText (..) + , ConstitutionUrl (..) + , CredentialGenerationMode (..) , CurrentKesPeriod (..) , DRepCredentials (..) , EpochLeadershipSchedule (..) - , File(..) + , File (..) , FileDirection (..) - , GenesisDir(..) + , GenesisDir (..) , GenesisFile (..) - , GenesisKeyFile(..) + , GenesisKeyFile (..) , InputTxBodyOrTxFile (..) - , KeyOutputFormat(..) - , MetadataFile(..) + , KeyOutputFormat (..) + , MetadataFile (..) , OpCertCounter , OpCertCounterFile , OpCertEndingKesPeriod (..) @@ -41,13 +41,13 @@ module Cardano.CLI.Types.Common , Params (..) , ParserFileDirection (..) , IdOutputFormat (..) - , PrivKeyFile(..) + , PrivKeyFile (..) , ProposalBinary , ProposalFile , ProposalText - , ProposalUrl(..) - , ProtocolParamsFile(..) - , OutputFormatJsonOrText(..) + , ProposalUrl (..) + , ProtocolParamsFile (..) + , OutputFormatJsonOrText (..) , ReferenceScriptAnyEra (..) , ReferenceScriptSize (..) , RequiredSigner (..) @@ -58,34 +58,35 @@ module Cardano.CLI.Types.Common , ScriptWitnessFiles (..) , SigningKeyFile , SlotsTillKesKeyExpiry (..) - , SomeKeyFile(..) - , StakeDelegators(..) + , SomeKeyFile (..) + , StakeDelegators (..) , StakePoolMetadataFile - , TransferDirection(..) + , TransferDirection (..) , TxBodyFile - , TxBuildOutputOptions(..) - , TxByronWitnessCount(..) + , TxBuildOutputOptions (..) + , TxByronWitnessCount (..) , TxFile - , TxTreasuryDonation(..) - , TxInCount(..) + , TxTreasuryDonation (..) + , TxInCount (..) , TxMempoolQuery (..) , TxOutAnyEra (..) , TxOutShelleyBasedEra (..) , TxOutChangeAddress (..) - , TxOutCount(..) + , TxOutCount (..) , TxOutDatumAnyEra (..) - , TxShelleyWitnessCount(..) + , TxShelleyWitnessCount (..) , UpdateProposalFile (..) - , VerificationKeyBase64(..) + , VerificationKeyBase64 (..) , VerificationKeyFile - , ViewOutputFormat(..) - , VoteUrl(..) - , VoteText(..) - , VoteHashSource(..) - , WitnessFile(..) - , WitnessSigningData(..) + , ViewOutputFormat (..) + , VoteUrl (..) + , VoteText (..) + , VoteHashSource (..) + , WitnessFile (..) + , WitnessSigningData (..) , DRepMetadataFile - ) where + ) +where import Cardano.Api hiding (Script) import qualified Cardano.Api.Ledger as L @@ -100,8 +101,8 @@ import qualified Data.Text as Text import Data.Word (Word64) -- | Determines the direction in which the MIR certificate will transfer ADA. -data TransferDirection = - TransferToReserves +data TransferDirection + = TransferToReserves | TransferToTreasury deriving Show @@ -109,11 +110,13 @@ data OpCertCounter newtype ConstitutionUrl = ConstitutionUrl { unConstitutionUrl :: L.Url - } deriving (Eq, Show) + } + deriving (Eq, Show) newtype ConstitutionText = ConstitutionText { unConstitutionText :: Text - } deriving (Eq, Show) + } + deriving (Eq, Show) data ConstitutionHashSource = ConstitutionHashSourceFile (File ConstitutionText In) @@ -123,7 +126,8 @@ data ConstitutionHashSource newtype ProposalUrl = ProposalUrl { unProposalUrl :: L.Url - } deriving (Eq, Show) + } + deriving (Eq, Show) -- | Tag for tracking proposals submitted as 'Bytestring' data ProposalBinary @@ -133,11 +137,13 @@ data ProposalText newtype VoteUrl = VoteUrl { unVoteUrl :: L.Url - } deriving (Eq, Show) + } + deriving (Eq, Show) newtype VoteText = VoteText { unVoteText :: Text - } deriving (Eq, Show) + } + deriving (Eq, Show) data VoteHashSource = VoteHashSourceFile (File VoteText In) @@ -146,42 +152,51 @@ data VoteHashSource deriving Show data StakeDelegators = StakeDelegators - { stakeDelegatorsGenerationMode :: !CredentialGenerationMode -- ^ Whether to write them to disk - , numOfStakeDelegators :: !Word -- ^ The number of stake credentials to generate - } deriving Show + { stakeDelegatorsGenerationMode :: !CredentialGenerationMode + -- ^ Whether to write them to disk + , numOfStakeDelegators :: !Word + -- ^ The number of stake credentials to generate + } + deriving Show data DRepCredentials = DRepCredentials - { dRepCredentialGenerationMode :: !CredentialGenerationMode -- ^ Whether to write them to disk - , numOfDRepCredentials :: !Word -- ^ The number of DRep credentials to generate - } deriving Show + { dRepCredentialGenerationMode :: !CredentialGenerationMode + -- ^ Whether to write them to disk + , numOfDRepCredentials :: !Word + -- ^ The number of DRep credentials to generate + } + deriving Show data CredentialGenerationMode - = OnDisk -- ^ Write credentials to disk - | Transient -- ^ Don't write them to disk (process them in memory) + = -- | Write credentials to disk + OnDisk + | -- | Don't write them to disk (process them in memory) + Transient deriving (Show, Eq) -- | Specify whether to render the script cost as JSON -- in the cli's build command. -data TxBuildOutputOptions = OutputScriptCostOnly (File () Out) - | OutputTxBodyOnly (TxBodyFile Out) - deriving Show - +data TxBuildOutputOptions + = OutputScriptCostOnly (File () Out) + | OutputTxBodyOnly (TxBodyFile Out) + deriving Show -- | Specify what the CBOR file is -- i.e a block, a tx, etc -data CBORObject = CBORBlockByron Byron.EpochSlots - | CBORDelegationCertificateByron - | CBORTxByron - | CBORUpdateProposalByron - | CBORVoteByron - deriving Show +data CBORObject + = CBORBlockByron Byron.EpochSlots + | CBORDelegationCertificateByron + | CBORTxByron + | CBORUpdateProposalByron + | CBORVoteByron + deriving Show -- Encompasses stake certificates, stake pool certificates, -- genesis delegate certificates and MIR certificates. -newtype CertificateFile = CertificateFile { unCertificateFile :: FilePath } - deriving newtype (Eq, Show) +newtype CertificateFile = CertificateFile {unCertificateFile :: FilePath} + deriving newtype (Eq, Show) -newtype CurrentKesPeriod = CurrentKesPeriod { unCurrentKesPeriod :: Word64 } deriving (Eq, Show) +newtype CurrentKesPeriod = CurrentKesPeriod {unCurrentKesPeriod :: Word64} deriving (Eq, Show) instance ToJSON CurrentKesPeriod where toJSON (CurrentKesPeriod k) = toJSON k @@ -190,49 +205,49 @@ instance FromJSON CurrentKesPeriod where parseJSON v = CurrentKesPeriod <$> parseJSON v newtype GenesisFile = GenesisFile - { unGenesisFile :: FilePath } + {unGenesisFile :: FilePath} deriving stock (Eq, Ord) deriving newtype (IsString, Show) data OpCertNodeAndOnDiskCounterInformation - -- | The on disk operational certificate has a counter - -- that is equal to its corresponding counter in the - -- node state. The on disk operational certificate therefore - -- has a valid counter. - = OpCertOnDiskCounterEqualToNodeState + = -- | The on disk operational certificate has a counter + -- that is equal to its corresponding counter in the + -- node state. The on disk operational certificate therefore + -- has a valid counter. + OpCertOnDiskCounterEqualToNodeState OpCertOnDiskCounter OpCertNodeStateCounter - -- | The on disk operational certificate has a counter - -- that is ahead of the counter in the node state by 1. - -- The on disk operational certificate is invalid in - -- this case. - | OpCertOnDiskCounterAheadOfNodeState + | -- | The on disk operational certificate has a counter + -- that is ahead of the counter in the node state by 1. + -- The on disk operational certificate is invalid in + -- this case. + OpCertOnDiskCounterAheadOfNodeState OpCertOnDiskCounter OpCertNodeStateCounter - -- | The on disk operational certificate has a counter - -- that is less than the counter in the node state. The - -- on disk operational certificate is invalid in this case. - | OpCertOnDiskCounterTooFarAheadOfNodeState + | -- | The on disk operational certificate has a counter + -- that is less than the counter in the node state. The + -- on disk operational certificate is invalid in this case. + OpCertOnDiskCounterTooFarAheadOfNodeState OpCertOnDiskCounter OpCertNodeStateCounter - -- | The corresponding counter for operational certificate - -- was not found in the node state. This means the relevant - -- stake pool has not minted a block yet. When the stake pool - -- has minted a block the corresponding operational certificate's - -- counter will be present in the node state. - | OpCertOnDiskCounterBehindNodeState + | -- | The corresponding counter for operational certificate + -- was not found in the node state. This means the relevant + -- stake pool has not minted a block yet. When the stake pool + -- has minted a block the corresponding operational certificate's + -- counter will be present in the node state. + OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter OpCertNodeStateCounter - -- | The on disk operational certificate has a counter - -- that is ahead of the counter in the node state by more - -- than 1. The on disk operational certificate is invalid in - -- this case. - | OpCertNoBlocksMintedYet + | -- | The on disk operational certificate has a counter + -- that is ahead of the counter in the node state by more + -- than 1. The on disk operational certificate is invalid in + -- this case. + OpCertNoBlocksMintedYet OpCertOnDiskCounter deriving (Eq, Show) -newtype OpCertOnDiskCounter = OpCertOnDiskCounter { unOpCertOnDiskCounter :: Word64 } - deriving (Eq, Show) +newtype OpCertOnDiskCounter = OpCertOnDiskCounter {unOpCertOnDiskCounter :: Word64} + deriving (Eq, Show) instance ToJSON OpCertOnDiskCounter where toJSON (OpCertOnDiskCounter k) = toJSON k @@ -240,8 +255,8 @@ instance ToJSON OpCertOnDiskCounter where instance FromJSON OpCertOnDiskCounter where parseJSON v = OpCertOnDiskCounter <$> parseJSON v -newtype OpCertNodeStateCounter = OpCertNodeStateCounter { unOpCertNodeStateCounter :: Word64 } - deriving (Eq, Show) +newtype OpCertNodeStateCounter = OpCertNodeStateCounter {unOpCertNodeStateCounter :: Word64} + deriving (Eq, Show) instance ToJSON OpCertNodeStateCounter where toJSON (OpCertNodeStateCounter k) = toJSON k @@ -249,8 +264,8 @@ instance ToJSON OpCertNodeStateCounter where instance FromJSON OpCertNodeStateCounter where parseJSON v = OpCertNodeStateCounter <$> parseJSON v -newtype OpCertStartingKesPeriod = OpCertStartingKesPeriod { unOpCertStartingKesPeriod :: Word64 } - deriving (Eq, Show) +newtype OpCertStartingKesPeriod = OpCertStartingKesPeriod {unOpCertStartingKesPeriod :: Word64} + deriving (Eq, Show) instance ToJSON OpCertStartingKesPeriod where toJSON (OpCertStartingKesPeriod k) = toJSON k @@ -258,8 +273,8 @@ instance ToJSON OpCertStartingKesPeriod where instance FromJSON OpCertStartingKesPeriod where parseJSON v = OpCertStartingKesPeriod <$> parseJSON v -newtype OpCertEndingKesPeriod = OpCertEndingKesPeriod { unOpCertEndingKesPeriod :: Word64 } - deriving (Eq, Show) +newtype OpCertEndingKesPeriod = OpCertEndingKesPeriod {unOpCertEndingKesPeriod :: Word64} + deriving (Eq, Show) instance ToJSON OpCertEndingKesPeriod where toJSON (OpCertEndingKesPeriod k) = toJSON k @@ -281,7 +296,8 @@ data OpCertIntervalInformation OpCertStartingKesPeriod OpCertEndingKesPeriod CurrentKesPeriod - | OpCertSomeOtherError -- ^ Shouldn't be possible + | -- | Shouldn't be possible + OpCertSomeOtherError OpCertStartingKesPeriod OpCertEndingKesPeriod CurrentKesPeriod @@ -289,8 +305,11 @@ data OpCertIntervalInformation instance FromJSON GenesisFile where parseJSON (Aeson.String genFp) = pure . GenesisFile $ Text.unpack genFp - parseJSON invalid = error $ "Parsing of GenesisFile failed due to type mismatch. " - <> "Encountered: " <> show invalid + parseJSON invalid = + error $ + "Parsing of GenesisFile failed due to type mismatch. " + <> "Encountered: " + <> show invalid -- | Some entities such as stake pools and dreps have a notion of an ID and that id can be -- encoded as either a bech32 or hex string. This type is used to specify which encoding @@ -314,36 +333,44 @@ data Params crypto = Params { poolParameters :: Maybe (L.PoolParams crypto) , futurePoolParameters :: Maybe (L.PoolParams crypto) , retiringEpoch :: Maybe EpochNo - } deriving Show + } + deriving Show -- | Pretty printing for pool parameters -instance L.Crypto crypto => ToJSON (Params crypto) where - toJSON (Params p fp r) = object - [ "poolParams" .= p - , "futurePoolParams" .= fp - , "retiring" .= r - ] - - toEncoding (Params p fp r) = pairs $ mconcat - [ "poolParams" .= p - , "futurePoolParams" .= fp - , "retiring" .= r - ] +instance L.Crypto crypto => ToJSON (Params crypto) where + toJSON (Params p fp r) = + object + [ "poolParams" .= p + , "futurePoolParams" .= fp + , "retiring" .= r + ] + + toEncoding (Params p fp r) = + pairs $ + mconcat + [ "poolParams" .= p + , "futurePoolParams" .= fp + , "retiring" .= r + ] type SigningKeyFile = File (SigningKey ()) type ProposalFile = File () -newtype UpdateProposalFile = UpdateProposalFile { unUpdateProposalFile :: FilePath } - deriving newtype (Eq, Show) +newtype UpdateProposalFile = UpdateProposalFile {unUpdateProposalFile :: FilePath} + deriving newtype (Eq, Show) type VerificationKeyFile = File (VerificationKey ()) type ScriptFile = File ScriptInAnyLang In -data ScriptDataOrFile = ScriptDataCborFile FilePath -- ^ By reference to a CBOR file - | ScriptDataJsonFile FilePath -- ^ By reference to a JSON file - | ScriptDataValue HashableScriptData -- ^ By value +data ScriptDataOrFile + = -- | By reference to a CBOR file + ScriptDataCborFile FilePath + | -- | By reference to a JSON file + ScriptDataJsonFile FilePath + | -- | By value + ScriptDataValue HashableScriptData deriving (Eq, Show) type ScriptRedeemerOrFile = ScriptDataOrFile @@ -358,46 +385,46 @@ type ScriptRedeemerOrFile = ScriptDataOrFile -- in conveying that we either expect a script witness -- or a key witness is provided at the signing stage. data ScriptWitnessFiles witctx where - SimpleScriptWitnessFile :: ScriptFile - -> ScriptWitnessFiles witctx - - PlutusScriptWitnessFiles :: ScriptFile - -> ScriptDatumOrFile witctx - -> ScriptRedeemerOrFile - -> ExecutionUnits - -> ScriptWitnessFiles witctx - - -- TODO: Need to figure out how to exclude PlutusV1 scripts at the type level - PlutusReferenceScriptWitnessFiles - :: TxIn - -> AnyScriptLanguage - -> ScriptDatumOrFile witctx - -> ScriptRedeemerOrFile - -> ExecutionUnits - -> Maybe PolicyId -- ^ For minting reference scripts - -> ScriptWitnessFiles witctx - - SimpleReferenceScriptWitnessFiles - :: TxIn - -> AnyScriptLanguage - -> Maybe PolicyId -- ^ For minting reference scripts - -> ScriptWitnessFiles witctx - + SimpleScriptWitnessFile + :: ScriptFile + -> ScriptWitnessFiles witctx + PlutusScriptWitnessFiles + :: ScriptFile + -> ScriptDatumOrFile witctx + -> ScriptRedeemerOrFile + -> ExecutionUnits + -> ScriptWitnessFiles witctx + -- TODO: Need to figure out how to exclude PlutusV1 scripts at the type level + PlutusReferenceScriptWitnessFiles + :: TxIn + -> AnyScriptLanguage + -> ScriptDatumOrFile witctx + -> ScriptRedeemerOrFile + -> ExecutionUnits + -> Maybe PolicyId + -- ^ For minting reference scripts + -> ScriptWitnessFiles witctx + SimpleReferenceScriptWitnessFiles + :: TxIn + -> AnyScriptLanguage + -> Maybe PolicyId + -- ^ For minting reference scripts + -> ScriptWitnessFiles witctx deriving instance Show (ScriptWitnessFiles witctx) data ScriptDatumOrFile witctx where - ScriptDatumOrFileForTxIn :: ScriptDataOrFile - -> ScriptDatumOrFile WitCtxTxIn - InlineDatumPresentAtTxIn :: ScriptDatumOrFile WitCtxTxIn - - NoScriptDatumOrFileForMint :: ScriptDatumOrFile WitCtxMint - NoScriptDatumOrFileForStake :: ScriptDatumOrFile WitCtxStake + ScriptDatumOrFileForTxIn + :: ScriptDataOrFile + -> ScriptDatumOrFile WitCtxTxIn + InlineDatumPresentAtTxIn :: ScriptDatumOrFile WitCtxTxIn + NoScriptDatumOrFileForMint :: ScriptDatumOrFile WitCtxMint + NoScriptDatumOrFileForStake :: ScriptDatumOrFile WitCtxStake deriving instance Show (ScriptDatumOrFile witctx) -newtype SlotsTillKesKeyExpiry = SlotsTillKesKeyExpiry { unSlotsTillKesKeyExpiry :: SlotNo } - deriving (Eq, Show) +newtype SlotsTillKesKeyExpiry = SlotsTillKesKeyExpiry {unSlotsTillKesKeyExpiry :: SlotNo} + deriving (Eq, Show) instance ToJSON SlotsTillKesKeyExpiry where toJSON (SlotsTillKesKeyExpiry k) = toJSON k @@ -405,7 +432,6 @@ instance ToJSON SlotsTillKesKeyExpiry where instance FromJSON SlotsTillKesKeyExpiry where parseJSON v = SlotsTillKesKeyExpiry <$> parseJSON v - data TxOutShelleyBasedEra = TxOutShelleyBasedEra !(Address ShelleyAddr) @@ -413,23 +439,25 @@ data TxOutShelleyBasedEra TxOutDatumAnyEra ReferenceScriptAnyEra deriving Show + -- | A TxOut value that is the superset of possibilities for any era: any -- address type and allowing multi-asset values. This is used as the type for -- values passed on the command line. It can be converted into the -- era-dependent 'TxOutValue' type. --- -data TxOutAnyEra = TxOutAnyEra - AddressAny - Value - TxOutDatumAnyEra - ReferenceScriptAnyEra +data TxOutAnyEra + = TxOutAnyEra + AddressAny + Value + TxOutDatumAnyEra + ReferenceScriptAnyEra deriving (Eq, Show) -data TxOutDatumAnyEra = TxOutDatumByHashOnly (Hash ScriptData) - | TxOutDatumByHashOf ScriptDataOrFile - | TxOutDatumByValue ScriptDataOrFile - | TxOutInlineDatumByValue ScriptDataOrFile - | TxOutDatumByNone +data TxOutDatumAnyEra + = TxOutDatumByHashOnly (Hash ScriptData) + | TxOutDatumByHashOf ScriptDataOrFile + | TxOutDatumByValue ScriptDataOrFile + | TxOutInlineDatumByValue ScriptDataOrFile + | TxOutDatumByNone deriving (Eq, Show) data ReferenceScriptAnyEra @@ -444,7 +472,6 @@ data ReferenceScriptAnyEra -- -- It does not use any script data hash, since that's generally not used for -- change outputs. --- newtype TxOutChangeAddress = TxOutChangeAddress AddressAny deriving (Eq, Show) @@ -454,9 +481,9 @@ data BalanceTxExecUnits = AutoBalance | ManualBalance -- | Plutus script required signers data RequiredSigner - = RequiredSignerSkeyFile (SigningKeyFile In) - | RequiredSignerHash (Hash PaymentKey) - deriving Show + = RequiredSignerSkeyFile (SigningKeyFile In) + | RequiredSignerHash (Hash PaymentKey) + deriving Show -- | Which leadership schedule we are interested in. -- TODO: Implement Previous and Next epochs @@ -469,13 +496,13 @@ type TxBodyFile = File (TxBody ()) type TxFile = File (Tx ()) -newtype TxTreasuryDonation = TxTreasuryDonation { unTxTreasuryDonation :: L.Coin } +newtype TxTreasuryDonation = TxTreasuryDonation {unTxTreasuryDonation :: L.Coin} deriving Show -data TxMempoolQuery = - TxMempoolQueryTxExists TxId - | TxMempoolQueryNextTx - | TxMempoolQueryInfo +data TxMempoolQuery + = TxMempoolQueryTxExists TxId + | TxMempoolQueryNextTx + | TxMempoolQueryInfo deriving Show data OutputFormatJsonOrText @@ -487,6 +514,7 @@ data ViewOutputFormat = ViewOutputFormatJson | ViewOutputFormatYaml deriving Show + -- -- Shelley CLI flag/option data types -- @@ -512,7 +540,7 @@ newtype TxByronWitnessCount deriving Show newtype ReferenceScriptSize - = ReferenceScriptSize { unReferenceScriptSize :: Int } + = ReferenceScriptSize {unReferenceScriptSize :: Int} deriving Show newtype BlockId @@ -523,9 +551,9 @@ newtype GenesisKeyFile = GenesisKeyFile FilePath deriving Show -data MetadataFile = MetadataFileJSON (File () In) - | MetadataFileCBOR (File () In) - +data MetadataFile + = MetadataFileJSON (File () In) + | MetadataFileCBOR (File () In) deriving Show type StakePoolMetadataFile = File StakePoolMetadata @@ -538,7 +566,6 @@ newtype GenesisDir -- | Either a verification or signing key, used for conversions and other -- commands that make sense for both. --- data SomeKeyFile direction = AVerificationKeyFile (VerificationKeyFile direction) | ASigningKeyFile (SigningKeyFile direction) @@ -551,13 +578,14 @@ data AddressKeyType deriving Show data ByronKeyType - = ByronPaymentKey ByronKeyFormat - | ByronGenesisKey ByronKeyFormat + = ByronPaymentKey ByronKeyFormat + | ByronGenesisKey ByronKeyFormat | ByronDelegateKey ByronKeyFormat deriving Show -data ByronKeyFormat = NonLegacyByronKeyFormat - | LegacyByronKeyFormat +data ByronKeyFormat + = NonLegacyByronKeyFormat + | LegacyByronKeyFormat deriving Show -- | The type of @cardano-address@ key. diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs index 0a9b7f23b2..f9d5bf16f4 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressCmdError.hs @@ -6,9 +6,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.AddressCmdError - ( AddressCmdError(..) + ( AddressCmdError (..) , renderAddressCmdError - ) where + ) +where import Cardano.Api @@ -39,4 +40,5 @@ renderAddressCmdError = \case AddressCmdWriteFileError fileErr -> prettyError fileErr AddressCmdExpectedPaymentVerificationKey someAddress -> - "Expected payment verification key but got: " <> pretty (renderSomeAddressVerificationKey someAddress) + "Expected payment verification key but got: " + <> pretty (renderSomeAddressVerificationKey someAddress) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs index a0b0361929..bf43e1a913 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/AddressInfoError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.AddressInfoError - ( AddressInfoError(..) - ) where + ( AddressInfoError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs index 759adb9176..6428a3a266 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/BootstrapWitnessError.hs @@ -1,16 +1,17 @@ module Cardano.CLI.Types.Errors.BootstrapWitnessError - ( BootstrapWitnessError(..) + ( BootstrapWitnessError (..) , renderBootstrapWitnessError - ) where + ) +where import Prettyprinter -- | Error constructing a Shelley bootstrap witness (i.e. a Byron key witness -- in the Shelley era). data BootstrapWitnessError - = MissingNetworkIdOrByronAddressError - -- ^ Neither a network ID nor a Byron address were provided to construct the - -- Shelley bootstrap witness. One or the other is required. + = -- | Neither a network ID nor a Byron address were provided to construct the + -- Shelley bootstrap witness. One or the other is required. + MissingNetworkIdOrByronAddressError deriving Show -- | Render an error message for a 'BootstrapWitnessError'. diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs index 8c8ba84aae..5de4c358b3 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/CardanoAddressSigningKeyConversionError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.CardanoAddressSigningKeyConversionError - ( CardanoAddressSigningKeyConversionError(..) - ) where + ( CardanoAddressSigningKeyConversionError (..) + ) +where import Cardano.Api @@ -11,11 +12,11 @@ import Data.ByteString (ByteString) -- | An error that can occur while converting a @cardano-address@ extended -- signing key. data CardanoAddressSigningKeyConversionError - = CardanoAddressSigningKeyBech32DecodeError !Bech32DecodeError - -- ^ There was an error in decoding the string as Bech32. - | CardanoAddressSigningKeyDeserialisationError !ByteString - -- ^ There was an error in converting the @cardano-address@ extended signing - -- key. + = -- | There was an error in decoding the string as Bech32. + CardanoAddressSigningKeyBech32DecodeError !Bech32DecodeError + | -- | There was an error in converting the @cardano-address@ extended signing + -- key. + CardanoAddressSigningKeyDeserialisationError !ByteString deriving (Show, Eq) instance Error CardanoAddressSigningKeyConversionError where diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs index 646758efc2..39f9d58cf4 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/CmdError.hs @@ -1,9 +1,10 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.CmdError - ( CmdError(..) + ( CmdError (..) , renderCmdError - ) where + ) +where import Cardano.Api @@ -28,49 +29,49 @@ import Cardano.CLI.Types.Errors.TxCmdError import Data.Text (Text) data CmdError - = CmdAddressError !AddressCmdError - | CmdEraDelegationError !DelegationError - | CmdGenesisError !GenesisCmdError - | CmdGovernanceActionError !GovernanceActionsError - | CmdGovernanceCmdError !GovernanceCmdError - | CmdGovernanceCommitteeError !GovernanceCommitteeError - | CmdGovernanceQueryError !GovernanceQueryError - | CmdGovernanceVoteError !GovernanceVoteCmdError - | CmdHashError !HashCmdError -- TODO delete me - | CmdKeyError !KeyCmdError - | CmdNodeError !NodeCmdError - | CmdQueryError !QueryCmdError - | CmdRegistrationError !RegistrationError - | CmdStakeAddressError !StakeAddressCmdError - | CmdStakePoolError !StakePoolCmdError - | CmdTextViewError !TextViewFileError - | CmdTransactionError !TxCmdError + = CmdAddressError !AddressCmdError + | CmdEraDelegationError !DelegationError + | CmdGenesisError !GenesisCmdError + | CmdGovernanceActionError !GovernanceActionsError + | CmdGovernanceCmdError !GovernanceCmdError + | CmdGovernanceCommitteeError !GovernanceCommitteeError + | CmdGovernanceQueryError !GovernanceQueryError + | CmdGovernanceVoteError !GovernanceVoteCmdError + | CmdHashError !HashCmdError -- TODO delete me + | CmdKeyError !KeyCmdError + | CmdNodeError !NodeCmdError + | CmdQueryError !QueryCmdError + | CmdRegistrationError !RegistrationError + | CmdStakeAddressError !StakeAddressCmdError + | CmdStakePoolError !StakePoolCmdError + | CmdTextViewError !TextViewFileError + | CmdTransactionError !TxCmdError renderCmdError :: Text -> CmdError -> Doc ann renderCmdError cmdText = \case - CmdAddressError e -> renderError renderAddressCmdError e - CmdEraDelegationError e -> renderError prettyError e - CmdGenesisError e -> renderError prettyError e - CmdGovernanceActionError e -> renderError prettyError e - CmdGovernanceCmdError e -> renderError prettyError e - CmdGovernanceCommitteeError e -> renderError prettyError e - CmdGovernanceQueryError e -> renderError prettyError e - CmdGovernanceVoteError e -> renderError prettyError e - CmdHashError e -> renderError prettyError e - CmdKeyError e -> renderError renderKeyCmdError e - CmdNodeError e -> renderError renderNodeCmdError e - CmdQueryError e -> renderError renderQueryCmdError e - CmdRegistrationError e -> renderError prettyError e - CmdStakeAddressError e -> renderError prettyError e - CmdStakePoolError e -> renderError renderStakePoolCmdError e - CmdTextViewError e -> renderError renderTextViewFileError e - CmdTransactionError e -> renderError renderTxCmdError e - where - renderError :: (a -> Doc ann) -> a -> Doc ann - renderError renderer shelCliCmdErr = - mconcat - [ "Command failed: " - , pretty cmdText - , " Error: " - , renderer shelCliCmdErr - ] + CmdAddressError e -> renderError renderAddressCmdError e + CmdEraDelegationError e -> renderError prettyError e + CmdGenesisError e -> renderError prettyError e + CmdGovernanceActionError e -> renderError prettyError e + CmdGovernanceCmdError e -> renderError prettyError e + CmdGovernanceCommitteeError e -> renderError prettyError e + CmdGovernanceQueryError e -> renderError prettyError e + CmdGovernanceVoteError e -> renderError prettyError e + CmdHashError e -> renderError prettyError e + CmdKeyError e -> renderError renderKeyCmdError e + CmdNodeError e -> renderError renderNodeCmdError e + CmdQueryError e -> renderError renderQueryCmdError e + CmdRegistrationError e -> renderError prettyError e + CmdStakeAddressError e -> renderError prettyError e + CmdStakePoolError e -> renderError renderStakePoolCmdError e + CmdTextViewError e -> renderError renderTextViewFileError e + CmdTransactionError e -> renderError renderTxCmdError e + where + renderError :: (a -> Doc ann) -> a -> Doc ann + renderError renderer shelCliCmdErr = + mconcat + [ "Command failed: " + , pretty cmdText + , " Error: " + , renderer shelCliCmdErr + ] diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs index f6b7fca1f7..5b1800ac61 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/DelegationError.hs @@ -3,8 +3,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.DelegationError - ( DelegationError(..) - ) where + ( DelegationError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs index 8ea416f6fa..7a442f9100 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs @@ -2,8 +2,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.GenesisCmdError - ( GenesisCmdError(..) - ) where + ( GenesisCmdError (..) + ) +where import Cardano.Api @@ -27,7 +28,10 @@ data GenesisCmdError | GenesisCmdFilesNoIndex [FilePath] | GenesisCmdFilesDupIndex [FilePath] | GenesisCmdTextEnvReadFileError !(FileError TextEnvelopeError) - | GenesisCmdUnexpectedAddressVerificationKey !(VerificationKeyFile In) !Text !SomeAddressVerificationKey + | GenesisCmdUnexpectedAddressVerificationKey + !(VerificationKeyFile In) + !Text + !SomeAddressVerificationKey | GenesisCmdTooFewPoolsForBulkCreds !Word !Word !Word | GenesisCmdAddressCmdError !AddressCmdError | GenesisCmdNodeCmdError !NodeCmdError @@ -35,11 +39,13 @@ data GenesisCmdError | GenesisCmdStakePoolCmdError !StakePoolCmdError | GenesisCmdCostModelsError !FilePath | GenesisCmdByronError !ByronGenesisError - | GenesisCmdTooManyRelaysError !FilePath !Int !Int -- ^ First @Int@ is the number of SPOs, second @Int@ is number of relays + | -- | First @Int@ is the number of SPOs, second @Int@ is number of relays + GenesisCmdTooManyRelaysError !FilePath !Int !Int | GenesisCmdStakePoolRelayFileError !FilePath !IOException | GenesisCmdStakePoolRelayJsonDecodeError !FilePath !String | GenesisCmdFileInputDecodeError !(FileError InputDecodeError) - | GenesisCmdDelegatedSupplyExceedsTotalSupply !Integer !Integer -- ^ First @Integer@ is the delegate supply, second @Integer@ is the total supply + | -- | First @Integer@ is the delegate supply, second @Integer@ is the total supply + GenesisCmdDelegatedSupplyExceedsTotalSupply !Integer !Integer deriving Show instance Error GenesisCmdError where @@ -52,9 +58,14 @@ instance Error GenesisCmdError where prettyError fe GenesisCmdMismatchedGenesisKeyFiles gfiles dfiles vfiles -> "Mismatch between the files found:\n" - <> "Genesis key file indexes: " <> pshow gfiles <> "\n" - <> "Delegate key file indexes: " <> pshow dfiles <> "\n" - <> "Delegate VRF key file indexes: " <> pshow vfiles + <> "Genesis key file indexes: " + <> pshow gfiles + <> "\n" + <> "Delegate key file indexes: " + <> pshow dfiles + <> "\n" + <> "Delegate VRF key file indexes: " + <> pshow vfiles GenesisCmdFilesNoIndex files -> "The genesis keys files are expected to have a numeric index but these do not:\n" <> vsep (fmap pretty files) @@ -65,14 +76,22 @@ instance Error GenesisCmdError where prettyError fileErr GenesisCmdUnexpectedAddressVerificationKey (File file) expect got -> mconcat - [ "Unexpected address verification key type in file ", pretty file - , ", expected: ", pretty expect, ", got: ", pretty (renderSomeAddressVerificationKey got) + [ "Unexpected address verification key type in file " + , pretty file + , ", expected: " + , pretty expect + , ", got: " + , pretty (renderSomeAddressVerificationKey got) ] GenesisCmdTooFewPoolsForBulkCreds pools files perPool -> mconcat - [ "Number of pools requested for generation (", pshow pools - , ") is insufficient to fill ", pshow files - , " bulk files, with ", pshow perPool, " pools per file." + [ "Number of pools requested for generation (" + , pshow pools + , ") is insufficient to fill " + , pshow files + , " bulk files, with " + , pshow perPool + , " pools per file." ] GenesisCmdAddressCmdError e -> renderAddressCmdError e @@ -85,23 +104,38 @@ instance Error GenesisCmdError where GenesisCmdCostModelsError fp -> "Cost model is invalid: " <> pretty fp GenesisCmdGenesisFileDecodeError fp e -> - "Error while decoding Shelley genesis at: " <> pretty fp <> - " Error: " <> pretty e + "Error while decoding Shelley genesis at: " + <> pretty fp + <> " Error: " + <> pretty e GenesisCmdGenesisFileReadError e -> prettyError e GenesisCmdByronError e -> pshow e GenesisCmdTooManyRelaysError fp nbSPOs nbRelays -> - pretty fp <> " specifies " <> pretty nbRelays <> " relays, but only " <> pretty nbSPOs <> " SPOs have been specified." <> - " Please specify a number of relays that is lesser or equal to the number of SPOs." + pretty fp + <> " specifies " + <> pretty nbRelays + <> " relays, but only " + <> pretty nbSPOs + <> " SPOs have been specified." + <> " Please specify a number of relays that is lesser or equal to the number of SPOs." GenesisCmdStakePoolRelayFileError fp e -> - "Error occurred while reading the stake pool relay specification file: " <> pretty fp <> - " Error: " <> pshow e + "Error occurred while reading the stake pool relay specification file: " + <> pretty fp + <> " Error: " + <> pshow e GenesisCmdStakePoolRelayJsonDecodeError fp e -> - "Error occurred while decoding the stake pool relay specification file: " <> pretty fp <> - " Error: " <> pretty e + "Error occurred while decoding the stake pool relay specification file: " + <> pretty fp + <> " Error: " + <> pretty e GenesisCmdFileInputDecodeError ide -> "Error occured while decoding a file: " <> pshow ide GenesisCmdDelegatedSupplyExceedsTotalSupply delegated total -> - "Provided delegated supply is " <> pretty delegated <> ", which is greater than the specified total supply: " <> pretty total <> "." <> - "This is incorrect: the delegated supply should be less or equal to the total supply." <> - " Note that the total supply can either come from --total-supply or from the default template. Please fix what you use." + "Provided delegated supply is " + <> pretty delegated + <> ", which is greater than the specified total supply: " + <> pretty total + <> "." + <> "This is incorrect: the delegated supply should be less or equal to the total supply." + <> " Note that the total supply can either come from --total-supply or from the default template. Please fix what you use." diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs index 87f74d08dc..8064a5a9f3 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceActionsError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.GovernanceActionsError - ( GovernanceActionsError(..) - ) where + ( GovernanceActionsError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs index 6fa63a24ce..e75d54da4d 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCmdError.hs @@ -22,8 +22,8 @@ data GovernanceCmdError | VotingCredentialDecodeGovCmdEror DecoderError | WriteFileError (FileError ()) | ReadFileError (FileError InputDecodeError) - -- Governance action related - | GovernanceCmdConstitutionError ConstitutionError + | -- Governance action related + GovernanceCmdConstitutionError ConstitutionError | GovernanceCmdProposalError ProposalError | GovernanceCmdTextEnvReadError !(FileError TextEnvelopeError) | GovernanceCmdTextEnvCddlReadError !(FileError TextEnvelopeCddlError) @@ -40,19 +40,19 @@ data GovernanceCmdError -- ^ Number of reward amounts | GovernanceCmdCostModelsJsonDecodeErr !FilePath !Text | GovernanceCmdEmptyCostModel !FilePath - | GovernanceCmdUnexpectedKeyType + | -- | Expected key types + GovernanceCmdUnexpectedKeyType ![TextEnvelopeType] - -- ^ Expected key types - | GovernanceCmdPollOutOfBoundAnswer + | -- | Maximum answer index + GovernanceCmdPollOutOfBoundAnswer !Int - -- ^ Maximum answer index | GovernanceCmdPollInvalidChoice | GovernanceCmdDecoderError !DecoderError | GovernanceCmdVerifyPollError !GovernancePollError | GovernanceCmdWriteFileError !(FileError ()) | GovernanceCmdDRepMetadataValidationError !DRepMetadataValidationError - -- Legacy - remove me after cardano-cli transitions to new era based structure - | GovernanceCmdMIRCertNotSupportedInConway + | -- Legacy - remove me after cardano-cli transitions to new era based structure + GovernanceCmdMIRCertNotSupportedInConway | GovernanceCmdGenesisDelegationNotSupportedInConway deriving Show @@ -85,10 +85,13 @@ instance Error GovernanceCmdError where GovernanceCmdEmptyUpdateProposalError -> "Empty update proposals are not allowed." GovernanceCmdMIRCertificateKeyRewardMistmach fp nStakeVerKeys nRewards -> - "Error creating the MIR certificate at: " <> pretty fp - <> " The number of staking keys: " <> pshow nStakeVerKeys - <> " and the number of reward amounts: " <> pshow nRewards - <> " are not equivalent." + "Error creating the MIR certificate at: " + <> pretty fp + <> " The number of staking keys: " + <> pshow nStakeVerKeys + <> " and the number of reward amounts: " + <> pshow nRewards + <> " are not equivalent." GovernanceCmdCostModelsJsonDecodeErr fp msg -> "Error decoding cost model: " <> pretty msg <> " at: " <> pretty fp GovernanceCmdEmptyCostModel fp -> @@ -114,5 +117,5 @@ instance Error GovernanceCmdError where "MIR certificates are not supported in Conway era onwards." GovernanceCmdGenesisDelegationNotSupportedInConway -> "Genesis delegation is not supported in Conway era onwards." - where - renderDecoderError = pretty . TL.toLazyText . B.build + where + renderDecoderError = pretty . TL.toLazyText . B.build diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs index 9f35cf4579..d461d2ae09 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceCommitteeError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.GovernanceCommitteeError - ( GovernanceCommitteeError(..) - ) where + ( GovernanceCommitteeError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs index 4be24f77a4..b762a95dcd 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceQueryError.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} + module Cardano.CLI.Types.Errors.GovernanceQueryError where import Cardano.Api @@ -23,7 +24,11 @@ instance Error GovernanceQueryError where GovernanceQueryUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) -> vsep [ "Unsupported feature for the node-to-client protocol version." - , "This query requires at least " <> pshow minNtcVersion <> " but the node negotiated " <> pshow ntcVersion <> "." + , "This query requires at least " + <> pshow minNtcVersion + <> " but the node negotiated " + <> pshow ntcVersion + <> "." , "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." ] GovernanceQueryEraMismatch err -> diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs index 0a3a7e4cba..820db0f949 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GovernanceVoteCmdError.hs @@ -32,5 +32,5 @@ instance Error GovernanceVoteCmdError where "Cannot write vote: " <> prettyError e GovernanceVoteCmdReadVoteTextError e -> "Cannot read vote text: " <> prettyError e - where - renderDecoderError = pretty . TL.toLazyText . B.build + where + renderDecoderError = pretty . TL.toLazyText . B.build diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/HashCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/HashCmdError.hs index 42c4b6c215..b2cad2576d 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/HashCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/HashCmdError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.HashCmdError - ( HashCmdError(..) - ) where + ( HashCmdError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs index 852d9c25e2..922c112611 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ItnKeyConversionError.hs @@ -5,9 +5,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.ItnKeyConversionError - ( ItnKeyConversionError(..) + ( ItnKeyConversionError (..) , renderConversionError - ) where + ) +where import Cardano.Api @@ -30,8 +31,10 @@ renderConversionError = \case ItnKeyBech32DecodeError decErr -> "Error decoding Bech32 key: " <> prettyError decErr ItnReadBech32FileError fp readErr -> - "Error reading Bech32 key at: " <> pshow fp - <> " Error: " <> pshow (displayException readErr) + "Error reading Bech32 key at: " + <> pshow fp + <> " Error: " + <> pshow (displayException readErr) ItnSigningKeyDeserialisationError _sKey -> -- Sensitive data, such as the signing key, is purposely not included in -- the error message. diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs index a708a80d2f..a1ac6de59e 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/KeyCmdError.hs @@ -4,9 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.KeyCmdError - ( KeyCmdError(..) + ( KeyCmdError (..) , renderKeyCmdError - ) where + ) +where import Cardano.Api @@ -22,10 +23,10 @@ data KeyCmdError | KeyCmdReadKeyFileError !(FileError InputDecodeError) | KeyCmdWriteFileError !(FileError ()) | KeyCmdByronKeyFailure !Byron.ByronKeyFailure - | KeyCmdByronKeyParseError + | -- | Text representation of the parse error. Unfortunately, the actual + -- error type isn't exported. + KeyCmdByronKeyParseError !Text - -- ^ Text representation of the parse error. Unfortunately, the actual - -- error type isn't exported. | KeyCmdItnKeyConvError !ItnKeyConversionError | KeyCmdWrongKeyTypeError | KeyCmdCardanoAddressSigningKeyFileError @@ -55,8 +56,11 @@ renderKeyCmdError err = KeyCmdCardanoAddressSigningKeyFileError fileErr -> prettyError fileErr KeyCmdNonLegacyKey fp -> - "Signing key at: " <> pretty fp <> " is not a legacy Byron signing key and should not need to be converted." + "Signing key at: " + <> pretty fp + <> " is not a legacy Byron signing key and should not need to be converted." KeyCmdVerificationKeyReadError e -> renderVerificationKeyTextOrFileError e KeyCmdExpectedExtendedVerificationKey someVerKey -> - "Expected an extended verification key but got: " <> pretty (renderSomeAddressVerificationKey someVerKey) + "Expected an extended verification key but got: " + <> pretty (renderSomeAddressVerificationKey someVerKey) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs index 19680156de..8e4edaf199 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/NodeCmdError.hs @@ -2,9 +2,10 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.NodeCmdError - ( NodeCmdError(..) + ( NodeCmdError (..) , renderNodeCmdError - ) where + ) +where import Cardano.Api @@ -24,14 +25,16 @@ data NodeCmdError renderNodeCmdError :: NodeCmdError -> Doc ann renderNodeCmdError = \case - NodeCmdVrfSigningKeyCreationError targetPath tempPath -> - "Error creating VRF signing key file. Target path: " <> pshow targetPath - <> " Temporary path: " <> pshow tempPath - NodeCmdReadFileError fileErr -> - prettyError fileErr - NodeCmdReadKeyFileError fileErr -> - prettyError fileErr - NodeCmdWriteFileError fileErr -> - prettyError fileErr - NodeCmdOperationalCertificateIssueError issueErr -> - prettyError issueErr + NodeCmdVrfSigningKeyCreationError targetPath tempPath -> + "Error creating VRF signing key file. Target path: " + <> pshow targetPath + <> " Temporary path: " + <> pshow tempPath + NodeCmdReadFileError fileErr -> + prettyError fileErr + NodeCmdReadKeyFileError fileErr -> + prettyError fileErr + NodeCmdWriteFileError fileErr -> + prettyError fileErr + NodeCmdOperationalCertificateIssueError issueErr -> + prettyError issueErr diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/NodeEraMismatchError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/NodeEraMismatchError.hs index 4c00bf7416..6717997c77 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/NodeEraMismatchError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/NodeEraMismatchError.hs @@ -1,13 +1,15 @@ {-# LANGUAGE GADTs #-} module Cardano.CLI.Types.Errors.NodeEraMismatchError - ( NodeEraMismatchError(..) - ) where + ( NodeEraMismatchError (..) + ) +where import Cardano.Api -data NodeEraMismatchError = forall era nodeEra. +data NodeEraMismatchError + = forall era nodeEra. NodeEraMismatchError - { era :: !(CardanoEra era) - , nodeEra :: !(CardanoEra nodeEra) + { era :: !(CardanoEra era) + , nodeEra :: !(CardanoEra nodeEra) } diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs index ee62502103..f89f9fe1d6 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ProtocolParamsError.hs @@ -5,9 +5,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.ProtocolParamsError - ( ProtocolParamsError(..) + ( ProtocolParamsError (..) , renderProtocolParamsError - ) where + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs index edc730886f..a87e5c9d80 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdError.hs @@ -9,9 +9,10 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.QueryCmdError - ( QueryCmdError(..) + ( QueryCmdError (..) , renderQueryCmdError - ) where + ) +where import Cardano.Api hiding (QueryInShelleyBasedEra (..)) import Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..)) @@ -68,8 +69,11 @@ renderQueryCmdError = \case QueryCmdByronEra -> "This query cannot be used for the Byron era" QueryCmdEraMismatch (EraMismatch ledgerEra queryEra) -> - "\nAn error mismatch occurred." <> "\nSpecified query era: " <> pretty queryEra <> - "\nCurrent ledger era: " <> pretty ledgerEra + "\nAn error mismatch occurred." + <> "\nSpecified query era: " + <> pretty queryEra + <> "\nCurrent ledger era: " + <> pretty ledgerEra QueryCmdPastHorizon e -> "Past horizon: " <> pshow e QueryCmdSystemStartUnavailable -> @@ -91,9 +95,13 @@ renderQueryCmdError = \case QueryCmdStakeSnapshotDecodeError decoderError -> "Failed to decode StakeSnapshot. Error: " <> pshow decoderError QueryCmdUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion) -> - "Unsupported feature for the node-to-client protocol version.\n" <> - "This query requires at least " <> pshow minNtcVersion <> " but the node negotiated " <> pshow ntcVersion <> ".\n" <> - "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." + "Unsupported feature for the node-to-client protocol version.\n" + <> "This query requires at least " + <> pshow minNtcVersion + <> " but the node negotiated " + <> pshow ntcVersion + <> ".\n" + <> "Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)." QueryCmdProtocolParameterConversionError ppce -> "Failed to convert protocol parameter: " <> prettyError ppce QueryCmdConvenienceError qce -> diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs index dd55616adc..5ceff770aa 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/QueryCmdLocalStateQueryError.hs @@ -2,29 +2,35 @@ {-# LANGUAGE NamedFieldPuns #-} module Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError - ( QueryCmdLocalStateQueryError(..) + ( QueryCmdLocalStateQueryError (..) , mkEraMismatchError - ) where + ) +where import Cardano.Api (Error (..)) -import Cardano.CLI.Pretty +import Cardano.CLI.Pretty import Cardano.CLI.Types.Errors.NodeEraMismatchError import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) - -- | An error that can occur while querying a node's local state. newtype QueryCmdLocalStateQueryError - = EraMismatchError EraMismatch - -- ^ A query from a certain era was applied to a ledger from a different era. + = -- | A query from a certain era was applied to a ledger from a different era. + EraMismatchError EraMismatch deriving (Eq, Show) mkEraMismatchError :: NodeEraMismatchError -> QueryCmdLocalStateQueryError mkEraMismatchError NodeEraMismatchError{nodeEra, era} = - EraMismatchError EraMismatch{ ledgerEraName = docToText $ pretty nodeEra - , otherEraName = docToText $ pretty era} + EraMismatchError + EraMismatch + { ledgerEraName = docToText $ pretty nodeEra + , otherEraName = docToText $ pretty era + } instance Error QueryCmdLocalStateQueryError where prettyError = \case EraMismatchError EraMismatch{ledgerEraName, otherEraName} -> - "A query from" <+> pretty otherEraName <+> "era was applied to a ledger from a different era:" <+> pretty ledgerEraName + "A query from" + <+> pretty otherEraName + <+> "era was applied to a ledger from a different era:" + <+> pretty ledgerEraName diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs index 1336f3e1a7..289b8b95cb 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/RegistrationError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.RegistrationError - ( RegistrationError(..) - ) where + ( RegistrationError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs index 9ab441eade..2b4c37c9c6 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/ScriptDecodeError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.ScriptDecodeError - ( ScriptDecodeError(..) - ) where + ( ScriptDecodeError (..) + ) +where import Cardano.Api @@ -10,8 +11,8 @@ import Cardano.Api -- Handling decoding the variety of script languages and formats -- -data ScriptDecodeError = - ScriptDecodeTextEnvelopeError TextEnvelopeError +data ScriptDecodeError + = ScriptDecodeTextEnvelopeError TextEnvelopeError | ScriptDecodeSimpleScriptError JsonDecodeError deriving Show diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs index 077cd19007..50b163fdd7 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressCmdError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.StakeAddressCmdError - ( StakeAddressCmdError(..) - ) where + ( StakeAddressCmdError (..) + ) +where import Cardano.Api @@ -22,9 +23,9 @@ data StakeAddressCmdError instance Error StakeAddressCmdError where prettyError = \case - StakeAddressCmdReadKeyFileError e -> prettyError e - StakeAddressCmdReadScriptFileError e -> prettyError e - StakeAddressCmdStakeCredentialError e -> prettyError e - StakeAddressCmdWriteFileError e -> prettyError e - StakeAddressCmdDelegationError e -> prettyError e - StakeAddressCmdRegistrationError e -> prettyError e + StakeAddressCmdReadKeyFileError e -> prettyError e + StakeAddressCmdReadScriptFileError e -> prettyError e + StakeAddressCmdStakeCredentialError e -> prettyError e + StakeAddressCmdWriteFileError e -> prettyError e + StakeAddressCmdDelegationError e -> prettyError e + StakeAddressCmdRegistrationError e -> prettyError e diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs index 9a4c96e18b..ad4e008c1c 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressDelegationError.hs @@ -2,12 +2,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.StakeAddressDelegationError - ( StakeAddressDelegationError(..) - ) where + ( StakeAddressDelegationError (..) + ) +where import Cardano.Api -newtype StakeAddressDelegationError = VoteDelegationNotSupported (EraInEon ShelleyToBabbageEra) deriving Show +newtype StakeAddressDelegationError = VoteDelegationNotSupported (EraInEon ShelleyToBabbageEra) + deriving Show instance Error StakeAddressDelegationError where prettyError = \case diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs index a32eae31cb..cd027e6600 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeAddressRegistrationError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.StakeAddressRegistrationError - ( StakeAddressRegistrationError(..) - ) where + ( StakeAddressRegistrationError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs index 83e0db13ed..047d4ed529 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakeCredentialError.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.StakeCredentialError - ( StakeCredentialError(..) - ) where + ( StakeCredentialError (..) + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs index 4715ff7e63..2a5573dabf 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/StakePoolCmdError.hs @@ -4,9 +4,10 @@ {-# LANGUAGE RankNTypes #-} module Cardano.CLI.Types.Errors.StakePoolCmdError - ( StakePoolCmdError(..) + ( StakePoolCmdError (..) , renderStakePoolCmdError - ) where + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs index df558e284e..4048272da2 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TextViewFileError.hs @@ -2,9 +2,10 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.Errors.TextViewFileError - ( TextViewFileError(..) + ( TextViewFileError (..) , renderTextViewFileError - ) where + ) +where import Cardano.Api diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs index c4d327ed23..f0a1ec37e3 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxCmdError.hs @@ -7,11 +7,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.CLI.Types.Errors.TxCmdError - ( TxCmdError(..) - , AnyTxBodyErrorAutoBalance(..) - , AnyTxCmdTxExecUnitsErr(..) + ( TxCmdError (..) + , AnyTxBodyErrorAutoBalance (..) + , AnyTxCmdTxExecUnitsErr (..) , renderTxCmdError - ) where + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -58,9 +59,9 @@ data TxCmdError | TxCmdNotImplemented !Text | TxCmdWitnessEraMismatch !AnyCardanoEra !AnyCardanoEra !WitnessFile | TxCmdPolicyIdsMissing ![PolicyId] ![PolicyId] - -- The first list is the missing policy Ids, the second list is the + | -- The first list is the missing policy Ids, the second list is the -- policy Ids that were provided in the transaction. - | TxCmdPolicyIdsExcess ![PolicyId] + TxCmdPolicyIdsExcess ![PolicyId] | TxCmdByronEra | TxCmdBalanceTxBody !AnyTxBodyErrorAutoBalance | TxCmdTxInsDoNotExist !TxInsExistError @@ -78,8 +79,8 @@ data TxCmdError | TxCmdScriptDataError !ScriptDataError | TxCmdCddlWitnessError CddlWitnessError | TxCmdRequiredSignerError RequiredSignerError - -- Validation errors - | forall era. TxCmdNotSupportedInEraValidationError (TxNotSupportedInEraValidationError era) + | -- Validation errors + forall era. TxCmdNotSupportedInEraValidationError (TxNotSupportedInEraValidationError era) | TxCmdAuxScriptsValidationError TxAuxScriptsValidationError | TxCmdProtocolParamsConverstionError ProtocolParametersConversionError | forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era) @@ -108,81 +109,88 @@ renderTxCmdError = \case TxCmdTxSubmitError res -> "Error while submitting tx: " <> pretty res TxCmdTxSubmitErrorEraMismatch EraMismatch{ledgerEraName, otherEraName} -> - "The era of the node and the tx do not match. " <> - "The node is running in the " <> pretty ledgerEraName <> - " era, but the transaction is for the " <> pretty otherEraName <> " era." + "The era of the node and the tx do not match. " + <> "The node is running in the " + <> pretty ledgerEraName + <> " era, but the transaction is for the " + <> pretty otherEraName + <> " era." TxCmdBootstrapWitnessError sbwErr -> renderBootstrapWitnessError sbwErr TxCmdTxFeatureMismatch era TxFeatureImplicitFees -> - "An explicit transaction fee must be specified for " <> - pretty era <> " era transactions." - + "An explicit transaction fee must be specified for " + <> pretty era + <> " era transactions." TxCmdTxFeatureMismatch (AnyCardanoEra ShelleyEra) TxFeatureValidityNoUpperBound -> "A TTL must be specified for Shelley era transactions." - TxCmdTxFeatureMismatch era feature -> - pretty (renderFeature feature) <> " cannot be used for " <> pretty era <> - " era transactions." - + pretty (renderFeature feature) + <> " cannot be used for " + <> pretty era + <> " era transactions." TxCmdTxBodyError err' -> "Transaction validaton error: " <> prettyError err' - TxCmdNotImplemented msg -> "Feature not yet implemented: " <> pretty msg - TxCmdWitnessEraMismatch era era' (WitnessFile file) -> - "The era of a witness does not match the era of the transaction. " <> - "The transaction is for the " <> pretty era <> " era, but the " <> - "witness in " <> pshow file <> " is for the " <> pretty era' <> " era." - + "The era of a witness does not match the era of the transaction. " + <> "The transaction is for the " + <> pretty era + <> " era, but the " + <> "witness in " + <> pshow file + <> " is for the " + <> pretty era' + <> " era." TxCmdPolicyIdsMissing missingPolicyIds knownPolicyIds -> 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: " - , prettyPolicyIdList missingPolicyIds - ] <> [". Known policy Ids are: " <> prettyPolicyIdList knownPolicyIds | not (null knownPolicyIds) ] - - + [ "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: " + , prettyPolicyIdList missingPolicyIds + ] + <> [". Known policy Ids are: " <> prettyPolicyIdList knownPolicyIds | not (null knownPolicyIds)] TxCmdPolicyIdsExcess 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: " - , prettyPolicyIdList 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: " + , prettyPolicyIdList policyids + ] TxCmdByronEra -> "This query cannot be used for the Byron era" TxCmdBalanceTxBody (AnyTxBodyErrorAutoBalance err') -> - prettyError err' + prettyError err' TxCmdTxInsDoNotExist e -> pretty $ renderTxInsExistError e TxCmdPParamsErr err' -> prettyError err' TxCmdTextEnvError err' -> mconcat - [ "Failed to decode the ledger's CDDL serialisation format. " - , "File error: " <> prettyError err' - ] + [ "Failed to decode the ledger's CDDL serialisation format. " + , "File error: " <> prettyError err' + ] TxCmdTextEnvCddlError cddlErr -> mconcat - [ "Failed to decode the ledger's CDDL serialisation format. " - , "TextEnvelopeCddl error: " <> prettyError cddlErr - ] + [ "Failed to decode the ledger's CDDL serialisation format. " + , "TextEnvelopeCddl error: " <> prettyError cddlErr + ] TxCmdTxExecUnitsErr (AnyTxCmdTxExecUnitsErr err') -> prettyError err' - TxCmdPlutusScriptCostErr err'-> + TxCmdPlutusScriptCostErr err' -> prettyError err' TxCmdPParamExecutionUnitsNotAvailable -> mconcat - [ "Execution units not available in the protocol parameters. This is " - , "likely due to not being in the Alonzo era" - ] - TxCmdTxNodeEraMismatchError (NodeEraMismatchError { NEM.era = valueEra, nodeEra = nodeEra }) -> - cardanoEraConstraints nodeEra $ cardanoEraConstraints valueEra $ mconcat - [ "Transactions can only be produced in the same era as the node. Requested era: " - , pretty valueEra <> ", node era: " - , pretty nodeEra <> "." + [ "Execution units not available in the protocol parameters. This is " + , "likely due to not being in the Alonzo era" ] + TxCmdTxNodeEraMismatchError (NodeEraMismatchError{NEM.era = valueEra, nodeEra = nodeEra}) -> + cardanoEraConstraints nodeEra $ + cardanoEraConstraints valueEra $ + mconcat + [ "Transactions can only be produced in the same era as the node. Requested era: " + , pretty valueEra <> ", node era: " + , pretty nodeEra <> "." + ] TxCmdQueryConvenienceError e -> pretty $ renderQueryConvenienceError e TxCmdQueryNotScriptLocked e -> @@ -215,4 +223,4 @@ renderTxCmdError = \case prettyPolicyIdList :: [PolicyId] -> Doc ann prettyPolicyIdList = - mconcat . List.intersperse ", " . fmap (pretty . serialiseToRawBytesHexText) + mconcat . List.intersperse ", " . fmap (pretty . serialiseToRawBytesHexText) diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs index 6b4bd6b302..7d4e74dcba 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/TxValidationError.hs @@ -8,9 +8,9 @@ {-# LANGUAGE TypeApplications #-} module Cardano.CLI.Types.Errors.TxValidationError - ( TxAuxScriptsValidationError(..) - , TxGovDuplicateVotes(..) - , TxNotSupportedInEraValidationError(..) + ( TxAuxScriptsValidationError (..) + , TxGovDuplicateVotes (..) + , TxNotSupportedInEraValidationError (..) , convToTxProposalProcedures , convertToTxVotingProcedures , validateScriptSupportedInEra @@ -23,7 +23,8 @@ module Cardano.CLI.Types.Errors.TxValidationError , validateUpdateProposalFile , validateTxCurrentTreasuryValue , validateTxTreasuryDonation - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -49,8 +50,11 @@ data ScriptLanguageValidationError instance Error ScriptLanguageValidationError where prettyError = \case ScriptLanguageValidationError lang era -> - "The script language " <> pshow lang <> " is not supported in the " <> - pretty era <> " era." + "The script language " + <> pshow lang + <> " is not supported in the " + <> pretty era + <> " era." validateScriptSupportedInEra :: ShelleyBasedEra era @@ -58,82 +62,96 @@ validateScriptSupportedInEra -> Either ScriptLanguageValidationError (ScriptInEra era) validateScriptSupportedInEra era script@(ScriptInAnyLang lang _) = case toScriptInEra era script of - Nothing -> Left $ ScriptLanguageValidationError - (AnyScriptLanguage lang) (anyCardanoEra $ toCardanoEra era) + Nothing -> + Left $ + ScriptLanguageValidationError + (AnyScriptLanguage lang) + (anyCardanoEra $ toCardanoEra era) Just script' -> pure script' -data TxNotSupportedInEraValidationError era = - -- | First argument is the kind of data that is not supported. +data TxNotSupportedInEraValidationError era + = -- | First argument is the kind of data that is not supported. -- Second argument is the era that doesn't support the data. TxNotSupportedInAnyCardanoEraValidationError T.Text AnyCardanoEra - -- | First argument is the kind of data that is not supported. + | -- | First argument is the kind of data that is not supported. -- Second argument is the Shelley era that doesn't support the data. - | TxNotSupportedInShelleyBasedEraValidationError T.Text (ShelleyBasedEra era) + TxNotSupportedInShelleyBasedEraValidationError T.Text (ShelleyBasedEra era) instance Show (TxNotSupportedInEraValidationError era) where show = \case TxNotSupportedInAnyCardanoEraValidationError a cEra -> go a cEra TxNotSupportedInShelleyBasedEraValidationError a sbe -> go a sbe - where - go a era = show (pretty a) <> " not supported in " <> show era + where + go a era = show (pretty a) <> " not supported in " <> show era instance Error (TxNotSupportedInEraValidationError era) where prettyError = \case TxNotSupportedInAnyCardanoEraValidationError a cEra -> go a cEra TxNotSupportedInShelleyBasedEraValidationError a sbe -> go a sbe - where - go a cEra = pretty a <+> "not supported in" <+> viaShow cEra + where + go a cEra = pretty a <+> "not supported in" <+> viaShow cEra -validateTxTotalCollateral :: ShelleyBasedEra era - -> Maybe L.Coin - -> Either (TxNotSupportedInEraValidationError era) (TxTotalCollateral era) +validateTxTotalCollateral + :: ShelleyBasedEra era + -> Maybe L.Coin + -> Either (TxNotSupportedInEraValidationError era) (TxTotalCollateral era) validateTxTotalCollateral _ Nothing = return TxTotalCollateralNone validateTxTotalCollateral sbe (Just coll) = do - supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction collateral" + supported <- + conjureWitness (toCardanoEra sbe) $ + TxNotSupportedInAnyCardanoEraValidationError "Transaction collateral" pure $ TxTotalCollateral supported coll -validateTxCurrentTreasuryValue :: () +validateTxCurrentTreasuryValue + :: () => ShelleyBasedEra era -> Maybe TxCurrentTreasuryValue -> Either (TxNotSupportedInEraValidationError era) (Maybe (Featured ConwayEraOnwards era L.Coin)) validateTxCurrentTreasuryValue sbe mCurrentTreasuryValue = case mCurrentTreasuryValue of Nothing -> Right Nothing - Just (TxCurrentTreasuryValue { unTxCurrentTreasuryValue }) -> + Just (TxCurrentTreasuryValue{unTxCurrentTreasuryValue}) -> caseShelleyToBabbageOrConwayEraOnwards (const $ Left $ TxNotSupportedInShelleyBasedEraValidationError "Current treasury value" sbe) (\cOnwards -> Right $ Just $ Featured cOnwards unTxCurrentTreasuryValue) sbe -validateTxTreasuryDonation :: () +validateTxTreasuryDonation + :: () => ShelleyBasedEra era -> Maybe TxTreasuryDonation -> Either (TxNotSupportedInEraValidationError era) (Maybe (Featured ConwayEraOnwards era L.Coin)) validateTxTreasuryDonation sbe mTreasuryDonation = case mTreasuryDonation of Nothing -> Right Nothing - Just (TxTreasuryDonation { unTxTreasuryDonation }) -> + Just (TxTreasuryDonation{unTxTreasuryDonation}) -> caseShelleyToBabbageOrConwayEraOnwards (const $ Left $ TxNotSupportedInShelleyBasedEraValidationError "Treasury donation" sbe) - (\cOnwards -> Right $ Just $ Featured cOnwards unTxTreasuryDonation ) + (\cOnwards -> Right $ Just $ Featured cOnwards unTxTreasuryDonation) sbe -validateTxReturnCollateral :: ShelleyBasedEra era - -> Maybe (TxOut CtxTx era) - -> Either (TxNotSupportedInEraValidationError era) (TxReturnCollateral CtxTx era) +validateTxReturnCollateral + :: ShelleyBasedEra era + -> Maybe (TxOut CtxTx era) + -> Either (TxNotSupportedInEraValidationError era) (TxReturnCollateral CtxTx era) validateTxReturnCollateral _ Nothing = return TxReturnCollateralNone validateTxReturnCollateral sbe (Just retColTxOut) = do - supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction return collateral" + supported <- + conjureWitness (toCardanoEra sbe) $ + TxNotSupportedInAnyCardanoEraValidationError "Transaction return collateral" pure $ TxReturnCollateral supported retColTxOut -validateTxValidityLowerBound :: ShelleyBasedEra era - -> Maybe SlotNo - -> Either (TxNotSupportedInEraValidationError era) (TxValidityLowerBound era) +validateTxValidityLowerBound + :: ShelleyBasedEra era + -> Maybe SlotNo + -> Either (TxNotSupportedInEraValidationError era) (TxValidityLowerBound era) validateTxValidityLowerBound _ Nothing = return TxValidityNoLowerBound validateTxValidityLowerBound sbe (Just slot) = do - supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction validity lower bound" + supported <- + conjureWitness (toCardanoEra sbe) $ + TxNotSupportedInAnyCardanoEraValidationError "Transaction validity lower bound" pure $ TxValidityLowerBound supported slot data TxAuxScriptsValidationError @@ -163,7 +181,9 @@ validateRequiredSigners -> Either (TxNotSupportedInEraValidationError era) (TxExtraKeyWitnesses era) validateRequiredSigners _ [] = return TxExtraKeyWitnessesNone validateRequiredSigners sbe reqSigs = do - supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction required signers" + supported <- + conjureWitness (toCardanoEra sbe) $ + TxNotSupportedInAnyCardanoEraValidationError "Transaction required signers" pure $ TxExtraKeyWitnesses supported reqSigs validateTxScriptValidity @@ -172,26 +192,35 @@ validateTxScriptValidity -> Either (TxNotSupportedInEraValidationError era) (TxScriptValidity era) validateTxScriptValidity _ Nothing = pure TxScriptValidityNone validateTxScriptValidity sbe (Just scriptValidity) = do - supported <- conjureWitness (toCardanoEra sbe) $ TxNotSupportedInAnyCardanoEraValidationError "Transaction script validity" + supported <- + conjureWitness (toCardanoEra sbe) $ + TxNotSupportedInAnyCardanoEraValidationError "Transaction script validity" pure $ TxScriptValidity supported scriptValidity -- TODO legacy. This can be deleted when legacy commands are removed. validateUpdateProposalFile :: CardanoEra era -> Maybe UpdateProposalFile - -> Either (TxNotSupportedInEraValidationError era) (Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) + -> Either + (TxNotSupportedInEraValidationError era) + (Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile))) validateUpdateProposalFile era = \case Nothing -> pure Nothing Just updateProposal -> do - supported <- conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction update proposal" + supported <- + conjureWitness era $ TxNotSupportedInAnyCardanoEraValidationError "Transaction update proposal" pure $ Just $ Featured supported $ Just updateProposal -- TODO make this function take a ShelleyBasedEra when the last -- CardanoEra caller is removed (there remains only one). -conjureWitness :: Eon eon - => CardanoEra era -- ^ era to try to conjure eon from - -> (AnyCardanoEra -> e) -- ^ error wrapper function - -> Either e (eon era) -- ^ eon if it includes the era, an error otherwise +conjureWitness + :: Eon eon + => CardanoEra era + -- ^ era to try to conjure eon from + -> (AnyCardanoEra -> e) + -- ^ error wrapper function + -> Either e (eon era) + -- ^ eon if it includes the era, an error otherwise conjureWitness era errF = maybe (cardanoEraConstraints era $ Left . errF $ AnyCardanoEra era) Right $ forEraMaybeEon era @@ -209,29 +238,33 @@ votingScriptWitnessSingleton votingScriptWitnessSingleton _ Nothing = Map.empty votingScriptWitnessSingleton votingProcedures (Just scriptWitness) = let voter = fromJust $ getVotingScriptCredentials votingProcedures - in Map.singleton voter scriptWitness + in Map.singleton voter scriptWitness -newtype TxGovDuplicateVotes era = - TxGovDuplicateVotes (VotesMergingConflict era) +newtype TxGovDuplicateVotes era + = TxGovDuplicateVotes (VotesMergingConflict era) instance Error (TxGovDuplicateVotes era) where prettyError (TxGovDuplicateVotes (VotesMergingConflict (_voter, actionIds))) = - "Trying to merge votes with similar action identifiers: " <> viaShow actionIds <> - ". This would cause ignoring some of the votes, so not proceeding." + "Trying to merge votes with similar action identifiers: " + <> viaShow actionIds + <> ". This would cause ignoring some of the votes, so not proceeding." -- TODO: We fold twice, we can do it in a single fold convertToTxVotingProcedures - :: [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] - -> Either (TxGovDuplicateVotes era) (TxVotingProcedures BuildTx era) + :: [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] + -> Either (TxGovDuplicateVotes era) (TxVotingProcedures BuildTx era) convertToTxVotingProcedures votingProcedures = do - VotingProcedures procedure <- first TxGovDuplicateVotes $ - foldM f emptyVotingProcedures votingProcedures + VotingProcedures procedure <- + first TxGovDuplicateVotes $ + foldM f emptyVotingProcedures votingProcedures pure $ TxVotingProcedures procedure (BuildTxWith votingScriptWitnessMap) - where - votingScriptWitnessMap = foldl (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next) - Map.empty - votingProcedures - f acc (procedure, _witness) = mergeVotingProcedures acc procedure + where + votingScriptWitnessMap = + foldl + (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next) + Map.empty + votingProcedures + f acc (procedure, _witness) = mergeVotingProcedures acc procedure proposingScriptWitnessSingleton :: Proposal era @@ -246,10 +279,9 @@ convToTxProposalProcedures => [(Proposal era, Maybe (ScriptWitness WitCtxStake era))] -> TxProposalProcedures BuildTx era convToTxProposalProcedures proposalProcedures = - -- TODO: Ledger does not export snoc so we can't fold here. - let proposals = OSet.fromFoldable $ map (unProposal . fst) proposalProcedures - sWitMap = BuildTxWith $ foldl sWitMapFolder Map.empty proposalProcedures + -- TODO: Ledger does not export snoc so we can't fold here. + let proposals = OSet.fromFoldable $ map (unProposal . fst) proposalProcedures + sWitMap = BuildTxWith $ foldl sWitMapFolder Map.empty proposalProcedures in TxProposalProcedures proposals sWitMap - where - sWitMapFolder sWitMapAccum nextSWit = sWitMapAccum `Map.union` uncurry proposingScriptWitnessSingleton nextSWit - + where + sWitMapFolder sWitMapAccum nextSWit = sWitMapAccum `Map.union` uncurry proposingScriptWitnessSingleton nextSWit diff --git a/cardano-cli/src/Cardano/CLI/Types/Governance.hs b/cardano-cli/src/Cardano/CLI/Types/Governance.hs index c30189f5fc..7173121ac1 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Governance.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Governance.hs @@ -9,22 +9,23 @@ import Cardano.Api.Shelley import Cardano.CLI.Types.Key (DRepHashSource, VerificationKeyOrHashOrFile, VerificationKeyOrHashOrFileOrScriptHash) - data ConwayVote -type VoteFile = File ConwayVote +type VoteFile = File ConwayVote -- Vote type -- TODO: Conway era - remove me -data VType = VCC -- committee - | VDR -- drep - | VSP -- spo - deriving Show +data VType + = VCC -- committee + | VDR -- drep + | VSP -- spo + deriving Show -- | Possible credentials for creating a vote -data AnyVotingStakeVerificationKeyOrHashOrFile = - AnyDRepVerificationKeyOrHashOrFileOrScriptHash (VerificationKeyOrHashOrFileOrScriptHash DRepKey) +data AnyVotingStakeVerificationKeyOrHashOrFile + = AnyDRepVerificationKeyOrHashOrFileOrScriptHash (VerificationKeyOrHashOrFileOrScriptHash DRepKey) | AnyStakePoolVerificationKeyOrHashOrFile (VerificationKeyOrHashOrFile StakePoolKey) - | AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash (VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey) + | AnyCommitteeHotVerificationKeyOrHashOrFileOrScriptHash + (VerificationKeyOrHashOrFileOrScriptHash CommitteeHotKey) data VoteDelegationTarget = VoteDelegationTargetOfDRep DRepHashSource diff --git a/cardano-cli/src/Cardano/CLI/Types/Key.hs b/cardano-cli/src/Cardano/CLI/Types/Key.hs index 2be5450d55..5fb56aa5fe 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Key.hs @@ -13,44 +13,34 @@ module Cardano.CLI.Types.Key ( VerificationKeyOrFile (..) , readVerificationKeyOrFile , readVerificationKeyOrTextEnvFile - , VerificationKeyTextOrFile (..) , VerificationKeyTextOrFileError (..) , readVerificationKeyTextOrFileAnyOf , renderVerificationKeyTextOrFileError - , VerificationKeyOrHashOrFile (..) , readVerificationKeyOrHashOrFile , readVerificationKeyOrHashOrTextEnvFile - - , VerificationKeyOrHashOrFileOrScript(..) - , VerificationKeyOrHashOrFileOrScriptHash(..) - , VerificationKeySource(..) + , VerificationKeyOrHashOrFileOrScript (..) + , VerificationKeyOrHashOrFileOrScriptHash (..) + , VerificationKeySource (..) , readVerificationKeyOrHashOrFileOrScriptHash - - , PaymentVerifier(..) - , StakeIdentifier(..) - , StakeVerifier(..) - + , PaymentVerifier (..) + , StakeIdentifier (..) + , StakeVerifier (..) , generateKeyPair - --- Legacy - , StakePoolRegistrationParserRequirements(..) - + , StakePoolRegistrationParserRequirements (..) -- NewEraBased - , AnyDelegationTarget(..) + , AnyDelegationTarget (..) , StakeTarget (..) - - , ColdVerificationKeyOrFile(..) - - , DRepHashSource(..) - + , ColdVerificationKeyOrFile (..) + , DRepHashSource (..) , readDRepCredential - - , SomeSigningKey(..) + , SomeSigningKey (..) , withSomeSigningKey , readSigningKeyFile - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -70,17 +60,19 @@ import qualified Data.Text.Encoding as Text -- | Either a verification key or path to a verification key file. data VerificationKeyOrFile keyrole - = VerificationKeyValue !(VerificationKey keyrole) - -- ^ A verification key. - | VerificationKeyFilePath !(VerificationKeyFile In) - -- ^ A path to a verification key file. - -- Note that this file hasn't been validated at all (whether it exists, - -- contains a key of the correct type, etc.) - -deriving instance Show (VerificationKey keyrole) + = -- | A verification key. + VerificationKeyValue !(VerificationKey keyrole) + | -- | A path to a verification key file. + -- Note that this file hasn't been validated at all (whether it exists, + -- contains a key of the correct type, etc.) + VerificationKeyFilePath !(VerificationKeyFile In) + +deriving instance + Show (VerificationKey keyrole) => Show (VerificationKeyOrFile keyrole) -deriving instance Eq (VerificationKey keyrole) +deriving instance + Eq (VerificationKey keyrole) => Eq (VerificationKeyOrFile keyrole) -- | Read a verification key or verification key file and return a @@ -98,11 +90,12 @@ readVerificationKeyOrFile readVerificationKeyOrFile asType verKeyOrFile = case verKeyOrFile of VerificationKeyValue vk -> pure vk - VerificationKeyFilePath (File fp) -> hoistIOEither $ - readKeyFile - (AsVerificationKey asType) - (NE.fromList [InputFormatBech32, InputFormatHex, InputFormatTextEnvelope]) - fp + VerificationKeyFilePath (File fp) -> + hoistIOEither $ + readKeyFile + (AsVerificationKey asType) + (NE.fromList [InputFormatBech32, InputFormatHex, InputFormatTextEnvelope]) + fp -- | Read a verification key or verification key file and return a -- verification key. @@ -136,41 +129,39 @@ data StakeIdentifier deriving (Eq, Show) data StakePoolRegistrationParserRequirements - = StakePoolRegistrationParserRequirements - { sprStakePoolKey :: VerificationKeyOrFile StakePoolKey - -- ^ Stake pool verification key. - , sprVrfKey :: VerificationKeyOrFile VrfKey - -- ^ VRF Verification key. - , sprPoolPledge :: L.Coin - -- ^ Pool pledge. - , sprPoolCost :: L.Coin - -- ^ Pool cost. - , sprPoolMargin :: Rational - -- ^ Pool margin. - , sprRewardAccountKey :: VerificationKeyOrFile StakeKey - -- ^ Reward account verification staking key. - , spoPoolOwnerKeys :: [VerificationKeyOrFile StakeKey] - -- ^ Pool owner verification staking key(s). - , sprRelays :: [StakePoolRelay] - -- ^ Stake pool relays. - , sprMetadata :: Maybe StakePoolMetadataReference - -- ^ Stake pool metadata. - , sprNetworkId :: NetworkId - } - + = StakePoolRegistrationParserRequirements + { sprStakePoolKey :: VerificationKeyOrFile StakePoolKey + -- ^ Stake pool verification key. + , sprVrfKey :: VerificationKeyOrFile VrfKey + -- ^ VRF Verification key. + , sprPoolPledge :: L.Coin + -- ^ Pool pledge. + , sprPoolCost :: L.Coin + -- ^ Pool cost. + , sprPoolMargin :: Rational + -- ^ Pool margin. + , sprRewardAccountKey :: VerificationKeyOrFile StakeKey + -- ^ Reward account verification staking key. + , spoPoolOwnerKeys :: [VerificationKeyOrFile StakeKey] + -- ^ Pool owner verification staking key(s). + , sprRelays :: [StakePoolRelay] + -- ^ Stake pool relays. + , sprMetadata :: Maybe StakePoolMetadataReference + -- ^ Stake pool metadata. + , sprNetworkId :: NetworkId + } -- | A resource that identifies the delegation target. We can delegate -- our stake for two reasons: -- 1. To gain rewards. This is limited to choosing a stake pool -- 2. To delegate voting power. We can delegate this to a DRep, always -- abstain our vote or vote no confidence - data AnyDelegationTarget where ShelleyToBabbageDelegTarget :: ShelleyToBabbageEra era - -> VerificationKeyOrHashOrFile StakePoolKey -- ^ Stake pool target + -> VerificationKeyOrHashOrFile StakePoolKey + -- ^ Stake pool target -> AnyDelegationTarget - ConwayOnwardDelegTarget :: ConwayEraOnwards era -> StakeTarget era @@ -184,28 +175,23 @@ data StakeTarget era where :: ConwayEraOnwards era -> VerificationKeyOrHashOrFile StakePoolKey -> StakeTarget era - -- This delegates stake for voting TargetVotingDrep :: ConwayEraOnwards era -> VerificationKeyOrHashOrFile DRepKey -> StakeTarget era - -- This delegates stake for voting and rewards TargetVotingDrepAndStakePool :: ConwayEraOnwards era -> VerificationKeyOrHashOrFile DRepKey -> VerificationKeyOrHashOrFile StakePoolKey -> StakeTarget era - TargetAlwaysAbstain :: ConwayEraOnwards era -> StakeTarget era - TargetAlwaysNoConfidence :: ConwayEraOnwards era -> StakeTarget era - TargetVotingDRepScriptHash :: ConwayEraOnwards era -> ScriptHash @@ -243,26 +229,29 @@ readVerificationKeyTextOrFileAnyOf readVerificationKeyTextOrFileAnyOf verKeyTextOrFile = case verKeyTextOrFile of VktofVerificationKeyText vkText -> - pure $ first VerificationKeyTextError $ - deserialiseAnyVerificationKey (Text.encodeUtf8 vkText) + pure $ + first VerificationKeyTextError $ + deserialiseAnyVerificationKey (Text.encodeUtf8 vkText) VktofVerificationKeyFile (File fp) -> do vkBs <- liftIO $ BS.readFile fp - pure $ first VerificationKeyTextError $ - deserialiseAnyVerificationKey vkBs - + pure $ + first VerificationKeyTextError $ + deserialiseAnyVerificationKey vkBs -- | Verification key, verification key hash, or path to a verification key -- file. data VerificationKeyOrHashOrFile keyrole - = VerificationKeyOrFile !(VerificationKeyOrFile keyrole) - -- ^ Either a verification key or path to a verification key file. - | VerificationKeyHash !(Hash keyrole) - -- ^ A verification key hash. + = -- | Either a verification key or path to a verification key file. + VerificationKeyOrFile !(VerificationKeyOrFile keyrole) + | -- | A verification key hash. + VerificationKeyHash !(Hash keyrole) -deriving instance (Show (VerificationKeyOrFile keyrole), Show (Hash keyrole)) +deriving instance + (Show (VerificationKeyOrFile keyrole), Show (Hash keyrole)) => Show (VerificationKeyOrHashOrFile keyrole) -deriving instance (Eq (VerificationKeyOrFile keyrole), Eq (Hash keyrole)) +deriving instance + (Eq (VerificationKeyOrFile keyrole), Eq (Hash keyrole)) => Eq (VerificationKeyOrHashOrFile keyrole) -- | Read a verification key or verification key hash or verification key file @@ -338,25 +327,31 @@ readDRepCredential = \case DRepHashSourceScript (ScriptHash scriptHash) -> pure (L.ScriptHashObj scriptHash) DRepHashSourceVerificationKey drepVKeyOrHashOrFile -> - L.KeyHashObj . unDRepKeyHash <$> - readVerificationKeyOrHashOrTextEnvFile AsDRepKey drepVKeyOrHashOrFile + L.KeyHashObj . unDRepKeyHash + <$> readVerificationKeyOrHashOrTextEnvFile AsDRepKey drepVKeyOrHashOrFile data VerificationKeyOrHashOrFileOrScript keyrole = VkhfsKeyHashFile !(VerificationKeyOrHashOrFile keyrole) | VkhfsScript !(File ScriptInAnyLang In) -deriving instance (Eq (VerificationKeyOrHashOrFile keyrole)) +deriving instance + Eq (VerificationKeyOrHashOrFile keyrole) => Eq (VerificationKeyOrHashOrFileOrScript keyrole) -deriving instance (Show (VerificationKeyOrHashOrFile keyrole)) + +deriving instance + Show (VerificationKeyOrHashOrFile keyrole) => Show (VerificationKeyOrHashOrFileOrScript keyrole) data VerificationKeyOrHashOrFileOrScriptHash keyrole = VkhfshKeyHashFile !(VerificationKeyOrHashOrFile keyrole) | VkhfshScriptHash !ScriptHash -deriving instance (Eq (VerificationKeyOrHashOrFile keyrole)) +deriving instance + Eq (VerificationKeyOrHashOrFile keyrole) => Eq (VerificationKeyOrHashOrFileOrScriptHash keyrole) -deriving instance (Show (VerificationKeyOrHashOrFile keyrole)) + +deriving instance + Show (VerificationKeyOrHashOrFile keyrole) => Show (VerificationKeyOrHashOrFileOrScriptHash keyrole) data VerificationKeySource keyrole @@ -364,9 +359,12 @@ data VerificationKeySource keyrole | VksScript !(File ScriptInAnyLang In) | VksScriptHash !ScriptHash -deriving instance (Eq (VerificationKeyOrHashOrFile keyrole)) +deriving instance + Eq (VerificationKeyOrHashOrFile keyrole) => Eq (VerificationKeySource keyrole) -deriving instance (Show (VerificationKeyOrHashOrFile keyrole)) + +deriving instance + Show (VerificationKeyOrHashOrFile keyrole) => Show (VerificationKeySource keyrole) readVerificationKeyOrHashOrFileOrScriptHash @@ -380,93 +378,95 @@ readVerificationKeyOrHashOrFileOrScriptHash asType extractHash = \case VkhfshScriptHash (ScriptHash scriptHash) -> pure (L.ScriptHashObj scriptHash) VkhfshKeyHashFile vKeyOrHashOrFile -> - L.KeyHashObj . extractHash <$> - readVerificationKeyOrHashOrTextEnvFile asType vKeyOrHashOrFile + L.KeyHashObj . extractHash + <$> readVerificationKeyOrHashOrTextEnvFile asType vKeyOrHashOrFile data SomeSigningKey - = AByronSigningKey (SigningKey ByronKey) - | APaymentSigningKey (SigningKey PaymentKey) - | APaymentExtendedSigningKey (SigningKey PaymentExtendedKey) - | AStakeSigningKey (SigningKey StakeKey) - | AStakeExtendedSigningKey (SigningKey StakeExtendedKey) - | AStakePoolSigningKey (SigningKey StakePoolKey) - | AGenesisSigningKey (SigningKey GenesisKey) - | AGenesisExtendedSigningKey (SigningKey GenesisExtendedKey) - | AGenesisDelegateSigningKey (SigningKey GenesisDelegateKey) - | AGenesisDelegateExtendedSigningKey (SigningKey GenesisDelegateExtendedKey) - | AGenesisUTxOSigningKey (SigningKey GenesisUTxOKey) - | ADRepSigningKey (SigningKey DRepKey) - | ADRepExtendedSigningKey (SigningKey DRepExtendedKey) - | ACommitteeColdSigningKey (SigningKey CommitteeColdKey) - | ACommitteeColdExtendedSigningKey (SigningKey CommitteeColdExtendedKey) - | ACommitteeHotSigningKey (SigningKey CommitteeHotKey) - | ACommitteeHotExtendedSigningKey (SigningKey CommitteeHotExtendedKey) - | AVrfSigningKey (SigningKey VrfKey) - | AKesSigningKey (SigningKey KesKey) - -withSomeSigningKey :: () + = AByronSigningKey (SigningKey ByronKey) + | APaymentSigningKey (SigningKey PaymentKey) + | APaymentExtendedSigningKey (SigningKey PaymentExtendedKey) + | AStakeSigningKey (SigningKey StakeKey) + | AStakeExtendedSigningKey (SigningKey StakeExtendedKey) + | AStakePoolSigningKey (SigningKey StakePoolKey) + | AGenesisSigningKey (SigningKey GenesisKey) + | AGenesisExtendedSigningKey (SigningKey GenesisExtendedKey) + | AGenesisDelegateSigningKey (SigningKey GenesisDelegateKey) + | AGenesisDelegateExtendedSigningKey (SigningKey GenesisDelegateExtendedKey) + | AGenesisUTxOSigningKey (SigningKey GenesisUTxOKey) + | ADRepSigningKey (SigningKey DRepKey) + | ADRepExtendedSigningKey (SigningKey DRepExtendedKey) + | ACommitteeColdSigningKey (SigningKey CommitteeColdKey) + | ACommitteeColdExtendedSigningKey (SigningKey CommitteeColdExtendedKey) + | ACommitteeHotSigningKey (SigningKey CommitteeHotKey) + | ACommitteeHotExtendedSigningKey (SigningKey CommitteeHotExtendedKey) + | AVrfSigningKey (SigningKey VrfKey) + | AKesSigningKey (SigningKey KesKey) + +withSomeSigningKey + :: () => SomeSigningKey -> (forall keyrole. (Key keyrole, HasTypeProxy keyrole) => SigningKey keyrole -> a) -> a withSomeSigningKey ssk f = - case ssk of - AByronSigningKey sk -> f sk - APaymentSigningKey sk -> f sk - APaymentExtendedSigningKey sk -> f sk - AStakeSigningKey sk -> f sk - AStakeExtendedSigningKey sk -> f sk - AStakePoolSigningKey sk -> f sk - AGenesisSigningKey sk -> f sk - AGenesisExtendedSigningKey sk -> f sk - AGenesisDelegateSigningKey sk -> f sk - AGenesisDelegateExtendedSigningKey sk -> f sk - AGenesisUTxOSigningKey sk -> f sk - ADRepSigningKey sk -> f sk - ADRepExtendedSigningKey sk -> f sk - ACommitteeColdSigningKey sk -> f sk - ACommitteeColdExtendedSigningKey sk -> f sk - ACommitteeHotSigningKey sk -> f sk - ACommitteeHotExtendedSigningKey sk -> f sk - AVrfSigningKey sk -> f sk - AKesSigningKey sk -> f sk - -readSigningKeyFile :: () + case ssk of + AByronSigningKey sk -> f sk + APaymentSigningKey sk -> f sk + APaymentExtendedSigningKey sk -> f sk + AStakeSigningKey sk -> f sk + AStakeExtendedSigningKey sk -> f sk + AStakePoolSigningKey sk -> f sk + AGenesisSigningKey sk -> f sk + AGenesisExtendedSigningKey sk -> f sk + AGenesisDelegateSigningKey sk -> f sk + AGenesisDelegateExtendedSigningKey sk -> f sk + AGenesisUTxOSigningKey sk -> f sk + ADRepSigningKey sk -> f sk + ADRepExtendedSigningKey sk -> f sk + ACommitteeColdSigningKey sk -> f sk + ACommitteeColdExtendedSigningKey sk -> f sk + ACommitteeHotSigningKey sk -> f sk + ACommitteeHotExtendedSigningKey sk -> f sk + AVrfSigningKey sk -> f sk + AKesSigningKey sk -> f sk + +readSigningKeyFile + :: () => SigningKeyFile In -> ExceptT (FileError InputDecodeError) IO SomeSigningKey readSigningKeyFile skFile = - newExceptT $ - readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile - where - -- If you update these variables, consider updating the ones with the same - -- names in Cardano.CLI.Read - textEnvFileTypes = - [ FromSomeType (AsSigningKey AsByronKey) AByronSigningKey - , FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningKey - , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningKey - , FromSomeType (AsSigningKey AsStakeKey) AStakeSigningKey - , FromSomeType (AsSigningKey AsStakeExtendedKey) AStakeExtendedSigningKey - , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningKey - , FromSomeType (AsSigningKey AsGenesisKey) AGenesisSigningKey - , FromSomeType (AsSigningKey AsGenesisExtendedKey) AGenesisExtendedSigningKey - , FromSomeType (AsSigningKey AsGenesisDelegateKey) AGenesisDelegateSigningKey - , FromSomeType (AsSigningKey AsGenesisDelegateExtendedKey) AGenesisDelegateExtendedSigningKey - , FromSomeType (AsSigningKey AsGenesisUTxOKey) AGenesisUTxOSigningKey - , FromSomeType (AsSigningKey AsDRepKey) ADRepSigningKey - , FromSomeType (AsSigningKey AsDRepExtendedKey) ADRepExtendedSigningKey - , FromSomeType (AsSigningKey AsCommitteeColdKey) ACommitteeColdSigningKey - , FromSomeType (AsSigningKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedSigningKey - , FromSomeType (AsSigningKey AsCommitteeHotKey) ACommitteeHotSigningKey - , FromSomeType (AsSigningKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedSigningKey - , FromSomeType (AsSigningKey AsVrfKey) AVrfSigningKey - , FromSomeType (AsSigningKey AsKesKey) AKesSigningKey - ] - - bech32FileTypes = - [ FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningKey - , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningKey - , FromSomeType (AsSigningKey AsStakeKey) AStakeSigningKey - , FromSomeType (AsSigningKey AsStakeExtendedKey) AStakeExtendedSigningKey - , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningKey - , FromSomeType (AsSigningKey AsVrfKey) AVrfSigningKey - , FromSomeType (AsSigningKey AsKesKey) AKesSigningKey - ] + newExceptT $ + readKeyFileAnyOf bech32FileTypes textEnvFileTypes skFile + where + -- If you update these variables, consider updating the ones with the same + -- names in Cardano.CLI.Read + textEnvFileTypes = + [ FromSomeType (AsSigningKey AsByronKey) AByronSigningKey + , FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningKey + , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningKey + , FromSomeType (AsSigningKey AsStakeKey) AStakeSigningKey + , FromSomeType (AsSigningKey AsStakeExtendedKey) AStakeExtendedSigningKey + , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningKey + , FromSomeType (AsSigningKey AsGenesisKey) AGenesisSigningKey + , FromSomeType (AsSigningKey AsGenesisExtendedKey) AGenesisExtendedSigningKey + , FromSomeType (AsSigningKey AsGenesisDelegateKey) AGenesisDelegateSigningKey + , FromSomeType (AsSigningKey AsGenesisDelegateExtendedKey) AGenesisDelegateExtendedSigningKey + , FromSomeType (AsSigningKey AsGenesisUTxOKey) AGenesisUTxOSigningKey + , FromSomeType (AsSigningKey AsDRepKey) ADRepSigningKey + , FromSomeType (AsSigningKey AsDRepExtendedKey) ADRepExtendedSigningKey + , FromSomeType (AsSigningKey AsCommitteeColdKey) ACommitteeColdSigningKey + , FromSomeType (AsSigningKey AsCommitteeColdExtendedKey) ACommitteeColdExtendedSigningKey + , FromSomeType (AsSigningKey AsCommitteeHotKey) ACommitteeHotSigningKey + , FromSomeType (AsSigningKey AsCommitteeHotExtendedKey) ACommitteeHotExtendedSigningKey + , FromSomeType (AsSigningKey AsVrfKey) AVrfSigningKey + , FromSomeType (AsSigningKey AsKesKey) AKesSigningKey + ] + + bech32FileTypes = + [ FromSomeType (AsSigningKey AsPaymentKey) APaymentSigningKey + , FromSomeType (AsSigningKey AsPaymentExtendedKey) APaymentExtendedSigningKey + , FromSomeType (AsSigningKey AsStakeKey) AStakeSigningKey + , FromSomeType (AsSigningKey AsStakeExtendedKey) AStakeExtendedSigningKey + , FromSomeType (AsSigningKey AsStakePoolKey) AStakePoolSigningKey + , FromSomeType (AsSigningKey AsVrfKey) AVrfSigningKey + , FromSomeType (AsSigningKey AsKesKey) AKesSigningKey + ] diff --git a/cardano-cli/src/Cardano/CLI/Types/Key/VerificationKey.hs b/cardano-cli/src/Cardano/CLI/Types/Key/VerificationKey.hs index 698ec35c26..a985475534 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Key/VerificationKey.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Key/VerificationKey.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds #-} module Cardano.CLI.Types.Key.VerificationKey - ( AnyVerificationKeySource(..) - , AnyVerificationKeyText(..) - ) where + ( AnyVerificationKeySource (..) + , AnyVerificationKeyText (..) + ) +where import Cardano.Api @@ -21,4 +22,3 @@ data AnyVerificationKeySource = AnyVerificationKeySourceOfText !AnyVerificationKeyText | AnyVerificationKeySourceOfFile !(File (VerificationKey ()) In) deriving (Eq, Show) - diff --git a/cardano-cli/src/Cardano/CLI/Types/MonadWarning.hs b/cardano-cli/src/Cardano/CLI/Types/MonadWarning.hs index f46c3c50f2..eb100d82f4 100644 --- a/cardano-cli/src/Cardano/CLI/Types/MonadWarning.hs +++ b/cardano-cli/src/Cardano/CLI/Types/MonadWarning.hs @@ -1,4 +1,8 @@ ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} + -- | -- Module : Cardano.CLI.Types.MonadWarning -- @@ -33,19 +37,15 @@ -- result <- runWarningIO $ computeWithWarning (-4) -- putStrLn $ "Result: " ++ show result -- @ ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} - module Cardano.CLI.Types.MonadWarning - ( MonadWarning(..) + ( MonadWarning (..) , WarningIO , WarningStateT , eitherToWarning , runWarningIO , runWarningStateT - ) where + ) +where import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State (MonadState (..)) @@ -56,18 +56,22 @@ import System.IO (hPutStrLn, stderr) -- their execution in the process. class Monad m => MonadWarning m where -- | Report a non-fatal issue. - reportIssue :: String -- ^ The warning message to report. - -> m () -- ^ The action that reports the warning. + reportIssue + :: String + -- ^ The warning message to report. + -> m () + -- ^ The action that reports the warning. -- | Wrapper newtype for 'MonadIO' with 'MonadWarning' instance. -- This type is not meant to be constructed directly but just to serve -- as an instance of 'MonadWarning' that can be converted to 'MonadIO'. -- It is only necessary in order to avoid overlapping instances. -newtype WarningIO m a = WarningIO { - runWarningIO :: m a - -- ^ Interpret a 'MonadWarning' as a 'MonadIO' by reporting - -- warnings to 'stderr'. - } deriving (Functor, Applicative, Monad, MonadIO) +newtype WarningIO m a = WarningIO + { runWarningIO :: m a + -- ^ Interpret a 'MonadWarning' as a 'MonadIO' by reporting + -- warnings to 'stderr'. + } + deriving (Functor, Applicative, Monad, MonadIO) -- | This instance prints the issue to 'stderr'. instance MonadIO m => MonadWarning (WarningIO m) where @@ -78,19 +82,20 @@ instance MonadIO m => MonadWarning (WarningIO m) where -- This type is not meant to be constructed directly but just to serve -- as an instance of 'MonadWarning' that can be converted to 'StateT'. -- It is only necessary in order to avoid overlapping instances. -newtype WarningStateT m a = WarningStateT { - runWarningStateT :: StateT [String] m a - -- ^ Interpret a 'MonadWarning' as a @StateT [String]@ monad, - -- by accumulating warnings into the state. - } deriving (Functor, Applicative, Monad, MonadState [String]) +newtype WarningStateT m a = WarningStateT + { runWarningStateT :: StateT [String] m a + -- ^ Interpret a 'MonadWarning' as a @StateT [String]@ monad, + -- by accumulating warnings into the state. + } + deriving (Functor, Applicative, Monad, MonadState [String]) -- | This instance adds the issue to the @[String]@ in the state. instance Monad m => MonadWarning (WarningStateT m) where reportIssue :: String -> WarningStateT m () - reportIssue issue = state (\ x -> ((), issue : x)) + reportIssue issue = state (\x -> ((), issue : x)) -- | Convert an 'Either' into a 'MonadWarning'. If 'Either' is 'Left' -- it returns the default value (first parameter) and reports the 'String' -- as an error. If 'Either' is 'Right' it just returns that value. eitherToWarning :: MonadWarning m => a -> Either String a -> m a -eitherToWarning def = either (\issue -> do {reportIssue issue; return def}) return +eitherToWarning def = either (\issue -> do reportIssue issue; return def) return diff --git a/cardano-cli/src/Cardano/CLI/Types/Output.hs b/cardano-cli/src/Cardano/CLI/Types/Output.hs index 84328408f6..3d29fe095f 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Output.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Output.hs @@ -7,12 +7,13 @@ module Cardano.CLI.Types.Output ( PlutusScriptCostError , QueryKesPeriodInfoOutput (..) - , QueryTipLocalState(..) - , QueryTipLocalStateOutput(..) + , QueryTipLocalState (..) + , QueryTipLocalStateOutput (..) , ScriptCostOutput (..) , createOpCertIntervalInfo , renderScriptCosts - ) where + ) +where import Cardano.Api import qualified Cardano.Api.Ledger as L @@ -32,65 +33,70 @@ import qualified Data.Text as Text import Data.Time.Clock (UTCTime) import Data.Word -data QueryKesPeriodInfoOutput = - QueryKesPeriodInfoOutput - { qKesOpCertIntervalInformation :: OpCertIntervalInformation - -- | Date of KES key expiry. - , qKesInfoKesKeyExpiry :: Maybe UTCTime - -- | The latest operational certificate number in the node's state - -- i.e how many times a new KES key has been generated. - , qKesInfoNodeStateOperationalCertNo :: Maybe OpCertNodeStateCounter - -- | The on disk operational certificate number. - , qKesInfoOnDiskOperationalCertNo :: OpCertOnDiskCounter - -- | The maximum number of KES key evolutions permitted per KES period. - , qKesInfoMaxKesKeyEvolutions :: Word64 - , qKesInfoSlotsPerKesPeriod :: Word64 - } deriving (Eq, Show) +data QueryKesPeriodInfoOutput + = QueryKesPeriodInfoOutput + { qKesOpCertIntervalInformation :: OpCertIntervalInformation + , qKesInfoKesKeyExpiry :: Maybe UTCTime + -- ^ Date of KES key expiry. + , qKesInfoNodeStateOperationalCertNo :: Maybe OpCertNodeStateCounter + -- ^ The latest operational certificate number in the node's state + -- i.e how many times a new KES key has been generated. + , qKesInfoOnDiskOperationalCertNo :: OpCertOnDiskCounter + -- ^ The on disk operational certificate number. + , qKesInfoMaxKesKeyEvolutions :: Word64 + -- ^ The maximum number of KES key evolutions permitted per KES period. + , qKesInfoSlotsPerKesPeriod :: Word64 + } + deriving (Eq, Show) instance ToJSON QueryKesPeriodInfoOutput where - toJSON (QueryKesPeriodInfoOutput opCertIntervalInfo - kesKeyExpiryTime - nodeStateOpCertNo - (OpCertOnDiskCounter onDiskOpCertNo) - maxKesKeyOps - slotsPerKesPeriod) = do - let (sKes, eKes, cKes, slotsTillExp) = - case opCertIntervalInfo of - OpCertWithinInterval startKes endKes currKes sUntilExp -> - ( unOpCertStartingKesPeriod startKes - , unOpCertEndingKesPeriod endKes - , unCurrentKesPeriod currKes - , Just sUntilExp - ) - OpCertStartingKesPeriodIsInTheFuture startKes endKes currKes -> - ( unOpCertStartingKesPeriod startKes - , unOpCertEndingKesPeriod endKes - , unCurrentKesPeriod currKes - , Nothing - ) - OpCertExpired startKes endKes currKes -> - ( unOpCertStartingKesPeriod startKes - , unOpCertEndingKesPeriod endKes - , unCurrentKesPeriod currKes - , Nothing - ) - OpCertSomeOtherError startKes endKes currKes -> - ( unOpCertStartingKesPeriod startKes - , unOpCertEndingKesPeriod endKes - , unCurrentKesPeriod currKes - , Nothing - ) + toJSON + ( QueryKesPeriodInfoOutput + opCertIntervalInfo + kesKeyExpiryTime + nodeStateOpCertNo + (OpCertOnDiskCounter onDiskOpCertNo) + maxKesKeyOps + slotsPerKesPeriod + ) = do + let (sKes, eKes, cKes, slotsTillExp) = + case opCertIntervalInfo of + OpCertWithinInterval startKes endKes currKes sUntilExp -> + ( unOpCertStartingKesPeriod startKes + , unOpCertEndingKesPeriod endKes + , unCurrentKesPeriod currKes + , Just sUntilExp + ) + OpCertStartingKesPeriodIsInTheFuture startKes endKes currKes -> + ( unOpCertStartingKesPeriod startKes + , unOpCertEndingKesPeriod endKes + , unCurrentKesPeriod currKes + , Nothing + ) + OpCertExpired startKes endKes currKes -> + ( unOpCertStartingKesPeriod startKes + , unOpCertEndingKesPeriod endKes + , unCurrentKesPeriod currKes + , Nothing + ) + OpCertSomeOtherError startKes endKes currKes -> + ( unOpCertStartingKesPeriod startKes + , unOpCertEndingKesPeriod endKes + , unCurrentKesPeriod currKes + , Nothing + ) - object [ "qKesCurrentKesPeriod" .= cKes - , "qKesStartKesInterval" .= sKes - , "qKesEndKesInterval" .= eKes - , "qKesRemainingSlotsInKesPeriod" .= slotsTillExp - , "qKesOnDiskOperationalCertificateNumber" .= onDiskOpCertNo - , "qKesNodeStateOperationalCertificateNumber" .= nodeStateOpCertNo - , "qKesMaxKESEvolutions" .= maxKesKeyOps - , "qKesSlotsPerKesPeriod" .= slotsPerKesPeriod - , "qKesKesKeyExpiry" .= kesKeyExpiryTime - ] + object + [ "qKesCurrentKesPeriod" .= cKes + , "qKesStartKesInterval" .= sKes + , "qKesEndKesInterval" .= eKes + , "qKesRemainingSlotsInKesPeriod" .= slotsTillExp + , "qKesOnDiskOperationalCertificateNumber" .= onDiskOpCertNo + , "qKesNodeStateOperationalCertificateNumber" .= nodeStateOpCertNo + , "qKesMaxKESEvolutions" .= maxKesKeyOps + , "qKesSlotsPerKesPeriod" .= slotsPerKesPeriod + , "qKesKesKeyExpiry" .= kesKeyExpiryTime + ] instance FromJSON QueryKesPeriodInfoOutput where parseJSON = withObject "QueryKesPeriodInfoOutput" $ \o -> do @@ -103,20 +109,21 @@ instance FromJSON QueryKesPeriodInfoOutput where maxKESEvolutions <- o .: "qKesMaxKESEvolutions" slotsPerKesPeriod <- o .: "qKesSlotsPerKesPeriod" kesKeyExpiry <- o .: "qKesKesKeyExpiry" - let opCertIntervalInfo = createOpCertIntervalInfo - currentKesPeriod - startKesInterval - endKesInterval - remainingSlotsInKesPeriod - return $ QueryKesPeriodInfoOutput - { qKesOpCertIntervalInformation = opCertIntervalInfo - , qKesInfoKesKeyExpiry = kesKeyExpiry - , qKesInfoNodeStateOperationalCertNo = nodeStateOperationalCertificateNumber - , qKesInfoOnDiskOperationalCertNo = onDiskOperationalCertificateNumber - , qKesInfoMaxKesKeyEvolutions = maxKESEvolutions - , qKesInfoSlotsPerKesPeriod = slotsPerKesPeriod - } - + let opCertIntervalInfo = + createOpCertIntervalInfo + currentKesPeriod + startKesInterval + endKesInterval + remainingSlotsInKesPeriod + return $ + QueryKesPeriodInfoOutput + { qKesOpCertIntervalInformation = opCertIntervalInfo + , qKesInfoKesKeyExpiry = kesKeyExpiry + , qKesInfoNodeStateOperationalCertNo = nodeStateOperationalCertificateNumber + , qKesInfoOnDiskOperationalCertNo = onDiskOperationalCertificateNumber + , qKesInfoMaxKesKeyEvolutions = maxKESEvolutions + , qKesInfoSlotsPerKesPeriod = slotsPerKesPeriod + } createOpCertIntervalInfo :: CurrentKesPeriod @@ -124,23 +131,24 @@ createOpCertIntervalInfo -> OpCertEndingKesPeriod -> Maybe SlotsTillKesKeyExpiry -> OpCertIntervalInformation -createOpCertIntervalInfo c@(CurrentKesPeriod cKesPeriod) - s@(OpCertStartingKesPeriod oCertStart) - e@(OpCertEndingKesPeriod oCertEnd) - (Just tillExp) - | oCertStart <= cKesPeriod && cKesPeriod < oCertEnd = - OpCertWithinInterval s e c tillExp - | oCertStart > cKesPeriod = OpCertStartingKesPeriodIsInTheFuture s e c - | cKesPeriod >= oCertEnd = OpCertExpired s e c - | otherwise = OpCertSomeOtherError s e c -createOpCertIntervalInfo c@(CurrentKesPeriod cKesPeriod) - s@(OpCertStartingKesPeriod oCertStart) - e@(OpCertEndingKesPeriod oCertEnd) - Nothing - | oCertStart > cKesPeriod = OpCertStartingKesPeriodIsInTheFuture s e c - | cKesPeriod >= oCertEnd = OpCertExpired s e c - | otherwise = OpCertSomeOtherError s e c - +createOpCertIntervalInfo + c@(CurrentKesPeriod cKesPeriod) + s@(OpCertStartingKesPeriod oCertStart) + e@(OpCertEndingKesPeriod oCertEnd) + (Just tillExp) + | oCertStart <= cKesPeriod && cKesPeriod < oCertEnd = + OpCertWithinInterval s e c tillExp + | oCertStart > cKesPeriod = OpCertStartingKesPeriodIsInTheFuture s e c + | cKesPeriod >= oCertEnd = OpCertExpired s e c + | otherwise = OpCertSomeOtherError s e c +createOpCertIntervalInfo + c@(CurrentKesPeriod cKesPeriod) + s@(OpCertStartingKesPeriod oCertStart) + e@(OpCertEndingKesPeriod oCertEnd) + Nothing + | oCertStart > cKesPeriod = OpCertStartingKesPeriodIsInTheFuture s e c + | cKesPeriod >= oCertEnd = OpCertExpired s e c + | otherwise = OpCertSomeOtherError s e c data QueryTipLocalState mode = QueryTipLocalState { era :: AnyCardanoEra @@ -156,16 +164,17 @@ data QueryTipLocalStateOutput = QueryTipLocalStateOutput , mSlotInEpoch :: Maybe Word64 , mSlotsToEpochEnd :: Maybe Word64 , mSyncProgress :: Maybe Text - } deriving Show + } + deriving Show -- | A key-value pair difference list for encoding a JSON object. (..=) :: (KeyValue e kv, ToJSON v) => Aeson.Key -> v -> [kv] -> [kv] -(..=) n v = (n .= v:) +(..=) n v = (n .= v :) -- | A key-value pair difference list for encoding a JSON object where Nothing encodes absence of the key-value pair. (..=?) :: (KeyValue e kv, ToJSON v) => Aeson.Key -> Maybe v -> [kv] -> [kv] (..=?) n mv = case mv of - Just v -> (n .= v:) + Just v -> (n .= v :) Nothing -> id instance ToJSON QueryTipLocalStateOutput where @@ -173,42 +182,48 @@ instance ToJSON QueryTipLocalStateOutput where ChainTipAtGenesis -> object $ ( ("era" ..=? mEra a) - . ("epoch" ..=? mEpoch a) - . ("slotInEpoch" ..=? mSlotInEpoch a) - . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) - . ("syncProgress" ..=? mSyncProgress a) - ) [] + . ("epoch" ..=? mEpoch a) + . ("slotInEpoch" ..=? mSlotInEpoch a) + . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) + . ("syncProgress" ..=? mSyncProgress a) + ) + [] ChainTip slotNo blockHeader blockNo -> object $ ( ("slot" ..= slotNo) - . ("hash" ..= serialiseToRawBytesHexText blockHeader) - . ("block" ..= blockNo) - . ("era" ..=? mEra a) - . ("epoch" ..=? mEpoch a) - . ("slotInEpoch" ..=? mSlotInEpoch a) - . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) - . ("syncProgress" ..=? mSyncProgress a) - ) [] + . ("hash" ..= serialiseToRawBytesHexText blockHeader) + . ("block" ..= blockNo) + . ("era" ..=? mEra a) + . ("epoch" ..=? mEpoch a) + . ("slotInEpoch" ..=? mSlotInEpoch a) + . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) + . ("syncProgress" ..=? mSyncProgress a) + ) + [] toEncoding a = case localStateChainTip a of ChainTipAtGenesis -> - pairs $ mconcat $ - ( ("era" ..=? mEra a) - . ("epoch" ..=? mEpoch a) - . ("slotInEpoch" ..=? mSlotInEpoch a) - . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) - . ("syncProgress" ..=? mSyncProgress a) - ) [] + pairs $ + mconcat $ + ( ("era" ..=? mEra a) + . ("epoch" ..=? mEpoch a) + . ("slotInEpoch" ..=? mSlotInEpoch a) + . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) + . ("syncProgress" ..=? mSyncProgress a) + ) + [] ChainTip slotNo blockHeader blockNo -> - pairs $ mconcat $ - ( ("slot" ..= slotNo) - . ("hash" ..= serialiseToRawBytesHexText blockHeader) - . ("block" ..= blockNo) - . ("era" ..=? mEra a) - . ("epoch" ..=? mEpoch a) - . ("slotInEpoch" ..=? mSlotInEpoch a) - . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) - . ("syncProgress" ..=? mSyncProgress a) - ) [] + pairs $ + mconcat $ + ( ("slot" ..= slotNo) + . ("hash" ..= serialiseToRawBytesHexText blockHeader) + . ("block" ..= blockNo) + . ("era" ..=? mEra a) + . ("epoch" ..=? mEpoch a) + . ("slotInEpoch" ..=? mSlotInEpoch a) + . ("slotsToEpochEnd" ..=? mSlotsToEpochEnd a) + . ("syncProgress" ..=? mSyncProgress a) + ) + [] instance FromJSON QueryTipLocalStateOutput where parseJSON = withObject "QueryTipLocalStateOutput" $ \o -> do @@ -223,72 +238,82 @@ instance FromJSON QueryTipLocalStateOutput where mSlotsToEpochEnd' <- o .:? "slotsToEpochEnd" case (mSlot, mHash, mBlock) of (Nothing, Nothing, Nothing) -> - pure $ QueryTipLocalStateOutput - ChainTipAtGenesis - mEra' - mEpoch' - mSlotInEpoch' - mSlotsToEpochEnd' - mSyncProgress' + pure $ + QueryTipLocalStateOutput + ChainTipAtGenesis + mEra' + mEpoch' + mSlotInEpoch' + mSlotsToEpochEnd' + mSyncProgress' (Just slot, Just hash, Just block) -> - pure $ QueryTipLocalStateOutput - (ChainTip slot hash block) - mEra' - mEpoch' - mSlotInEpoch' - mSlotsToEpochEnd' - mSyncProgress' - (_,_,_) -> - fail $ mconcat - [ "QueryTipLocalStateOutput was incorrectly JSON encoded." - , " Expected slot, header hash and block number (ChainTip)" - , " or none (ChainTipAtGenesis)" - ] + pure $ + QueryTipLocalStateOutput + (ChainTip slot hash block) + mEra' + mEpoch' + mSlotInEpoch' + mSlotsToEpochEnd' + mSyncProgress' + (_, _, _) -> + fail $ + mconcat + [ "QueryTipLocalStateOutput was incorrectly JSON encoded." + , " Expected slot, header hash and block number (ChainTip)" + , " or none (ChainTipAtGenesis)" + ] -data ScriptCostOutput = - ScriptCostOutput - { scScriptHash :: ScriptHash - , scExecutionUnits :: ExecutionUnits - , scAda :: L.Coin - } +data ScriptCostOutput + = ScriptCostOutput + { scScriptHash :: ScriptHash + , scExecutionUnits :: ExecutionUnits + , scAda :: L.Coin + } instance ToJSON ScriptCostOutput where toJSON (ScriptCostOutput sHash execUnits llCost) = - object [ "scriptHash" .= sHash - , "executionUnits" .= execUnits - , "lovelaceCost" .= llCost - ] + object + [ "scriptHash" .= sHash + , "executionUnits" .= execUnits + , "lovelaceCost" .= llCost + ] data PlutusScriptCostError = PlutusScriptCostErrPlutusScriptNotFound ScriptWitnessIndex | PlutusScriptCostErrExecError ScriptWitnessIndex (Maybe ScriptHash) ScriptExecutionError | PlutusScriptCostErrRationalExceedsBound - [Text] -- ^ Execution logs + [Text] + -- ^ Execution logs L.Prices ExecutionUnits | PlutusScriptCostErrRefInputNoScript TxIn | PlutusScriptCostErrRefInputNotInUTxO TxIn deriving Show - instance Error PlutusScriptCostError where prettyError = \case PlutusScriptCostErrPlutusScriptNotFound sWitIndex -> "No Plutus script was found at: " <> pshow sWitIndex PlutusScriptCostErrExecError sWitIndex sHash sExecErro -> - "Plutus script at: " <> pshow sWitIndex <> " with hash: " <> pshow sHash <> - " errored with: " <> prettyError sExecErro + "Plutus script at: " + <> pshow sWitIndex + <> " with hash: " + <> pshow sHash + <> " errored with: " + <> prettyError sExecErro PlutusScriptCostErrRationalExceedsBound executionLogs eUnitPrices eUnits -> - let firstLine = mconcat [ "Either the execution unit prices: " - , pshow eUnitPrices - , " or the execution units: " - , pshow eUnits - , " or both are either too precise or not within bounds" - ] - in vsep [ firstLine - , "Execution logs: " <> pretty (Text.unlines executionLogs) + let firstLine = + mconcat + [ "Either the execution unit prices: " + , pshow eUnitPrices + , " or the execution units: " + , pshow eUnits + , " or both are either too precise or not within bounds" ] - + in vsep + [ firstLine + , "Execution logs: " <> pretty (Text.unlines executionLogs) + ] PlutusScriptCostErrRefInputNoScript txin -> "No reference script found at input: " <> pretty (renderTxIn txin) PlutusScriptCostErrRefInputNotInUTxO txin -> @@ -306,44 +331,43 @@ renderScriptCosts -- index to execution units. -> Either PlutusScriptCostError [ScriptCostOutput] renderScriptCosts (UTxO utxo) eUnitPrices scriptMapping executionCostMapping = - sequenceA $ Map.foldlWithKey - (\accum sWitInd eExecUnits -> do - case List.lookup sWitInd scriptMapping of - Just (AnyScriptWitness SimpleScriptWitness{}) -> accum - - Just (AnyScriptWitness (PlutusScriptWitness _ pVer (PScript pScript) _ _ _)) -> do - let scriptHash = hashScript $ PlutusScript pVer pScript - case eExecUnits of - Right (logs, execUnits) -> - case calculateExecutionUnitsLovelace eUnitPrices execUnits of - Just llCost -> - Right (ScriptCostOutput scriptHash execUnits llCost) - : accum - Nothing -> - Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits) - : accum - Left err -> Left (PlutusScriptCostErrExecError sWitInd (Just scriptHash) err) : accum - -- TODO: Create a new sum type to encapsulate the fact that we can also - -- have a txin and render the txin in the case of reference scripts. - Just (AnyScriptWitness (PlutusScriptWitness _ _ (PReferenceScript refTxIn _) _ _ _)) -> - case Map.lookup refTxIn utxo of - Nothing -> Left (PlutusScriptCostErrRefInputNotInUTxO refTxIn) : accum - Just (TxOut _ _ _ refScript) -> - case refScript of - ReferenceScriptNone -> Left (PlutusScriptCostErrRefInputNoScript refTxIn) : accum - ReferenceScript _ (ScriptInAnyLang _ script) -> - case eExecUnits of - Right (logs, execUnits) -> - case calculateExecutionUnitsLovelace eUnitPrices execUnits of - Just llCost -> - Right (ScriptCostOutput (hashScript script) execUnits llCost) - : accum - Nothing -> - Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits) - : accum - Left err -> Left (PlutusScriptCostErrExecError sWitInd Nothing err) : accum - - - Nothing -> Left (PlutusScriptCostErrPlutusScriptNotFound sWitInd) : accum - - ) [] executionCostMapping + sequenceA $ + Map.foldlWithKey + ( \accum sWitInd eExecUnits -> do + case List.lookup sWitInd scriptMapping of + Just (AnyScriptWitness SimpleScriptWitness{}) -> accum + Just (AnyScriptWitness (PlutusScriptWitness _ pVer (PScript pScript) _ _ _)) -> do + let scriptHash = hashScript $ PlutusScript pVer pScript + case eExecUnits of + Right (logs, execUnits) -> + case calculateExecutionUnitsLovelace eUnitPrices execUnits of + Just llCost -> + Right (ScriptCostOutput scriptHash execUnits llCost) + : accum + Nothing -> + Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits) + : accum + Left err -> Left (PlutusScriptCostErrExecError sWitInd (Just scriptHash) err) : accum + -- TODO: Create a new sum type to encapsulate the fact that we can also + -- have a txin and render the txin in the case of reference scripts. + Just (AnyScriptWitness (PlutusScriptWitness _ _ (PReferenceScript refTxIn _) _ _ _)) -> + case Map.lookup refTxIn utxo of + Nothing -> Left (PlutusScriptCostErrRefInputNotInUTxO refTxIn) : accum + Just (TxOut _ _ _ refScript) -> + case refScript of + ReferenceScriptNone -> Left (PlutusScriptCostErrRefInputNoScript refTxIn) : accum + ReferenceScript _ (ScriptInAnyLang _ script) -> + case eExecUnits of + Right (logs, execUnits) -> + case calculateExecutionUnitsLovelace eUnitPrices execUnits of + Just llCost -> + Right (ScriptCostOutput (hashScript script) execUnits llCost) + : accum + Nothing -> + Left (PlutusScriptCostErrRationalExceedsBound logs eUnitPrices execUnits) + : accum + Left err -> Left (PlutusScriptCostErrExecError sWitInd Nothing err) : accum + Nothing -> Left (PlutusScriptCostErrPlutusScriptNotFound sWitInd) : accum + ) + [] + executionCostMapping diff --git a/cardano-cli/src/Cardano/CLI/Types/TxFeature.hs b/cardano-cli/src/Cardano/CLI/Types/TxFeature.hs index c35ec08429..28f7491cf6 100644 --- a/cardano-cli/src/Cardano/CLI/Types/TxFeature.hs +++ b/cardano-cli/src/Cardano/CLI/Types/TxFeature.hs @@ -1,15 +1,15 @@ {-# LANGUAGE LambdaCase #-} module Cardano.CLI.Types.TxFeature - ( TxFeature(..) + ( TxFeature (..) , renderFeature - ) where + ) +where import Data.Text (Text) -- | An enumeration of era-dependent features where we have to check that it -- is permissible to use this feature in this era. --- data TxFeature = TxFeatureShelleyAddresses | TxFeatureExplicitFees @@ -38,26 +38,26 @@ data TxFeature renderFeature :: TxFeature -> Text renderFeature = \case - TxFeatureShelleyAddresses -> "Shelley addresses" - TxFeatureExplicitFees -> "Explicit fees" - TxFeatureImplicitFees -> "Implicit fees" - TxFeatureValidityLowerBound -> "A validity lower bound" - TxFeatureValidityUpperBound -> "A validity upper bound" + TxFeatureShelleyAddresses -> "Shelley addresses" + TxFeatureExplicitFees -> "Explicit fees" + TxFeatureImplicitFees -> "Implicit fees" + TxFeatureValidityLowerBound -> "A validity lower bound" + TxFeatureValidityUpperBound -> "A validity upper bound" TxFeatureValidityNoUpperBound -> "An absent validity upper bound" - TxFeatureTxMetadata -> "Transaction metadata" - TxFeatureAuxScripts -> "Auxiliary scripts" - TxFeatureWithdrawals -> "Reward account withdrawals" - TxFeatureCertificates -> "Certificates" - TxFeatureMintValue -> "Asset minting" - TxFeatureMultiAssetOutputs -> "Multi-Asset outputs" - TxFeatureScriptWitnesses -> "Script witnesses" - TxFeatureShelleyKeys -> "Shelley keys" - TxFeatureCollateral -> "Collateral inputs" - TxFeatureProtocolParameters -> "Protocol parameters" - TxFeatureTxOutDatum -> "Transaction output datums" - TxFeatureScriptValidity -> "Script validity" - TxFeatureExtraKeyWits -> "Required signers" - TxFeatureInlineDatums -> "Inline datums" - TxFeatureTotalCollateral -> "Total collateral" - TxFeatureReferenceInputs -> "Reference inputs" - TxFeatureReturnCollateral -> "Return collateral" + TxFeatureTxMetadata -> "Transaction metadata" + TxFeatureAuxScripts -> "Auxiliary scripts" + TxFeatureWithdrawals -> "Reward account withdrawals" + TxFeatureCertificates -> "Certificates" + TxFeatureMintValue -> "Asset minting" + TxFeatureMultiAssetOutputs -> "Multi-Asset outputs" + TxFeatureScriptWitnesses -> "Script witnesses" + TxFeatureShelleyKeys -> "Shelley keys" + TxFeatureCollateral -> "Collateral inputs" + TxFeatureProtocolParameters -> "Protocol parameters" + TxFeatureTxOutDatum -> "Transaction output datums" + TxFeatureScriptValidity -> "Script validity" + TxFeatureExtraKeyWits -> "Required signers" + TxFeatureInlineDatums -> "Inline datums" + TxFeatureTotalCollateral -> "Total collateral" + TxFeatureReferenceInputs -> "Reference inputs" + TxFeatureReturnCollateral -> "Return collateral" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Babbage/Transaction/CalculateMinFee.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Babbage/Transaction/CalculateMinFee.hs index 31899cc8e6..6cc28bbfaf 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Babbage/Transaction/CalculateMinFee.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Babbage/Transaction/CalculateMinFee.hs @@ -2,7 +2,8 @@ module Test.Golden.Babbage.Transaction.CalculateMinFee ( hprop_golden_babbage_transaction_calculate_min_fee - ) where + ) +where import Test.Cardano.CLI.Util @@ -13,15 +14,23 @@ import qualified Hedgehog as H hprop_golden_babbage_transaction_calculate_min_fee :: Property hprop_golden_babbage_transaction_calculate_min_fee = propertyOnce $ do - protocolParamsJsonFile <- noteInputFile "test/cardano-cli-golden/files/input/babbage/transaction-calculate-min-fee/protocol-params.json" + protocolParamsJsonFile <- + noteInputFile + "test/cardano-cli-golden/files/input/babbage/transaction-calculate-min-fee/protocol-params.json" txBodyFile <- noteInputFile "test/cardano-cli-golden/files/input/babbage/tx/txbody" - minFeeTxt <- execCardanoCLI - [ "transaction","calculate-min-fee" - , "--witness-count", "1" - , "--protocol-params-file", protocolParamsJsonFile - , "--reference-script-size", "0" - , "--tx-body-file", txBodyFile - ] + minFeeTxt <- + execCardanoCLI + [ "transaction" + , "calculate-min-fee" + , "--witness-count" + , "1" + , "--protocol-params-file" + , protocolParamsJsonFile + , "--reference-script-size" + , "0" + , "--tx-body-file" + , txBodyFile + ] H.diff minFeeTxt (==) "165633 Lovelace\n" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/SigningKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/SigningKeys.hs index 9dcf4e7c8d..2f23345600 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/SigningKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/SigningKeys.hs @@ -9,7 +9,8 @@ module Test.Golden.Byron.SigningKeys , hprop_migrate_legacy_to_nonlegacy_signingkeys , hprop_print_legacy_signing_key_address , hprop_print_nonLegacy_signing_key_address - ) where + ) +where import Cardano.Api.Byron @@ -47,33 +48,47 @@ hprop_print_legacy_signing_key_address :: Property hprop_print_legacy_signing_key_address = propertyOnce $ do let legKeyFp = "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" - void $ execCardanoCLI - [ "signing-key-address", "--byron-legacy-formats" - , "--testnet-magic", "42" - , "--secret", legKeyFp - ] - - void $ execCardanoCLI - [ "signing-key-address", "--byron-legacy-formats" - , "--mainnet" - , "--secret", legKeyFp - ] + void $ + execCardanoCLI + [ "signing-key-address" + , "--byron-legacy-formats" + , "--testnet-magic" + , "42" + , "--secret" + , legKeyFp + ] + + void $ + execCardanoCLI + [ "signing-key-address" + , "--byron-legacy-formats" + , "--mainnet" + , "--secret" + , legKeyFp + ] hprop_print_nonLegacy_signing_key_address :: Property hprop_print_nonLegacy_signing_key_address = propertyOnce $ do let nonLegKeyFp = "test/cardano-cli-golden/files/input/byron/keys/byron.skey" - void $ execCardanoCLI - [ "signing-key-address", "--byron-formats" - , "--testnet-magic", "42" - , "--secret", nonLegKeyFp - ] - - void $ execCardanoCLI - [ "signing-key-address", "--byron-formats" - , "--mainnet" - , "--secret", nonLegKeyFp - ] + void $ + execCardanoCLI + [ "signing-key-address" + , "--byron-formats" + , "--testnet-magic" + , "42" + , "--secret" + , nonLegKeyFp + ] + + void $ + execCardanoCLI + [ "signing-key-address" + , "--byron-formats" + , "--mainnet" + , "--secret" + , nonLegKeyFp + ] hprop_generate_and_read_nonlegacy_signingkeys :: Property hprop_generate_and_read_nonlegacy_signingkeys = property $ do @@ -88,14 +103,18 @@ hprop_migrate_legacy_to_nonlegacy_signingkeys = let legKeyFp = "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" nonLegacyKeyFp <- noteTempFile tempDir "nonlegacy.skey" - void $ execCardanoCLI - [ "migrate-delegate-key-from" - , "--from", legKeyFp - , "--to", nonLegacyKeyFp - ] + void $ + execCardanoCLI + [ "migrate-delegate-key-from" + , "--from" + , legKeyFp + , "--to" + , nonLegacyKeyFp + ] - eSignKey <- H.evalIO . runExceptT . readByronSigningKey NonLegacyByronKeyFormat - $ File nonLegacyKeyFp + eSignKey <- + H.evalIO . runExceptT . readByronSigningKey NonLegacyByronKeyFormat $ + File nonLegacyKeyFp case eSignKey of Left err -> failWith Nothing $ show err @@ -103,14 +122,22 @@ hprop_migrate_legacy_to_nonlegacy_signingkeys = hprop_deserialise_NonLegacy_Signing_Key_API :: Property hprop_deserialise_NonLegacy_Signing_Key_API = propertyOnce $ do - eFailOrWit <- H.evalIO . runExceptT $ readByronSigningKey NonLegacyByronKeyFormat "test/cardano-cli-golden/files/input/byron/keys/byron.skey" + eFailOrWit <- + H.evalIO . runExceptT $ + readByronSigningKey + NonLegacyByronKeyFormat + "test/cardano-cli-golden/files/input/byron/keys/byron.skey" case eFailOrWit of Left keyFailure -> failWith Nothing $ show keyFailure Right _ -> success hprop_deserialiseLegacy_Signing_Key_API :: Property hprop_deserialiseLegacy_Signing_Key_API = propertyOnce $ do - eFailOrWit <- H.evalIO . runExceptT $ readByronSigningKey LegacyByronKeyFormat "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" + eFailOrWit <- + H.evalIO . runExceptT $ + readByronSigningKey + LegacyByronKeyFormat + "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" case eFailOrWit of Left keyFailure -> failWith Nothing $ show keyFailure Right _ -> success diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs index 6c9e44e378..02d73e9ba5 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs @@ -24,15 +24,22 @@ hprop_byronTx_legacy = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey" expectedTx <- noteInputFile "test/cardano-cli-golden/files/input/byron/tx/legacy.tx" createdTx <- noteTempFile tempDir "tx" - void $ execCardanoCLI - [ "byron", "transaction", "issue-utxo-expenditure" - , "--mainnet" - , "--byron-legacy-formats" - , "--wallet-key", signingKey - , "--tx", createdTx - , "--txin", "(796a90e0a89b292d53a6129b9f0d757429063b529d27e4f56565192a8c8da5e3,10)" - , "--txout", "(\"2657WMsDfac6eFirdvKVPVMxNVYuACd1RGM2arH3g1y1yaQCr1yYpb2jr2b2aSiDZ\",999)" - ] + void $ + execCardanoCLI + [ "byron" + , "transaction" + , "issue-utxo-expenditure" + , "--mainnet" + , "--byron-legacy-formats" + , "--wallet-key" + , signingKey + , "--tx" + , createdTx + , "--txin" + , "(796a90e0a89b292d53a6129b9f0d757429063b529d27e4f56565192a8c8da5e3,10)" + , "--txout" + , "(\"2657WMsDfac6eFirdvKVPVMxNVYuACd1RGM2arH3g1y1yaQCr1yYpb2jr2b2aSiDZ\",999)" + ] compareByronTxs createdTx expectedTx @@ -41,15 +48,22 @@ hprop_byronTx = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey" expectedTx <- noteInputFile "test/cardano-cli-golden/files/input/byron/tx/normal.tx" createdTx <- noteTempFile tempDir "tx" - void $ execCardanoCLI - [ "byron", "transaction", "issue-utxo-expenditure" - , "--mainnet" - , "--byron-formats" - , "--wallet-key", signingKey - , "--tx", createdTx - , "--txin", "(796a90e0a89b292d53a6129b9f0d757429063b529d27e4f56565192a8c8da5e3,10)" - , "--txout", "(\"2657WMsDfac6eFirdvKVPVMxNVYuACd1RGM2arH3g1y1yaQCr1yYpb2jr2b2aSiDZ\",999)" - ] + void $ + execCardanoCLI + [ "byron" + , "transaction" + , "issue-utxo-expenditure" + , "--mainnet" + , "--byron-formats" + , "--wallet-key" + , signingKey + , "--tx" + , createdTx + , "--txin" + , "(796a90e0a89b292d53a6129b9f0d757429063b529d27e4f56565192a8c8da5e3,10)" + , "--txout" + , "(\"2657WMsDfac6eFirdvKVPVMxNVYuACd1RGM2arH3g1y1yaQCr1yYpb2jr2b2aSiDZ\",999)" + ] compareByronTxs createdTx expectedTx diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs index 0b22c94bb2..6e344ce4c1 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/UpdateProposal.hs @@ -2,9 +2,8 @@ module Test.Golden.Byron.UpdateProposal where -import Cardano.CLI.Pretty - import Cardano.CLI.Byron.UpdateProposal +import Cardano.CLI.Pretty import Control.Monad (void) import Control.Monad.Trans.Except (runExceptT) @@ -22,28 +21,40 @@ hprop_byron_update_proposal = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir expectedUpdateProposal <- noteInputFile "test/cardano-cli-golden/files/input/byron/update-proposal" signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey" createdUpdateProposal <- noteTempFile tempDir "byron-update-proposal" - void $ execCardanoCLI - [ "byron", "governance", "create-update-proposal" - , "--mainnet" - , "--signing-key", signingKey - , "--protocol-version-major", "1" - , "--protocol-version-minor", "0" - , "--protocol-version-alt", "0" - , "--application-name", "cardano-sl" - , "--software-version-num", "1" - , "--system-tag", "linux" - , "--installer-hash", "0" - , "--filepath", createdUpdateProposal - ] + void $ + execCardanoCLI + [ "byron" + , "governance" + , "create-update-proposal" + , "--mainnet" + , "--signing-key" + , signingKey + , "--protocol-version-major" + , "1" + , "--protocol-version-minor" + , "0" + , "--protocol-version-alt" + , "0" + , "--application-name" + , "cardano-sl" + , "--software-version-num" + , "1" + , "--system-tag" + , "linux" + , "--installer-hash" + , "0" + , "--filepath" + , createdUpdateProposal + ] eExpected <- liftIO . runExceptT $ readByronUpdateProposal expectedUpdateProposal expected <- case eExpected of - Left err -> failWith Nothing . docToString $ renderByronUpdateProposalError err - Right prop -> return prop + Left err -> failWith Nothing . docToString $ renderByronUpdateProposalError err + Right prop -> return prop eCreated <- liftIO . runExceptT $ readByronUpdateProposal createdUpdateProposal created <- case eCreated of - Left err -> failWith Nothing . docToString $ renderByronUpdateProposalError err - Right prop -> return prop + Left err -> failWith Nothing . docToString $ renderByronUpdateProposalError err + Right prop -> return prop expected === created diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs index 0257c91c0c..65cbd9daf1 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Vote.hs @@ -2,9 +2,8 @@ module Test.Golden.Byron.Vote where -import Cardano.CLI.Pretty - import Cardano.CLI.Byron.Vote +import Cardano.CLI.Pretty import Control.Monad (void) import Control.Monad.Trans.Except (runExceptT) @@ -23,24 +22,30 @@ hprop_byron_yes_vote = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do proposal <- noteInputFile "test/cardano-cli-golden/files/input/byron/update-proposal" signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey" createdYesVote <- noteTempFile tempDir "byron-yes-vote" - void $ execCardanoCLI - [ "byron", "governance", "create-proposal-vote" - , "--mainnet" - , "--proposal-filepath", proposal - , "--signing-key", signingKey - , "--vote-yes" - , "--output-filepath", createdYesVote - ] + void $ + execCardanoCLI + [ "byron" + , "governance" + , "create-proposal-vote" + , "--mainnet" + , "--proposal-filepath" + , proposal + , "--signing-key" + , signingKey + , "--vote-yes" + , "--output-filepath" + , createdYesVote + ] eExpected <- liftIO . runExceptT $ readByronVote expectedYesVote expected <- case eExpected of - Left err -> failWith Nothing . docToString $ renderByronVoteError err - Right prop -> return prop + Left err -> failWith Nothing . docToString $ renderByronVoteError err + Right prop -> return prop eCreated <- liftIO . runExceptT $ readByronVote createdYesVote created <- case eCreated of - Left err -> failWith Nothing . docToString $ renderByronVoteError err - Right prop -> return prop + Left err -> failWith Nothing . docToString $ renderByronVoteError err + Right prop -> return prop expected === created @@ -50,23 +55,29 @@ hprop_byron_no_vote = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do proposal <- noteInputFile "test/cardano-cli-golden/files/input/byron/update-proposal" signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey" createdNoVote <- noteTempFile tempDir "byron-no-vote" - void $ execCardanoCLI - [ "byron", "governance", "create-proposal-vote" - , "--mainnet" - , "--proposal-filepath", proposal - , "--signing-key", signingKey - , "--vote-no" - , "--output-filepath", createdNoVote - ] + void $ + execCardanoCLI + [ "byron" + , "governance" + , "create-proposal-vote" + , "--mainnet" + , "--proposal-filepath" + , proposal + , "--signing-key" + , signingKey + , "--vote-no" + , "--output-filepath" + , createdNoVote + ] eExpected <- liftIO . runExceptT $ readByronVote expectedNoVote expected <- case eExpected of - Left err -> failWith Nothing . docToString $ renderByronVoteError err - Right prop -> return prop + Left err -> failWith Nothing . docToString $ renderByronVoteError err + Right prop -> return prop eCreated <- liftIO . runExceptT $ readByronVote createdNoVote created <- case eCreated of - Left err -> failWith Nothing . docToString $ renderByronVoteError err - Right prop -> return prop + Left err -> failWith Nothing . docToString $ renderByronVoteError err + Right prop -> return prop expected === created diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Witness.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Witness.hs index 28bcb03c98..586311514a 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Witness.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Witness.hs @@ -1,4 +1,3 @@ - module Test.Golden.Byron.Witness where import Hedgehog (Property, property, success) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/Assemble.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/Assemble.hs index 9c7848aac2..6e31d431db 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/Assemble.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/Assemble.hs @@ -18,15 +18,23 @@ hprop_golden_conway_transaction_assemble_witness_signing_key :: Property hprop_golden_conway_transaction_assemble_witness_signing_key = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do witnessTx <- noteTempFile tempDir "single-signing-key-witness-tx" txBodyFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/txbody" - signingKeyWitnessFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/singleSigningKeyWitness" - - void $ execCardanoCLI - [ "conway", "transaction", "assemble" - , "--tx-body-file", txBodyFile - , "--witness-file", signingKeyWitnessFile - , "--witness-file", signingKeyWitnessFile - , "--out-file", witnessTx - ] + signingKeyWitnessFile <- + noteInputFile "test/cardano-cli-golden/files/input/conway/singleSigningKeyWitness" + + void $ + execCardanoCLI + [ "conway" + , "transaction" + , "assemble" + , "--tx-body-file" + , txBodyFile + , "--witness-file" + , signingKeyWitnessFile + , "--witness-file" + , signingKeyWitnessFile + , "--out-file" + , witnessTx + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/conway/transaction/assemble_out" - H.diffFileVsGoldenFile witnessTx goldenFile \ No newline at end of file + H.diffFileVsGoldenFile witnessTx goldenFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/BuildRaw.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/BuildRaw.hs index d207d6b876..fa209e2bf8 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/BuildRaw.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/BuildRaw.hs @@ -3,6 +3,8 @@ module Test.Golden.Conway.Transaction.BuildRaw where import Control.Monad (void) +import Data.List (isInfixOf) +import System.Exit (ExitCode (..)) import Test.Cardano.CLI.Util @@ -11,9 +13,6 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Base as H import qualified Hedgehog.Extras.Test.Golden as H -import Data.List (isInfixOf) -import System.Exit (ExitCode (..)) - {- HLINT ignore "Use camelCase" -} -- | Execute me with: @@ -25,59 +24,89 @@ hprop_golden_conway_build_raw_treasury_donation = propertyOnce . H.moduleWorkspa -- Key filepaths outFile <- noteTempFile tempDir "out.json" - void $ execCardanoCLI - [ "conway", "transaction", "build-raw" - , "--tx-in", "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" - , "--tx-out", "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" - , "--tx-out", "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" - , "--current-treasury-value", "543" - , "--treasury-donation", "1000343" - , "--fee", "166777" - , "--out-file", outFile - ] + void $ + execCardanoCLI + [ "conway" + , "transaction" + , "build-raw" + , "--tx-in" + , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" + , "--tx-out" + , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" + , "--tx-out" + , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" + , "--current-treasury-value" + , "543" + , "--treasury-donation" + , "1000343" + , "--fee" + , "166777" + , "--out-file" + , outFile + ] H.diffFileVsGoldenFile outFile goldenFile -- Negative test: Missing --current-treasury-value + -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden conway build raw donation no current treasury value/"'@ hprop_golden_conway_build_raw_donation_no_current_treasury_value :: Property -hprop_golden_conway_build_raw_donation_no_current_treasury_value = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - +hprop_golden_conway_build_raw_donation_no_current_treasury_value = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Key filepaths outFile <- noteTempFile tempDir "out.json" - (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI - [ "conway", "transaction", "build-raw" - , "--tx-in", "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" - , "--tx-out", "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" - , "--tx-out", "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" - , "--treasury-donation", "1000343" - , "--fee", "166777" - , "--out-file", outFile - ] + (exitCode, _stdout, stderr) <- + H.noteShowM $ + execDetailCardanoCLI + [ "conway" + , "transaction" + , "build-raw" + , "--tx-in" + , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" + , "--tx-out" + , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" + , "--tx-out" + , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" + , "--treasury-donation" + , "1000343" + , "--fee" + , "166777" + , "--out-file" + , outFile + ] exitCode H.=== ExitFailure 1 H.assertWith stderr ("Missing: --current-treasury-value LOVELACE" `isInfixOf`) -- Negative test: Missing --treasury-donation + -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden conway build raw donation no treasury donation/"'@ hprop_golden_conway_build_raw_donation_no_treasury_donation :: Property -hprop_golden_conway_build_raw_donation_no_treasury_donation = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - +hprop_golden_conway_build_raw_donation_no_treasury_donation = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Key filepaths outFile <- noteTempFile tempDir "out.json" - (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI - [ "conway", "transaction", "build-raw" - , "--tx-in", "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" - , "--tx-out", "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" - , "--tx-out", "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" - , "--current-treasury-value", "1000343" - , "--fee", "166777" - , "--out-file", outFile - ] + (exitCode, _stdout, stderr) <- + H.noteShowM $ + execDetailCardanoCLI + [ "conway" + , "transaction" + , "build-raw" + , "--tx-in" + , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" + , "--tx-out" + , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" + , "--tx-out" + , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" + , "--current-treasury-value" + , "1000343" + , "--fee" + , "166777" + , "--out-file" + , outFile + ] exitCode H.=== ExitFailure 1 - H.assertWith stderr ("Missing: --treasury-donation LOVELACE" `isInfixOf`) \ No newline at end of file + H.assertWith stderr ("Missing: --treasury-donation LOVELACE" `isInfixOf`) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs index 462fe093c3..6382af380b 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateStaked.hs @@ -2,9 +2,9 @@ module Test.Golden.CreateStaked where +import Cardano.Api.Ledger (StandardCrypto) import Cardano.Api.Shelley (ShelleyGenesis (sgNetworkMagic, sgStaking)) -import Cardano.Api.Ledger (StandardCrypto) import Cardano.Ledger.Shelley.Genesis (ShelleyGenesisStaking (sgsPools, sgsStake)) import Control.Monad (filterM, void) @@ -23,7 +23,6 @@ import Hedgehog.Extras (moduleWorkspace, propertyOnce) import qualified Hedgehog.Extras as H import qualified Hedgehog.Extras.Test.Golden as H - {- HLINT ignore "Use camelCase" -} -- | Given a root directory, returns files within this root (recursively) @@ -40,7 +39,6 @@ tree root = do hprop_golden_create_staked :: Property hprop_golden_create_staked = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do - let alonzo = "genesis.alonzo.spec.json" conway = "genesis.conway.spec.json" networkMagic = 42 @@ -55,18 +53,31 @@ hprop_golden_create_staked = void $ execCardanoCLI - ["conway", "genesis", "create-staked" - , "--gen-genesis-keys", "2" - , "--gen-pools", show numPools - , "--gen-utxo-keys", "3" - , "--gen-stake-delegs", show numStake - , "--supply", "1000000000000" - , "--supply-delegated", "1000000000000" - , "--testnet-magic", show networkMagic - , "--bulk-pool-cred-files", "2" - , "--bulk-pools-per-file", "2" - , "--num-stuffed-utxo", "7" - , "--genesis-dir", tempDir + [ "conway" + , "genesis" + , "create-staked" + , "--gen-genesis-keys" + , "2" + , "--gen-pools" + , show numPools + , "--gen-utxo-keys" + , "3" + , "--gen-stake-delegs" + , show numStake + , "--supply" + , "1000000000000" + , "--supply-delegated" + , "1000000000000" + , "--testnet-magic" + , show networkMagic + , "--bulk-pool-cred-files" + , "2" + , "--bulk-pools-per-file" + , "2" + , "--num-stuffed-utxo" + , "7" + , "--genesis-dir" + , tempDir ] generated <- liftIO $ tree tempDir diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs index d433c96a3b..8cd2d32e66 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/CreateTestnetData.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} + module Test.Golden.CreateTestnetData where import Cardano.Api.Ledger (ConwayGenesis (..), StandardCrypto) @@ -45,15 +46,24 @@ numUtxoKeys = 3 -- between the two tests, except for the possibly transient ones. mkArguments :: String -> [String] mkArguments outputDir = - ["conway", "genesis", "create-testnet-data" - , "--genesis-keys", "2" - , "--utxo-keys", show numUtxoKeys - , "--out-dir", outputDir - , "--testnet-magic", show networkMagic - , "--pools", show numPools - , "--drep-keys", show numDReps - -- Relays file specifies two relays, like the number of SPOs - , "--relays", "test/cardano-cli-golden/files/input/shelley/genesis/relays.json" + [ "conway" + , "genesis" + , "create-testnet-data" + , "--genesis-keys" + , "2" + , "--utxo-keys" + , show numUtxoKeys + , "--out-dir" + , outputDir + , "--testnet-magic" + , show networkMagic + , "--pools" + , show numPools + , "--drep-keys" + , show numDReps + , -- Relays file specifies two relays, like the number of SPOs + "--relays" + , "test/cardano-cli-golden/files/input/shelley/genesis/relays.json" ] -- | Given a root directory, returns files within this root (recursively) @@ -77,21 +87,23 @@ hprop_golden_create_testnet_data = -- @cabal test cardano-cli-golden --test-options '-p "/golden create testnet data with template/"'@ hprop_golden_create_testnet_data_with_template :: Property hprop_golden_create_testnet_data_with_template = - golden_create_testnet_data $ Just "test/cardano-cli-golden/files/input/shelley/genesis/genesis.spec.json" + golden_create_testnet_data $ + Just "test/cardano-cli-golden/files/input/shelley/genesis/genesis.spec.json" -- | Semaphore protecting against locked file error, when running properties concurrently. createTestnetDataOutSem :: FileSem createTestnetDataOutSem = newFileSem "test/cardano-cli-golden/files/golden/conway/create-testnet-data.out" -{-# NOINLINE createTestnetDataOutSem #-} +{-# NOINLINE createTestnetDataOutSem #-} -- | This test tests the non-transient case, i.e. it maximizes the files -- that can be written to disk. -golden_create_testnet_data :: () - => Maybe FilePath -- ^ The path to the shelley template use, if any +golden_create_testnet_data + :: () + => Maybe FilePath + -- ^ The path to the shelley template use, if any -> Property golden_create_testnet_data mShelleyTemplate = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do - let outputDir = tempDir "out" templateArg :: [String] = case mShelleyTemplate of @@ -99,7 +111,9 @@ golden_create_testnet_data mShelleyTemplate = Just shelleyTemplate -> ["--spec-shelley", shelleyTemplate] numStakeDelegs = 4 - void $ execCardanoCLI $ mkArguments outputDir <> ["--stake-delegators", show numStakeDelegs] <> templateArg + void $ + execCardanoCLI $ + mkArguments outputDir <> ["--stake-delegators", show numStakeDelegs] <> templateArg generated <- liftIO $ tree outputDir -- Sort output for stability, and make relative to avoid storing @@ -113,7 +127,8 @@ golden_create_testnet_data mShelleyTemplate = bracketSem createTestnetDataOutSem $ H.diffVsGoldenFile generated'' - shelleyGenesis :: ShelleyGenesis StandardCrypto <- H.readJsonFileOk $ outputDir "shelley-genesis.json" + shelleyGenesis :: ShelleyGenesis StandardCrypto <- + H.readJsonFileOk $ outputDir "shelley-genesis.json" sgNetworkMagic shelleyGenesis H.=== networkMagic length (L.sgsPools $ sgStaking shelleyGenesis) H.=== numPools @@ -127,29 +142,35 @@ golden_create_testnet_data mShelleyTemplate = actualNumUtxoKeys <- liftIO $ listDirectories $ outputDir "utxo-keys" length actualNumUtxoKeys H.=== numUtxoKeys - conwayGenesis :: ConwayGenesis StandardCrypto <- H.readJsonFileOk $ outputDir "conway-genesis.json" + conwayGenesis :: ConwayGenesis StandardCrypto <- + H.readJsonFileOk $ outputDir "conway-genesis.json" length (cgInitialDReps conwayGenesis) H.=== numDReps length (cgDelegs conwayGenesis) H.=== numStakeDelegs - -- Execute this test with: -- @cabal test cardano-cli-golden --test-options '-p "/golden create testnet data deleg non deleg/"'@ hprop_golden_create_testnet_data_deleg_non_deleg :: Property hprop_golden_create_testnet_data_deleg_non_deleg = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do - let outputDir = tempDir "out" totalSupply :: Int = 2_000_000_000_000 -- 2*10^12 delegatedSupply :: Int = 500_000_000_000 -- 5*10^11, i.e. totalSupply / 4 - - void $ execCardanoCLI - [ "conway", "genesis", "create-testnet-data" - , "--utxo-keys", "1" - , "--total-supply", show totalSupply - , "--delegated-supply", show delegatedSupply - , "--out-dir", outputDir] + void $ + execCardanoCLI + [ "conway" + , "genesis" + , "create-testnet-data" + , "--utxo-keys" + , "1" + , "--total-supply" + , show totalSupply + , "--delegated-supply" + , show delegatedSupply + , "--out-dir" + , outputDir + ] genesis :: ShelleyGenesis StandardCrypto <- H.readJsonFileOk $ outputDir "shelley-genesis.json" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/AnswerPoll.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/AnswerPoll.hs index b4485892b8..ed4a684db9 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/AnswerPoll.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/AnswerPoll.hs @@ -19,12 +19,18 @@ hprop_golden_governanceAnswerPollNeg1Invalid = propertyOnce . H.moduleWorkspace pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" outFile <- H.noteTempFile tempDir "answer-file.json" - result <- tryExecCardanoCLI - [ "babbage", "governance", "answer-poll" - , "--poll-file", pollFile - , "--answer", "-1" - , "--out-file", outFile - ] + result <- + tryExecCardanoCLI + [ "babbage" + , "governance" + , "answer-poll" + , "--poll-file" + , pollFile + , "--answer" + , "-1" + , "--out-file" + , outFile + ] H.assertFileMissing outFile @@ -33,30 +39,44 @@ hprop_golden_governanceAnswerPollNeg1Invalid = propertyOnce . H.moduleWorkspace hprop_golden_governanceAnswerPoll0 :: Property hprop_golden_governanceAnswerPoll0 = propertyOnce . H.moduleWorkspace "governance-answer-poll" $ \tempDir -> do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" - goldenAnswerFile <- H.note "test/cardano-cli-golden/files/golden/governance/polls/basic.answer.0.json" + goldenAnswerFile <- + H.note "test/cardano-cli-golden/files/golden/governance/polls/basic.answer.0.json" outFile <- H.noteTempFile tempDir "answer-file.json" - void $ execCardanoCLI - [ "babbage", "governance", "answer-poll" - , "--poll-file", pollFile - , "--answer", "0" - , "--out-file", outFile - ] + void $ + execCardanoCLI + [ "babbage" + , "governance" + , "answer-poll" + , "--poll-file" + , pollFile + , "--answer" + , "0" + , "--out-file" + , outFile + ] H.diffFileVsGoldenFile outFile goldenAnswerFile hprop_golden_governanceAnswerPollPos1 :: Property hprop_golden_governanceAnswerPollPos1 = propertyOnce . H.moduleWorkspace "governance-answer-poll" $ \tempDir -> do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" - goldenAnswerFile <- H.note "test/cardano-cli-golden/files/golden/governance/polls/basic.answer.1.json" + goldenAnswerFile <- + H.note "test/cardano-cli-golden/files/golden/governance/polls/basic.answer.1.json" outFile <- H.noteTempFile tempDir "answer-file.json" - void $ execCardanoCLI - [ "babbage", "governance", "answer-poll" - , "--poll-file", pollFile - , "--answer", "1" - , "--out-file", outFile - ] + void $ + execCardanoCLI + [ "babbage" + , "governance" + , "answer-poll" + , "--poll-file" + , pollFile + , "--answer" + , "1" + , "--out-file" + , outFile + ] H.diffFileVsGoldenFile outFile goldenAnswerFile @@ -65,12 +85,18 @@ hprop_golden_governanceAnswerPollPos2Invalid = propertyOnce . H.moduleWorkspace pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" outFile <- H.noteTempFile tempDir "answer-file.json" - result <- tryExecCardanoCLI - [ "babbage", "governance", "answer-poll" - , "--poll-file", pollFile - , "--answer", "2" - , "--out-file", outFile - ] + result <- + tryExecCardanoCLI + [ "babbage" + , "governance" + , "answer-poll" + , "--poll-file" + , pollFile + , "--answer" + , "2" + , "--out-file" + , outFile + ] H.assertFileMissing outFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/CreatePoll.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/CreatePoll.hs index c5a9d55cfd..8f4c7289fa 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/CreatePoll.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/CreatePoll.hs @@ -19,13 +19,20 @@ hprop_golden_governanceCreatePoll = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do pollFile <- noteTempFile tempDir "poll.json" - stdout <- execCardanoCLI - [ "babbage", "governance", "create-poll" - , "--question", "Pineapples on pizza?" - , "--answer", "yes" - , "--answer", "no" - , "--out-file", pollFile - ] + stdout <- + execCardanoCLI + [ "babbage" + , "governance" + , "create-poll" + , "--question" + , "Pineapples on pizza?" + , "--answer" + , "yes" + , "--answer" + , "no" + , "--out-file" + , pollFile + ] void $ H.readFile pollFile noteInputFile "test/cardano-cli-golden/files/input/governance/create/basic.json" @@ -41,19 +48,27 @@ hprop_golden_governanceCreateLongPoll = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do pollFile <- noteTempFile tempDir "poll.json" - stdout <- execCardanoCLI - [ "babbage", "governance", "create-poll" - , "--question", "What is the most adequate topping to put on a pizza (please consider all possibilities and take time to answer)?" - , "--answer", "pineapples" - , "--answer", "only traditional topics should go on a pizza, this isn't room for jokes" - , "--out-file", pollFile - ] + stdout <- + execCardanoCLI + [ "babbage" + , "governance" + , "create-poll" + , "--question" + , "What is the most adequate topping to put on a pizza (please consider all possibilities and take time to answer)?" + , "--answer" + , "pineapples" + , "--answer" + , "only traditional topics should go on a pizza, this isn't room for jokes" + , "--out-file" + , pollFile + ] void $ H.readFile pollFile noteInputFile "test/cardano-cli-golden/files/input/governance/create/long-text.json" >>= H.readFile >>= (H.===) stdout - goldenFile <- H.note "test/cardano-cli-golden/files/golden/governance/polls/create-poll-long-text-out.json" + goldenFile <- + H.note "test/cardano-cli-golden/files/golden/governance/polls/create-poll-long-text-out.json" H.diffFileVsGoldenFile pollFile goldenFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs index 19e4ae87dd..889269ecac 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/EraBased/Governance/VerifyPoll.hs @@ -23,14 +23,21 @@ hprop_golden_governanceVerifyPoll :: Property hprop_golden_governanceVerifyPoll = propertyOnce $ do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" txFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/verify/valid" - goldenVkFile <- VerificationKeyFilePath . File <$> - H.note "test/cardano-cli-golden/files/input/governance/cold.vk" - - stdout <- BSC.pack <$> execCardanoCLI - [ "babbage", "governance", "verify-poll" - , "--poll-file", pollFile - , "--tx-file", txFile - ] + goldenVkFile <- + VerificationKeyFilePath . File + <$> H.note "test/cardano-cli-golden/files/input/governance/cold.vk" + + stdout <- + BSC.pack + <$> execCardanoCLI + [ "babbage" + , "governance" + , "verify-poll" + , "--poll-file" + , pollFile + , "--tx-file" + , txFile + ] H.evalIO (runExceptT $ readVerificationKeyOrTextEnvFile AsStakePoolKey goldenVkFile) >>= \case Left e -> do H.noteShow_ $ prettyError e @@ -44,11 +51,16 @@ hprop_golden_governanceVerifyPollMismatch = propertyOnce $ do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" txFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/verify/mismatch" - result <- tryExecCardanoCLI - [ "babbage", "governance", "verify-poll" - , "--poll-file", pollFile - , "--tx-file", txFile - ] + result <- + tryExecCardanoCLI + [ "babbage" + , "governance" + , "verify-poll" + , "--poll-file" + , pollFile + , "--tx-file" + , txFile + ] either (const H.success) (H.failWith Nothing) result @@ -57,11 +69,16 @@ hprop_golden_governanceVerifyPollNoAnswer = propertyOnce $ do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" txFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/verify/none" - result <- tryExecCardanoCLI - [ "babbage", "governance", "verify-poll" - , "--poll-file", pollFile - , "--tx-file", txFile - ] + result <- + tryExecCardanoCLI + [ "babbage" + , "governance" + , "verify-poll" + , "--poll-file" + , pollFile + , "--tx-file" + , txFile + ] either (const H.success) (H.failWith Nothing) result @@ -70,11 +87,16 @@ hprop_golden_governanceVerifyPollMalformedAnswer = propertyOnce $ do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" txFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/verify/malformed" - result <- tryExecCardanoCLI - [ "babbage", "governance", "verify-poll" - , "--poll-file", pollFile - , "--tx-file", txFile - ] + result <- + tryExecCardanoCLI + [ "babbage" + , "governance" + , "verify-poll" + , "--poll-file" + , pollFile + , "--tx-file" + , txFile + ] either (const H.success) (H.failWith Nothing) result @@ -83,10 +105,15 @@ hprop_golden_governanceVerifyPollInvalidAnswer = propertyOnce $ do pollFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/polls/basic.json" txFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/verify/invalid" - result <- tryExecCardanoCLI - [ "babbage", "governance", "verify-poll" - , "--poll-file", pollFile - , "--tx-file", txFile - ] + result <- + tryExecCardanoCLI + [ "babbage" + , "governance" + , "verify-poll" + , "--poll-file" + , pollFile + , "--tx-file" + , txFile + ] either (const H.success) (H.failWith Nothing) result diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/ErrorsSpec.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/ErrorsSpec.hs index e1f2cb43a9..e5349a6694 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/ErrorsSpec.hs @@ -8,7 +8,8 @@ module Test.Golden.ErrorsSpec , test_RegistrationError , test_VoteReadError , test_CostModelsError - ) where + ) +where import Cardano.Api import Cardano.Api.Shelley @@ -33,176 +34,291 @@ import Test.Tasty test_GovernanceCmdError :: TestTree test_GovernanceCmdError = - testErrorMessagesRendering "Cardano.CLI.Types.Errors.GovernanceCmdError" "GovernanceCmdError" - [ ("StakeCredGovCmdError" + testErrorMessagesRendering + "Cardano.CLI.Types.Errors.GovernanceCmdError" + "GovernanceCmdError" + [ + ( "StakeCredGovCmdError" , StakeCredGovCmdError - . StakeAddressCmdReadKeyFileError - $ FileError "path/file.txt" InputInvalidError) - , ("VotingCredentialDecodeGovCmdEror" - , VotingCredentialDecodeGovCmdEror $ DecoderErrorEmptyList "emptylist") - , ("WriteFileError" - , WriteFileError $ FileError "path/file.txt" ()) - , ("ReadFileError" - , ReadFileError $ FileError "path/file.txt" InputInvalidError) - , ("NonUtf8EncodedConstitution" - , GovernanceCmdConstitutionError - $ ConstitutionNotUnicodeError - $ DecodeError "seq" Nothing) - , ("GovernanceCmdTextEnvReadError" + . StakeAddressCmdReadKeyFileError + $ FileError "path/file.txt" InputInvalidError + ) + , + ( "VotingCredentialDecodeGovCmdEror" + , VotingCredentialDecodeGovCmdEror $ DecoderErrorEmptyList "emptylist" + ) + , + ( "WriteFileError" + , WriteFileError $ FileError "path/file.txt" () + ) + , + ( "ReadFileError" + , ReadFileError $ FileError "path/file.txt" InputInvalidError + ) + , + ( "NonUtf8EncodedConstitution" + , GovernanceCmdConstitutionError $ + ConstitutionNotUnicodeError $ + DecodeError "seq" Nothing + ) + , + ( "GovernanceCmdTextEnvReadError" , GovernanceCmdTextEnvReadError - . FileError "path/file.txt" - $ TextEnvelopeAesonDecodeError "cannot decode json") - , ("GovernanceCmdCddlError" - , GovernanceCmdCddlError - $ CddlErrorTextEnv - (FileError "path/file.txt" . TextEnvelopeDecodeError $ DecoderErrorCustom "todecode" "decodeerr") - (FileError "path/file.txt" TextEnvelopeCddlUnknownKeyWitness)) - , ("GovernanceCmdKeyReadError" - , GovernanceCmdKeyReadError $ FileError "path/file.txt" InputInvalidError) - , ("GovernanceCmdCostModelReadError" - , GovernanceCmdCostModelReadError $ FileError "path/file.txt" ()) - , ("GovernanceCmdTextEnvWriteError" - , GovernanceCmdTextEnvWriteError $ FileError "path/file.txt" ()) - , ("GovernanceCmdEmptyUpdateProposalError" - , GovernanceCmdEmptyUpdateProposalError) - , ("GovernanceCmdMIRCertificateKeyRewardMistmach" - ,GovernanceCmdMIRCertificateKeyRewardMistmach "path/file.txt" 1 2) - , ("GovernanceCmdCostModelsJsonDecodeErr" - , GovernanceCmdCostModelsJsonDecodeErr "path/file.txt" "jsonerr") - , ("GovernanceCmdEmptyCostModel" - , GovernanceCmdEmptyCostModel "path/file.txt") - , ("GovernanceCmdUnexpectedKeyType" - , GovernanceCmdUnexpectedKeyType (TextEnvelopeType <$> ["env1", "env2"])) - , ("GovernanceCmdPollOutOfBoundAnswer" - , GovernanceCmdPollOutOfBoundAnswer 4) - , ("GovernanceCmdPollInvalidChoice" - , GovernanceCmdPollInvalidChoice) - , ("GovernanceCmdDecoderError" - , GovernanceCmdDecoderError $ DecoderErrorEmptyList "empty") - , ("GovernanceCmdVerifyPollError" - , GovernanceCmdVerifyPollError ErrGovernancePollNoAnswer) - , ("GovernanceCmdWriteFileError" - , GovernanceCmdWriteFileError $ FileError "path/file.txt" ()) - , ("GovernanceCmdMIRCertNotSupportedInConway" - , GovernanceCmdMIRCertNotSupportedInConway) - , ("GovernanceCmdGenesisDelegationNotSupportedInConway" - , GovernanceCmdGenesisDelegationNotSupportedInConway) + . FileError "path/file.txt" + $ TextEnvelopeAesonDecodeError "cannot decode json" + ) + , + ( "GovernanceCmdCddlError" + , GovernanceCmdCddlError $ + CddlErrorTextEnv + (FileError "path/file.txt" . TextEnvelopeDecodeError $ DecoderErrorCustom "todecode" "decodeerr") + (FileError "path/file.txt" TextEnvelopeCddlUnknownKeyWitness) + ) + , + ( "GovernanceCmdKeyReadError" + , GovernanceCmdKeyReadError $ FileError "path/file.txt" InputInvalidError + ) + , + ( "GovernanceCmdCostModelReadError" + , GovernanceCmdCostModelReadError $ FileError "path/file.txt" () + ) + , + ( "GovernanceCmdTextEnvWriteError" + , GovernanceCmdTextEnvWriteError $ FileError "path/file.txt" () + ) + , + ( "GovernanceCmdEmptyUpdateProposalError" + , GovernanceCmdEmptyUpdateProposalError + ) + , + ( "GovernanceCmdMIRCertificateKeyRewardMistmach" + , GovernanceCmdMIRCertificateKeyRewardMistmach "path/file.txt" 1 2 + ) + , + ( "GovernanceCmdCostModelsJsonDecodeErr" + , GovernanceCmdCostModelsJsonDecodeErr "path/file.txt" "jsonerr" + ) + , + ( "GovernanceCmdEmptyCostModel" + , GovernanceCmdEmptyCostModel "path/file.txt" + ) + , + ( "GovernanceCmdUnexpectedKeyType" + , GovernanceCmdUnexpectedKeyType (TextEnvelopeType <$> ["env1", "env2"]) + ) + , + ( "GovernanceCmdPollOutOfBoundAnswer" + , GovernanceCmdPollOutOfBoundAnswer 4 + ) + , + ( "GovernanceCmdPollInvalidChoice" + , GovernanceCmdPollInvalidChoice + ) + , + ( "GovernanceCmdDecoderError" + , GovernanceCmdDecoderError $ DecoderErrorEmptyList "empty" + ) + , + ( "GovernanceCmdVerifyPollError" + , GovernanceCmdVerifyPollError ErrGovernancePollNoAnswer + ) + , + ( "GovernanceCmdWriteFileError" + , GovernanceCmdWriteFileError $ FileError "path/file.txt" () + ) + , + ( "GovernanceCmdMIRCertNotSupportedInConway" + , GovernanceCmdMIRCertNotSupportedInConway + ) + , + ( "GovernanceCmdGenesisDelegationNotSupportedInConway" + , GovernanceCmdGenesisDelegationNotSupportedInConway + ) ] test_DelegationError :: TestTree test_DelegationError = - testErrorMessagesRendering "Cardano.CLI.Types.Errors.CmdError" "DelegationError" - [ ("DelegationReadError" - , DelegationReadError - $ FileError "path/file.txt" InputInvalidError) - , ("DelegationStakeCredentialError1" - , DelegationStakeCredentialError - $ StakeCredentialInputDecodeError - $ FileError "path/file.txt" InputInvalidError) - , ("DelegationStakeCredentialError2" - , DelegationStakeCredentialError - $ StakeCredentialScriptDecodeError - $ FileError "path/file.txt" - $ ScriptDecodeSimpleScriptError - $ JsonDecodeError "json decode error") - , ("DelegationStakeCredentialError3" - , DelegationStakeCredentialError - $ StakeCredentialInputDecodeError - $ FileError "path/file.txt" InputInvalidError) - , ("DelegationCertificateWriteFileError" - , DelegationCertificateWriteFileError - $ FileError "path/file.txt" ()) - , ("DelegationDRepReadError" - , DelegationDRepReadError $ FileError "path/file.txt" InputInvalidError) + testErrorMessagesRendering + "Cardano.CLI.Types.Errors.CmdError" + "DelegationError" + [ + ( "DelegationReadError" + , DelegationReadError $ + FileError "path/file.txt" InputInvalidError + ) + , + ( "DelegationStakeCredentialError1" + , DelegationStakeCredentialError $ + StakeCredentialInputDecodeError $ + FileError "path/file.txt" InputInvalidError + ) + , + ( "DelegationStakeCredentialError2" + , DelegationStakeCredentialError $ + StakeCredentialScriptDecodeError $ + FileError "path/file.txt" $ + ScriptDecodeSimpleScriptError $ + JsonDecodeError "json decode error" + ) + , + ( "DelegationStakeCredentialError3" + , DelegationStakeCredentialError $ + StakeCredentialInputDecodeError $ + FileError "path/file.txt" InputInvalidError + ) + , + ( "DelegationCertificateWriteFileError" + , DelegationCertificateWriteFileError $ + FileError "path/file.txt" () + ) + , + ( "DelegationDRepReadError" + , DelegationDRepReadError $ FileError "path/file.txt" InputInvalidError + ) ] test_RegistrationError :: TestTree test_RegistrationError = - testErrorMessagesRendering "Cardano.CLI.Types.Errors.CmdError" "RegistrationError" - [ ("RegistrationReadError" - , RegistrationReadError $ FileError "path/file.txt" InputInvalidError) - , ("RegistrationWriteFileError" - , RegistrationWriteFileError $ FileError "path/file.txt" ()) - , ("RegistrationStakeCredReadError1" - , RegistrationStakeCredentialError - $ StakeCredentialInputDecodeError - $ FileError "path/file.txt" InputInvalidError) - , ("RegistrationStakeCredReadError2" - , RegistrationStakeCredentialError - $ StakeCredentialScriptDecodeError - $ FileError "path/file.txt" - $ ScriptDecodeSimpleScriptError - $ JsonDecodeError "json decode error") - , ("RegistrationStakeCredReadError3" - , RegistrationStakeCredentialError - $ StakeCredentialInputDecodeError - $ FileError "path/file.txt" InputInvalidError) - , ("RegistrationStakeError" - , RegistrationStakeError StakeAddressRegistrationDepositRequired) + testErrorMessagesRendering + "Cardano.CLI.Types.Errors.CmdError" + "RegistrationError" + [ + ( "RegistrationReadError" + , RegistrationReadError $ FileError "path/file.txt" InputInvalidError + ) + , + ( "RegistrationWriteFileError" + , RegistrationWriteFileError $ FileError "path/file.txt" () + ) + , + ( "RegistrationStakeCredReadError1" + , RegistrationStakeCredentialError $ + StakeCredentialInputDecodeError $ + FileError "path/file.txt" InputInvalidError + ) + , + ( "RegistrationStakeCredReadError2" + , RegistrationStakeCredentialError $ + StakeCredentialScriptDecodeError $ + FileError "path/file.txt" $ + ScriptDecodeSimpleScriptError $ + JsonDecodeError "json decode error" + ) + , + ( "RegistrationStakeCredReadError3" + , RegistrationStakeCredentialError $ + StakeCredentialInputDecodeError $ + FileError "path/file.txt" InputInvalidError + ) + , + ( "RegistrationStakeError" + , RegistrationStakeError StakeAddressRegistrationDepositRequired + ) ] test_VoteReadError :: TestTree test_VoteReadError = - testErrorMessagesRendering "Cardano.CLI.Types.Errors.GovernanceVoteCmdError" "GovernanceVoteCmdError" - [ ("GovernanceVoteCmdCredentialDecodeError" - , GovernanceVoteCmdCredentialDecodeError - $ DecoderErrorCustom "" "") - , ("GovernanceVoteCmdReadVerificationKeyError" - , GovernanceVoteCmdReadVerificationKeyError $ FileError "path/file.txt" InputInvalidError) - , ("GovernanceVoteCmdReadVoteFileError" - , GovernanceVoteCmdReadVoteFileError $ VoteErrorFile $ FileError "path/file.txt" $ TextEnvelopeAesonDecodeError "some error description") - , ("GovernanceVoteCmdWriteError" - , GovernanceVoteCmdWriteError $ FileError "path/file.txt" ()) + testErrorMessagesRendering + "Cardano.CLI.Types.Errors.GovernanceVoteCmdError" + "GovernanceVoteCmdError" + [ + ( "GovernanceVoteCmdCredentialDecodeError" + , GovernanceVoteCmdCredentialDecodeError $ + DecoderErrorCustom "" "" + ) + , + ( "GovernanceVoteCmdReadVerificationKeyError" + , GovernanceVoteCmdReadVerificationKeyError $ FileError "path/file.txt" InputInvalidError + ) + , + ( "GovernanceVoteCmdReadVoteFileError" + , GovernanceVoteCmdReadVoteFileError $ + VoteErrorFile $ + FileError "path/file.txt" $ + TextEnvelopeAesonDecodeError "some error description" + ) + , + ( "GovernanceVoteCmdWriteError" + , GovernanceVoteCmdWriteError $ FileError "path/file.txt" () + ) ] test_GovernanceComitteeError :: TestTree test_GovernanceComitteeError = - testErrorMessagesRendering "Cardano.CLI.EraBased.Run.Governance.Committee" "GovernanceCommitteeError" - [ ("GovernanceCommitteeCmdWriteFileError" - , GovernanceCommitteeCmdWriteFileError $ FileError "path/file.txt" ()) - , ("GovernanceCommitteeCmdTextEnvReadFileError" - , GovernanceCommitteeCmdTextEnvReadFileError - $ FileError "path/file.txt" - $ TextEnvelopeAesonDecodeError "cannot decode json") + testErrorMessagesRendering + "Cardano.CLI.EraBased.Run.Governance.Committee" + "GovernanceCommitteeError" + [ + ( "GovernanceCommitteeCmdWriteFileError" + , GovernanceCommitteeCmdWriteFileError $ FileError "path/file.txt" () + ) + , + ( "GovernanceCommitteeCmdTextEnvReadFileError" + , GovernanceCommitteeCmdTextEnvReadFileError $ + FileError "path/file.txt" $ + TextEnvelopeAesonDecodeError "cannot decode json" + ) ] test_GovernanceActionsError :: TestTree test_GovernanceActionsError = - testErrorMessagesRendering "Cardano.CLI.EraBased.Run.Governance.Actions" "GovernanceActionsError" - [ ("GovernanceActionsCmdWriteFileError" - , GovernanceActionsCmdWriteFileError $ FileError "path/file.txt" ()) - , ("GovernanceActionsCmdReadFileError" - , GovernanceActionsCmdReadFileError $ FileError "path/file.txt" InputInvalidError) - , ("GovernanceActionsCmdConstitutionError" - , GovernanceActionsCmdConstitutionError - $ ConstitutionNotUnicodeError - $ DecodeError "seq" Nothing) - , ("GovernanceActionsCmdCostModelsError" - , GovernanceActionsCmdCostModelsError - $ CostModelsErrorReadFile - $ FileError "some/file.txt" ()) + testErrorMessagesRendering + "Cardano.CLI.EraBased.Run.Governance.Actions" + "GovernanceActionsError" + [ + ( "GovernanceActionsCmdWriteFileError" + , GovernanceActionsCmdWriteFileError $ FileError "path/file.txt" () + ) + , + ( "GovernanceActionsCmdReadFileError" + , GovernanceActionsCmdReadFileError $ FileError "path/file.txt" InputInvalidError + ) + , + ( "GovernanceActionsCmdConstitutionError" + , GovernanceActionsCmdConstitutionError $ + ConstitutionNotUnicodeError $ + DecodeError "seq" Nothing + ) + , + ( "GovernanceActionsCmdCostModelsError" + , GovernanceActionsCmdCostModelsError $ + CostModelsErrorReadFile $ + FileError "some/file.txt" () + ) ] test_CostModelsError :: TestTree test_CostModelsError = - testErrorMessagesRendering "Cardano.CLI.Read" "CostModelsError" - [ ("CostModelsErrorReadFile" - , CostModelsErrorReadFile $ FileError "some/file.txt" ()) - , ("CostModelsErrorJSONDecode" - , CostModelsErrorJSONDecode "some/file.txt" "some error") - , ("CostModelsErrorEmpty" - , CostModelsErrorEmpty "some/file.txt") + testErrorMessagesRendering + "Cardano.CLI.Read" + "CostModelsError" + [ + ( "CostModelsErrorReadFile" + , CostModelsErrorReadFile $ FileError "some/file.txt" () + ) + , + ( "CostModelsErrorJSONDecode" + , CostModelsErrorJSONDecode "some/file.txt" "some error" + ) + , + ( "CostModelsErrorEmpty" + , CostModelsErrorEmpty "some/file.txt" + ) ] goldenFilesPath :: FilePath goldenFilesPath = "test/cardano-cli-golden/files/golden/errors" -testErrorMessagesRendering :: forall a. () +testErrorMessagesRendering + :: forall a + . () => HasCallStack => Error a - => String -- ^ module name - -> String -- ^ type name - -> [(String, a)] -- ^ list of constructor names and values + => String + -- ^ module name + -> String + -- ^ type name + -> [(String, a)] + -- ^ list of constructor names and values -> TestTree testErrorMessagesRendering = ErrorMessage.testAllErrorMessages_ goldenFilesPath - diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Action.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Action.hs index 60ea9205e7..317b7a43f1 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Action.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Action.hs @@ -17,36 +17,62 @@ hprop_golden_governance_action_create_constitution = stakeAddressVKeyFile <- noteTempFile tempDir "stake-address.vkey" stakeAddressSKeyFile <- noteTempFile tempDir "stake-address.skey" - void $ execCardanoCLI - [ "legacy", "stake-address", "key-gen" - , "--verification-key-file", stakeAddressVKeyFile - , "--signing-key-file", stakeAddressSKeyFile - ] + void $ + execCardanoCLI + [ "legacy" + , "stake-address" + , "key-gen" + , "--verification-key-file" + , stakeAddressVKeyFile + , "--signing-key-file" + , stakeAddressSKeyFile + ] actionFile <- noteTempFile tempDir "create-constitution.action" redactedActionFile <- noteTempFile tempDir "create-constitution.action.redacted" - proposalHash <- execCardanoCLI - [ "hash", "anchor-data" - , "--text", "whatever"] - - constitutionHash <- execCardanoCLI - [ "hash", "anchor-data" - , "--text", "something else"] - - void $ execCardanoCLI - [ "conway", "governance", "action", "create-constitution" - , "--mainnet" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--anchor-url", proposalHash - , "--governance-action-deposit", "10" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--out-file", actionFile - , "--constitution-url", "constitution-dummy-url" - , "--constitution-hash", constitutionHash - ] - - goldenActionFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/create-constitution-for-stake-address.action.golden" + proposalHash <- + execCardanoCLI + [ "hash" + , "anchor-data" + , "--text" + , "whatever" + ] + + constitutionHash <- + execCardanoCLI + [ "hash" + , "anchor-data" + , "--text" + , "something else" + ] + + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-constitution" + , "--mainnet" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--anchor-url" + , proposalHash + , "--governance-action-deposit" + , "10" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--out-file" + , actionFile + , "--constitution-url" + , "constitution-dummy-url" + , "--constitution-hash" + , constitutionHash + ] + + goldenActionFile <- + H.note + "test/cardano-cli-golden/files/golden/governance/action/create-constitution-for-stake-address.action.golden" -- Remove cbor hex from comparison, as it's not stable H.redactJsonField "cborHex" "" actionFile redactedActionFile @@ -62,36 +88,60 @@ hprop_golden_conway_governance_action_view_constitution_json = actionFile <- noteTempFile tempDir "action" -- We go through a file for the hash, to test --out-file - void $ execCardanoCLI - [ "hash", "anchor-data" - , "--text", "whatever " - , "--out-file", hashFile - ] + void $ + execCardanoCLI + [ "hash" + , "anchor-data" + , "--text" + , "whatever " + , "--out-file" + , hashFile + ] proposalHash <- H.readFile hashFile - constitutionHash <- execCardanoCLI - [ "hash", "anchor-data" - , "--text", "nonAsciiInput: 你好 and some more: こんにちは" - ] - - void $ execCardanoCLI - [ "conway", "governance", "action", "create-constitution" - , "--mainnet" - , "--anchor-data-hash", proposalHash - , "--anchor-url", "proposal-dummy-url" - , "--governance-action-deposit", "10" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--out-file", actionFile - , "--constitution-url", "http://my-great-constitution.rocks" - , "--constitution-hash", constitutionHash - ] - - goldenActionViewFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/view/create-constitution.action.view" - actionView <- execCardanoCLI - [ "conway", "governance", "action", "view" - , "--action-file", actionFile - ] + constitutionHash <- + execCardanoCLI + [ "hash" + , "anchor-data" + , "--text" + , "nonAsciiInput: 你好 and some more: こんにちは" + ] + + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-constitution" + , "--mainnet" + , "--anchor-data-hash" + , proposalHash + , "--anchor-url" + , "proposal-dummy-url" + , "--governance-action-deposit" + , "10" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--out-file" + , actionFile + , "--constitution-url" + , "http://my-great-constitution.rocks" + , "--constitution-hash" + , constitutionHash + ] + + goldenActionViewFile <- + H.note "test/cardano-cli-golden/files/golden/governance/action/view/create-constitution.action.view" + actionView <- + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "view" + , "--action-file" + , actionFile + ] H.diffVsGoldenFile actionView goldenActionViewFile hprop_golden_conway_governance_action_view_update_committee_yaml :: Property @@ -101,23 +151,39 @@ hprop_golden_conway_governance_action_view_update_committee_yaml = actionFile <- noteTempFile tempDir "action" - void $ execCardanoCLI - [ "conway", "governance", "action", "update-committee" - , "--mainnet" - , "--governance-action-deposit", "10" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--anchor-url", "proposal-dummy-url" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--threshold", "0.61" - , "--out-file", actionFile - ] - - goldenActionViewFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/view/update-committee.action.view" - actionView <- execCardanoCLI - [ "conway", "governance", "action", "view" - , "--action-file", actionFile - , "--output-yaml" - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "update-committee" + , "--mainnet" + , "--governance-action-deposit" + , "10" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--anchor-url" + , "proposal-dummy-url" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--threshold" + , "0.61" + , "--out-file" + , actionFile + ] + + goldenActionViewFile <- + H.note "test/cardano-cli-golden/files/golden/governance/action/view/update-committee.action.view" + actionView <- + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "view" + , "--action-file" + , actionFile + , "--output-yaml" + ] H.diffVsGoldenFile actionView goldenActionViewFile hprop_golden_conway_governance_action_view_create_info_json_outfile :: Property @@ -127,51 +193,87 @@ hprop_golden_conway_governance_action_view_create_info_json_outfile = actionFile <- noteTempFile tempDir "action" - void $ execCardanoCLI - [ "conway", "governance", "action", "create-info" - , "--testnet" - , "--governance-action-deposit", "10" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--anchor-url", "proposal-dummy-url" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--out-file", actionFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-info" + , "--testnet" + , "--governance-action-deposit" + , "10" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--anchor-url" + , "proposal-dummy-url" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--out-file" + , actionFile + ] actionViewFile <- noteTempFile tempDir "action-view" - goldenActionViewFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/view/create-info.action.view" - void $ execCardanoCLI - [ "conway", "governance", "action", "view" - , "--action-file", actionFile - , "--out-file", actionViewFile - ] + goldenActionViewFile <- + H.note "test/cardano-cli-golden/files/golden/governance/action/view/create-info.action.view" + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "view" + , "--action-file" + , actionFile + , "--out-file" + , actionViewFile + ] H.diffFileVsGoldenFile actionViewFile goldenActionViewFile hprop_golden_governanceActionCreateNoConfidence :: Property hprop_golden_governanceActionCreateNoConfidence = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - stakeAddressVKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/stake-address.vkey" + stakeAddressVKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/governance/stake-address.vkey" actionFile <- noteTempFile tempDir "action" - void $ execCardanoCLI - [ "conway", "governance", "action", "create-no-confidence" - , "--mainnet" - , "--governance-action-deposit", "10" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--anchor-url", "proposal-dummy-url" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--prev-governance-action-index", "5" - , "--prev-governance-action-tx-id", "b1015258a99351c143a7a40b7b58f033ace10e3cc09c67780ed5b2b0992aa60a" - , "--out-file", actionFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-no-confidence" + , "--mainnet" + , "--governance-action-deposit" + , "10" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--anchor-url" + , "proposal-dummy-url" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--prev-governance-action-index" + , "5" + , "--prev-governance-action-tx-id" + , "b1015258a99351c143a7a40b7b58f033ace10e3cc09c67780ed5b2b0992aa60a" + , "--out-file" + , actionFile + ] actionViewFile <- noteTempFile tempDir "action-view" - goldenActionViewFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/view/create-no-confidence.action.view" - void $ execCardanoCLI - [ "conway", "governance", "action", "view" - , "--action-file", actionFile - , "--out-file", actionViewFile - ] + goldenActionViewFile <- + H.note + "test/cardano-cli-golden/files/golden/governance/action/view/create-no-confidence.action.view" + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "view" + , "--action-file" + , actionFile + , "--out-file" + , actionViewFile + ] H.diffFileVsGoldenFile actionViewFile goldenActionViewFile hprop_golden_conway_governance_action_create_protocol_parameters_update :: Property @@ -184,23 +286,38 @@ hprop_golden_conway_governance_action_create_protocol_parameters_update = actionFile <- noteTempFile tempDir "action" - void $ execCardanoCLI - [ "conway", "governance", "action", "create-protocol-parameters-update" - , "--anchor-url", "example.com" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--mainnet" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--governance-action-deposit", "12345" - , "--new-governance-action-deposit", "123454321" - , "--max-tx-size", "1234" - , "--cost-model-file", costModelsFile - , "--out-file", actionFile - ] - - goldenActionFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/conway-create-protocol-parameters-update.action" + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-protocol-parameters-update" + , "--anchor-url" + , "example.com" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--mainnet" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--governance-action-deposit" + , "12345" + , "--new-governance-action-deposit" + , "123454321" + , "--max-tx-size" + , "1234" + , "--cost-model-file" + , costModelsFile + , "--out-file" + , actionFile + ] + + goldenActionFile <- + H.note + "test/cardano-cli-golden/files/golden/governance/action/conway-create-protocol-parameters-update.action" H.diffFileVsGoldenFile actionFile goldenActionFile -hprop_golden_conway_governance_action_create_protocol_parameters_update_partial_costmodel :: Property +hprop_golden_conway_governance_action_create_protocol_parameters_update_partial_costmodel + :: Property hprop_golden_conway_governance_action_create_protocol_parameters_update_partial_costmodel = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do stakeAddressVKeyFile <- H.note "test/cardano-cli-golden/files/input/governance/stake-address.vkey" @@ -208,18 +325,30 @@ hprop_golden_conway_governance_action_create_protocol_parameters_update_partial_ actionFile <- noteTempFile tempDir "action" - void $ execCardanoCLI - [ "conway", "governance", "action", "create-protocol-parameters-update" - , "--anchor-url", "example.com" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--mainnet" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--governance-action-deposit", "12345" - , "--cost-model-file", costModelsFile - , "--out-file", actionFile - ] - - goldenActionFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/conway-create-protocol-parameters-update-partial-costmodels.action" + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-protocol-parameters-update" + , "--anchor-url" + , "example.com" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--mainnet" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--governance-action-deposit" + , "12345" + , "--cost-model-file" + , costModelsFile + , "--out-file" + , actionFile + ] + + goldenActionFile <- + H.note + "test/cardano-cli-golden/files/golden/governance/action/conway-create-protocol-parameters-update-partial-costmodels.action" H.diffFileVsGoldenFile actionFile goldenActionFile hprop_golden_conway_governance_action_create_hardfork :: Property @@ -229,17 +358,30 @@ hprop_golden_conway_governance_action_create_hardfork = actionFile <- noteTempFile tempDir "action" - void $ execCardanoCLI - ["conway", "governance", "action", "create-hardfork" - , "--anchor-url", "example.com" - , "--anchor-data-hash", "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" - , "--mainnet" - , "--deposit-return-stake-verification-key-file", stakeAddressVKeyFile - , "--governance-action-deposit", "12345" - , "--protocol-major-version", "10" - , "--protocol-minor-version", "0" - , "--out-file", actionFile - ] - - goldenActionFile <- H.note "test/cardano-cli-golden/files/golden/governance/action/hardfork/conway-create-hardfork.action" + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "create-hardfork" + , "--anchor-url" + , "example.com" + , "--anchor-data-hash" + , "c7ddb5b493faa4d3d2d679847740bdce0c5d358d56f9b1470ca67f5652a02745" + , "--mainnet" + , "--deposit-return-stake-verification-key-file" + , stakeAddressVKeyFile + , "--governance-action-deposit" + , "12345" + , "--protocol-major-version" + , "10" + , "--protocol-minor-version" + , "0" + , "--out-file" + , actionFile + ] + + goldenActionFile <- + H.note + "test/cardano-cli-golden/files/golden/governance/action/hardfork/conway-create-hardfork.action" H.diffFileVsGoldenFile actionFile goldenActionFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Committee.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Committee.hs index b2c804effd..aa41f3c480 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Committee.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Committee.hs @@ -19,32 +19,44 @@ import qualified Hedgehog.Extras.Test.Golden as H goldenDir, inputDir :: FilePath goldenDir = "test/cardano-cli-golden/files/golden" -inputDir = "test/cardano-cli-golden/files/input" +inputDir = "test/cardano-cli-golden/files/input" -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden governance committee key gen/"'@ hprop_golden_governance_committee_key_gen :: Property hprop_golden_governance_committee_key_gen = - let supplyValues = [ ("key-gen-cold", "Cold") - , ("key-gen-hot", "Hot") ] in - propertyOnce $ forM_ supplyValues $ \(flag, inJson) -> - H.moduleWorkspace "tmp" $ \tempDir -> do - verificationKeyFile <- noteTempFile tempDir "key-gen.vkey" - signingKeyFile <- noteTempFile tempDir "key-gen.skey" - - H.noteShowM_ $ execCardanoCLI - [ "conway", "governance", "committee", flag - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - ] - - assertHasMappings [ ("type", "ConstitutionalCommittee" <> inJson <> "VerificationKey_ed25519") - , ("description", "Constitutional Committee " <> inJson <> " Verification Key")] - verificationKeyFile - - assertHasMappings [ ("type", "ConstitutionalCommittee" <> inJson <> "SigningKey_ed25519") - , ("description", "Constitutional Committee " <> inJson <> " Signing Key")] - signingKeyFile + let supplyValues = + [ ("key-gen-cold", "Cold") + , ("key-gen-hot", "Hot") + ] + in propertyOnce $ forM_ supplyValues $ \(flag, inJson) -> + H.moduleWorkspace "tmp" $ \tempDir -> do + verificationKeyFile <- noteTempFile tempDir "key-gen.vkey" + signingKeyFile <- noteTempFile tempDir "key-gen.skey" + + H.noteShowM_ $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , flag + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + ] + + assertHasMappings + [ ("type", "ConstitutionalCommittee" <> inJson <> "VerificationKey_ed25519") + , ("description", "Constitutional Committee " <> inJson <> " Verification Key") + ] + verificationKeyFile + + assertHasMappings + [ ("type", "ConstitutionalCommittee" <> inJson <> "SigningKey_ed25519") + , ("description", "Constitutional Committee " <> inJson <> " Signing Key") + ] + signingKeyFile -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden governance CommitteeCreateHotKeyAuthorizationCertificate/"'@ @@ -58,28 +70,49 @@ hprop_golden_governance_CommitteeCreateHotKeyAuthorizationCertificate = certFile <- noteTempFile tempDir "hot-auth.cert" - void $ execCardanoCLI - [ "conway", "governance", "committee", "key-gen-cold" - , "--verification-key-file", ccColdVKey - , "--signing-key-file", ccColdSKey - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "key-gen-cold" + , "--verification-key-file" + , ccColdVKey + , "--signing-key-file" + , ccColdSKey + ] - void $ execCardanoCLI - [ "conway", "governance", "committee", "key-gen-hot" - , "--verification-key-file", ccHotVKey - , "--signing-key-file", ccHotSKey - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "key-gen-hot" + , "--verification-key-file" + , ccHotVKey + , "--signing-key-file" + , ccHotSKey + ] - H.noteShowM_ $ execCardanoCLI - [ "conway", "governance", "committee", "create-hot-key-authorization-certificate" - , "--cold-verification-key-file", ccColdVKey - , "--hot-verification-key-file", ccHotVKey - , "--out-file", certFile - ] + H.noteShowM_ $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "create-hot-key-authorization-certificate" + , "--cold-verification-key-file" + , ccColdVKey + , "--hot-verification-key-file" + , ccHotVKey + , "--out-file" + , certFile + ] - assertHasMappings [ ("type", "CertificateConway") - , ("description", "Constitutional Committee Hot Key Registration Certificate")] - certFile + assertHasMappings + [ ("type", "CertificateConway") + , ("description", "Constitutional Committee Hot Key Registration Certificate") + ] + certFile -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden governance CommitteeCreateColdKeyResignationCertificate/"'@ @@ -91,21 +124,35 @@ hprop_golden_governance_CommitteeCreateColdKeyResignationCertificate = certFile <- noteTempFile tempDir "hot-auth.cert" - void $ execCardanoCLI - [ "conway", "governance", "committee", "key-gen-cold" - , "--verification-key-file", ccColdVKey - , "--signing-key-file", ccColdSKey - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "key-gen-cold" + , "--verification-key-file" + , ccColdVKey + , "--signing-key-file" + , ccColdSKey + ] - void $ execCardanoCLI - [ "conway", "governance", "committee", "create-cold-key-resignation-certificate" - , "--cold-verification-key-file", ccColdVKey - , "--out-file", certFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "create-cold-key-resignation-certificate" + , "--cold-verification-key-file" + , ccColdVKey + , "--out-file" + , certFile + ] - assertHasMappings [ ("type", "CertificateConway") - , ("description", "Constitutional Committee Cold Key Resignation Certificate")] - certFile + assertHasMappings + [ ("type", "CertificateConway") + , ("description", "Constitutional Committee Cold Key Resignation Certificate") + ] + certFile -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden governance UpdateCommittee/"'@ @@ -119,28 +166,47 @@ hprop_golden_governance_UpdateCommittee = outFile <- H.noteTempFile tempDir "answer-file.json" - proposalHash <- execCardanoCLI - [ "hash", "anchor-data" - , "--file-text", ccProposal ] + proposalHash <- + execCardanoCLI + [ "hash" + , "anchor-data" + , "--file-text" + , ccProposal + ] H.note_ proposalHash H.note_ $ show $ length proposalHash goldenAnswerFile <- H.note $ goldenDir "governance/committee/update-committee-answer.json" - void $ execCardanoCLI - [ "conway", "governance", "action", "update-committee" - , "--testnet", "--governance-action-deposit", "0" - , "--deposit-return-stake-verification-key-file", stakeVkey - , "--anchor-url", "http://dummy" - , "--anchor-data-hash", proposalHash - , "--add-cc-cold-verification-key-file", coldCCVkey1 - , "--epoch", "202" - , "--add-cc-cold-verification-key-file", coldCCVkey2 - , "--epoch", "252" - , "--threshold", "51/100" - , "--out-file", outFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "action" + , "update-committee" + , "--testnet" + , "--governance-action-deposit" + , "0" + , "--deposit-return-stake-verification-key-file" + , stakeVkey + , "--anchor-url" + , "http://dummy" + , "--anchor-data-hash" + , proposalHash + , "--add-cc-cold-verification-key-file" + , coldCCVkey1 + , "--epoch" + , "202" + , "--add-cc-cold-verification-key-file" + , coldCCVkey2 + , "--epoch" + , "252" + , "--threshold" + , "51/100" + , "--out-file" + , outFile + ] H.diffFileVsGoldenFile outFile goldenAnswerFile @@ -155,12 +221,18 @@ hprop_golden_governance_committee_cold_extended_key_signing = outGold <- H.note $ goldenDir "governance/committee/tx.cold.extended.signed" outFile <- H.noteTempFile tempDir "outFile" - H.noteM_ $ execCardanoCLI - [ "conway", "transaction", "sign" - , "--tx-body-file", txBody - , "--signing-key-file", skeyFile - , "--out-file", outFile - ] + H.noteM_ $ + execCardanoCLI + [ "conway" + , "transaction" + , "sign" + , "--tx-body-file" + , txBody + , "--signing-key-file" + , skeyFile + , "--out-file" + , outFile + ] H.diffFileVsGoldenFile outFile outGold @@ -175,12 +247,18 @@ hprop_golden_governance_committee_hot_extended_key_signing = outGold <- H.note $ goldenDir "governance/committee/tx.hot.extended.signed" outFile <- H.noteTempFile tempDir "outFile" - H.noteM_ $ execCardanoCLI - [ "conway", "transaction", "sign" - , "--tx-body-file", txBody - , "--signing-key-file", skeyFile - , "--out-file", outFile - ] + H.noteM_ $ + execCardanoCLI + [ "conway" + , "transaction" + , "sign" + , "--tx-body-file" + , txBody + , "--signing-key-file" + , skeyFile + , "--out-file" + , outFile + ] H.diffFileVsGoldenFile outFile outGold @@ -188,24 +266,31 @@ hprop_golden_governance_committee_hot_extended_key_signing = -- @cabal test cardano-cli-golden --test-options '-p "/golden verification key committee/"'@ hprop_golden_verification_key_committee :: Property hprop_golden_verification_key_committee = do - let values = [ ( inputDir "governance/committee/cc.extended.hot.skey" - , goldenDir "governance/committee/cc.extended.hot.vkey" - ) - , - ( inputDir "governance/committee/cc.extended.cold.skey" - , goldenDir "governance/committee/cc.extended.cold.vkey" - ) - ] + let values = + [ + ( inputDir "governance/committee/cc.extended.hot.skey" + , goldenDir "governance/committee/cc.extended.hot.vkey" + ) + , + ( inputDir "governance/committee/cc.extended.cold.skey" + , goldenDir "governance/committee/cc.extended.cold.vkey" + ) + ] propertyOnce $ forM_ values $ \(skeyFile, vkeyGolden) -> H.moduleWorkspace "tmp" $ \tempDir -> do vkeyFileOut <- noteTempFile tempDir "cc.extended.vkey" - H.noteM_ $ execCardanoCLI - [ "conway", "key", "verification-key" - , "--signing-key-file", skeyFile - , "--verification-key-file", vkeyFileOut - ] + H.noteM_ $ + execCardanoCLI + [ "conway" + , "key" + , "verification-key" + , "--signing-key-file" + , skeyFile + , "--verification-key-file" + , vkeyFileOut + ] H.diffFileVsGoldenFile vkeyFileOut vkeyGolden @@ -213,16 +298,28 @@ hprop_golden_verification_key_committee = do -- @cabal test cardano-cli-golden --test-options '-p "/golden governance extended committee key hash/"'@ hprop_golden_governance_extended_committee_key_hash :: Property hprop_golden_governance_extended_committee_key_hash = - let supplyValues = [ (inputDir "governance/committee/cc.extended.cold.vkey", "9fe92405abcd903d34e21a97328e7cd222eebd4ced5995a95777f7a3\n") - , (inputDir "governance/committee/cc.extended.hot.vkey", "4eb7202ffcc6d5513dba5edc618bd7b582a257c76d6b0cd83975f4e6\n") - ] in - propertyOnce $ forM_ supplyValues $ \(extendedKeyFile, expected) -> - H.moduleWorkspace "tmp" $ \_tempDir -> do - verificationKeyFile <- H.noteInputFile extendedKeyFile - - result <- execCardanoCLI - [ "conway", "governance", "committee", "key-hash" - , "--verification-key-file", verificationKeyFile - ] - - result H.=== expected + let supplyValues = + [ + ( inputDir "governance/committee/cc.extended.cold.vkey" + , "9fe92405abcd903d34e21a97328e7cd222eebd4ced5995a95777f7a3\n" + ) + , + ( inputDir "governance/committee/cc.extended.hot.vkey" + , "4eb7202ffcc6d5513dba5edc618bd7b582a257c76d6b0cd83975f4e6\n" + ) + ] + in propertyOnce $ forM_ supplyValues $ \(extendedKeyFile, expected) -> + H.moduleWorkspace "tmp" $ \_tempDir -> do + verificationKeyFile <- H.noteInputFile extendedKeyFile + + result <- + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "key-hash" + , "--verification-key-file" + , verificationKeyFile + ] + + result H.=== expected diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/StakeAddress.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/StakeAddress.hs index 723d55a800..f9bc5164b9 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/StakeAddress.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/StakeAddress.hs @@ -15,14 +15,20 @@ hprop_golden_conway_stakeaddress_delegate_no_confidence = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do vkeyFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/stake.vkey" delegFile <- H.noteTempFile tempDir "deleg" - delegGold <- H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/noConfidenceDeleg.cert" - - void $ execCardanoCLI - [ "conway", "stake-address", "vote-delegation-certificate" - , "--stake-verification-key-file", vkeyFile - , "--always-no-confidence" - , "--out-file", delegFile - ] + delegGold <- + H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/noConfidenceDeleg.cert" + + void $ + execCardanoCLI + [ "conway" + , "stake-address" + , "vote-delegation-certificate" + , "--stake-verification-key-file" + , vkeyFile + , "--always-no-confidence" + , "--out-file" + , delegFile + ] H.diffFileVsGoldenFile delegFile delegGold @@ -31,14 +37,20 @@ hprop_golden_conway_stakeaddress_delegate_always_abstain = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do vkeyFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/stake.vkey" delegFile <- H.noteTempFile tempDir "deleg" - delegGold <- H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/alwaysAbstainDeleg.cert" - - void $ execCardanoCLI - [ "conway", "stake-address", "vote-delegation-certificate" - , "--stake-verification-key-file", vkeyFile - , "--always-abstain" - , "--out-file", delegFile - ] + delegGold <- + H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/alwaysAbstainDeleg.cert" + + void $ + execCardanoCLI + [ "conway" + , "stake-address" + , "vote-delegation-certificate" + , "--stake-verification-key-file" + , vkeyFile + , "--always-abstain" + , "--out-file" + , delegFile + ] H.diffFileVsGoldenFile delegFile delegGold @@ -48,15 +60,22 @@ hprop_golden_conway_stakeaddress_delegate_pool_and_no_confidence = vkeyFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/stake.vkey" vkeyPool <- noteInputFile "test/cardano-cli-golden/files/input/conway/poolCold.vkey" delegFile <- H.noteTempFile tempDir "deleg" - delegGold <- H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/poolAndNoConfidenceDeleg.cert" - - void $ execCardanoCLI - [ "conway", "stake-address", "stake-and-vote-delegation-certificate" - , "--stake-verification-key-file", vkeyFile - , "--cold-verification-key-file", vkeyPool - , "--always-no-confidence" - , "--out-file", delegFile - ] + delegGold <- + H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/poolAndNoConfidenceDeleg.cert" + + void $ + execCardanoCLI + [ "conway" + , "stake-address" + , "stake-and-vote-delegation-certificate" + , "--stake-verification-key-file" + , vkeyFile + , "--cold-verification-key-file" + , vkeyPool + , "--always-no-confidence" + , "--out-file" + , delegFile + ] H.diffFileVsGoldenFile delegFile delegGold @@ -66,15 +85,22 @@ hprop_golden_conway_stakeaddress_delegate_pool_and_always_abstain = vkeyFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/stake.vkey" vkeyPool <- noteInputFile "test/cardano-cli-golden/files/input/conway/poolCold.vkey" delegFile <- H.noteTempFile tempDir "deleg" - delegGold <- H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/poolAndAlwaysAbstainDeleg.cert" - - void $ execCardanoCLI - [ "conway", "stake-address", "stake-and-vote-delegation-certificate" - , "--stake-verification-key-file", vkeyFile - , "--cold-verification-key-file", vkeyPool - , "--always-abstain" - , "--out-file", delegFile - ] + delegGold <- + H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/poolAndAlwaysAbstainDeleg.cert" + + void $ + execCardanoCLI + [ "conway" + , "stake-address" + , "stake-and-vote-delegation-certificate" + , "--stake-verification-key-file" + , vkeyFile + , "--cold-verification-key-file" + , vkeyPool + , "--always-abstain" + , "--out-file" + , delegFile + ] H.diffFileVsGoldenFile delegFile delegGold @@ -85,14 +111,22 @@ hprop_golden_conway_stakeaddress_delegate_pool_and_drep = vkeyPool <- noteInputFile "test/cardano-cli-golden/files/input/conway/poolCold.vkey" vkeyDrep <- noteInputFile "test/cardano-cli-golden/files/input/governance/drep/drep.vkey" delegFile <- H.noteTempFile tempDir "deleg" - delegGold <- H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/poolAndDrepVkeyDeleg.cert" - - void $ execCardanoCLI - [ "conway", "stake-address", "stake-and-vote-delegation-certificate" - , "--stake-verification-key-file", vkeyFile - , "--cold-verification-key-file", vkeyPool - , "--drep-verification-key-file", vkeyDrep - , "--out-file", delegFile - ] + delegGold <- + H.note "test/cardano-cli-golden/files/golden/governance/stakeaddress/poolAndDrepVkeyDeleg.cert" + + void $ + execCardanoCLI + [ "conway" + , "stake-address" + , "stake-and-vote-delegation-certificate" + , "--stake-verification-key-file" + , vkeyFile + , "--cold-verification-key-file" + , vkeyPool + , "--drep-verification-key-file" + , vkeyDrep + , "--out-file" + , delegFile + ] H.diffFileVsGoldenFile delegFile delegGold diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Vote.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Vote.hs index 5910510d37..e6125a5216 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Vote.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Governance/Vote.hs @@ -18,16 +18,26 @@ hprop_golden_governance_governance_vote_create = voteFile <- H.noteTempFile tempDir "vote" voteGold <- H.note "test/cardano-cli-golden/files/golden/governance/vote/vote" - void $ execCardanoCLI - [ "conway", "governance", "vote", "create" - , "--yes" - , "--governance-action-tx-id", "b1015258a99351c143a7a40b7b58f033ace10e3cc09c67780ed5b2b0992aa60a" - , "--governance-action-index", "5" - , "--drep-verification-key-file", vkeyFile - , "--out-file", voteFile - , "--anchor-url", "https://example.com/vote" - , "--anchor-data-hash", "6163683a90d8cb460a38cdcf0d7bab286f0f004ec6e761dc670c2ca4d3709a17" - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "create" + , "--yes" + , "--governance-action-tx-id" + , "b1015258a99351c143a7a40b7b58f033ace10e3cc09c67780ed5b2b0992aa60a" + , "--governance-action-index" + , "5" + , "--drep-verification-key-file" + , vkeyFile + , "--out-file" + , voteFile + , "--anchor-url" + , "https://example.com/vote" + , "--anchor-data-hash" + , "6163683a90d8cb460a38cdcf0d7bab286f0f004ec6e761dc670c2ca4d3709a17" + ] H.diffFileVsGoldenFile voteFile voteGold @@ -40,10 +50,15 @@ hprop_golden_governance_governance_vote_view_json_stdout = propertyOnce $ do voteFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/vote/vote" H.noteShow_ voteViewJsonSem - voteView <- execCardanoCLI - [ "conway", "governance", "vote", "view" - , "--vote-file", voteFile - ] + voteView <- + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "view" + , "--vote-file" + , voteFile + ] bracketSem voteViewJsonSem $ H.diffVsGoldenFile voteView @@ -54,11 +69,17 @@ hprop_golden_governance_governance_vote_view_json_outfile = voteFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/vote/vote" voteViewFile <- H.noteTempFile tempDir "voteView" H.noteShow_ voteViewJsonSem - void $ execCardanoCLI - [ "conway", "governance", "vote", "view" - , "--vote-file", voteFile - , "--out-file", voteViewFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "view" + , "--vote-file" + , voteFile + , "--out-file" + , voteViewFile + ] bracketSem voteViewJsonSem $ H.diffFileVsGoldenFile voteViewFile @@ -68,11 +89,16 @@ hprop_golden_governance_governance_vote_view_yaml = propertyOnce $ do voteFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/vote/vote" voteViewGold <- H.note "test/cardano-cli-golden/files/golden/governance/vote/voteViewYAML" - voteView <- execCardanoCLI - [ "conway", "governance", "vote", "view" - , "--output-yaml" - , "--vote-file", voteFile - ] + voteView <- + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "view" + , "--output-yaml" + , "--vote-file" + , voteFile + ] H.diffVsGoldenFile voteView voteViewGold @@ -83,14 +109,22 @@ hprop_golden_governance_governance_vote_create_yes_cc_hot_key = voteFile <- H.noteTempFile tempDir "vote" voteGold <- H.note "test/cardano-cli-golden/files/golden/governance/vote/vote_cc_yes.json" - void $ execCardanoCLI - [ "conway", "governance", "vote", "create" - , "--yes" - , "--governance-action-tx-id", "d21d997b5dbdd90180b642c3f4f2653cea629f6134cd9dc820d0fe6f11b54af4" - , "--governance-action-index", "0" - , "--cc-hot-verification-key-file", ccVkeyFile - , "--out-file", voteFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "create" + , "--yes" + , "--governance-action-tx-id" + , "d21d997b5dbdd90180b642c3f4f2653cea629f6134cd9dc820d0fe6f11b54af4" + , "--governance-action-index" + , "0" + , "--cc-hot-verification-key-file" + , ccVkeyFile + , "--out-file" + , voteFile + ] H.diffFileVsGoldenFile voteFile voteGold @@ -101,14 +135,22 @@ hprop_golden_governance_governance_vote_create_no_cc_hot_key = voteFile <- H.noteTempFile tempDir "vote" voteGold <- H.note "test/cardano-cli-golden/files/golden/governance/vote/vote_cc_no.json" - void $ execCardanoCLI - [ "conway", "governance", "vote", "create" - , "--no" - , "--governance-action-tx-id", "d21d997b5dbdd90180b642c3f4f2653cea629f6134cd9dc820d0fe6f11b54af4" - , "--governance-action-index", "0" - , "--cc-hot-verification-key-file", ccVkeyFile - , "--out-file", voteFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "create" + , "--no" + , "--governance-action-tx-id" + , "d21d997b5dbdd90180b642c3f4f2653cea629f6134cd9dc820d0fe6f11b54af4" + , "--governance-action-index" + , "0" + , "--cc-hot-verification-key-file" + , ccVkeyFile + , "--out-file" + , voteFile + ] H.diffFileVsGoldenFile voteFile voteGold @@ -119,13 +161,21 @@ hprop_golden_governance_governance_vote_create_abstain_cc_hot_key = voteFile <- H.noteTempFile tempDir "vote" voteGold <- H.note "test/cardano-cli-golden/files/golden/governance/vote/vote_cc_abstain.json" - void $ execCardanoCLI - [ "conway", "governance", "vote", "create" - , "--abstain" - , "--governance-action-tx-id", "d21d997b5dbdd90180b642c3f4f2653cea629f6134cd9dc820d0fe6f11b54af4" - , "--governance-action-index", "0" - , "--cc-hot-verification-key-file", ccVkeyFile - , "--out-file", voteFile - ] + void $ + execCardanoCLI + [ "conway" + , "governance" + , "vote" + , "create" + , "--abstain" + , "--governance-action-tx-id" + , "d21d997b5dbdd90180b642c3f4f2653cea629f6134cd9dc820d0fe6f11b54af4" + , "--governance-action-index" + , "0" + , "--cc-hot-verification-key-file" + , ccVkeyFile + , "--out-file" + , voteFile + ] H.diffFileVsGoldenFile voteFile voteGold diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Hash/Hash.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Hash/Hash.hs index 0ed7b04183..0ddf86650d 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Hash/Hash.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Hash/Hash.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use camelCase" #-} module Test.Golden.Hash.Hash where + import Control.Monad import Test.Cardano.CLI.Util @@ -9,7 +11,6 @@ import Hedgehog (Property) import qualified Hedgehog.Extras as H import qualified Hedgehog.Extras.Test.Golden as H - hprop_golden_governance_hash_script :: Property hprop_golden_governance_hash_script = H.propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do @@ -17,10 +18,14 @@ hprop_golden_governance_hash_script = hashFile <- H.noteTempFile tempDir "foo.script.hash" hashGold <- H.note "test/cardano-cli-golden/files/golden/hash/foo.script.hash" - void $ execCardanoCLI - [ "hash", "script" - , "--script-file", scriptFile - , "--out-file", hashFile - ] + void $ + execCardanoCLI + [ "hash" + , "script" + , "--script-file" + , scriptFile + , "--out-file" + , hashFile + ] H.diffFileVsGoldenFile hashFile hashGold diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Help.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Help.hs index daf04b18ad..45a28016fe 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Help.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Help.hs @@ -5,7 +5,8 @@ module Test.Golden.Help ( hprop_golden_HelpAll , hprop_golden_HelpCmds - ) where + ) +where import Prelude hiding (lines) @@ -31,20 +32,23 @@ ansiRegex = mkRegex "\\[[0-9]+m" filterAnsi :: String -> String filterAnsi line = subRegex ansiRegex stripped "" - where stripped = filter (/= '\ESC') line + where + stripped = filter (/= '\ESC') line {- HLINT ignore "Use camelCase" -} extractCmd :: Text -> [Text] -extractCmd = id - . takeWhile nonSwitch - . Text.split Char.isSpace - . Text.strip - where nonSwitch :: Text -> Bool - nonSwitch s = - case Text.unpack (Text.take 1 s) of - (c:_) -> Char.isAlpha c - [] -> False +extractCmd = + id + . takeWhile nonSwitch + . Text.split Char.isSpace + . Text.strip + where + nonSwitch :: Text -> Bool + nonSwitch s = + case Text.unpack (Text.take 1 s) of + (c : _) -> Char.isAlpha c + [] -> False -- | Test that converting a @cardano-address@ Byron signing key yields the -- expected result. @@ -57,9 +61,11 @@ hprop_golden_HelpAll = unless isWin32 $ do helpFp <- H.note "test/cardano-cli-golden/files/golden/help.cli" - help <- filterAnsi <$> execCardanoCLI - [ "help" - ] + help <- + filterAnsi + <$> execCardanoCLI + [ "help" + ] H.diffVsGoldenFile help helpFp @@ -89,16 +95,19 @@ hprop_golden_HelpCmds = -- output is slightly different on Windows. For example it uses -- "cardano-cli.exe" instead of "cardano-cli". unless isWin32 $ do - help <- filterAnsi <$> execCardanoCLI - [ "help" - ] + help <- + filterAnsi + <$> execCardanoCLI + [ "help" + ] let lines = Text.lines $ Text.pack help let usages = List.filter (not . null) $ fmap extractCmd $ maybeToList . selectCmd =<< lines forM_ usages $ \usage -> do H.noteShow_ usage - let expectedCmdHelpFp = "test/cardano-cli-golden/files/golden/help" Text.unpack (Text.intercalate "_" usage) <> ".cli" + let expectedCmdHelpFp = + "test/cardano-cli-golden/files/golden/help" Text.unpack (Text.intercalate "_" usage) <> ".cli" cmdHelp <- filterAnsi . third <$> H.execDetailCardanoCLI (fmap Text.unpack usage) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Key/NonExtendedKey.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Key/NonExtendedKey.hs index cf1b255e27..e539a4ae38 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Key/NonExtendedKey.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Key/NonExtendedKey.hs @@ -20,16 +20,22 @@ import qualified Hedgehog.Extras.Test.Golden as H hprop_golden_KeyNonExtendedKey_GenesisExtendedVerificationKey :: Property hprop_golden_KeyNonExtendedKey_GenesisExtendedVerificationKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - genesisVKeyFp <- H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/shelley.000.vkey" - nonExtendedFp <- H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-shelley.000.vkey" + genesisVKeyFp <- + H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/shelley.000.vkey" + nonExtendedFp <- + H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-shelley.000.vkey" outFp <- H.note $ tempDir "non-extended-shelley.000.vkey" -- Convert the `cardano-address` signing key - void $ execCardanoCLI - [ "key", "non-extended-key" - , "--extended-verification-key-file", genesisVKeyFp - , "--verification-key-file", outFp - ] + void $ + execCardanoCLI + [ "key" + , "non-extended-key" + , "--extended-verification-key-file" + , genesisVKeyFp + , "--verification-key-file" + , outFp + ] H.diffFileVsGoldenFile outFp nonExtendedFp @@ -38,16 +44,22 @@ hprop_golden_KeyNonExtendedKey_GenesisExtendedVerificationKey = hprop_golden_KeyNonExtendedKey_StakeExtendedVerificationKeyShelley :: Property hprop_golden_KeyNonExtendedKey_StakeExtendedVerificationKeyShelley = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - genesisVKeyFp <- H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/stake.000.vkey" - nonExtendedFp <- H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-stake.000.vkey" + genesisVKeyFp <- + H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/stake.000.vkey" + nonExtendedFp <- + H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-stake.000.vkey" outFp <- H.note $ tempDir "non-extended-stake.000.vkey" -- Convert the `cardano-address` signing key - void $ execCardanoCLI - [ "key", "non-extended-key" - , "--extended-verification-key-file", genesisVKeyFp - , "--verification-key-file", outFp - ] + void $ + execCardanoCLI + [ "key" + , "non-extended-key" + , "--extended-verification-key-file" + , genesisVKeyFp + , "--verification-key-file" + , outFp + ] H.diffFileVsGoldenFile outFp nonExtendedFp @@ -56,15 +68,22 @@ hprop_golden_KeyNonExtendedKey_StakeExtendedVerificationKeyShelley = hprop_golden_KeyNonExtendedKey_DRepExtendedVerificationKey :: Property hprop_golden_KeyNonExtendedKey_DRepExtendedVerificationKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - extendedKeyFile <- H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/extended-drep.vkey" - goldenFile <- H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-drep.vkey" + extendedKeyFile <- + H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/extended-drep.vkey" + goldenFile <- + H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-drep.vkey" outFp <- H.note $ tempDir "non-extended-drep.vkey" - void $ execCardanoCLI - [ "conway", "key", "non-extended-key" - , "--extended-verification-key-file", extendedKeyFile - , "--verification-key-file", outFp - ] + void $ + execCardanoCLI + [ "conway" + , "key" + , "non-extended-key" + , "--extended-verification-key-file" + , extendedKeyFile + , "--verification-key-file" + , outFp + ] H.diffFileVsGoldenFile outFp goldenFile @@ -73,15 +92,22 @@ hprop_golden_KeyNonExtendedKey_DRepExtendedVerificationKey = hprop_golden_extended_payment_vkey_to_non_extended_vkey :: Property hprop_golden_extended_payment_vkey_to_non_extended_vkey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - extendedKeyFile <- H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/extended-payment.vkey" - goldenFile <- H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-payment.vkey" + extendedKeyFile <- + H.noteInputFile "test/cardano-cli-golden/files/input/key/non-extended-keys/extended-payment.vkey" + goldenFile <- + H.note "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-payment.vkey" outFp <- H.note $ tempDir "non-extended-payment.vkey" - void $ execCardanoCLI - [ "conway", "key", "non-extended-key" - , "--extended-verification-key-file", extendedKeyFile - , "--verification-key-file", outFp - ] + void $ + execCardanoCLI + [ "conway" + , "key" + , "non-extended-key" + , "--extended-verification-key-file" + , extendedKeyFile + , "--verification-key-file" + , outFp + ] H.diffFileVsGoldenFile outFp goldenFile @@ -90,17 +116,24 @@ hprop_golden_extended_payment_vkey_to_non_extended_vkey = -- @cabal test cardano-cli-golden --test-options '-p "/golden extended cc vkey to non extended vkey/"'@ hprop_golden_extended_cc_vkey_to_non_extended_vkey :: Property hprop_golden_extended_cc_vkey_to_non_extended_vkey = - let supplyValues = [ "cc-cold.vkey", "cc-hot.vkey" ] in - propertyOnce $ forM_ supplyValues $ \suffix-> - H.moduleWorkspace "tmp" $ \tempDir -> do - extendedKeyFile <- H.noteInputFile $ "test/cardano-cli-golden/files/input/key/non-extended-keys/extended-" <> suffix - goldenFile <- H.note $ "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-" <> suffix - outFp <- H.note $ tempDir "non-extended-" <> suffix - - void $ execCardanoCLI - [ "conway", "key", "non-extended-key" - , "--extended-verification-key-file", extendedKeyFile - , "--verification-key-file", outFp - ] - - H.diffFileVsGoldenFile outFp goldenFile + let supplyValues = ["cc-cold.vkey", "cc-hot.vkey"] + in propertyOnce $ forM_ supplyValues $ \suffix -> + H.moduleWorkspace "tmp" $ \tempDir -> do + extendedKeyFile <- + H.noteInputFile $ "test/cardano-cli-golden/files/input/key/non-extended-keys/extended-" <> suffix + goldenFile <- + H.note $ "test/cardano-cli-golden/files/golden/key/non-extended-keys/non-extended-" <> suffix + outFp <- H.note $ tempDir "non-extended-" <> suffix + + void $ + execCardanoCLI + [ "conway" + , "key" + , "non-extended-key" + , "--extended-verification-key-file" + , extendedKeyFile + , "--verification-key-file" + , outFp + ] + + H.diffFileVsGoldenFile outFp goldenFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Build.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Build.hs index 7c36f20adc..1033238a8b 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Build.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Build.hs @@ -14,21 +14,30 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyAddressBuild :: Property hprop_golden_shelleyAddressBuild = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - addressVKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/verification_key" - addressSKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" - goldenStakingAddressHexFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/addresses/staking-address.hex" - goldenEnterpriseAddressHexFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/addresses/enterprise-address.hex" + addressVKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/verification_key" + addressSKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + goldenStakingAddressHexFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/addresses/staking-address.hex" + goldenEnterpriseAddressHexFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/addresses/enterprise-address.hex" stakingAddressHexFile <- noteTempFile tempDir "staking-address.hex" enterpriseAddressHexFile <- noteTempFile tempDir "enterprise-address.hex" void $ H.readFile addressVKeyFile - stakingAddressText <- execCardanoCLI - [ "address","build" - , "--testnet-magic", "14" - , "--payment-verification-key-file", addressVKeyFile - , "--staking-verification-key-file", addressSKeyFile - ] + stakingAddressText <- + execCardanoCLI + [ "address" + , "build" + , "--testnet-magic" + , "14" + , "--payment-verification-key-file" + , addressVKeyFile + , "--staking-verification-key-file" + , addressSKeyFile + ] goldenStakingAddressHex <- H.readFile goldenStakingAddressHexFile @@ -38,12 +47,17 @@ hprop_golden_shelleyAddressBuild = propertyOnce . H.moduleWorkspace "tmp" $ \tem void $ H.readFile addressSKeyFile - enterpriseAddressText <- execCardanoCLI - [ "address","build" - , "--testnet-magic", "14" - , "--payment-verification-key-file", addressVKeyFile - , "--staking-verification-key-file", addressSKeyFile - ] + enterpriseAddressText <- + execCardanoCLI + [ "address" + , "build" + , "--testnet-magic" + , "14" + , "--payment-verification-key-file" + , addressVKeyFile + , "--staking-verification-key-file" + , addressSKeyFile + ] goldenEnterpriseAddressHex <- H.readFile goldenEnterpriseAddressHexFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Info.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Info.hs index 2e26af6082..b743e31008 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Info.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/Info.hs @@ -16,32 +16,43 @@ hprop_golden_shelleyAddressInfo :: Property hprop_golden_shelleyAddressInfo = propertyOnce $ do -- Disable as per commit: e69984d797fc3bdd5d71bdd99a0328110d71f6ad when False $ do - let byronBase58 = "DdzFFzCqrhsg9F1joqXWJdGKwn6MaNavCqPsrZcjADRjA4ifEtrBmREJZyCojtuexKjMKNFr6CoU7Gx6PPR7pq14JxvPZuuk2xVkzn8p" + let byronBase58 = + "DdzFFzCqrhsg9F1joqXWJdGKwn6MaNavCqPsrZcjADRjA4ifEtrBmREJZyCojtuexKjMKNFr6CoU7Gx6PPR7pq14JxvPZuuk2xVkzn8p" - infoText1 <- execCardanoCLI - [ "address","info" - , "--address", byronBase58 - ] + infoText1 <- + execCardanoCLI + [ "address" + , "info" + , "--address" + , byronBase58 + ] H.assert $ "Encoding: Base58" `L.isInfixOf` infoText1 H.assert $ "Era: Byron" `L.isInfixOf` infoText1 - let byronHex = "82d818584283581c120e97e4ca7b831373c1060853d4896314e17d567a5723879b9a20eaa101581e581c135a115dd5dba68c28fb7e9409729ffc0503219ff7f9c08e84d13319001a28d0b871" + let byronHex = + "82d818584283581c120e97e4ca7b831373c1060853d4896314e17d567a5723879b9a20eaa101581e581c135a115dd5dba68c28fb7e9409729ffc0503219ff7f9c08e84d13319001a28d0b871" - infoText2 <- execCardanoCLI - [ "address","info" - , "--address", byronHex - ] + infoText2 <- + execCardanoCLI + [ "address" + , "info" + , "--address" + , byronHex + ] H.assert $ "Encoding: Hex" `L.isInfixOf` infoText2 H.assert $ "Era: Byron" `L.isInfixOf` infoText2 let shelleyHex = "82065820d8b4a892f2f6f1820d350c207d17d4cd7e7a1f7e0a83059e2d698a65ab8f96ed" - infoText3 <- execCardanoCLI - [ "address","info" - , "--address", shelleyHex - ] + infoText3 <- + execCardanoCLI + [ "address" + , "info" + , "--address" + , shelleyHex + ] H.assert $ "Encoding: Hex" `L.isInfixOf` infoText3 H.assert $ "Era: Shelley" `L.isInfixOf` infoText3 diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/KeyGen.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/KeyGen.hs index 99c67aeec3..00afc396fc 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/KeyGen.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Address/KeyGen.hs @@ -18,22 +18,30 @@ hprop_golden_shelley_address_key_gen = propertyOnce . H.moduleWorkspace "tmp" $ addressVKeyFile <- noteTempFile tempDir "address.vkey" addressSKeyFile <- noteTempFile tempDir "address.skey" - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", addressVKeyFile - , "--signing-key-file", addressSKeyFile - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , addressVKeyFile + , "--signing-key-file" + , addressSKeyFile + ] - assertHasMappings [("type", "PaymentVerificationKeyShelley_ed25519"), - ("description", "Payment Verification Key")] - addressVKeyFile - assertHasKeys ["cborHex"] addressVKeyFile + assertHasMappings + [ ("type", "PaymentVerificationKeyShelley_ed25519") + , ("description", "Payment Verification Key") + ] + addressVKeyFile + assertHasKeys ["cborHex"] addressVKeyFile H.assertEndsWithSingleNewline addressVKeyFile - assertHasMappings [("type", "PaymentSigningKeyShelley_ed25519"), - ("description", "Payment Signing Key")] - addressSKeyFile - assertHasKeys ["cborHex"] addressSKeyFile + assertHasMappings + [ ("type", "PaymentSigningKeyShelley_ed25519") + , ("description", "Payment Signing Key") + ] + addressSKeyFile + assertHasKeys ["cborHex"] addressSKeyFile H.assertEndsWithSingleNewline addressSKeyFile hprop_golden_shelley_address_extended_key_gen :: Property @@ -41,21 +49,29 @@ hprop_golden_shelley_address_extended_key_gen = propertyOnce . H.moduleWorkspace addressVKeyFile <- noteTempFile tempDir "address.vkey" addressSKeyFile <- noteTempFile tempDir "address.skey" - void $ execCardanoCLI - [ "address","key-gen" - , "--extended-key" - , "--verification-key-file", addressVKeyFile - , "--signing-key-file", addressSKeyFile - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--extended-key" + , "--verification-key-file" + , addressVKeyFile + , "--signing-key-file" + , addressSKeyFile + ] - assertHasMappings [("type", "PaymentExtendedVerificationKeyShelley_ed25519_bip32"), - ("description", "Payment Verification Key")] - addressVKeyFile - assertHasKeys ["cborHex"] addressVKeyFile + assertHasMappings + [ ("type", "PaymentExtendedVerificationKeyShelley_ed25519_bip32") + , ("description", "Payment Verification Key") + ] + addressVKeyFile + assertHasKeys ["cborHex"] addressVKeyFile H.assertEndsWithSingleNewline addressVKeyFile - assertHasMappings [("type", "PaymentExtendedSigningKeyShelley_ed25519_bip32"), - ("description", "Payment Signing Key")] - addressSKeyFile - assertHasKeys ["cborHex"] addressSKeyFile + assertHasMappings + [ ("type", "PaymentExtendedSigningKeyShelley_ed25519_bip32") + , ("description", "Payment Signing Key") + ] + addressSKeyFile + assertHasKeys ["cborHex"] addressSKeyFile H.assertEndsWithSingleNewline addressSKeyFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs index 599ba5dd39..f0cc0fdb0c 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/Create.hs @@ -4,7 +4,8 @@ module Test.Golden.Shelley.Genesis.Create ( hprop_golden_shelleyGenesisCreate - ) where + ) +where import Control.Monad (void) import qualified Data.Aeson as J @@ -63,16 +64,19 @@ parseHashKeys = J.withObject "Object" $ \o -> do pure $ fmap fst (HM.toList delegates) parseTotalSupply :: J.Value -> J.Parser Int -parseTotalSupply = J.withObject "Object" $ \ o -> do +parseTotalSupply = J.withObject "Object" $ \o -> do initialFunds <- (o J..: "initialFunds") >>= parseHashMap fmap sum (sequence (fmap (J.parseJSON @Int . snd) (HM.toList initialFunds))) hprop_golden_shelleyGenesisCreate :: Property hprop_golden_shelleyGenesisCreate = propertyOnce $ do H.moduleWorkspace "tmp" $ \tempDir -> do - sourceGenesisSpecFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/genesis/genesis.spec.json" - sourceAlonzoGenesisSpecFile <- noteInputFile "test/cardano-cli-golden/files/input/alonzo/genesis.alonzo.spec.json" - sourceConwayGenesisSpecFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/genesis.conway.spec.json" + sourceGenesisSpecFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/genesis/genesis.spec.json" + sourceAlonzoGenesisSpecFile <- + noteInputFile "test/cardano-cli-golden/files/input/alonzo/genesis.alonzo.spec.json" + sourceConwayGenesisSpecFile <- + noteInputFile "test/cardano-cli-golden/files/input/conway/genesis.conway.spec.json" genesisSpecFile <- noteTempFile tempDir "genesis.spec.json" alonzoSpecFile <- noteTempFile tempDir "genesis.alonzo.spec.json" @@ -91,15 +95,23 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do (utxoCount, fmtUtxoCount) <- fmap (OP.withSnd show) $ forAll $ G.int (R.linear 4 19) -- Create the genesis json file and required keys - void $ execCardanoCLI - [ "genesis","create" - , "--testnet-magic", "12" - , "--start-time", fmtStartTime - , "--supply", fmtSupply - , "--gen-genesis-keys", fmtDelegateCount - , "--gen-utxo-keys", fmtUtxoCount - , "--genesis-dir", tempDir - ] + void $ + execCardanoCLI + [ "genesis" + , "create" + , "--testnet-magic" + , "12" + , "--start-time" + , fmtStartTime + , "--supply" + , fmtSupply + , "--gen-genesis-keys" + , fmtDelegateCount + , "--gen-utxo-keys" + , fmtUtxoCount + , "--genesis-dir" + , tempDir + ] H.assertFilesExist [genesisFile] @@ -118,8 +130,8 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do actualDelegateCount === delegateCount actualDelegateCount === utxoCount actualTotalSupply === supply - 1_000_000 -- Check that the sum of the initial fund amounts matches the total supply - -- We don't use the entire supply so there is ada in the treasury. This is - -- required for stake pool rewards. + -- We don't use the entire supply so there is ada in the treasury. This is + -- required for stake pool rewards. -- Check uniqueness and count of hash keys S.size (S.fromList actualHashKeys) === length actualHashKeys -- This isn't strictly necessary because we use aeson which guarantees uniqueness of keys @@ -131,24 +143,31 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do for_ [1 .. delegateCount] $ \i -> do -- Check Genesis keys - assertHasMappings [("type", "GenesisVerificationKey_ed25519")] $ tempDir <> "/genesis-keys/genesis" <> show i <> ".vkey" - assertHasMappings [("type", "GenesisSigningKey_ed25519")] $ tempDir <> "/genesis-keys/genesis" <> show i <> ".skey" + assertHasMappings [("type", "GenesisVerificationKey_ed25519")] $ + tempDir <> "/genesis-keys/genesis" <> show i <> ".vkey" + assertHasMappings [("type", "GenesisSigningKey_ed25519")] $ + tempDir <> "/genesis-keys/genesis" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/genesis-keys/genesis" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/genesis-keys/genesis" <> show i <> ".vkey" -- Check delegate keys - assertHasMappings [("type", "GenesisDelegateSigningKey_ed25519")] $ tempDir <> "/delegate-keys/delegate" <> show i <> ".skey" - assertHasMappings [("type", "GenesisDelegateVerificationKey_ed25519")] $ tempDir <> "/delegate-keys/delegate" <> show i <> ".vkey" - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter")] $ tempDir <> "/delegate-keys/delegate" <> show i <> ".counter" + assertHasMappings [("type", "GenesisDelegateSigningKey_ed25519")] $ + tempDir <> "/delegate-keys/delegate" <> show i <> ".skey" + assertHasMappings [("type", "GenesisDelegateVerificationKey_ed25519")] $ + tempDir <> "/delegate-keys/delegate" <> show i <> ".vkey" + assertHasMappings [("type", "NodeOperationalCertificateIssueCounter")] $ + tempDir <> "/delegate-keys/delegate" <> show i <> ".counter" H.assertEndsWithSingleNewline $ tempDir <> "/delegate-keys/delegate" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/delegate-keys/delegate" <> show i <> ".vkey" H.assertEndsWithSingleNewline $ tempDir <> "/delegate-keys/delegate" <> show i <> ".counter" -- Check utxo keys - assertHasMappings [("type", "GenesisUTxOSigningKey_ed25519")] $ tempDir <> "/utxo-keys/utxo" <> show i <> ".skey" - assertHasMappings [("type", "GenesisUTxOVerificationKey_ed25519")] $ tempDir <> "/utxo-keys/utxo" <> show i <> ".vkey" + assertHasMappings [("type", "GenesisUTxOSigningKey_ed25519")] $ + tempDir <> "/utxo-keys/utxo" <> show i <> ".skey" + assertHasMappings [("type", "GenesisUTxOVerificationKey_ed25519")] $ + tempDir <> "/utxo-keys/utxo" <> show i <> ".vkey" H.assertEndsWithSingleNewline $ tempDir <> "/utxo-keys/utxo" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/utxo-keys/utxo" <> show i <> ".vkey" @@ -162,23 +181,33 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do (delegateCount, fmtDelegateCount) <- fmap (OP.withSnd show) $ forAll $ G.int (R.linear 4 19) (utxoCount, fmtUtxoCount) <- fmap (OP.withSnd show) $ forAll $ G.int (R.linear 4 19) - sourceAlonzoGenesisSpecFile <- noteInputFile "test/cardano-cli-golden/files/input/alonzo/genesis.alonzo.spec.json" + sourceAlonzoGenesisSpecFile <- + noteInputFile "test/cardano-cli-golden/files/input/alonzo/genesis.alonzo.spec.json" alonzoSpecFile <- noteTempFile tempDir "genesis.alonzo.spec.json" H.copyFile sourceAlonzoGenesisSpecFile alonzoSpecFile - sourceConwayGenesisSpecFile <- noteInputFile "test/cardano-cli-golden/files/input/conway/genesis.conway.spec.json" + sourceConwayGenesisSpecFile <- + noteInputFile "test/cardano-cli-golden/files/input/conway/genesis.conway.spec.json" conwaySpecFile <- noteTempFile tempDir "genesis.conway.spec.json" H.copyFile sourceConwayGenesisSpecFile conwaySpecFile -- Create the genesis json file and required keys - void $ execCardanoCLI - [ "genesis","create" - , "--testnet-magic", "12" - , "--start-time", fmtStartTime - , "--supply", fmtSupply - , "--gen-genesis-keys", fmtDelegateCount - , "--gen-utxo-keys", fmtUtxoCount - , "--genesis-dir", tempDir + void $ + execCardanoCLI + [ "genesis" + , "create" + , "--testnet-magic" + , "12" + , "--start-time" + , fmtStartTime + , "--supply" + , fmtSupply + , "--gen-genesis-keys" + , fmtDelegateCount + , "--gen-utxo-keys" + , fmtUtxoCount + , "--genesis-dir" + , tempDir ] H.assertFilesExist [genesisFile] @@ -197,9 +226,9 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do actualStartTime === fmtStartTime actualDelegateCount === delegateCount actualDelegateCount === utxoCount - actualTotalSupply === supply - 1_000_000 -- Check that the sum of the initial fund amounts matches the total supply - -- We don't use the entire supply so there is ada in the treasury. This is - -- required for stake pool rewards. + actualTotalSupply === supply - 1_000_000 -- Check that the sum of the initial fund amounts matches the total supply + -- We don't use the entire supply so there is ada in the treasury. This is + -- required for stake pool rewards. -- Check uniqueness and count of hash keys S.size (S.fromList actualHashKeys) === length actualHashKeys -- This isn't strictly necessary because we use aeson which guarantees uniqueness of keys S.size (S.fromList actualHashKeys) === delegateCount @@ -210,24 +239,31 @@ hprop_golden_shelleyGenesisCreate = propertyOnce $ do for_ [1 .. delegateCount] $ \i -> do -- Check Genesis keys - assertHasMappings [("type", "GenesisSigningKey_ed25519")] $ tempDir <> "/genesis-keys/genesis" <> show i <> ".skey" - assertHasMappings [("type", "GenesisVerificationKey_ed25519")] $ tempDir <> "/genesis-keys/genesis" <> show i <> ".vkey" + assertHasMappings [("type", "GenesisSigningKey_ed25519")] $ + tempDir <> "/genesis-keys/genesis" <> show i <> ".skey" + assertHasMappings [("type", "GenesisVerificationKey_ed25519")] $ + tempDir <> "/genesis-keys/genesis" <> show i <> ".vkey" H.assertEndsWithSingleNewline $ tempDir <> "/genesis-keys/genesis" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/genesis-keys/genesis" <> show i <> ".vkey" -- Check delegate keys - assertHasMappings [("type", "GenesisDelegateSigningKey_ed25519")] $ tempDir <> "/delegate-keys/delegate" <> show i <> ".skey" - assertHasMappings [("type", "GenesisDelegateVerificationKey_ed25519")] $ tempDir <> "/delegate-keys/delegate" <> show i <> ".vkey" - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter")] $ tempDir <> "/delegate-keys/delegate" <> show i <> ".counter" + assertHasMappings [("type", "GenesisDelegateSigningKey_ed25519")] $ + tempDir <> "/delegate-keys/delegate" <> show i <> ".skey" + assertHasMappings [("type", "GenesisDelegateVerificationKey_ed25519")] $ + tempDir <> "/delegate-keys/delegate" <> show i <> ".vkey" + assertHasMappings [("type", "NodeOperationalCertificateIssueCounter")] $ + tempDir <> "/delegate-keys/delegate" <> show i <> ".counter" H.assertEndsWithSingleNewline $ tempDir <> "/delegate-keys/delegate" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/delegate-keys/delegate" <> show i <> ".vkey" H.assertEndsWithSingleNewline $ tempDir <> "/delegate-keys/delegate" <> show i <> ".counter" -- Check utxo keys - assertHasMappings [("type", "GenesisUTxOSigningKey_ed25519")] $ tempDir <> "/utxo-keys/utxo" <> show i <> ".skey" - assertHasMappings [("type", "GenesisUTxOVerificationKey_ed25519")] $ tempDir <> "/utxo-keys/utxo" <> show i <> ".vkey" + assertHasMappings [("type", "GenesisUTxOSigningKey_ed25519")] $ + tempDir <> "/utxo-keys/utxo" <> show i <> ".skey" + assertHasMappings [("type", "GenesisUTxOVerificationKey_ed25519")] $ + tempDir <> "/utxo-keys/utxo" <> show i <> ".vkey" H.assertEndsWithSingleNewline $ tempDir <> "/utxo-keys/utxo" <> show i <> ".skey" H.assertEndsWithSingleNewline $ tempDir <> "/utxo-keys/utxo" <> show i <> ".vkey" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/InitialTxIn.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/InitialTxIn.hs index ee2a6e73fb..9cc554d53a 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/InitialTxIn.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/InitialTxIn.hs @@ -12,12 +12,19 @@ import qualified Hedgehog.Extras.Test.Golden as H hprop_golden_shelleyGenesisInitialTxIn :: Property hprop_golden_shelleyGenesisInitialTxIn = propertyOnce $ do - verificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_verification_keys/genesis-utxo.vkey" - goldenUtxoHashFile <- H.note "test/cardano-cli-golden/files/golden/shelley/keys/genesis_utxo_hashes/utxo_hash" - utxoHash <- execCardanoCLI - [ "genesis","initial-txin" - , "--testnet-magic", "16" - , "--verification-key-file", verificationKeyFile - ] + verificationKeyFile <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/genesis_verification_keys/genesis-utxo.vkey" + goldenUtxoHashFile <- + H.note "test/cardano-cli-golden/files/golden/shelley/keys/genesis_utxo_hashes/utxo_hash" + utxoHash <- + execCardanoCLI + [ "genesis" + , "initial-txin" + , "--testnet-magic" + , "16" + , "--verification-key-file" + , verificationKeyFile + ] H.diffVsGoldenFile utxoHash goldenUtxoHashFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenDelegate.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenDelegate.hs index e0b6f8d386..aec076e758 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenDelegate.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenDelegate.hs @@ -19,27 +19,38 @@ hprop_golden_shelley_genesis_key_gen_delegate = propertyOnce . H.moduleWorkspace signingKeyFile <- noteTempFile tempDir "key-gen.skey" operationalCertificateIssueCounterFile <- noteTempFile tempDir "op-cert.counter" - void $ execCardanoCLI - [ "genesis","key-gen-delegate" - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - , "--operational-certificate-issue-counter", operationalCertificateIssueCounterFile + void $ + execCardanoCLI + [ "genesis" + , "key-gen-delegate" + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + , "--operational-certificate-issue-counter" + , operationalCertificateIssueCounterFile + ] + + assertHasMappings + [ ("type", "GenesisDelegateVerificationKey_ed25519") + , ("description", "Genesis delegate operator key") ] - - assertHasMappings [("type", "GenesisDelegateVerificationKey_ed25519"), - ("description", "Genesis delegate operator key")] - verificationKeyFile - assertHasKeys ["cborHex"] verificationKeyFile + verificationKeyFile + assertHasKeys ["cborHex"] verificationKeyFile H.assertEndsWithSingleNewline verificationKeyFile - assertHasMappings [("type", "GenesisDelegateSigningKey_ed25519"), - ("description", "Genesis delegate operator key")] - signingKeyFile - assertHasKeys ["cborHex"] signingKeyFile + assertHasMappings + [ ("type", "GenesisDelegateSigningKey_ed25519") + , ("description", "Genesis delegate operator key") + ] + signingKeyFile + assertHasKeys ["cborHex"] signingKeyFile H.assertEndsWithSingleNewline signingKeyFile - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter"), - ("description", "Next certificate issue number: 0")] - operationalCertificateIssueCounterFile - assertHasKeys ["cborHex"] operationalCertificateIssueCounterFile + assertHasMappings + [ ("type", "NodeOperationalCertificateIssueCounter") + , ("description", "Next certificate issue number: 0") + ] + operationalCertificateIssueCounterFile + assertHasKeys ["cborHex"] operationalCertificateIssueCounterFile H.assertEndsWithSingleNewline operationalCertificateIssueCounterFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenGenesis.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenGenesis.hs index bdc4b0035d..a441b0ff3d 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenGenesis.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenGenesis.hs @@ -18,11 +18,15 @@ hprop_golden_shelleyGenesisKeyGenGenesis = propertyOnce . H.moduleWorkspace "tmp verificationKeyFile <- noteTempFile tempDir "key-gen.vkey" signingKeyFile <- noteTempFile tempDir "key-gen.skey" - void $ execCardanoCLI - [ "genesis","key-gen-genesis" - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-genesis" + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + ] assertHasMappings [("type", "GenesisVerificationKey_ed25519")] verificationKeyFile assertHasMappings [("type", "GenesisSigningKey_ed25519")] signingKeyFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenUtxo.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenUtxo.hs index d3dff1416b..bb2896f1ef 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenUtxo.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyGenUtxo.hs @@ -18,11 +18,15 @@ hprop_golden_shelleyGenesisKeyGenUtxo = propertyOnce . H.moduleWorkspace "tmp" $ utxoVerificationKeyFile <- noteTempFile tempDir "utxo.vkey" utxoSigningKeyFile <- noteTempFile tempDir "utxo.skey" - void $ execCardanoCLI - [ "genesis","key-gen-utxo" - , "--verification-key-file", utxoVerificationKeyFile - , "--signing-key-file", utxoSigningKeyFile - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-utxo" + , "--verification-key-file" + , utxoVerificationKeyFile + , "--signing-key-file" + , utxoSigningKeyFile + ] assertHasMappings [("type", "GenesisUTxOVerificationKey_ed25519")] utxoVerificationKeyFile assertHasMappings [("type", "GenesisUTxOSigningKey_ed25519")] utxoSigningKeyFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyHash.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyHash.hs index 31cb5d12a9..b961e67906 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyHash.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Genesis/KeyHash.hs @@ -12,14 +12,20 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyGenesisKeyHash :: Property hprop_golden_shelleyGenesisKeyHash = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - referenceVerificationKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/verification_key" - goldenGenesisVerificationKeyHashFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/verification_key.key-hash" + referenceVerificationKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/verification_key" + goldenGenesisVerificationKeyHashFile <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/verification_key.key-hash" genesisVerificationKeyHashFile <- noteTempFile tempDir "key-hash.hex" - genesisVerificationKeyHash <- execCardanoCLI - [ "genesis","key-hash" - , "--verification-key-file", referenceVerificationKey - ] + genesisVerificationKeyHash <- + execCardanoCLI + [ "genesis" + , "key-hash" + , "--verification-key-file" + , referenceVerificationKey + ] H.writeFile genesisVerificationKeyHashFile genesisVerificationKeyHash diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Key/ConvertCardanoAddressKey.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Key/ConvertCardanoAddressKey.hs index 018cdc893c..5ad89d8269 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Key/ConvertCardanoAddressKey.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Key/ConvertCardanoAddressKey.hs @@ -47,7 +47,6 @@ exampleShelleySigningKey = hprop_golden_convertCardanoAddressByronSigningKey :: Property hprop_golden_convertCardanoAddressByronSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - -- `cardano-address` signing key filepath signingKeyFp <- noteTempFile tempDir "cardano-address-byron.skey" @@ -60,19 +59,24 @@ hprop_golden_convertCardanoAddressByronSigningKey = H.assertFilesExist [signingKeyFp] -- Convert the `cardano-address` signing key - void $ execCardanoCLI - [ "key","convert-cardano-address-key" - , "--byron-payment-key" - , "--signing-key-file", signingKeyFp - , "--out-file", convertedSigningKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-cardano-address-key" + , "--byron-payment-key" + , "--signing-key-file" + , signingKeyFp + , "--out-file" + , convertedSigningKeyFp + ] -- Check for existence of the converted signing key file H.assertFilesExist [convertedSigningKeyFp] -- Check that the contents of the converted signing key file match that of -- the golden file. - H.diffFileVsGoldenFile convertedSigningKeyFp + H.diffFileVsGoldenFile + convertedSigningKeyFp "test/cardano-cli-golden/files/golden/shelley/keys/converted_cardano-address_keys/byron_signing_key" -- | Test that converting a @cardano-address@ Icarus signing key yields the @@ -80,7 +84,6 @@ hprop_golden_convertCardanoAddressByronSigningKey = hprop_golden_convertCardanoAddressIcarusSigningKey :: Property hprop_golden_convertCardanoAddressIcarusSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - -- `cardano-address` signing key filepath signingKeyFp <- H.noteTempFile tempDir "cardano-address-icarus.skey" @@ -93,19 +96,24 @@ hprop_golden_convertCardanoAddressIcarusSigningKey = H.assertFilesExist [signingKeyFp] -- Convert the `cardano-address` signing key - void $ execCardanoCLI - [ "key","convert-cardano-address-key" - , "--icarus-payment-key" - , "--signing-key-file", signingKeyFp - , "--out-file", convertedSigningKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-cardano-address-key" + , "--icarus-payment-key" + , "--signing-key-file" + , signingKeyFp + , "--out-file" + , convertedSigningKeyFp + ] -- Check for existence of the converted signing key file H.assertFilesExist [convertedSigningKeyFp] -- Check that the contents of the converted signing key file match that of -- the golden file. - H.diffFileVsGoldenFile convertedSigningKeyFp + H.diffFileVsGoldenFile + convertedSigningKeyFp "test/cardano-cli-golden/files/golden/shelley/keys/converted_cardano-address_keys/icarus_signing_key" -- | Test that converting a @cardano-address@ Shelley payment signing key @@ -113,7 +121,6 @@ hprop_golden_convertCardanoAddressIcarusSigningKey = hprop_golden_convertCardanoAddressShelleyPaymentSigningKey :: Property hprop_golden_convertCardanoAddressShelleyPaymentSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - -- `cardano-address` signing key filepath signingKeyFp <- noteTempFile tempDir "cardano-address-shelley-payment.skey" @@ -127,19 +134,24 @@ hprop_golden_convertCardanoAddressShelleyPaymentSigningKey = H.assertFilesExist [signingKeyFp] -- Convert the `cardano-address` signing key - void $ execCardanoCLI - [ "key","convert-cardano-address-key" - , "--shelley-payment-key" - , "--signing-key-file", signingKeyFp - , "--out-file", convertedSigningKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-cardano-address-key" + , "--shelley-payment-key" + , "--signing-key-file" + , signingKeyFp + , "--out-file" + , convertedSigningKeyFp + ] -- Check for existence of the converted signing key file H.assertFilesExist [convertedSigningKeyFp] -- Check that the contents of the converted signing key file match that of -- the golden file. - H.diffFileVsGoldenFile convertedSigningKeyFp + H.diffFileVsGoldenFile + convertedSigningKeyFp "test/cardano-cli-golden/files/golden/shelley/keys/converted_cardano-address_keys/shelley_payment_signing_key" -- | Test that converting a @cardano-address@ Shelley stake signing key yields @@ -147,7 +159,6 @@ hprop_golden_convertCardanoAddressShelleyPaymentSigningKey = hprop_golden_convertCardanoAddressShelleyStakeSigningKey :: Property hprop_golden_convertCardanoAddressShelleyStakeSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - -- `cardano-address` signing key filepath signingKeyFp <- noteTempFile tempDir "cardano-address-shelley-stake.skey" @@ -161,19 +172,24 @@ hprop_golden_convertCardanoAddressShelleyStakeSigningKey = H.assertFilesExist [signingKeyFp] -- Convert the `cardano-address` signing key - void $ execCardanoCLI - [ "key","convert-cardano-address-key" - , "--shelley-stake-key" - , "--signing-key-file", signingKeyFp - , "--out-file", convertedSigningKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-cardano-address-key" + , "--shelley-stake-key" + , "--signing-key-file" + , signingKeyFp + , "--out-file" + , convertedSigningKeyFp + ] -- Check for existence of the converted signing key file H.assertFilesExist [convertedSigningKeyFp] -- Check that the contents of the converted signing key file match that of -- the golden file. - H.diffFileVsGoldenFile convertedSigningKeyFp + H.diffFileVsGoldenFile + convertedSigningKeyFp "test/cardano-cli-golden/files/golden/shelley/keys/converted_cardano-address_keys/shelley_stake_signing_key" -- | Test that converting a @cardano-address@ CC/DRep signing key @@ -184,26 +200,31 @@ hprop_golden_convert_cardano_address_cc_drep :: Property hprop_golden_convert_cardano_address_cc_drep = do let supplyValues = [ ("cc_cold.key", "--cc-cold-key", "Constitutional Committee Cold") - , ("cc_hot.key", "--cc-hot-key", "Constitutional Committee Hot") - , ("drep.key", "--drep-key", "Delegated Representative") + , ("cc_hot.key", "--cc-hot-key", "Constitutional Committee Hot") + , ("drep.key", "--drep-key", "Delegated Representative") ] propertyOnce $ forM_ supplyValues $ \(filename, flag, descPrefix) -> H.moduleWorkspace "tmp" $ \tempDir -> do - let outFile = tempDir "out.json" -- `cardano-address` signing key filepath - signingKeyFp <- H.noteInputFile $ "test/cardano-cli-golden/files/input/shelley/convert-cardano-address/" <> filename + signingKeyFp <- + H.noteInputFile $ "test/cardano-cli-golden/files/input/shelley/convert-cardano-address/" <> filename -- Convert the `cardano-address` signing key - H.noteShowM_ $ execCardanoCLI - [ "key", "convert-cardano-address-key" - , flag - , "--signing-key-file", signingKeyFp - , "--out-file", outFile - ] - - H.diffFileVsGoldenFile outFile + H.noteShowM_ $ + execCardanoCLI + [ "key" + , "convert-cardano-address-key" + , flag + , "--signing-key-file" + , signingKeyFp + , "--out-file" + , outFile + ] + + H.diffFileVsGoldenFile + outFile ("test/cardano-cli-golden/files/golden/shelley/keys/converted_cardano-address_keys/" <> filename) Aeson.assertHasMappings [("description", descPrefix <> " Extended Signing Key")] outFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Metadata/StakePoolMetadata.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Metadata/StakePoolMetadata.hs index ea90dbb66d..f521facdbe 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Metadata/StakePoolMetadata.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Metadata/StakePoolMetadata.hs @@ -17,7 +17,8 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_stakePoolMetadataHash :: Property hprop_golden_stakePoolMetadataHash = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - referenceStakePoolMetadata <- noteInputFile "test/cardano-cli-golden/files/input/shelley/metadata/stake_pool_metadata_hash" + referenceStakePoolMetadata <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/metadata/stake_pool_metadata_hash" stakePoolMetadataFile <- noteTempFile tempDir "stake-pool-metadata.json" outputStakePoolMetadataHashFp <- noteTempFile tempDir "stake-pool-metadata-hash.txt" @@ -26,17 +27,22 @@ hprop_golden_stakePoolMetadataHash = propertyOnce . H.moduleWorkspace "tmp" $ \t H.evalIO $ Text.writeFile stakePoolMetadataFile exampleStakePoolMetadata -- Hash the stake pool metadata - void $ execCardanoCLI - [ "stake-pool","metadata-hash" - , "--pool-metadata-file", stakePoolMetadataFile - , "--out-file", outputStakePoolMetadataHashFp - ] + void $ + execCardanoCLI + [ "stake-pool" + , "metadata-hash" + , "--pool-metadata-file" + , stakePoolMetadataFile + , "--out-file" + , outputStakePoolMetadataHashFp + ] -- Check that the stake pool metadata hash file content is correct. expectedStakePoolMetadataHash <- H.readFile referenceStakePoolMetadata actualStakePoolMetadataHash <- H.readFile outputStakePoolMetadataHashFp equivalence expectedStakePoolMetadataHash actualStakePoolMetadataHash - where - exampleStakePoolMetadata :: Text - exampleStakePoolMetadata = "{\"homepage\":\"https://iohk.io\",\"name\":\"Genesis Pool C\",\"ticker\":\"GPC\",\"description\":\"Lorem Ipsum Dolor Sit Amet.\"}" + where + exampleStakePoolMetadata :: Text + exampleStakePoolMetadata = + "{\"homepage\":\"https://iohk.io\",\"name\":\"Genesis Pool C\",\"ticker\":\"GPC\",\"description\":\"Lorem Ipsum Dolor Sit Amet.\"}" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/MultiSig/Address.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/MultiSig/Address.hs index dda7b39117..27a84a9197 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/MultiSig/Address.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/MultiSig/Address.hs @@ -15,13 +15,17 @@ hprop_golden_shelleyAllMultiSigAddressBuild :: Property hprop_golden_shelleyAllMultiSigAddressBuild = propertyOnce . H.moduleWorkspace "tmp" $ \_ -> do allMultiSigFp <- noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/scripts/all" - allMultiSigAddress <- execCardanoCLI - [ "address", "build" - , "--payment-script-file", allMultiSigFp - , "--mainnet" - ] - - goldenAllMultiSigAddrFp <- noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/addresses/all" + allMultiSigAddress <- + execCardanoCLI + [ "address" + , "build" + , "--payment-script-file" + , allMultiSigFp + , "--mainnet" + ] + + goldenAllMultiSigAddrFp <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/addresses/all" goldenAllMs <- H.readFile goldenAllMultiSigAddrFp @@ -31,13 +35,17 @@ hprop_golden_shelleyAnyMultiSigAddressBuild :: Property hprop_golden_shelleyAnyMultiSigAddressBuild = propertyOnce . H.moduleWorkspace "tmp" $ \_ -> do anyMultiSigFp <- noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/scripts/any" - anyMultiSigAddress <- execCardanoCLI - [ "address", "build" - , "--payment-script-file", anyMultiSigFp - , "--mainnet" - ] + anyMultiSigAddress <- + execCardanoCLI + [ "address" + , "build" + , "--payment-script-file" + , anyMultiSigFp + , "--mainnet" + ] - goldenAnyMultiSigAddrFp <- noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/addresses/any" + goldenAnyMultiSigAddrFp <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/addresses/any" goldenAnyMs <- H.readFile goldenAnyMultiSigAddrFp @@ -45,14 +53,19 @@ hprop_golden_shelleyAnyMultiSigAddressBuild = propertyOnce . H.moduleWorkspace " hprop_golden_shelleyAtLeastMultiSigAddressBuild :: Property hprop_golden_shelleyAtLeastMultiSigAddressBuild = propertyOnce . H.moduleWorkspace "tmp" $ \_ -> do - atLeastMultiSigFp <- noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/scripts/atleast" - - atLeastMultiSigAddress <- execCardanoCLI - [ "address", "build" - , "--payment-script-file", atLeastMultiSigFp - , "--mainnet" - ] - - goldenAtLeastMultiSigAddrFp <- H.note "test/cardano-cli-golden/files/golden/shelley/multisig/addresses/atleast" + atLeastMultiSigFp <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/multisig/scripts/atleast" + + atLeastMultiSigAddress <- + execCardanoCLI + [ "address" + , "build" + , "--payment-script-file" + , atLeastMultiSigFp + , "--mainnet" + ] + + goldenAtLeastMultiSigAddrFp <- + H.note "test/cardano-cli-golden/files/golden/shelley/multisig/addresses/atleast" H.diffVsGoldenFile atLeastMultiSigAddress goldenAtLeastMultiSigAddrFp diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/IssueOpCert.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/IssueOpCert.hs index f5839cabc5..bf1398c8a3 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/IssueOpCert.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/IssueOpCert.hs @@ -15,9 +15,13 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyNodeIssueOpCert :: Property hprop_golden_shelleyNodeIssueOpCert = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - hotKesVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/verification_key" - coldSigningKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/signing_key" - originalOperationalCertificateIssueCounterFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/operational_certificate_counter" + hotKesVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/verification_key" + coldSigningKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/signing_key" + originalOperationalCertificateIssueCounterFile <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/operational_certificate_counter" operationalCertificateIssueCounterFile <- noteTempFile tempDir "delegate-op-cert.counter" operationalCertFile <- noteTempFile tempDir "operational.cert" @@ -29,17 +33,28 @@ hprop_golden_shelleyNodeIssueOpCert = propertyOnce . H.moduleWorkspace "tmp" $ \ -- cabal run cardano-cli:cardano-cli -- shelley node key-gen-KES \ -- --verification-key-file cardano-cli/test/cli/node-issue-op-cert/data/node-kes.vkey \ -- --signing-key-file /dev/null - void $ execCardanoCLI - [ "node","issue-op-cert" - , "--hot-kes-verification-key-file", hotKesVerificationKeyFile - , "--cold-signing-key-file", coldSigningKeyFile - , "--operational-certificate-issue-counter", operationalCertificateIssueCounterFile - , "--kes-period", "0" - , "--out-file", operationalCertFile - ] + void $ + execCardanoCLI + [ "node" + , "issue-op-cert" + , "--hot-kes-verification-key-file" + , hotKesVerificationKeyFile + , "--cold-signing-key-file" + , coldSigningKeyFile + , "--operational-certificate-issue-counter" + , operationalCertificateIssueCounterFile + , "--kes-period" + , "0" + , "--out-file" + , operationalCertFile + ] assertHasMappings [("type", "NodeOperationalCertificate")] operationalCertFile - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter"), ("description", "Next certificate issue number: 1")] operationalCertificateIssueCounterFile + assertHasMappings + [ ("type", "NodeOperationalCertificateIssueCounter") + , ("description", "Next certificate issue number: 1") + ] + operationalCertificateIssueCounterFile H.assertEndsWithSingleNewline operationalCertFile H.assertEndsWithSingleNewline operationalCertificateIssueCounterFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGen.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGen.hs index 693f18a868..81d4116e9d 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGen.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGen.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Golden.Shelley.Node.KeyGen - where +module Test.Golden.Shelley.Node.KeyGen where import Control.Monad (void) @@ -20,16 +19,31 @@ hprop_golden_shelleyNodeKeyGen = propertyOnce . H.moduleWorkspace "tmp" $ \tempD signingKeyFile <- noteTempFile tempDir "key-gen.skey" opCertCounterFile <- noteTempFile tempDir "op-cert.counter" - void $ execCardanoCLI - [ "node","key-gen" - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - , "--operational-certificate-issue-counter", opCertCounterFile + void $ + execCardanoCLI + [ "node" + , "key-gen" + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + , "--operational-certificate-issue-counter" + , opCertCounterFile + ] + + assertHasMappings + [ ("type", "StakePoolVerificationKey_ed25519") + , ("description", "Stake Pool Operator Verification Key") ] - - assertHasMappings [("type", "StakePoolVerificationKey_ed25519"), ("description", "Stake Pool Operator Verification Key")] verificationKeyFile - assertHasMappings [("type", "StakePoolSigningKey_ed25519"), ("description", "Stake Pool Operator Signing Key")] signingKeyFile - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter"), ("description", "Next certificate issue number: 0")] opCertCounterFile + verificationKeyFile + assertHasMappings + [("type", "StakePoolSigningKey_ed25519"), ("description", "Stake Pool Operator Signing Key")] + signingKeyFile + assertHasMappings + [ ("type", "NodeOperationalCertificateIssueCounter") + , ("description", "Next certificate issue number: 0") + ] + opCertCounterFile H.assertEndsWithSingleNewline verificationKeyFile H.assertEndsWithSingleNewline signingKeyFile @@ -41,16 +55,31 @@ hprop_golden_shelleyNodeKeyGen_te = propertyOnce . H.moduleWorkspace "tmp" $ \te signingKeyFile <- noteTempFile tempDir "key-gen.skey" opCertCounterFile <- noteTempFile tempDir "op-cert.counter" - void $ execCardanoCLI - [ "node","key-gen" - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - , "--operational-certificate-issue-counter", opCertCounterFile + void $ + execCardanoCLI + [ "node" + , "key-gen" + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + , "--operational-certificate-issue-counter" + , opCertCounterFile + ] + + assertHasMappings + [ ("type", "StakePoolVerificationKey_ed25519") + , ("description", "Stake Pool Operator Verification Key") ] - - assertHasMappings [("type", "StakePoolVerificationKey_ed25519"), ("description", "Stake Pool Operator Verification Key")] verificationKeyFile - assertHasMappings [("type", "StakePoolSigningKey_ed25519"), ("description", "Stake Pool Operator Signing Key")] signingKeyFile - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter"), ("description", "Next certificate issue number: 0")] opCertCounterFile + verificationKeyFile + assertHasMappings + [("type", "StakePoolSigningKey_ed25519"), ("description", "Stake Pool Operator Signing Key")] + signingKeyFile + assertHasMappings + [ ("type", "NodeOperationalCertificateIssueCounter") + , ("description", "Next certificate issue number: 0") + ] + opCertCounterFile H.assertEndsWithSingleNewline verificationKeyFile H.assertEndsWithSingleNewline signingKeyFile @@ -62,16 +91,26 @@ hprop_golden_shelleyNodeKeyGen_bech32 = propertyOnce . H.moduleWorkspace "tmp" $ signingKeyFile <- noteTempFile tempDir "key-gen.skey" opCertCounterFile <- noteTempFile tempDir "op-cert.counter" - void $ execCardanoCLI - [ "node","key-gen" - , "--key-output-format", "bech32" - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - , "--operational-certificate-issue-counter", opCertCounterFile - ] + void $ + execCardanoCLI + [ "node" + , "key-gen" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + , "--operational-certificate-issue-counter" + , opCertCounterFile + ] H.assertFileOccurences 1 "pool_vk" verificationKeyFile H.assertFileOccurences 1 "pool_sk" signingKeyFile - assertHasMappings [("type", "NodeOperationalCertificateIssueCounter"), ("description", "Next certificate issue number: 0")] opCertCounterFile + assertHasMappings + [ ("type", "NodeOperationalCertificateIssueCounter") + , ("description", "Next certificate issue number: 0") + ] + opCertCounterFile H.assertEndsWithSingleNewline opCertCounterFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenKes.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenKes.hs index cbe2a6a333..f3bab09955 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenKes.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenKes.hs @@ -18,14 +18,22 @@ hprop_golden_shelleyNodeKeyGenKes = propertyOnce . H.moduleWorkspace "tmp" $ \te verificationKey <- noteTempFile tempDir "kes.vkey" signingKey <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--verification-key-file", verificationKey - , "--signing-key-file", signingKey - ] - - assertHasMappings [("type", "KesVerificationKey_ed25519_kes_2^6"), ("description", "KES Verification Key")] verificationKey - assertHasMappings [("type", "KesSigningKey_ed25519_kes_2^6"), ("description", "KES Signing Key")] signingKey + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--verification-key-file" + , verificationKey + , "--signing-key-file" + , signingKey + ] + + assertHasMappings + [("type", "KesVerificationKey_ed25519_kes_2^6"), ("description", "KES Verification Key")] + verificationKey + assertHasMappings + [("type", "KesSigningKey_ed25519_kes_2^6"), ("description", "KES Signing Key")] + signingKey H.assertEndsWithSingleNewline verificationKey H.assertEndsWithSingleNewline signingKey @@ -35,15 +43,24 @@ hprop_golden_shelleyNodeKeyGenKes_te = propertyOnce . H.moduleWorkspace "tmp" $ verificationKey <- noteTempFile tempDir "kes.vkey" signingKey <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--key-output-format", "text-envelope" - , "--verification-key-file", verificationKey - , "--signing-key-file", signingKey - ] - - assertHasMappings [("type", "KesVerificationKey_ed25519_kes_2^6"), ("description", "KES Verification Key")] verificationKey - assertHasMappings [("type", "KesSigningKey_ed25519_kes_2^6"), ("description", "KES Signing Key")] signingKey + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--key-output-format" + , "text-envelope" + , "--verification-key-file" + , verificationKey + , "--signing-key-file" + , signingKey + ] + + assertHasMappings + [("type", "KesVerificationKey_ed25519_kes_2^6"), ("description", "KES Verification Key")] + verificationKey + assertHasMappings + [("type", "KesSigningKey_ed25519_kes_2^6"), ("description", "KES Signing Key")] + signingKey H.assertEndsWithSingleNewline verificationKey H.assertEndsWithSingleNewline signingKey @@ -53,12 +70,17 @@ hprop_golden_shelleyNodeKeyGenKes_bech32 = propertyOnce . H.moduleWorkspace "tmp verificationKey <- noteTempFile tempDir "kes.vkey" signingKey <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--key-output-format", "bech32" - , "--verification-key-file", verificationKey - , "--signing-key-file", signingKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verificationKey + , "--signing-key-file" + , signingKey + ] H.assertFileOccurences 1 "kes_vk" verificationKey H.assertFileOccurences 1 "kes_sk" signingKey diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenVrf.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenVrf.hs index 944ed4b339..4807de24c4 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenVrf.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Node/KeyGenVrf.hs @@ -18,14 +18,22 @@ hprop_golden_shelleyNodeKeyGenVrf = propertyOnce . H.moduleWorkspace "tmp" $ \te verificationKey <- noteTempFile tempDir "kes.vkey" signingKey <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--verification-key-file", verificationKey - , "--signing-key-file", signingKey - ] - - assertHasMappings [("type", "VrfVerificationKey_PraosVRF"), ("description", "VRF Verification Key")] verificationKey - assertHasMappings [("type", "VrfSigningKey_PraosVRF"), ("description", "VRF Signing Key")] signingKey + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--verification-key-file" + , verificationKey + , "--signing-key-file" + , signingKey + ] + + assertHasMappings + [("type", "VrfVerificationKey_PraosVRF"), ("description", "VRF Verification Key")] + verificationKey + assertHasMappings + [("type", "VrfSigningKey_PraosVRF"), ("description", "VRF Signing Key")] + signingKey H.assertEndsWithSingleNewline verificationKey H.assertEndsWithSingleNewline signingKey @@ -35,15 +43,24 @@ hprop_golden_shelleyNodeKeyGenVrf_te = propertyOnce . H.moduleWorkspace "tmp" $ verificationKey <- noteTempFile tempDir "kes.vkey" signingKey <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--key-output-format", "text-envelope" - , "--verification-key-file", verificationKey - , "--signing-key-file", signingKey - ] - - assertHasMappings [("type", "VrfVerificationKey_PraosVRF"), ("description", "VRF Verification Key")] verificationKey - assertHasMappings [("type", "VrfSigningKey_PraosVRF"), ("description", "VRF Signing Key")] signingKey + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--key-output-format" + , "text-envelope" + , "--verification-key-file" + , verificationKey + , "--signing-key-file" + , signingKey + ] + + assertHasMappings + [("type", "VrfVerificationKey_PraosVRF"), ("description", "VRF Verification Key")] + verificationKey + assertHasMappings + [("type", "VrfSigningKey_PraosVRF"), ("description", "VRF Signing Key")] + signingKey H.assertEndsWithSingleNewline verificationKey H.assertEndsWithSingleNewline signingKey @@ -53,12 +70,17 @@ hprop_golden_shelleyNodeKeyGenVrf_bech32 = propertyOnce . H.moduleWorkspace "tmp verificationKey <- noteTempFile tempDir "kes.vkey" signingKey <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--key-output-format", "bech32" - , "--verification-key-file", verificationKey - , "--signing-key-file", signingKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verificationKey + , "--signing-key-file" + , signingKey + ] H.assertFileOccurences 1 "vrf_vk" verificationKey H.assertFileOccurences 1 "vrf_sk" signingKey diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/Build.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/Build.hs index 6babfa43d7..2afb42b5d3 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/Build.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/Build.hs @@ -12,14 +12,19 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyStakeAddressBuild :: Property hprop_golden_shelleyStakeAddressBuild = propertyOnce . H.moduleWorkspace "tmp" $ \_ -> do - verificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" - goldenRewardAddressFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/reward_address" - - rewardAddress <- execCardanoCLI - [ "stake-address","build" - , "--mainnet" - , "--staking-verification-key-file", verificationKeyFile - ] + verificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + goldenRewardAddressFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/reward_address" + + rewardAddress <- + execCardanoCLI + [ "stake-address" + , "build" + , "--mainnet" + , "--staking-verification-key-file" + , verificationKeyFile + ] goldenRewardsAddress <- H.readFile goldenRewardAddressFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs index 8afa30d7de..82b6af131e 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs @@ -9,8 +9,8 @@ import Test.Cardano.CLI.Util import Hedgehog (Property) import qualified Hedgehog.Extras.Test.Base as H -import qualified Hedgehog.Extras.Test.Process as H import qualified Hedgehog.Extras.Test.Golden as H +import qualified Hedgehog.Extras.Test.Process as H {- HLINT ignore "Use camelCase" -} @@ -18,25 +18,37 @@ hprop_golden_shelley_stake_address_deregistration_certificate :: Property hprop_golden_shelley_stake_address_deregistration_certificate = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do base <- H.getProjectBase - verificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + verificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" deregistrationCertFile <- noteTempFile tempDir "deregistrationCertFile" scriptDeregistrationCertFile <- noteTempFile tempDir "scripDeregistrationCertFile" - exampleScript <- noteInputFile $ base "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus" - - void $ execCardanoCLI - [ "babbage", "stake-address","deregistration-certificate" - , "--staking-verification-key-file", verificationKeyFile - , "--out-file", deregistrationCertFile - ] + exampleScript <- + noteInputFile $ base "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus" + + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "deregistration-certificate" + , "--staking-verification-key-file" + , verificationKeyFile + , "--out-file" + , deregistrationCertFile + ] goldenFile1 <- H.note "test/cardano-cli-golden/files/golden/shelley/dereg-cert-1.json" H.diffFileVsGoldenFile deregistrationCertFile goldenFile1 - void $ execCardanoCLI - [ "babbage", "stake-address","deregistration-certificate" - , "--stake-script-file", exampleScript - , "--out-file", scriptDeregistrationCertFile - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "deregistration-certificate" + , "--stake-script-file" + , exampleScript + , "--out-file" + , scriptDeregistrationCertFile + ] goldenFile2 <- H.note "test/cardano-cli-golden/files/golden/shelley/dereg-cert-2.json" H.diffFileVsGoldenFile scriptDeregistrationCertFile goldenFile2 diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyGen.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyGen.hs index 36cafa875d..67c03cd8db 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyGen.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyGen.hs @@ -17,11 +17,15 @@ hprop_golden_shelleyStakeAddressKeyGen = propertyOnce . H.moduleWorkspace "tmp" verificationKeyFile <- noteTempFile tempDir "kes.vkey" signingKeyFile <- noteTempFile tempDir "kes.skey" - void $ execCardanoCLI - [ "stake-address","key-gen" - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + ] H.assertFileOccurences 1 "StakeVerificationKeyShelley_ed25519" verificationKeyFile H.assertFileOccurences 1 "StakeSigningKeyShelley_ed25519" signingKeyFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyHash.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyHash.hs index 214168e071..ea2ce1eecf 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyHash.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/KeyHash.hs @@ -12,12 +12,18 @@ import qualified Hedgehog.Extras.Test.Golden as H hprop_golden_shelleyStakeAddressKeyHash :: Property hprop_golden_shelleyStakeAddressKeyHash = propertyOnce . H.moduleWorkspace "tmp" $ \_ -> do - verificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" - goldenVerificationKeyHashFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key.key-hash" + verificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + goldenVerificationKeyHashFile <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key.key-hash" - verificationKeyHash <- execCardanoCLI - [ "stake-address","key-hash" - , "--stake-verification-key-file", verificationKeyFile - ] + verificationKeyHash <- + execCardanoCLI + [ "stake-address" + , "key-hash" + , "--stake-verification-key-file" + , verificationKeyFile + ] H.diffVsGoldenFile verificationKeyHash goldenVerificationKeyHashFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/RegistrationCertificate.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/RegistrationCertificate.hs index 197ec3af8b..d0a36ac9f1 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/RegistrationCertificate.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/RegistrationCertificate.hs @@ -18,64 +18,100 @@ hprop_golden_shelley_stake_address_registration_certificate :: Property hprop_golden_shelley_stake_address_registration_certificate = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do base <- H.getProjectBase - keyGenStakingVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + keyGenStakingVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" registrationCertFile <- noteTempFile tempDir "registration.cert" scriptRegistrationCertFile <- noteTempFile tempDir "script-registration.cert" - exampleScript <- noteInputFile $ base "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus" - - void $ execCardanoCLI - [ "babbage", "stake-address", "registration-certificate" - , "--staking-verification-key-file", keyGenStakingVerificationKeyFile - , "--out-file", registrationCertFile - ] - - goldenFile1 <- H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/reg-certificate-1.json" + exampleScript <- + noteInputFile $ base "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus" + + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "registration-certificate" + , "--staking-verification-key-file" + , keyGenStakingVerificationKeyFile + , "--out-file" + , registrationCertFile + ] + + goldenFile1 <- + H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/reg-certificate-1.json" H.diffFileVsGoldenFile registrationCertFile goldenFile1 - void $ execCardanoCLI - [ "babbage", "stake-address", "registration-certificate" - , "--stake-script-file", exampleScript - , "--out-file", scriptRegistrationCertFile - ] - - goldenFile2 <- H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/script-reg-certificate.json" + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "registration-certificate" + , "--stake-script-file" + , exampleScript + , "--out-file" + , scriptRegistrationCertFile + ] + + goldenFile2 <- + H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/script-reg-certificate.json" H.diffFileVsGoldenFile scriptRegistrationCertFile goldenFile2 hprop_golden_shelley_stake_address_registration_certificate_with_build_raw :: Property hprop_golden_shelley_stake_address_registration_certificate_with_build_raw = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - keyGenStakingVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + keyGenStakingVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" registrationCertFile <- noteTempFile tempDir "registration.cert" txRawFile <- noteTempFile tempDir "tx.raw" - void $ execCardanoCLI - [ "conway", "stake-address", "registration-certificate" - , "--staking-verification-key-file", keyGenStakingVerificationKeyFile - , "--key-reg-deposit-amt", "2000000" - , "--out-file", registrationCertFile - ] - - goldenFile1 <- H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/reg-certificate-2.json" + void $ + execCardanoCLI + [ "conway" + , "stake-address" + , "registration-certificate" + , "--staking-verification-key-file" + , keyGenStakingVerificationKeyFile + , "--key-reg-deposit-amt" + , "2000000" + , "--out-file" + , registrationCertFile + ] + + goldenFile1 <- + H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/reg-certificate-2.json" H.diffFileVsGoldenFile registrationCertFile goldenFile1 - void $ execCardanoCLI - [ "conway", "transaction", "build-raw" - , "--tx-in", "bdfa7d91a29ffe071c028c0143c5d278c0a7ddb829c1e95f54a1676915fd82c2#0" - , "--fee", "1" - , "--certificate-file", registrationCertFile - , "--out-file", txRawFile - ] - - goldenFile2 <- H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/build-raw-out.json" + void $ + execCardanoCLI + [ "conway" + , "transaction" + , "build-raw" + , "--tx-in" + , "bdfa7d91a29ffe071c028c0143c5d278c0a7ddb829c1e95f54a1676915fd82c2#0" + , "--fee" + , "1" + , "--certificate-file" + , registrationCertFile + , "--out-file" + , txRawFile + ] + + goldenFile2 <- + H.note "test/cardano-cli-golden/files/golden/shelley/stake-address/build-raw-out.json" H.diffFileVsGoldenFile txRawFile goldenFile2 hprop_golden_shelley_stake_address_registration_certificate_missing_reg_deposit :: Property hprop_golden_shelley_stake_address_registration_certificate_missing_reg_deposit = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - keyGenStakingVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + keyGenStakingVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" registrationCertFile <- noteTempFile tempDir "registration.cert" - void $ execDetailCardanoCLI - [ "conway", "stake-address", "registration-certificate" - , "--staking-verification-key-file", keyGenStakingVerificationKeyFile - -- , "--key-reg-deposit-amt", "2000000" This argument being mandatory in conway, the call should fail - , "--out-file", registrationCertFile - ] + void $ + execDetailCardanoCLI + [ "conway" + , "stake-address" + , "registration-certificate" + , "--staking-verification-key-file" + , keyGenStakingVerificationKeyFile + , -- , "--key-reg-deposit-amt", "2000000" This argument being mandatory in conway, the call should fail + "--out-file" + , registrationCertFile + ] diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakePool/RegistrationCertificate.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakePool/RegistrationCertificate.hs index 9080e561b6..2ead8ac499 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakePool/RegistrationCertificate.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/StakePool/RegistrationCertificate.hs @@ -14,23 +14,38 @@ import qualified Hedgehog.Extras.Test.Golden as H hprop_golden_shelley_stake_pool_registration_certificate :: Property hprop_golden_shelley_stake_pool_registration_certificate = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - operatorVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/operator.vkey" - vrfVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/vrf.vkey" - ownerVerificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/owner.vkey" + operatorVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/operator.vkey" + vrfVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/vrf.vkey" + ownerVerificationKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/owner.vkey" registrationCertFile <- noteTempFile tempDir "registration.cert" - void $ execCardanoCLI - [ "babbage", "stake-pool", "registration-certificate" - , "--testnet-magic", "42" - , "--pool-pledge", "0" - , "--pool-cost", "0" - , "--pool-margin", "0" - , "--cold-verification-key-file", operatorVerificationKeyFile - , "--vrf-verification-key-file", vrfVerificationKeyFile - , "--reward-account-verification-key-file", ownerVerificationKeyFile - , "--pool-owner-stake-verification-key-file", ownerVerificationKeyFile - , "--out-file", registrationCertFile - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-pool" + , "registration-certificate" + , "--testnet-magic" + , "42" + , "--pool-pledge" + , "0" + , "--pool-cost" + , "0" + , "--pool-margin" + , "0" + , "--cold-verification-key-file" + , operatorVerificationKeyFile + , "--vrf-verification-key-file" + , vrfVerificationKeyFile + , "--reward-account-verification-key-file" + , ownerVerificationKeyFile + , "--pool-owner-stake-verification-key-file" + , ownerVerificationKeyFile + , "--out-file" + , registrationCertFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/reg-certificate.json" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/GenesisKeyDelegation.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/GenesisKeyDelegation.hs index bf64985644..daf095f1d0 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/GenesisKeyDelegation.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/GenesisKeyDelegation.hs @@ -42,29 +42,40 @@ hprop_golden_shelleyGenesisKeyDelegationCertificate = genesisDelegOpCertCounterFilePath <- noteTempFile tempDir "genesis-delegate-opcert-counter" - -- Generate genesis key pair - void $ execCardanoCLI - [ "genesis","key-gen-genesis" - , "--verification-key-file", genesisVerKeyFilePath - , "--signing-key-file", genesisSignKeyFilePath - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-genesis" + , "--verification-key-file" + , genesisVerKeyFilePath + , "--signing-key-file" + , genesisSignKeyFilePath + ] -- Generate genesis delegate key pair - void $ execCardanoCLI - [ "genesis","key-gen-delegate" - , "--verification-key-file", genesisDelegVerKeyFilePath - , "--signing-key-file", genesisDelegSignKeyFilePath - , "--operational-certificate-issue-counter-file" - , genesisDelegOpCertCounterFilePath - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-delegate" + , "--verification-key-file" + , genesisDelegVerKeyFilePath + , "--signing-key-file" + , genesisDelegSignKeyFilePath + , "--operational-certificate-issue-counter-file" + , genesisDelegOpCertCounterFilePath + ] -- Generate VRF key pair - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--verification-key-file", vrfVerKeyFilePath - , "--signing-key-file", vrfSignKeyFilePath - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--verification-key-file" + , vrfVerKeyFilePath + , "--signing-key-file" + , vrfSignKeyFilePath + ] H.assertFilesExist [ genesisVerKeyFilePath @@ -73,14 +84,21 @@ hprop_golden_shelleyGenesisKeyDelegationCertificate = ] -- Create genesis key delegation certificate - void $ execCardanoCLI - [ "legacy", "governance", "create-genesis-key-delegation-certificate" - , "--babbage-era" - , "--genesis-verification-key-file", genesisVerKeyFilePath - , "--genesis-delegate-verification-key-file", genesisDelegVerKeyFilePath - , "--vrf-verification-key-file", vrfVerKeyFilePath - , "--out-file", genesisKeyDelegCertFilePath - ] + void $ + execCardanoCLI + [ "legacy" + , "governance" + , "create-genesis-key-delegation-certificate" + , "--babbage-era" + , "--genesis-verification-key-file" + , genesisVerKeyFilePath + , "--genesis-delegate-verification-key-file" + , genesisDelegVerKeyFilePath + , "--vrf-verification-key-file" + , vrfVerKeyFilePath + , "--out-file" + , genesisKeyDelegCertFilePath + ] H.assertFilesExist [genesisKeyDelegCertFilePath] diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/MIR.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/MIR.hs index 37a05d37b6..934966dbe6 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/MIR.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/MIR.hs @@ -22,7 +22,8 @@ hprop_golden_shelleyMIRCertificate = propertyOnce . H.moduleWorkspace "tmp" $ \t let era = BabbageEra -- Reference keys - referenceMIRCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/mir_certificate" + referenceMIRCertificate <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/mir_certificate" -- Key filepaths verKey <- noteTempFile tempDir "stake-verification-key-file" @@ -30,23 +31,33 @@ hprop_golden_shelleyMIRCertificate = propertyOnce . H.moduleWorkspace "tmp" $ \t mirCertificate <- noteTempFile tempDir "mir-certificate-file" -- Generate stake key pair - void $ execCardanoCLI - [ "stake-address","key-gen" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] H.assertFilesExist [verKey, signKey] let testAddr = "stake1u9j6axhcpd0exvrthn5dqzqt54g85akqvkn4uqmccm70qsc5hpv9w" -- Create MIR certificate - void $ execCardanoCLI - [ "babbage", "governance", "create-mir-certificate" - , "--reserves" --TODO: Should also do "--reserves" - , "--stake-address", testAddr - , "--reward", "1000" - , "--out-file", mirCertificate - ] + void $ + execCardanoCLI + [ "babbage" + , "governance" + , "create-mir-certificate" + , "--reserves" -- TODO: Should also do "--reserves" + , "--stake-address" + , testAddr + , "--reward" + , "1000" + , "--out-file" + , mirCertificate + ] H.assertFilesExist [mirCertificate] diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/Operational.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/Operational.hs index 889de72520..60c9775742 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/Operational.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/Operational.hs @@ -21,7 +21,8 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyOperationalCertificate :: Property hprop_golden_shelleyOperationalCertificate = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceOperationalCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/operational_certificate" + referenceOperationalCertificate <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/operational_certificate" -- Key filepaths kesVerKey <- noteTempFile tempDir "KES-verification-key-file" @@ -32,33 +33,49 @@ hprop_golden_shelleyOperationalCertificate = propertyOnce . H.moduleWorkspace "t operationalCert <- noteTempFile tempDir "operational-certificate-file" -- Create KES key pair - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--verification-key-file", kesVerKey - , "--signing-key-file", kesSignKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--verification-key-file" + , kesVerKey + , "--signing-key-file" + , kesSignKey + ] H.assertFilesExist [kesSignKey, kesVerKey] -- Create cold key pair - void $ execCardanoCLI - [ "node","key-gen" - , "--cold-verification-key-file", coldVerKey - , "--cold-signing-key-file", coldSignKey - , "--operational-certificate-issue-counter", operationalCertCounter - ] + void $ + execCardanoCLI + [ "node" + , "key-gen" + , "--cold-verification-key-file" + , coldVerKey + , "--cold-signing-key-file" + , coldSignKey + , "--operational-certificate-issue-counter" + , operationalCertCounter + ] H.assertFilesExist [coldVerKey, coldSignKey, operationalCertCounter] -- Create operational certificate - void $ execCardanoCLI - [ "node","issue-op-cert" - , "--kes-verification-key-file", kesVerKey - , "--cold-signing-key-file", coldSignKey - , "--operational-certificate-issue-counter", operationalCertCounter - , "--kes-period", "1000" - , "--out-file", operationalCert - ] + void $ + execCardanoCLI + [ "node" + , "issue-op-cert" + , "--kes-verification-key-file" + , kesVerKey + , "--cold-signing-key-file" + , coldSignKey + , "--operational-certificate-issue-counter" + , operationalCertCounter + , "--kes-period" + , "1000" + , "--out-file" + , operationalCert + ] let operationalCertificateType = textEnvelopeType AsOperationalCertificate diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakeAddress.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakeAddress.hs index 0d728bae01..41ca8ceac5 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakeAddress.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakeAddress.hs @@ -22,9 +22,15 @@ hprop_golden_shelleyStakeAddressCertificates = propertyOnce . H.moduleWorkspace let era = BabbageEra -- Reference files - referenceRegistrationCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_registration_certificate" - referenceDeregistrationCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_deregistration_certificate" - referenceDelegationCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_delegation_certificate" + referenceRegistrationCertificate <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_registration_certificate" + referenceDeregistrationCertificate <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_deregistration_certificate" + referenceDelegationCertificate <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_delegation_certificate" operatorVkey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/node-pool/operator.vkey" -- Key filepaths @@ -34,46 +40,74 @@ hprop_golden_shelleyStakeAddressCertificates = propertyOnce . H.moduleWorkspace registrationCertificate <- noteTempFile tempDir "stake-address-registration-certificate" -- Generate stake verification key - void $ execCardanoCLI - [ "stake-address", "key-gen" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] H.assertFilesExist [verKey, signKey] -- Create stake address registration certificate - void $ execCardanoCLI - [ "babbage", "stake-address", "registration-certificate" - , "--stake-verification-key-file", verKey - , "--out-file", registrationCertificate - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "registration-certificate" + , "--stake-verification-key-file" + , verKey + , "--out-file" + , registrationCertificate + ] let registrationCertificateType = textEnvelopeTypeInEra era AsCertificate -- Check the newly created files have not deviated from the -- golden files - checkTextEnvelopeFormat registrationCertificateType referenceRegistrationCertificate registrationCertificate + checkTextEnvelopeFormat + registrationCertificateType + referenceRegistrationCertificate + registrationCertificate -- Create stake address deregistration certificate - void $ execCardanoCLI - [ "babbage", "stake-address", "deregistration-certificate" - , "--stake-verification-key-file", verKey - , "--out-file", deregistrationCertificate - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "deregistration-certificate" + , "--stake-verification-key-file" + , verKey + , "--out-file" + , deregistrationCertificate + ] -- Check the newly created files have not deviated from the -- golden files - checkTextEnvelopeFormat registrationCertificateType referenceDeregistrationCertificate deregistrationCertificate + checkTextEnvelopeFormat + registrationCertificateType + referenceDeregistrationCertificate + deregistrationCertificate -- Create stake address delegation certificate - void $ execCardanoCLI - [ "stake-address", "delegation-certificate" - , "--stake-verification-key-file", verKey - , "--cold-verification-key-file", operatorVkey - , "--out-file", deregistrationCertificate - ] + void $ + execCardanoCLI + [ "stake-address" + , "delegation-certificate" + , "--stake-verification-key-file" + , verKey + , "--cold-verification-key-file" + , operatorVkey + , "--out-file" + , deregistrationCertificate + ] -- Check the newly created files have not deviated from the -- golden files - checkTextEnvelopeFormat registrationCertificateType referenceDelegationCertificate deregistrationCertificate + checkTextEnvelopeFormat + registrationCertificateType + referenceDelegationCertificate + deregistrationCertificate diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakePool.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakePool.hs index 0e2e6b0945..0ed34287a0 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakePool.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Certificates/StakePool.hs @@ -26,8 +26,12 @@ hprop_golden_shelleyStakePoolCertificates = propertyOnce . H.moduleWorkspace "tm let era = BabbageEra -- TODO generate for all eras -- Reference files - referenceRegistrationCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/stake_pool_registration_certificate" - referenceDeregistrationCertificate <- noteInputFile "test/cardano-cli-golden/files/input/shelley/certificates/stake_pool_deregistration_certificate" + referenceRegistrationCertificate <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/certificates/stake_pool_registration_certificate" + referenceDeregistrationCertificate <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/certificates/stake_pool_deregistration_certificate" -- Key filepaths coldVerKey <- noteTempFile tempDir "cold-verification-key-file" @@ -41,47 +45,70 @@ hprop_golden_shelleyStakePoolCertificates = propertyOnce . H.moduleWorkspace "tm deregistrationCertificate <- noteTempFile tempDir "stake-pool-deregistration-certificate" -- Create cold key pair - void $ execCardanoCLI - [ "node", "key-gen" - , "--cold-verification-key-file", coldVerKey - , "--cold-signing-key-file", coldSignKey - , "--operational-certificate-issue-counter", operationalCertCounter - ] + void $ + execCardanoCLI + [ "node" + , "key-gen" + , "--cold-verification-key-file" + , coldVerKey + , "--cold-signing-key-file" + , coldSignKey + , "--operational-certificate-issue-counter" + , operationalCertCounter + ] H.assertFilesExist [coldSignKey, coldVerKey, operationalCertCounter] -- Generate stake key pair - void $ execCardanoCLI - [ "stake-address", "key-gen" - , "--verification-key-file", poolRewardAccountAndOwnerVerKey - , "--signing-key-file", poolRewardAccountSignKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , poolRewardAccountAndOwnerVerKey + , "--signing-key-file" + , poolRewardAccountSignKey + ] H.assertFilesExist [poolRewardAccountAndOwnerVerKey, poolRewardAccountSignKey] -- Generate vrf verification key - void $ execCardanoCLI - [ "node", "key-gen-VRF" - , "--verification-key-file", vrfVerKey - , "--signing-key-file", vrfSignKey - ] - + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--verification-key-file" + , vrfVerKey + , "--signing-key-file" + , vrfSignKey + ] H.assertFilesExist [vrfSignKey, vrfVerKey] -- Create stake pool registration certificate - void $ execCardanoCLI - [ "babbage", "stake-pool", "registration-certificate" - , "--cold-verification-key-file", coldVerKey - , "--vrf-verification-key-file", vrfVerKey - , "--mainnet" - , "--pool-cost", "1000" - , "--pool-pledge", "5000" - , "--pool-margin", "0.1" - , "--pool-reward-account-verification-key-file", poolRewardAccountAndOwnerVerKey - , "--pool-owner-stake-verification-key-file", poolRewardAccountAndOwnerVerKey - , "--out-file", registrationCertificate - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-pool" + , "registration-certificate" + , "--cold-verification-key-file" + , coldVerKey + , "--vrf-verification-key-file" + , vrfVerKey + , "--mainnet" + , "--pool-cost" + , "1000" + , "--pool-pledge" + , "5000" + , "--pool-margin" + , "0.1" + , "--pool-reward-account-verification-key-file" + , poolRewardAccountAndOwnerVerKey + , "--pool-owner-stake-verification-key-file" + , poolRewardAccountAndOwnerVerKey + , "--out-file" + , registrationCertificate + ] H.assertFilesExist [registrationCertificate] @@ -89,18 +116,30 @@ hprop_golden_shelleyStakePoolCertificates = propertyOnce . H.moduleWorkspace "tm -- Check the newly created files have not deviated from the -- golden files - checkTextEnvelopeFormat registrationCertificateType referenceRegistrationCertificate registrationCertificate + checkTextEnvelopeFormat + registrationCertificateType + referenceRegistrationCertificate + registrationCertificate -- Create stake pool deregistration certificate - void $ execCardanoCLI - [ "babbage", "stake-pool", "deregistration-certificate" - , "--cold-verification-key-file", coldVerKey - , "--epoch", "42" - , "--out-file", deregistrationCertificate - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-pool" + , "deregistration-certificate" + , "--cold-verification-key-file" + , coldVerKey + , "--epoch" + , "42" + , "--out-file" + , deregistrationCertificate + ] H.assertFilesExist [deregistrationCertificate] -- Check the newly created files have not deviated from the -- golden files - checkTextEnvelopeFormat registrationCertificateType referenceDeregistrationCertificate deregistrationCertificate + checkTextEnvelopeFormat + registrationCertificateType + referenceDeregistrationCertificate + deregistrationCertificate diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/ExtendedPaymentKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/ExtendedPaymentKeys.hs index 2630d07d47..33688b81e8 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/ExtendedPaymentKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/ExtendedPaymentKeys.hs @@ -23,20 +23,27 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyExtendedPaymentKeys :: Property hprop_golden_shelleyExtendedPaymentKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/signing_key" + referenceVerKey <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "extended-payment-verification-key-file" signKey <- noteTempFile tempDir "extended-payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--extended-key" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--extended-key" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsPaymentExtendedKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsPaymentExtendedKey) @@ -52,21 +59,29 @@ hprop_golden_shelleyExtendedPaymentKeys = propertyOnce . H.moduleWorkspace "tmp" hprop_golden_shelleyExtendedPaymentKeys_te :: Property hprop_golden_shelleyExtendedPaymentKeys_te = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/signing_key" + referenceVerKey <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/extended_payment_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "extended-payment-verification-key-file" signKey <- noteTempFile tempDir "extended-payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--key-output-format", "text-envelope" - , "--extended-key" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--key-output-format" + , "text-envelope" + , "--extended-key" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsPaymentExtendedKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsPaymentExtendedKey) @@ -88,13 +103,18 @@ hprop_golden_shelleyExtendedPaymentKeys_bech32 = propertyOnce . H.moduleWorkspac signKeyFile <- noteTempFile tempDir "payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--key-output-format", "bech32" - , "--extended-key" - , "--verification-key-file", verKeyFile - , "--signing-key-file", signKeyFile - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--key-output-format" + , "bech32" + , "--extended-key" + , "--verification-key-file" + , verKeyFile + , "--signing-key-file" + , signKeyFile + ] verKey <- H.readFile verKeyFile H.assert $ verKey =~ id @String "^addr_xvk[a-z0-9]{110}$" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisDelegateKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisDelegateKeys.hs index 816b7222ef..65c9c7550e 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisDelegateKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisDelegateKeys.hs @@ -19,9 +19,14 @@ import qualified Hedgehog.Extras.Test.Base as H hprop_golden_shelleyGenesisDelegateKeys :: Property hprop_golden_shelleyGenesisDelegateKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/signing_key" - referenceOpCertCounter <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/operational_certificate_counter" + referenceVerKey <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/signing_key" + referenceOpCertCounter <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/keys/genesis_delegate_keys/operational_certificate_counter" -- Key filepaths verKey <- noteTempFile tempDir "genesis-delegate-verification-key-file" @@ -29,12 +34,17 @@ hprop_golden_shelleyGenesisDelegateKeys = propertyOnce . H.moduleWorkspace "tmp" opCertCounter <- noteTempFile tempDir "delegate-operational-cert-counter-file" -- Generate payment verification key - void $ execCardanoCLI - [ "genesis","key-gen-delegate" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - , "--operational-certificate-issue-counter-file", opCertCounter - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-delegate" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + , "--operational-certificate-issue-counter-file" + , opCertCounter + ] let signingKeyType = textEnvelopeType (AsSigningKey AsGenesisDelegateKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsGenesisDelegateKey) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisKeys.hs index 819e77356c..500316dd18 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisKeys.hs @@ -19,19 +19,25 @@ import qualified Hedgehog.Extras.Test.Base as H hprop_golden_shelleyGenesisKeys :: Property hprop_golden_shelleyGenesisKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "genesis-verification-key-file" signKey <- noteTempFile tempDir "genesis-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "genesis","key-gen-genesis" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-genesis" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsGenesisKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsGenesisKey) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisUTxOKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisUTxOKeys.hs index ba1fea089a..3898d1a3bd 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisUTxOKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/GenesisUTxOKeys.hs @@ -19,19 +19,25 @@ import qualified Hedgehog.Extras.Test.Base as H hprop_golden_shelleyGenesisUTxOKeys :: Property hprop_golden_shelleyGenesisUTxOKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_utxo_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_utxo_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_utxo_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/genesis_utxo_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "genesis-utxo-verification-key-file" signKey <- noteTempFile tempDir "genesis-utxo-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "genesis","key-gen-utxo" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "genesis" + , "key-gen-utxo" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsGenesisUTxOKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsGenesisUTxOKey) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/KESKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/KESKeys.hs index c1ba9d855d..60add90692 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/KESKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/KESKeys.hs @@ -23,19 +23,25 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyKESKeys :: Property hprop_golden_shelleyKESKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "kes-verification-key-file" signKey <- noteTempFile tempDir "kes-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsKesKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsKesKey) @@ -51,20 +57,27 @@ hprop_golden_shelleyKESKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir hprop_golden_shelleyKESKeys_te :: Property hprop_golden_shelleyKESKeys_te = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/kes_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "kes-verification-key-file" signKey <- noteTempFile tempDir "kes-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--key-output-format", "text-envelope" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--key-output-format" + , "text-envelope" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsKesKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsKesKey) @@ -84,12 +97,17 @@ hprop_golden_shelleyKESKeys_bech32 = propertyOnce . H.moduleWorkspace "tmp" $ \t signKeyFile <- noteTempFile tempDir "kes-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--key-output-format", "bech32" - , "--verification-key-file", verKeyFile - , "--signing-key-file", signKeyFile - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verKeyFile + , "--signing-key-file" + , signKeyFile + ] -- Check the newly created files have not deviated from the -- golden files diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/PaymentKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/PaymentKeys.hs index 4912e9ec33..db600a5498 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/PaymentKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/PaymentKeys.hs @@ -23,19 +23,25 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyPaymentKeys :: Property hprop_golden_shelleyPaymentKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "payment-verification-key-file" signKey <- noteTempFile tempDir "payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsPaymentKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsPaymentKey) @@ -51,20 +57,27 @@ hprop_golden_shelleyPaymentKeys = propertyOnce . H.moduleWorkspace "tmp" $ \temp hprop_golden_shelleyPaymentKeys_te :: Property hprop_golden_shelleyPaymentKeys_te = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "payment-verification-key-file" signKey <- noteTempFile tempDir "payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--key-output-format", "text-envelope" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--key-output-format" + , "text-envelope" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsPaymentKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsPaymentKey) @@ -86,12 +99,17 @@ hprop_golden_shelleyPaymentKeys_bech32 = propertyOnce . H.moduleWorkspace "tmp" signKeyFile <- noteTempFile tempDir "payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--key-output-format", "bech32" - , "--verification-key-file", verKeyFile - , "--signing-key-file", signKeyFile - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verKeyFile + , "--signing-key-file" + , signKeyFile + ] verKey <- H.readFile verKeyFile H.assert $ verKey =~ id @String "^addr_vk[a-z0-9]{59}$" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/StakeKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/StakeKeys.hs index 0954c27197..b56628c264 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/StakeKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/StakeKeys.hs @@ -23,19 +23,25 @@ import qualified Hedgehog.Extras.Test.File as H hprop_golden_shelleyStakeKeys :: Property hprop_golden_shelleyStakeKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "stake-verification-key-file" signKey <- noteTempFile tempDir "stake-signing-key-file" -- Generate stake key pair - void $ execCardanoCLI - [ "stake-address","key-gen" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsStakeKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsStakeKey) @@ -51,20 +57,27 @@ hprop_golden_shelleyStakeKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDi hprop_golden_shelleyStakeKeys_te :: Property hprop_golden_shelleyStakeKeys_te = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "stake-verification-key-file" signKey <- noteTempFile tempDir "stake-signing-key-file" -- Generate stake key pair - void $ execCardanoCLI - [ "stake-address","key-gen" - , "--key-output-format", "text-envelope" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--key-output-format" + , "text-envelope" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsStakeKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsStakeKey) @@ -86,12 +99,17 @@ hprop_golden_shelleyStakeKeys_bech32 = propertyOnce . H.moduleWorkspace "tmp" $ signKeyFile <- noteTempFile tempDir "stake-signing-key-file" -- Generate stake key pair - void $ execCardanoCLI - [ "stake-address","key-gen" - , "--key-output-format", "bech32" - , "--verification-key-file", verKeyFile - , "--signing-key-file", signKeyFile - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verKeyFile + , "--signing-key-file" + , signKeyFile + ] verKey <- H.readFile verKeyFile H.assert $ verKey =~ id @String "stake_vk[a-z0-9]{59}" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/VRFKeys.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/VRFKeys.hs index 1bd1027b6c..d5e47bd24b 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/VRFKeys.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Keys/VRFKeys.hs @@ -25,19 +25,25 @@ hprop_golden_shelleyVRFKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir H.note_ tempDir -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "vrf-verification-key-file" signKey <- noteTempFile tempDir "vrf-signing-key-file" -- Generate vrf verification key - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsVrfKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsVrfKey) @@ -55,20 +61,27 @@ hprop_golden_shelleyVRFKeys_te = propertyOnce . H.moduleWorkspace "tmp" $ \tempD H.note_ tempDir -- Reference keys - referenceVerKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/verification_key" - referenceSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/signing_key" + referenceVerKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/verification_key" + referenceSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/vrf_keys/signing_key" -- Key filepaths verKey <- noteTempFile tempDir "vrf-verification-key-file" signKey <- noteTempFile tempDir "vrf-signing-key-file" -- Generate vrf verification key - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--key-output-format", "text-envelope" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--key-output-format" + , "text-envelope" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] let signingKeyType = textEnvelopeType (AsSigningKey AsVrfKey) verificationKeyType = textEnvelopeType (AsVerificationKey AsVrfKey) @@ -90,12 +103,17 @@ hprop_golden_shelleyVRFKeys_bech32 = propertyOnce . H.moduleWorkspace "tmp" $ \t signKeyFile <- noteTempFile tempDir "vrf-signing-key-file" -- Generate vrf verification key - void $ execCardanoCLI - [ "node","key-gen-VRF" - , "--key-output-format", "bech32" - , "--verification-key-file", verKeyFile - , "--signing-key-file", signKeyFile - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--key-output-format" + , "bech32" + , "--verification-key-file" + , verKeyFile + , "--signing-key-file" + , signKeyFile + ] verKey <- H.readFile verKeyFile H.assert $ verKey =~ id @String "vrf_vk[a-z0-9]{59}" diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Tx.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Tx.hs index a7c6c0b832..4c989d8500 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Tx.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Tx.hs @@ -21,28 +21,43 @@ hprop_golden_shelleyTx = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do let goldenReferenceTx = "test/cardano-cli-golden/files/golden/alonzo/tx" -- Key filepaths - paymentSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/utxo.skey" + paymentSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/utxo.skey" transactionFile <- noteTempFile tempDir "tx-file" transactionBodyFile <- noteTempFile tempDir "tx-body-file" -- Create transaction body - void $ execCardanoCLI - [ "alonzo", "transaction", "build-raw" - , "--tx-in", "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" - , "--tx-out", "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" - , "--tx-out", "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" - , "--fee", "166777" - , "--out-file", transactionBodyFile - ] + void $ + execCardanoCLI + [ "alonzo" + , "transaction" + , "build-raw" + , "--tx-in" + , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" + , "--tx-out" + , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" + , "--tx-out" + , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" + , "--fee" + , "166777" + , "--out-file" + , transactionBodyFile + ] -- Sign transaction - void $ execCardanoCLI - [ "transaction", "sign" - , "--tx-body-file", transactionBodyFile - , "--signing-key-file", paymentSignKey - , "--testnet-magic", "42" - , "--out-file", transactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--tx-body-file" + , transactionBodyFile + , "--signing-key-file" + , paymentSignKey + , "--testnet-magic" + , "42" + , "--out-file" + , transactionFile + ] -- Check the newly created files have not deviated from the -- golden files @@ -55,31 +70,47 @@ disable_hprop_golden_checkIfConstitutionalCommitteeKeyCanSign = propertyOnce . H let referenceTx = "test/cardano-cli-golden/files/input/conway/tx" -- Key filepaths - paymentSignKey <- noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/utxo.skey" + paymentSignKey <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/utxo.skey" -- constitutional committee signing key paymentSignKey2 <- noteInputFile "test/cardano-cli-golden/files/input/conway/cold1-cc.skey" transactionFile <- noteTempFile tempDir "tx-file" transactionBodyFile <- noteTempFile tempDir "tx-body-file" -- Create transaction body - void $ execCardanoCLI - [ "conway", "transaction", "build-raw" - , "--tx-in", "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" - , "--tx-out", "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" - , "--tx-out", "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" - , "--fee", "166777" - , "--out-file", transactionBodyFile - ] + void $ + execCardanoCLI + [ "conway" + , "transaction" + , "build-raw" + , "--tx-in" + , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0" + , "--tx-out" + , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223" + , "--tx-out" + , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000" + , "--fee" + , "166777" + , "--out-file" + , transactionBodyFile + ] -- Sign transaction - void $ execCardanoCLI - [ "transaction", "sign" - , "--tx-body-file", transactionBodyFile - , "--signing-key-file", paymentSignKey - , "--signing-key-file", paymentSignKey2 - , "--testnet-magic", "42" - , "--out-file", transactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--tx-body-file" + , transactionBodyFile + , "--signing-key-file" + , paymentSignKey + , "--signing-key-file" + , paymentSignKey2 + , "--testnet-magic" + , "42" + , "--out-file" + , transactionFile + ] -- Check the newly created files have not deviated from the -- golden files diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/TxBody.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/TxBody.hs index c1902d6774..c5a59aa5c7 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/TxBody.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/TxBody.hs @@ -22,15 +22,22 @@ hprop_golden_shelleyTxBody = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir - transactionBodyFile <- noteTempFile tempDir "transaction-body-file" -- Create transaction body - void $ execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in", "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" - , "--tx-out", "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3+100000000" - , "--fee", "1000000" - , "--invalid-hereafter", "500000" - , "--out-file", transactionBodyFile - ] - + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" + , "--tx-out" + , "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3+100000000" + , "--fee" + , "1000000" + , "--invalid-hereafter" + , "500000" + , "--out-file" + , transactionBodyFile + ] -- Check the newly created files have not deviated from the -- golden files diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Witness.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Witness.hs index 9d43cdb6ee..d38658aa30 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Witness.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextEnvelope/Tx/Witness.hs @@ -1,4 +1,3 @@ - module Test.Golden.Shelley.TextEnvelope.Tx.Witness where import Hedgehog (Property, property, success) diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextView/DecodeCbor.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextView/DecodeCbor.hs index a8479d2b25..8a6aaf5e3d 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextView/DecodeCbor.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/TextView/DecodeCbor.hs @@ -17,10 +17,13 @@ hprop_golden_shelleyTextViewDecodeCbor = propertyOnce $ H.moduleWorkspace "tmp" -- Defaults to signing a Mainnet transaction. - decodedTxt <- execCardanoCLI - [ "text-view","decode-cbor" - , "--file", unsignedTxFile - ] + decodedTxt <- + execCardanoCLI + [ "text-view" + , "decode-cbor" + , "--file" + , unsignedTxFile + ] H.writeFile decodedTxtFile decodedTxt diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Assemble.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Assemble.hs index 4e69c3822c..5457510830 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Assemble.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Assemble.hs @@ -18,13 +18,20 @@ hprop_golden_shelleyTransactionAssembleWitness_SigningKey :: Property hprop_golden_shelleyTransactionAssembleWitness_SigningKey = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do witnessTx <- noteTempFile tempDir "single-signing-key-witness-tx" txBodyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/tx/txbody" - signingKeyWitnessFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/witnesses/singleSigningKeyWitness" - void $ execCardanoCLI - [ "transaction","sign-witness" - , "--tx-body-file", txBodyFile - , "--witness-file", signingKeyWitnessFile - , "--witness-file", signingKeyWitnessFile - , "--out-file", witnessTx - ] + signingKeyWitnessFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/witnesses/singleSigningKeyWitness" + void $ + execCardanoCLI + [ "transaction" + , "sign-witness" + , "--tx-body-file" + , txBodyFile + , "--witness-file" + , signingKeyWitnessFile + , "--witness-file" + , signingKeyWitnessFile + , "--out-file" + , witnessTx + ] H.assertFileOccurences 1 "Tx MaryEra" witnessTx diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Build.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Build.hs index 2fd791c4d7..1458dcd2de 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Build.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Build.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Test.Golden.Shelley.Transaction.Build - where +module Test.Golden.Shelley.Transaction.Build where import Control.Monad (void) import qualified Data.ByteString.Base16 as Base16 @@ -17,7 +16,8 @@ import qualified Hedgehog.Extras.Test.Golden as H {- HLINT ignore "Use camelCase" -} txOut :: String -txOut = "addr1q94cxl99qvtwunsqqv6g9mgj3zrawtpt4edsgwxkjtwpy5dsezcht90tmwfur7t5hc9fk8hjd3r5vjwec2h8vmk3xh8s7er7t3+100" +txOut = + "addr1q94cxl99qvtwunsqqv6g9mgj3zrawtpt4edsgwxkjtwpy5dsezcht90tmwfur7t5hc9fk8hjd3r5vjwec2h8vmk3xh8s7er7t3+100" txIn :: String txIn = "2392d2b1200b5139fe555c81261697b29a8ccf561c5c783d46e78a479d977053#0" @@ -27,34 +27,51 @@ hprop_golden_shelley_transaction_build = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do txBodyOutFile <- noteTempFile tempDir "tx-body-out" - void $ execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in", txIn - , "--tx-out", txOut - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--tx-out" + , txOut + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/build-raw-tx-body-out-1.json" H.diffFileVsGoldenFile txBodyOutFile goldenFile - hprop_golden_shelley_transaction_build_certificate_script_witnessed :: Property hprop_golden_shelley_transaction_build_certificate_script_witnessed = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do - let deregcert = "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_deregistration_certificate" + let deregcert = + "test/cardano-cli-golden/files/input/shelley/certificates/stake_address_deregistration_certificate" scriptWit = "test/cardano-cli-golden/files/input/shelley/multisig/scripts/any" txBodyOutFile <- noteTempFile tempDir "tx-body-out" - void $ execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in", txIn - , "--tx-out", txOut - , "--certificate-file", deregcert, "--certificate-script-file", scriptWit - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--tx-out" + , txOut + , "--certificate-file" + , deregcert + , "--certificate-script-file" + , scriptWit + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/build-raw-tx-body-out-2.json" H.diffFileVsGoldenFile txBodyOutFile goldenFile @@ -64,27 +81,38 @@ hprop_golden_shelley_transaction_build_minting = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do let scriptWit = "test/cardano-cli-golden/files/input/shelley/multisig/scripts/any" - polid <- execCardanoCLI - [ "transaction" - , "policyid" - , "--script-file" - , scriptWit - ] + polid <- + execCardanoCLI + [ "transaction" + , "policyid" + , "--script-file" + , scriptWit + ] let dummyMA = filter (/= '\n') $ - "50 " ++ polid ++ "." ++ BSC.unpack (Base16.encode "ethereum") + "50 " ++ polid ++ "." ++ BSC.unpack (Base16.encode "ethereum") txBodyOutFile <- noteTempFile tempDir "tx-body-out" - void $ execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in", txIn - , "--tx-out", txOut ++ "+" ++ dummyMA, "--mint-script-file", scriptWit - , "--mint", dummyMA - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--tx-out" + , txOut ++ "+" ++ dummyMA + , "--mint-script-file" + , scriptWit + , "--mint" + , dummyMA + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/build-raw-tx-body-out-3.json" H.diffFileVsGoldenFile txBodyOutFile goldenFile @@ -94,19 +122,30 @@ hprop_golden_shelley_transaction_build_withdrawal_script_witnessed = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do txBodyOutFile <- noteTempFile tempDir "tx-body-out" - stakeAddress <- H.readFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/reward_address" + stakeAddress <- + H.readFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/reward_address" let withdrawal = filter (/= '\n') $ stakeAddress <> "+100" scriptWit = "test/cardano-cli-golden/files/input/shelley/multisig/scripts/any" - void $ execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in", txIn - , "--tx-out", txOut - , "--withdrawal", withdrawal, "--withdrawal-script-file", scriptWit - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--tx-out" + , txOut + , "--withdrawal" + , withdrawal + , "--withdrawal-script-file" + , scriptWit + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/build-raw-tx-body-out-4.json" H.diffFileVsGoldenFile txBodyOutFile goldenFile @@ -118,13 +157,22 @@ hprop_golden_shelley_transaction_build_txin_script_witnessed = txBodyOutFile <- noteTempFile tempDir "tx-body-out" - void $ execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in", txIn, "--txin-script-file", scriptWit - , "--tx-out", txOut - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--txin-script-file" + , scriptWit + , "--tx-out" + , txOut + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/build-raw-tx-body-out-5.json" H.diffFileVsGoldenFile txBodyOutFile goldenFile @@ -136,14 +184,22 @@ hprop_golden_shelley_transaction_build_txout_inline_datum = txBodyOutFile <- noteTempFile tempDir "tx-body-out" - void $ execCardanoCLI - [ "babbage", "transaction", "build-raw" - , "--tx-in", txIn - , "--tx-out", txOut - , "--tx-out-inline-datum-file", datum - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "babbage" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--tx-out" + , txOut + , "--tx-out-inline-datum-file" + , datum + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/build-raw-tx-body-out-6.json" H.diffFileVsGoldenFile txBodyOutFile goldenFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CalculateMinFee.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CalculateMinFee.hs index db7af8b26a..d7ec1364c2 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CalculateMinFee.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CalculateMinFee.hs @@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Golden.Shelley.Transaction.CalculateMinFee - where +module Test.Golden.Shelley.Transaction.CalculateMinFee where import Control.Monad (forM_) import Data.Aeson ((.=)) @@ -23,15 +22,18 @@ import qualified Hedgehog.Extras as H -- @cabal test cardano-cli-golden --test-options '-p "/golden shelley transaction calculate min fee/"'@ hprop_golden_shelley_transaction_calculate_min_fee :: Property hprop_golden_shelley_transaction_calculate_min_fee = do - let supplyValues = [ [] - , ["--output-json"] - , ["--output-text"] - , ["--output-json", "--out-file"] - , ["--output-text", "--out-file"] - ] + let supplyValues = + [ [] + , ["--output-json"] + , ["--output-text"] + , ["--output-json", "--out-file"] + , ["--output-text", "--out-file"] + ] propertyOnce $ forM_ supplyValues $ \flags -> H.moduleWorkspace "tmp" $ \tempDir -> do - protocolParamsJsonFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-calculate-min-fee/protocol-params.json" + protocolParamsJsonFile <- + noteInputFile + "test/cardano-cli-golden/files/input/shelley/transaction-calculate-min-fee/protocol-params.json" txBodyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/tx/txbody" let outFileFp = tempDir "out.txt" outFile = @@ -39,15 +41,23 @@ hprop_golden_shelley_transaction_calculate_min_fee = do _ : ["--out-file"] -> [outFileFp] _ -> [] - minFeeTxt <- execCardanoCLI $ - [ "transaction","calculate-min-fee" - , "--byron-witness-count", "10" - , "--witness-count", "5" - , "--protocol-params-file", protocolParamsJsonFile - , "--reference-script-size", "0" - , "--tx-body-file", txBodyFile - ] ++ flags - ++ outFile + minFeeTxt <- + execCardanoCLI $ + [ "transaction" + , "calculate-min-fee" + , "--byron-witness-count" + , "10" + , "--witness-count" + , "5" + , "--protocol-params-file" + , protocolParamsJsonFile + , "--reference-script-size" + , "0" + , "--tx-body-file" + , txBodyFile + ] + ++ flags + ++ outFile case flags of [] -> diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CreateWitness.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CreateWitness.hs index 36cc1f56db..7b74679c49 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CreateWitness.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/CreateWitness.hs @@ -16,33 +16,48 @@ txIn :: String txIn = "2392d2b1200b5139fe555c81261697b29a8ccf561c5c783d46e78a479d977053#0" txOut :: String -txOut = "addr1q94cxl99qvtwunsqqv6g9mgj3zrawtpt4edsgwxkjtwpy5dsezcht90tmwfur7t5hc9fk8hjd3r5vjwec2h8vmk3xh8s7er7t3+100" +txOut = + "addr1q94cxl99qvtwunsqqv6g9mgj3zrawtpt4edsgwxkjtwpy5dsezcht90tmwfur7t5hc9fk8hjd3r5vjwec2h8vmk3xh8s7er7t3+100" hprop_golden_shelley_transaction_signing_key_witness :: Property hprop_golden_shelley_transaction_signing_key_witness = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do txBodyOutFile <- noteTempFile tempDir "tx-body-out" -- Create tx body file - void $ execCardanoCLI - [ "shelley", "transaction", "build-raw" - , "--tx-in", txIn - , "--tx-out", txOut - , "--invalid-hereafter", "60" - , "--fee", "12" - , "--tx-body-file", txBodyOutFile - ] + void $ + execCardanoCLI + [ "shelley" + , "transaction" + , "build-raw" + , "--tx-in" + , txIn + , "--tx-out" + , txOut + , "--invalid-hereafter" + , "60" + , "--fee" + , "12" + , "--tx-body-file" + , txBodyOutFile + ] -- Create all multisig witness witnessOutFile <- noteTempFile tempDir "signingkey-witness" - signingKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" - - void $ execCardanoCLI - [ "transaction","witness" - , "--tx-body-file", txBodyOutFile - , "--signing-key-file", signingKeyFile - , "--mainnet" - , "--out-file", witnessOutFile - ] + signingKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" + + void $ + execCardanoCLI + [ "transaction" + , "witness" + , "--tx-body-file" + , txBodyOutFile + , "--signing-key-file" + , signingKeyFile + , "--mainnet" + , "--out-file" + , witnessOutFile + ] goldenFile <- H.note "test/cardano-cli-golden/files/golden/shelley/witness-out.json" H.diffFileVsGoldenFile witnessOutFile goldenFile diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Sign.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Sign.hs index fb5bbe3837..bd2dc39dcd 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Sign.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Shelley/Transaction/Sign.hs @@ -15,63 +15,90 @@ import qualified Hedgehog.Extras.Test.Golden as H hprop_golden_shelley_transaction_sign :: Property hprop_golden_shelley_transaction_sign = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do txBodyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/tx/txbody" - initialUtxo1SigningKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" - utxoSigningKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/utxo.skey" - stakeSigningKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/stake.skey" - nodeColdSigningKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/node-cold.skey" + initialUtxo1SigningKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/payment_keys/signing_key" + utxoSigningKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/utxo.skey" + stakeSigningKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/stake.skey" + nodeColdSigningKeyFile <- + noteInputFile "test/cardano-cli-golden/files/input/shelley/transaction-sign/node-cold.skey" ccHotSigningKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/governance/cc-hot.skey" signedTransactionFile <- noteTempFile tempDir "signed.tx" transactionPoolRegSignedFile <- noteTempFile tempDir "tx-pool-reg.signed" -- Defaults to signing a Mainnet transaction - void $ execCardanoCLI - [ "transaction","sign" - , "--mainnet" - , "--tx-body-file", txBodyFile - , "--signing-key-file", initialUtxo1SigningKeyFile - , "--tx-file", signedTransactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--mainnet" + , "--tx-body-file" + , txBodyFile + , "--signing-key-file" + , initialUtxo1SigningKeyFile + , "--tx-file" + , signedTransactionFile + ] goldenFile1 <- H.note "test/cardano-cli-golden/files/golden/shelley/transaction-sign-1.json" H.diffFileVsGoldenFile signedTransactionFile goldenFile1 -- Sign for a testnet with a testnet network magic of 11, but use two signing keys - void $ execCardanoCLI - [ "transaction","sign" - , "--mainnet" - , "--tx-body-file", txBodyFile - , "--signing-key-file", initialUtxo1SigningKeyFile - , "--signing-key-file", initialUtxo1SigningKeyFile - , "--tx-file", signedTransactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--mainnet" + , "--tx-body-file" + , txBodyFile + , "--signing-key-file" + , initialUtxo1SigningKeyFile + , "--signing-key-file" + , initialUtxo1SigningKeyFile + , "--tx-file" + , signedTransactionFile + ] H.diffFileVsGoldenFile signedTransactionFile goldenFile1 -- Sign a pool registration transaction. -- TODO: This needs to use an unsigned tx with a registration certificate - void $ execCardanoCLI - [ "transaction","sign" - , "--mainnet" - , "--tx-body-file", txBodyFile - , "--signing-key-file", utxoSigningKeyFile - , "--signing-key-file", stakeSigningKeyFile - , "--signing-key-file", nodeColdSigningKeyFile - , "--tx-file", transactionPoolRegSignedFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--mainnet" + , "--tx-body-file" + , txBodyFile + , "--signing-key-file" + , utxoSigningKeyFile + , "--signing-key-file" + , stakeSigningKeyFile + , "--signing-key-file" + , nodeColdSigningKeyFile + , "--tx-file" + , transactionPoolRegSignedFile + ] goldenFile2 <- H.note "test/cardano-cli-golden/files/golden/shelley/transaction-sign-2.json" H.diffFileVsGoldenFile transactionPoolRegSignedFile goldenFile2 - void $ execCardanoCLI - [ "transaction","sign" - , "--mainnet" - , "--tx-body-file", txBodyFile - , "--signing-key-file", ccHotSigningKeyFile - , "--tx-file", transactionPoolRegSignedFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--mainnet" + , "--tx-body-file" + , txBodyFile + , "--signing-key-file" + , ccHotSigningKeyFile + , "--tx-file" + , transactionPoolRegSignedFile + ] goldenFile3 <- H.note "test/cardano-cli-golden/files/golden/shelley/transaction-sign-3.json" H.diffFileVsGoldenFile transactionPoolRegSignedFile goldenFile3 diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/TxView.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/TxView.hs index 76c18e6283..eaebe779dd 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/TxView.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/TxView.hs @@ -10,7 +10,8 @@ module Test.Golden.TxView , hprop_golden_view_alonzo_signed_yaml , hprop_golden_view_conway_three_votes , hprop_golden_view_conway_proposal - ) where + ) +where import Cardano.Api (TxMetadataJsonSchema (..)) @@ -33,231 +34,277 @@ inputDir = "test/cardano-cli-golden/files/input" _hprop_golden_view_byron_yaml :: Property _hprop_golden_view_byron_yaml = propertyOnce $ - moduleWorkspace "tmp" $ \tempDir -> do - transactionBodyFile <- noteTempFile tempDir "transaction-body-file" + moduleWorkspace "tmp" $ \tempDir -> do + transactionBodyFile <- noteTempFile tempDir "transaction-body-file" - -- Create transaction body - void $ - execCardanoCLI - [ "transaction", "build-raw" - , "--byron-era" - , "--tx-in" - , "F8EC302D19E3C8251C30B1434349BF2E949A1DBF14A4EBC3D512918D2D4D5C56#88" - , "--tx-out" - , "5oP9ib6ym3XfwXuy3ksXZzgtBzXSArXAACQVXKqcPhiLnHVYjXJNu2T6Zomh8LAWLV+68" - , "--out-file", transactionBodyFile - ] + -- Create transaction body + void $ + execCardanoCLI + [ "transaction" + , "build-raw" + , "--byron-era" + , "--tx-in" + , "F8EC302D19E3C8251C30B1434349BF2E949A1DBF14A4EBC3D512918D2D4D5C56#88" + , "--tx-out" + , "5oP9ib6ym3XfwXuy3ksXZzgtBzXSArXAACQVXKqcPhiLnHVYjXJNu2T6Zomh8LAWLV+68" + , "--out-file" + , transactionBodyFile + ] - -- View transaction body - result <- - execCardanoCLI - ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] - H.diffVsGoldenFile result $ goldenDir "byron/transaction-view.out" + -- View transaction body + result <- + execCardanoCLI + ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] + H.diffVsGoldenFile result $ goldenDir "byron/transaction-view.out" -- TODO: Expose command to view byron tx files _hprop_golden_view_byron_json_default :: Property _hprop_golden_view_byron_json_default = propertyOnce $ - moduleWorkspace "tmp" $ \tempDir -> do - transactionBodyFile <- noteTempFile tempDir "transaction-body-file" + moduleWorkspace "tmp" $ \tempDir -> do + transactionBodyFile <- noteTempFile tempDir "transaction-body-file" - -- Create transaction body - void $ - execCardanoCLI - [ "transaction", "build-raw" - , "--byron-era" - , "--tx-in" - , "F8EC302D19E3C8251C30B1434349BF2E949A1DBF14A4EBC3D512918D2D4D5C56#88" - , "--tx-out" - , "5oP9ib6ym3XfwXuy3ksXZzgtBzXSArXAACQVXKqcPhiLnHVYjXJNu2T6Zomh8LAWLV+68" - , "--out-file", transactionBodyFile - ] + -- Create transaction body + void $ + execCardanoCLI + [ "transaction" + , "build-raw" + , "--byron-era" + , "--tx-in" + , "F8EC302D19E3C8251C30B1434349BF2E949A1DBF14A4EBC3D512918D2D4D5C56#88" + , "--tx-out" + , "5oP9ib6ym3XfwXuy3ksXZzgtBzXSArXAACQVXKqcPhiLnHVYjXJNu2T6Zomh8LAWLV+68" + , "--out-file" + , transactionBodyFile + ] - -- View transaction body - result <- - execCardanoCLI - ["transaction", "view", "--tx-body-file", transactionBodyFile] - H.diffVsGoldenFile result $ goldenDir "byron/transaction-view-json.out" + -- View transaction body + result <- + execCardanoCLI + ["transaction", "view", "--tx-body-file", transactionBodyFile] + H.diffVsGoldenFile result $ goldenDir "byron/transaction-view-json.out" hprop_golden_view_shelley_yaml :: Property -hprop_golden_view_shelley_yaml = let - certDir = inputDir "shelley/certificates" - certs = - (certDir ) <$> - [ "genesis_key_delegation_certificate" - , "mir_certificate" - , "stake_address_deregistration_certificate" - , "stake_address_registration_certificate" - , "stake_pool_deregistration_certificate" - , "stake_pool_registration_certificate" - ] - in - propertyOnce $ - moduleWorkspace "tmp" $ \tempDir -> do - updateProposalFile <- noteTempFile tempDir "update-proposal" - transactionBodyFile <- noteTempFile tempDir "transaction-body" - - let extraEntropySeed = "c0ffee" - note_ $ "extra entropy seed: " ++ extraEntropySeed - note_ $ mconcat - [ "extra entropy hash:" - , " 88f04f011dcded879039ae4b9b20219d9448e5c7b42c2d1f638fb8740e0ab8be" - ] +hprop_golden_view_shelley_yaml = + let + certDir = inputDir "shelley/certificates" + certs = + (certDir ) + <$> [ "genesis_key_delegation_certificate" + , "mir_certificate" + , "stake_address_deregistration_certificate" + , "stake_address_registration_certificate" + , "stake_pool_deregistration_certificate" + , "stake_pool_registration_certificate" + ] + in + propertyOnce $ + moduleWorkspace "tmp" $ \tempDir -> do + updateProposalFile <- noteTempFile tempDir "update-proposal" + transactionBodyFile <- noteTempFile tempDir "transaction-body" + + let extraEntropySeed = "c0ffee" + note_ $ "extra entropy seed: " ++ extraEntropySeed + note_ $ + mconcat + [ "extra entropy hash:" + , " 88f04f011dcded879039ae4b9b20219d9448e5c7b42c2d1f638fb8740e0ab8be" + ] - note_ $ mconcat - [ "genesis-verification-key-file hash:" - , " 81cb0bc5b6fbba391e6f7ec3d9271cbea25bcbf907181b7c4d5f8c2f" - ] + note_ $ + mconcat + [ "genesis-verification-key-file hash:" + , " 81cb0bc5b6fbba391e6f7ec3d9271cbea25bcbf907181b7c4d5f8c2f" + ] - -- Create update proposal - void $ - execCardanoCLI - [ "legacy", "governance", "create-update-proposal" - , "--decentralization-parameter", "63/64" - , "--epoch", "64" - , "--extra-entropy", extraEntropySeed - , "--genesis-verification-key-file" - , inputDir "shelley/keys/genesis_keys/verification_key" - , "--key-reg-deposit-amt", "71" - , "--max-block-body-size", "72" - , "--max-block-header-size", "73" - , "--max-tx-size", "74" - , "--min-fee-constant", "75" - , "--min-fee-linear", "76" - , "--min-pool-cost", "77" - , "--min-utxo-value", "78" - , "--monetary-expansion", "79/80" - , "--number-of-pools", "80" - , "--out-file", updateProposalFile - , "--pool-influence", "82/83" - , "--pool-reg-deposit", "83" - , "--pool-retirement-epoch-boundary", "84" - , "--protocol-major-version", "8" - , "--protocol-minor-version", "86" - , "--treasury-expansion", "87/88" - ] + -- Create update proposal + void $ + execCardanoCLI + [ "legacy" + , "governance" + , "create-update-proposal" + , "--decentralization-parameter" + , "63/64" + , "--epoch" + , "64" + , "--extra-entropy" + , extraEntropySeed + , "--genesis-verification-key-file" + , inputDir "shelley/keys/genesis_keys/verification_key" + , "--key-reg-deposit-amt" + , "71" + , "--max-block-body-size" + , "72" + , "--max-block-header-size" + , "73" + , "--max-tx-size" + , "74" + , "--min-fee-constant" + , "75" + , "--min-fee-linear" + , "76" + , "--min-pool-cost" + , "77" + , "--min-utxo-value" + , "78" + , "--monetary-expansion" + , "79/80" + , "--number-of-pools" + , "80" + , "--out-file" + , updateProposalFile + , "--pool-influence" + , "82/83" + , "--pool-reg-deposit" + , "83" + , "--pool-retirement-epoch-boundary" + , "84" + , "--protocol-major-version" + , "8" + , "--protocol-minor-version" + , "86" + , "--treasury-expansion" + , "87/88" + ] - -- Create transaction body - void $ - execCardanoCLI $ - [ "shelley", "transaction", "build-raw" - , "--tx-in" - , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#29" - , "--tx-out" - , "addr_test1vz7w0r9epak6nmnh3mc8e2ypkjyu8zsc3xf7dpct6k577acxmcfyv+31" - , "--fee", "32" - , "--invalid-hereafter", "33" - , "--withdrawal" - , "stake_test1up00fz9lyqs5sjks82k22eqz7a9srym9vysjgp3h2ua2v2cm522kg+42" - , "--update-proposal-file", updateProposalFile - , "--out-file", transactionBodyFile - ] - ++ - ["--certificate-file=" <> cert | cert <- certs] + -- Create transaction body + void $ + execCardanoCLI $ + [ "shelley" + , "transaction" + , "build-raw" + , "--tx-in" + , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#29" + , "--tx-out" + , "addr_test1vz7w0r9epak6nmnh3mc8e2ypkjyu8zsc3xf7dpct6k577acxmcfyv+31" + , "--fee" + , "32" + , "--invalid-hereafter" + , "33" + , "--withdrawal" + , "stake_test1up00fz9lyqs5sjks82k22eqz7a9srym9vysjgp3h2ua2v2cm522kg+42" + , "--update-proposal-file" + , updateProposalFile + , "--out-file" + , transactionBodyFile + ] + ++ ["--certificate-file=" <> cert | cert <- certs] - -- View transaction body - result <- - execCardanoCLI - ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] + -- View transaction body + result <- + execCardanoCLI + ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] - H.diffVsGoldenFile result $ goldenDir "shelley/transaction-view.out" + H.diffVsGoldenFile result $ goldenDir "shelley/transaction-view.out" hprop_golden_view_allegra_yaml :: Property hprop_golden_view_allegra_yaml = propertyOnce $ - moduleWorkspace "tmp" $ \tempDir -> do - transactionBodyFile <- noteTempFile tempDir "transaction-body-file" + moduleWorkspace "tmp" $ \tempDir -> do + transactionBodyFile <- noteTempFile tempDir "transaction-body-file" - -- Create transaction body - void $ - execCardanoCLI - [ "allegra", "transaction", "build-raw" - , "--tx-in" - , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#94" - , "--tx-out" - , mconcat - [ "addr_test1" - , "qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r7" - , "9jmxlyk4eqt6z6hj5g8jd8393msqaw47f4" - , "+99" + -- Create transaction body + void $ + execCardanoCLI + [ "allegra" + , "transaction" + , "build-raw" + , "--tx-in" + , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#94" + , "--tx-out" + , mconcat + [ "addr_test1" + , "qrefnr4k09pvge6dq83v6s67ruter8sftmky8qrmkqqsxy7q5psgn8tgqmupq4r7" + , "9jmxlyk4eqt6z6hj5g8jd8393msqaw47f4" + , "+99" + ] + , "--fee" + , "100" + , "--invalid-hereafter" + , "101" + , "--out-file" + , transactionBodyFile ] - , "--fee", "100" - , "--invalid-hereafter", "101" - , "--out-file", transactionBodyFile - ] - -- View transaction body - result <- - execCardanoCLI - ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] - H.diffVsGoldenFile result $ goldenDir "allegra/transaction-view.out" + -- View transaction body + result <- + execCardanoCLI + ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] + H.diffVsGoldenFile result $ goldenDir "allegra/transaction-view.out" hprop_golden_view_mary_yaml :: Property hprop_golden_view_mary_yaml = propertyOnce $ - moduleWorkspace "tmp" $ \tempDir -> do - transactionBodyFile <- noteTempFile tempDir "transaction-body-file" + moduleWorkspace "tmp" $ \tempDir -> do + transactionBodyFile <- noteTempFile tempDir "transaction-body-file" - -- Create transaction body - void $ - execCardanoCLI - [ "mary", "transaction", "build-raw" - , "--tx-in" - , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#135" - , "--tx-out" - , 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" - , mconcat - [ "130 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" - , " + " - , "132 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.cafe" - , " + " - , "134 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf.f00d" - , " + " - , "136 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.dead" - , " + " - , "138" - , " d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" - , ".736e6f77" - , " + " - , "142" - , " a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067" - , ".736b79" - ] - , "--mint-script-file", inputDir "mary/scripts/mint.all" - , "--mint-script-file", inputDir "mary/scripts/mint.sig" - , "--out-file", transactionBodyFile - ] + -- Create transaction body + void $ + execCardanoCLI + [ "mary" + , "transaction" + , "build-raw" + , "--tx-in" + , "fe5dd07fb576bff960d6e066eade5b26cdb5afebe29f76ea58d0a098bce5d891#135" + , "--tx-out" + , 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" + , mconcat + [ "130 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" + , " + " + , "132 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.cafe" + , " + " + , "134 d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf.f00d" + , " + " + , "136 a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067.dead" + , " + " + , "138" + , " d441227553a0f1a965fee7d60a0f724b368dd1bddbc208730fccebcf" + , ".736e6f77" + , " + " + , "142" + , " a06ee5ffdd7f9b5bd992eb9543f44418323f81229526b77b0e4be067" + , ".736b79" + ] + , "--mint-script-file" + , inputDir "mary/scripts/mint.all" + , "--mint-script-file" + , inputDir "mary/scripts/mint.sig" + , "--out-file" + , transactionBodyFile + ] - -- View transaction body - result <- - execCardanoCLI - ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] - H.diffVsGoldenFile result $ goldenDir "mary/transaction-view.out" + -- View transaction body + result <- + execCardanoCLI + ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] + H.diffVsGoldenFile result $ goldenDir "mary/transaction-view.out" hprop_golden_view_redeemer :: Property hprop_golden_view_redeemer = do @@ -272,23 +319,32 @@ hprop_golden_view_redeemer = do ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] H.diffVsGoldenFile result $ goldenDir "babbage/transaction-view-redeemer.out" - where + where scriptTxBody :: FilePath -> Integration () scriptTxBody transactionBodyFile = - void $ execCardanoCLI - [ "babbage", "transaction", "build-raw" + void $ + execCardanoCLI + [ "babbage" + , "transaction" + , "build-raw" , "--tx-in" - , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#213" - , "--tx-in-datum-value", "6666" - , "--tx-in-redeemer-value", "42" - , "--tx-in-script-file", inputDir "AlwaysSucceeds.plutus" - , "--tx-in-execution-units", "(100, 200)" + , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#213" + , "--tx-in-datum-value" + , "6666" + , "--tx-in-redeemer-value" + , "42" + , "--tx-in-script-file" + , inputDir "AlwaysSucceeds.plutus" + , "--tx-in-execution-units" + , "(100, 200)" , "--tx-in-collateral" - , "c9765d7d0e3955be8920e6d7a38e1f3f2032eac48c7c59b0b9193caa87727e7e#256" + , "c9765d7d0e3955be8920e6d7a38e1f3f2032eac48c7c59b0b9193caa87727e7e#256" , "--protocol-params-file" - , inputDir "babbage/transaction-calculate-min-fee/protocol-params.json" - , "--fee", "213" - , "--out-file", transactionBodyFile + , inputDir "babbage/transaction-calculate-min-fee/protocol-params.json" + , "--fee" + , "213" + , "--out-file" + , transactionBodyFile ] -- | Test metadata format @@ -306,45 +362,58 @@ hprop_golden_view_metadata = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> resultDetailedSchema <- execCardanoCLI ["transaction", "view", "--tx-body-file", transactionBodyMetaDetailedSchema, "--output-yaml"] - H.diffVsGoldenFile resultDetailedSchema $ goldenDir "babbage/transaction-view-metadata-detailedschema.out" - where - makeTxBody :: TxMetadataJsonSchema -> FilePath -> Integration () - makeTxBody hasSchema transactionBodyFile = do - let metadataArgs = - case hasSchema of - TxMetadataJsonNoSchema -> - [ "--metadata-json-file", inputDir "tx_metadata_noschema.json" ] - TxMetadataJsonDetailedSchema -> - [ "--json-metadata-detailed-schema" - , "--metadata-json-file", inputDir "tx_metadata_withschema.json" - ] - void . execCardanoCLI $ - [ "babbage", "transaction", "build-raw" - , "--tx-in" , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#213" - , "--tx-out", "addr_test1vpfwv0ezc5g8a4mkku8hhy3y3vp92t7s3ul8g778g5yegsgalc6gc+24910487859" - , "--fee", "21300" - , "--out-file", transactionBodyFile - ] <> metadataArgs + H.diffVsGoldenFile resultDetailedSchema $ + goldenDir "babbage/transaction-view-metadata-detailedschema.out" + where + makeTxBody :: TxMetadataJsonSchema -> FilePath -> Integration () + makeTxBody hasSchema transactionBodyFile = do + let metadataArgs = + case hasSchema of + TxMetadataJsonNoSchema -> + ["--metadata-json-file", inputDir "tx_metadata_noschema.json"] + TxMetadataJsonDetailedSchema -> + [ "--json-metadata-detailed-schema" + , "--metadata-json-file" + , inputDir "tx_metadata_withschema.json" + ] + void . execCardanoCLI $ + [ "babbage" + , "transaction" + , "build-raw" + , "--tx-in" + , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#213" + , "--tx-out" + , "addr_test1vpfwv0ezc5g8a4mkku8hhy3y3vp92t7s3ul8g778g5yegsgalc6gc+24910487859" + , "--fee" + , "21300" + , "--out-file" + , transactionBodyFile + ] + <> metadataArgs createAlonzoTxBody :: Maybe FilePath -> FilePath -> Integration () createAlonzoTxBody mUpdateProposalFile transactionBodyFile = do void $ execCardanoCLI - ( [ "alonzo", "transaction", "build-raw" - , "--tx-in" - , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#212" - , "--tx-in-collateral" - , "c9765d7d0e3955be8920e6d7a38e1f3f2032eac48c7c59b0b9193caa87727e7e#256" - , "--fee", "213" - , "--required-signer-hash" - , "98717eaba8105a50a2a71831267552e337dfdc893bef5e40b8676d27" - , "--required-signer-hash" - , "fafaaac8681b5050a8987f95bce4a7f99362f189879258fdbf733fa4" - , "--out-file", transactionBodyFile - ] - ++ [ "--update-proposal-file=" <> updateProposalFile - | Just updateProposalFile <- [mUpdateProposalFile] - ] + ( [ "alonzo" + , "transaction" + , "build-raw" + , "--tx-in" + , "ed7c8f68c194cc763ee65ad22ef0973e26481be058c65005fd39fb93f9c43a20#212" + , "--tx-in-collateral" + , "c9765d7d0e3955be8920e6d7a38e1f3f2032eac48c7c59b0b9193caa87727e7e#256" + , "--fee" + , "213" + , "--required-signer-hash" + , "98717eaba8105a50a2a71831267552e337dfdc893bef5e40b8676d27" + , "--required-signer-hash" + , "fafaaac8681b5050a8987f95bce4a7f99362f189879258fdbf733fa4" + , "--out-file" + , transactionBodyFile + ] + ++ [ "--update-proposal-file=" <> updateProposalFile + | Just updateProposalFile <- [mUpdateProposalFile] + ] ) -- | Execute me with: @@ -352,38 +421,50 @@ createAlonzoTxBody mUpdateProposalFile transactionBodyFile = do hprop_golden_view_alonzo_yaml :: Property hprop_golden_view_alonzo_yaml = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do - updateProposalFile <- noteTempFile tempDir "update-proposal" - transactionBodyFile <- noteTempFile tempDir "transaction-body" + updateProposalFile <- noteTempFile tempDir "update-proposal" + transactionBodyFile <- noteTempFile tempDir "transaction-body" - note_ $ mconcat + note_ $ + mconcat [ "genesis-verification-key-file hash:" , " 1bafa294233a5a7ffbf539ae798da0943aa83d2a19398c2d0e5af114" ] - -- Create update proposal - void $ - execCardanoCLI - [ "legacy", "governance", "create-update-proposal" - , "--epoch", "190" - , "--genesis-verification-key-file" - , inputDir "shelley/keys/genesis_keys/verification_key" - , "--price-execution-steps", "195/196" - , "--price-execution-memory", "196/197" - , "--max-tx-execution-units", "(197, 198)" - , "--max-block-execution-units", "(198, 199)" - , "--max-value-size", "199" - , "--collateral-percent", "200" - , "--max-collateral-inputs", "201" - , "--out-file", updateProposalFile - ] + -- Create update proposal + void $ + execCardanoCLI + [ "legacy" + , "governance" + , "create-update-proposal" + , "--epoch" + , "190" + , "--genesis-verification-key-file" + , inputDir "shelley/keys/genesis_keys/verification_key" + , "--price-execution-steps" + , "195/196" + , "--price-execution-memory" + , "196/197" + , "--max-tx-execution-units" + , "(197, 198)" + , "--max-block-execution-units" + , "(198, 199)" + , "--max-value-size" + , "199" + , "--collateral-percent" + , "200" + , "--max-collateral-inputs" + , "201" + , "--out-file" + , updateProposalFile + ] - createAlonzoTxBody (Just updateProposalFile) transactionBodyFile + createAlonzoTxBody (Just updateProposalFile) transactionBodyFile - -- View transaction body - result <- - execCardanoCLI - ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] - H.diffVsGoldenFile result $ goldenDir "alonzo/transaction-view.out" + -- View transaction body + result <- + execCardanoCLI + ["transaction", "view", "--tx-body-file", transactionBodyFile, "--output-yaml"] + H.diffVsGoldenFile result $ goldenDir "alonzo/transaction-view.out" -- | Execute me with: -- @cabal test cardano-cli-golden --test-options '-p "/golden view alonzo signed yaml/"'@ @@ -401,10 +482,14 @@ hprop_golden_view_alonzo_signed_yaml = -- Sign void $ execCardanoCLI - [ "transaction", "sign" - , "--tx-body-file", transactionBodyFile - , "--signing-key-file", input "signing.key" - , "--out-file", transactionFile + [ "transaction" + , "sign" + , "--tx-body-file" + , transactionBodyFile + , "--signing-key-file" + , input "signing.key" + , "--out-file" + , transactionFile ] -- View transaction body @@ -440,4 +525,4 @@ hprop_golden_view_conway_proposal = execCardanoCLI ["transaction", "view", "--tx-file", input "tx-proposal.json", "--output-json"] - H.diffVsGoldenFile result (golden "tx-proposal.out.json") \ No newline at end of file + H.diffVsGoldenFile result (golden "tx-proposal.out.json") diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Version.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Version.hs index 4df905da8b..8fe120f815 100644 --- a/cardano-cli/test/cardano-cli-golden/Test/Golden/Version.hs +++ b/cardano-cli/test/cardano-cli-golden/Test/Golden/Version.hs @@ -2,7 +2,8 @@ module Test.Golden.Version ( hprop_golden_version - ) where + ) +where import Control.Monad (void) @@ -14,6 +15,7 @@ import Hedgehog (Property) hprop_golden_version :: Property hprop_golden_version = propertyOnce $ do - void $ execCardanoCLI - [ "version" - ] + void $ + execCardanoCLI + [ "version" + ] diff --git a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Aeson.hs b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Aeson.hs index c3d8ae432f..a19e7530fb 100644 --- a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Aeson.hs +++ b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Aeson.hs @@ -1,10 +1,11 @@ {-# LANGUAGE TypeApplications #-} -module Test.Cardano.CLI.Aeson ( - assertEqualModuloDesc +module Test.Cardano.CLI.Aeson + ( assertEqualModuloDesc , assertHasKeys , assertHasMappings - ) where + ) +where import Control.Monad (forM_) import Control.Monad.IO.Class @@ -28,7 +29,8 @@ import qualified Hedgehog.Extras as H -- -- For example. if @path@ contains @"{ "a":0, "b":1.0, "c": "foo"}"@, -- @hasKeys ["b", "a"] path@ succeeds. -assertHasKeys :: () +assertHasKeys + :: () => HasCallStack => MonadTest m => MonadIO m @@ -49,7 +51,8 @@ assertHasKeys keys jsonFile = GHC.withFrozenCallStack $ do -- the path from which @obj@ was loaded. -- -- Having this functions allows for good feedback in case of a test failure. -assertHasKey :: () +assertHasKey + :: () => HasCallStack => MonadTest m => FilePath @@ -68,7 +71,8 @@ assertHasKey file obj key = GHC.withFrozenCallStack $ do -- -- For example, if @path@ contains @"{ "a":"bar", "b":"buzz", "c":"foo"}"@, -- @assertHasMappings "[("b", "buzz"), ("a", "bar")] path@ succeeds. -assertHasMappings :: () +assertHasMappings + :: () => HasCallStack => MonadTest m => MonadIO m @@ -89,7 +93,8 @@ assertHasMappings pairs jsonFile = GHC.withFrozenCallStack $ do -- the path from which @obj@ was loaded. -- -- Having this functions allows for good feedback in case of a test failure. -assertHasMapping :: () +assertHasMapping + :: () => HasCallStack => MonadTest m => FilePath @@ -106,20 +111,26 @@ assertHasMapping file obj key value = GHC.withFrozenCallStack $ do case inThere of String textInThere | value == textInThere -> H.success String textInThere -> do - H.note_ $ "JSON file at " <> file <> " has the mapping \"" <> T.unpack key <> "\"->\"" <> T.unpack textInThere <> "\"" - H.note_ $ "whereas it was expected to be \"" <> T.unpack key <> "\"->\"" <> T.unpack value <> "\"" - H.failure + H.note_ $ + "JSON file at " + <> file + <> " has the mapping \"" + <> T.unpack key + <> "\"->\"" + <> T.unpack textInThere + <> "\"" + H.note_ $ "whereas it was expected to be \"" <> T.unpack key <> "\"->\"" <> T.unpack value <> "\"" + H.failure Object _ -> failWrongType "object" - Array _ -> failWrongType "array" + Array _ -> failWrongType "array" Number _ -> failWrongType "number" - Bool _ -> failWrongType "bool" - Null -> failWrongType "null" - where - failWrongType got = do - H.note_ $ "JSON file at " <> file <> " has wrong type for key: \"" <> T.unpack key <> "\"" - H.note_ $ "Expected string but got: " <> got - H.failure - + Bool _ -> failWrongType "bool" + Null -> failWrongType "null" + where + failWrongType got = do + H.note_ $ "JSON file at " <> file <> " has wrong type for key: \"" <> T.unpack key <> "\"" + H.note_ $ "Expected string but got: " <> got + H.failure -- | @assertEqualModuloDesc file1 file2@ loads @file1@ and @file2@ from disk, -- then it strips the field @description@ from the loaded content, and finally compare @@ -128,23 +139,27 @@ assertHasMapping file obj key value = GHC.withFrozenCallStack $ do -- Required, because command @"key" "verification-key"@ generates keys without descriptions. -- Note that it would be better to write descriptions, see: -- https://github.com/IntersectMBO/cardano-cli/issues/429#issuecomment-2003880575 -assertEqualModuloDesc :: () +assertEqualModuloDesc + :: () => (HasCallStack, MonadIO m, MonadTest m) - => FilePath -- ^ The file of the first generated verification key - -> FilePath -- ^ The file of the second generated verification key, i.e. the one - -- generated by calling "key verification-key" + => FilePath + -- ^ The file of the first generated verification key + -> FilePath + -- ^ The file of the second generated verification key, i.e. the one + -- generated by calling "key verification-key" -> m () -assertEqualModuloDesc file1 file2 = GHC.withFrozenCallStack $ do - value1 <- H.readJsonFileOk @Value file1 - value1' <- removeDescription value1 +assertEqualModuloDesc file1 file2 = GHC.withFrozenCallStack $ do + value1 <- H.readJsonFileOk @Value file1 + value1' <- removeDescription value1 - value2 <- H.readJsonFileOk @Value file2 - value2' <- removeDescription value2 + value2 <- H.readJsonFileOk @Value file2 + value2' <- removeDescription value2 - value1' H.=== value2' + value1' H.=== value2' -- | Removes the @description@ field from a JSON object. -removeDescription :: () +removeDescription + :: () => (HasCallStack, MonadTest m) => Value -> m Value @@ -152,12 +167,12 @@ removeDescription v = case v of Object inner -> return $ Object $ Aeson.KeyMap.delete (Aeson.fromText "description") inner - Array _ -> failWrongType "array" + Array _ -> failWrongType "array" Number _ -> failWrongType "number" - Bool _ -> failWrongType "bool" + Bool _ -> failWrongType "bool" String _ -> failWrongType "string" - Null -> failWrongType "null" - where - failWrongType got = do - H.note_ $ "Expected object but got: " <> got - H.failure + Null -> failWrongType "null" + where + failWrongType got = do + H.note_ $ "Expected object but got: " <> got + H.failure diff --git a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs index 64c613a30c..d73125d966 100644 --- a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs +++ b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Util.hs @@ -16,12 +16,12 @@ module Test.Cardano.CLI.Util , withSnd , noteInputFile , noteTempFile - , redactJsonField , bracketSem , FileSem , newFileSem - ) where + ) +where import Cardano.Api @@ -62,7 +62,6 @@ import qualified Hedgehog.Internal.Property as H import Hedgehog.Internal.Show (ValueDiff (ValueSame), mkValue, showPretty, valueDiff) import Hedgehog.Internal.Source (getCaller) - -- | Execute cardano-cli via the command line. -- -- Waits for the process to finish and returns the stdout. @@ -98,10 +97,11 @@ procFlex' -- ^ Captured stdout procFlex' execConfig pkg binaryEnv arguments = GHC.withFrozenCallStack . H.evalM $ do bin <- H.binFlex pkg binaryEnv - return (IO.proc bin arguments) - { IO.env = getLast $ execConfigEnv execConfig - , IO.cwd = getLast $ execConfigCwd execConfig - } + return + (IO.proc bin arguments) + { IO.env = getLast $ execConfigEnv execConfig + , IO.cwd = getLast $ execConfigCwd execConfig + } execDetailFlex :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) @@ -146,29 +146,32 @@ checkTextEnvelopeFormat tve reference created = GHC.withFrozenCallStack $ do createdTextEnvelope <- handleTextEnvelope eCreatedTextEnvelope typeTitleEquivalence refTextEnvelope createdTextEnvelope - where - handleTextEnvelope :: MonadTest m - => Either (FileError TextEnvelopeError) TextEnvelope - -> m TextEnvelope - handleTextEnvelope = \case - Right refTextEnvelope -> - return refTextEnvelope - Left fileErr -> - failWithCustom GHC.callStack Nothing . (docToString . prettyError) $ fileErr - - typeTitleEquivalence :: (MonadTest m, HasCallStack) => TextEnvelope -> TextEnvelope -> m () - typeTitleEquivalence (TextEnvelope refType refTitle _) - (TextEnvelope createdType createdTitle _) = GHC.withFrozenCallStack $ do + where + handleTextEnvelope + :: MonadTest m + => Either (FileError TextEnvelopeError) TextEnvelope + -> m TextEnvelope + handleTextEnvelope = \case + Right refTextEnvelope -> + return refTextEnvelope + Left fileErr -> + failWithCustom GHC.callStack Nothing . (docToString . prettyError) $ fileErr + + typeTitleEquivalence :: (MonadTest m, HasCallStack) => TextEnvelope -> TextEnvelope -> m () + typeTitleEquivalence + (TextEnvelope refType refTitle _) + (TextEnvelope createdType createdTitle _) = GHC.withFrozenCallStack $ do equivalence refType createdType equivalence refTitle createdTitle checkTxCddlFormat :: (MonadTest m, MonadIO m, HasCallStack) - => FilePath -- ^ Reference/golden file - -> FilePath -- ^ Newly created file + => FilePath + -- ^ Reference/golden file + -> FilePath + -- ^ Newly created file -> m () checkTxCddlFormat referencePath createdPath = do - fileExists <- liftIO $ IO.doesFileExist referencePath if fileExists @@ -178,19 +181,21 @@ checkTxCddlFormat referencePath createdPath = do r <- H.evalIO $ readCddlTx reference c <- H.evalIO $ readCddlTx created r H.=== c - else if createFiles - then do - -- CREATE_GOLDEN_FILES is set, so we create any golden files that don't - -- already exist. - H.note_ $ "Creating golden file " <> referencePath - H.createDirectoryIfMissing_ (takeDirectory referencePath) - H.readFile createdPath >>= H.writeFile referencePath - else do - H.note_ $ mconcat - [ "Golden file " <> referencePath - , " does not exist. To create, run with CREATE_GOLDEN_FILES=1" - ] - H.failure + else + if createFiles + then do + -- CREATE_GOLDEN_FILES is set, so we create any golden files that don't + -- already exist. + H.note_ $ "Creating golden file " <> referencePath + H.createDirectoryIfMissing_ (takeDirectory referencePath) + H.readFile createdPath >>= H.writeFile referencePath + else do + H.note_ $ + mconcat + [ "Golden file " <> referencePath + , " does not exist. To create, run with CREATE_GOLDEN_FILES=1" + ] + H.failure -- | Whether the test should create the golden files if the file does ont exist. createFiles :: Bool @@ -204,7 +209,6 @@ assertDirectoryMissing dir = GHC.withFrozenCallStack $ do exists <- H.evalIO $ IO.doesDirectoryExist dir when exists $ H.failWithCustom GHC.callStack Nothing (dir <> " should not have been created.") - -------------------------------------------------------------------------------- -- Helpers, Error rendering & Clean up -------------------------------------------------------------------------------- @@ -232,7 +236,7 @@ withSnd f a = (a, f a) -- These were lifted from hedgehog and slightly modified propertyOnce :: H.PropertyT IO () -> H.Property -propertyOnce = H.withTests 1 . H.withShrinks 0 . H.property +propertyOnce = H.withTests 1 . H.withShrinks 0 . H.property -- | Check for equivalence between two types and perform a file cleanup on failure. equivalence @@ -258,25 +262,32 @@ failDiffCustom cS x y = Nothing -> GHC.withFrozenCallStack $ failWithCustom cS Nothing $ - Prelude.unlines [ - "Failed" - , "━━ lhs ━━" - , showPretty x - , "━━ rhs ━━" - , showPretty y - ] - + Prelude.unlines + [ "Failed" + , "━━ lhs ━━" + , showPretty x + , "━━ rhs ━━" + , showPretty y + ] Just vdiff@(ValueSame _) -> GHC.withFrozenCallStack $ - failWithCustom cS (Just $ - H.Diff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff) "" - + failWithCustom + cS + ( Just $ + H.Diff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff + ) + "" Just vdiff -> GHC.withFrozenCallStack $ - failWithCustom cS (Just $ - H.Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) "" - -redactJsonField :: () + failWithCustom + cS + ( Just $ + H.Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff + ) + "" + +redactJsonField + :: () => MonadTest m => MonadIO m => HasCallStack @@ -299,7 +310,6 @@ redactJsonField fieldName replacement sourceFilePath targetFilePath = GHC.withFr v -> pure v H.evalIO $ LBS.writeFile targetFilePath (Aeson.encodePretty redactedJson) - -- | A file semaphore protecting against a concurrent path access data FileSem = FileSem !FilePath !QSem @@ -314,17 +324,22 @@ deriving via (ShowOf FileSem) instance Pretty FileSem -- createTestnetDataOutSem = newFileSem "test/cardano-cli-golden/files/golden/conway/create-testnet-data.out" -- {-# NOINLINE createTestnetDataOutSem #-} -- @ -newFileSem :: FilePath -- ^ path to be guarded by a semaphore allowing only one concurrent to access it - -> FileSem +newFileSem + :: FilePath + -- ^ path to be guarded by a semaphore allowing only one concurrent to access it + -> FileSem newFileSem fp = unsafePerformIO $ FileSem fp <$> newQSem 1 {-# INLINE newFileSem #-} -- | Run action acquiring a semaphore, and releasing afterwards. Guards against concurrent access to -- a block of code. -bracketSem :: MonadBaseControl IO m - => FileSem -- ^ a file semaphore - -> (FilePath -> m c) -- ^ an action, a file path will be extracted from the semaphore - -> m c +bracketSem + :: MonadBaseControl IO m + => FileSem + -- ^ a file semaphore + -> (FilePath -> m c) + -- ^ an action, a file path will be extracted from the semaphore + -> m c bracketSem (FileSem path semaphore) act = bracket_ (liftBase $ waitQSem semaphore) (liftBase $ signalQSem semaphore) $ act path diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs index 8dc4868d25..e6658ebed7 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/AddCostModels.hs @@ -23,10 +23,10 @@ hprop_roundtrip_Alonzo_addCostModelsToEraBasedProtocolParametersUpdate = cmdl (flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsAlonzo) ppu) getCostModels - where - getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels - getCostModels (AlonzoEraBasedProtocolParametersUpdate _ _ AlonzoOnwardsPParams {alCostModels = SJust cmdls} _) = Just cmdls - getCostModels _ = Nothing + where + getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels + getCostModels (AlonzoEraBasedProtocolParametersUpdate _ _ AlonzoOnwardsPParams{alCostModels = SJust cmdls} _) = Just cmdls + getCostModels _ = Nothing hprop_roundtrip_Babbage_addCostModelsToEraBasedProtocolParametersUpdate :: Property hprop_roundtrip_Babbage_addCostModelsToEraBasedProtocolParametersUpdate = @@ -37,10 +37,10 @@ hprop_roundtrip_Babbage_addCostModelsToEraBasedProtocolParametersUpdate = cmdl (flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsBabbage) ppu) getCostModels - where - getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels - getCostModels (BabbageEraBasedProtocolParametersUpdate _ AlonzoOnwardsPParams {alCostModels = SJust cmdls} _ _) = Just cmdls - getCostModels _ = Nothing + where + getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels + getCostModels (BabbageEraBasedProtocolParametersUpdate _ AlonzoOnwardsPParams{alCostModels = SJust cmdls} _ _) = Just cmdls + getCostModels _ = Nothing hprop_roundtrip_Conway_addCostModelsToEraBasedProtocolParametersUpdate :: Property hprop_roundtrip_Conway_addCostModelsToEraBasedProtocolParametersUpdate = @@ -51,7 +51,7 @@ hprop_roundtrip_Conway_addCostModelsToEraBasedProtocolParametersUpdate = cmdl (flip (addCostModelsToEraBasedProtocolParametersUpdate AlonzoEraOnwardsConway) ppu) getCostModels - where - getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels - getCostModels (ConwayEraBasedProtocolParametersUpdate _ AlonzoOnwardsPParams {alCostModels = SJust cmdls} _ _) = Just cmdls - getCostModels _ = Nothing + where + getCostModels :: EraBasedProtocolParametersUpdate era -> Maybe Alonzo.CostModels + getCostModels (ConwayEraBasedProtocolParametersUpdate _ AlonzoOnwardsPParams{alCostModels = SJust cmdls} _ _) = Just cmdls + getCostModels _ = Nothing diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs index db44fe0ace..b7cc44f4a9 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs @@ -29,16 +29,20 @@ import qualified Hedgehog.Extras as H hprop_create_testnet_data_minimal :: Property hprop_create_testnet_data_minimal = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do - let outputDir = tempDir "out" -- We test that the command doesn't crash, because otherwise -- execCardanoCLI would fail. - H.noteM_ $ execCardanoCLI - ["conway", "genesis", "create-testnet-data" - , "--testnet-magic", "42" - , "--out-dir", outputDir - ] + H.noteM_ $ + execCardanoCLI + [ "conway" + , "genesis" + , "create-testnet-data" + , "--testnet-magic" + , "42" + , "--out-dir" + , outputDir + ] success -- Execute this test with: @@ -55,51 +59,66 @@ hprop_create_testnet_data_create_nonegative_supply = do , (1_000_000_000, 1_000_000_001, ExitFailure 1) , (1_000_000_000, 1_100_000_001, ExitFailure 1) , (1_000_000_000, 2_000_000_000, ExitFailure 1) - ] :: [(Int, Int, ExitCode)] + ] + :: [(Int, Int, ExitCode)] propertyOnce $ forM_ supplyValues $ \(totalSupply, delegatedSupply, expectedExitCode) -> moduleWorkspace "tmp" $ \tempDir -> do let outputDir = tempDir "out" - (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI - ["conway", "genesis", "create-testnet-data" - , "--testnet-magic", "42" - , "--pools", "3" - , "--total-supply", show totalSupply - , "--delegated-supply", show delegatedSupply - , "--stake-delegators", "3" - , "--utxo-keys", "3" - , "--drep-keys", "3" - , "--out-dir", outputDir - ] + (exitCode, _stdout, stderr) <- + H.noteShowM $ + execDetailCardanoCLI + [ "conway" + , "genesis" + , "create-testnet-data" + , "--testnet-magic" + , "42" + , "--pools" + , "3" + , "--total-supply" + , show totalSupply + , "--delegated-supply" + , show delegatedSupply + , "--stake-delegators" + , "3" + , "--utxo-keys" + , "3" + , "--drep-keys" + , "3" + , "--out-dir" + , outputDir + ] H.note_ "check that exit code is equal to the expected one" exitCode === expectedExitCode if exitCode == ExitSuccess - then do - testGenesis@TestGenesis{maxLovelaceSupply, initialFunds} <- H.leftFailM . H.readJsonFile $ outputDir "shelley-genesis.json" - H.note_ $ show testGenesis - - H.note_ "check that max lovelace supply is set equal to --total-supply flag value" - maxLovelaceSupply === totalSupply - - H.note_ "check that all initial funds are positive" - H.assertWith initialFunds $ all (>= 0) . M.elems - - H.note_ "check that initial funds are not bigger than max lovelace supply" - H.assertWith initialFunds $ \initialFunds' -> do - let totalDistributed = sum . M.elems $ initialFunds' - totalDistributed <= maxLovelaceSupply - else do - H.assertWith stderr (`contains` "delegated supply should be less or equal to the total supply") - where - contains s1 s2 = s2 `isInfixOf` s1 + then do + testGenesis@TestGenesis{maxLovelaceSupply, initialFunds} <- + H.leftFailM . H.readJsonFile $ outputDir "shelley-genesis.json" + H.note_ $ show testGenesis + + H.note_ "check that max lovelace supply is set equal to --total-supply flag value" + maxLovelaceSupply === totalSupply + + H.note_ "check that all initial funds are positive" + H.assertWith initialFunds $ all (>= 0) . M.elems + + H.note_ "check that initial funds are not bigger than max lovelace supply" + H.assertWith initialFunds $ \initialFunds' -> do + let totalDistributed = sum . M.elems $ initialFunds' + totalDistributed <= maxLovelaceSupply + else do + H.assertWith stderr (`contains` "delegated supply should be less or equal to the total supply") + where + contains s1 s2 = s2 `isInfixOf` s1 data TestGenesis = TestGenesis { maxLovelaceSupply :: Int , initialFunds :: Map Text Int - } deriving (Show, Generic, ToJSON, FromJSON) + } + deriving (Show, Generic, ToJSON, FromJSON) -- | This test tests the transient case, i.e. it writes strictly -- less things to disk than 'hprop_golden_create_testnet_data'. Execute this test with: @@ -107,18 +126,28 @@ data TestGenesis = TestGenesis hprop_create_testnet_data_transient_stake_delegators :: Property hprop_create_testnet_data_transient_stake_delegators = propertyOnce $ moduleWorkspace "tmp" $ \tempDir -> do - let outputDir = tempDir "out" - void $ execCardanoCLI ["conway", "genesis", "create-testnet-data" - , "--genesis-keys", "2" - , "--utxo-keys", "3" - , "--out-dir", outputDir - , "--testnet-magic", "623" - , "--pools", "2" - , "--transient-drep-keys", "5" - , "--transient-stake-delegators", "4" - ] + void $ + execCardanoCLI + [ "conway" + , "genesis" + , "create-testnet-data" + , "--genesis-keys" + , "2" + , "--utxo-keys" + , "3" + , "--out-dir" + , outputDir + , "--testnet-magic" + , "623" + , "--pools" + , "2" + , "--transient-drep-keys" + , "5" + , "--transient-stake-delegators" + , "4" + ] H.note_ "check that DRep key folder was not created" assertDirectoryMissing (outputDir "drep-keys") @@ -126,5 +155,5 @@ hprop_create_testnet_data_transient_stake_delegators = H.note_ "check that stake delegator key folder was not created" assertDirectoryMissing (outputDir "stake-delegators") - -- For the golden part of this test, we are anyway covered by 'hprop_golden_create_testnet_data' - -- that generates strictly more stuff. +-- For the golden part of this test, we are anyway covered by 'hprop_golden_create_testnet_data' +-- that generates strictly more stuff. diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs index 8dc5620628..9650adf735 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/FilePermissions.hs @@ -2,7 +2,8 @@ module Test.Cli.FilePermissions ( hprop_createVRFSigningKeyFilePermissions - ) where + ) +where import Cardano.Api import Cardano.Api.IO (checkVrfFilePermissions) @@ -25,16 +26,21 @@ hprop_createVRFSigningKeyFilePermissions = vrfSignKey <- H.noteTempFile tempDir "VRF-signing-key-file" -- Create VRF key pair - void $ execCardanoCLI - [ "node", "key-gen-VRF" - , "--verification-key-file", vrfVerKey - , "--signing-key-file", vrfSignKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-VRF" + , "--verification-key-file" + , vrfVerKey + , "--signing-key-file" + , vrfSignKey + ] result <- liftIO . runExceptT $ checkVrfFilePermissions (File vrfSignKey) case result of Left err -> - failWith Nothing - $ "key-gen-VRF cli command created a VRF signing key \ - \file with the wrong permissions: " <> show err + failWith Nothing $ + "key-gen-VRF cli command created a VRF signing key \ + \file with the wrong permissions: " + <> show err Right () -> success diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/DRep.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/DRep.hs index 743c8994d5..ca119240d0 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/DRep.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/DRep.hs @@ -1,4 +1,3 @@ - {- HLINT ignore "Use camelCase" -} module Test.Cli.Governance.DRep where @@ -11,9 +10,11 @@ import Hedgehog import qualified Hedgehog.Extras.Test.Base as H metadataUrls :: [String] -metadataUrls = [ "dummy-url" - , "length-84-here-we-goooooooooooooooooooooooooooooooooooooooooooooooooooooo-dummy-url" - , "exactly-128-chars-here-we-goooooooooooooooooooooooooooooooooooooooooooooooooooooo-dummy-url-ooooooooooooooooooooooooooooooooooo" ] +metadataUrls = + [ "dummy-url" + , "length-84-here-we-goooooooooooooooooooooooooooooooooooooooooooooooooooooo-dummy-url" + , "exactly-128-chars-here-we-goooooooooooooooooooooooooooooooooooooooooooooooooooooo-dummy-url-ooooooooooooooooooooooooooooooooooo" + ] -- | This is a test of https://github.com/IntersectMBO/cardano-cli/issues/552 -- Execute me with: @@ -24,14 +25,23 @@ hprop_governance_drep_registration_certificate_script_hash = H.moduleWorkspace "tmp" $ \tempDir -> do outFile <- H.noteTempFile tempDir "drep-reg-cert.txt" - H.noteShowM_ $ execCardanoCLI - [ "conway", "governance", "drep", "registration-certificate" - , "--drep-script-hash", "00000000000000000000000000000000000000000000000000000003" - , "--key-reg-deposit-amt", "0" - , "--drep-metadata-url", metadataUrl - , "--drep-metadata-hash", "52e69500a92d80f2126c836a4903dc582006709f004cf7a28ed648f732dff8d2" - , "--out-file", outFile - ] + H.noteShowM_ $ + execCardanoCLI + [ "conway" + , "governance" + , "drep" + , "registration-certificate" + , "--drep-script-hash" + , "00000000000000000000000000000000000000000000000000000003" + , "--key-reg-deposit-amt" + , "0" + , "--drep-metadata-url" + , metadataUrl + , "--drep-metadata-hash" + , "52e69500a92d80f2126c836a4903dc582006709f004cf7a28ed648f732dff8d2" + , "--out-file" + , outFile + ] -- | This is a test of https://github.com/IntersectMBO/cardano-cli/issues/552 -- Execute me with: @@ -43,18 +53,32 @@ hprop_governance_drep_update_certificate_vkey_file = drepVKeyFile <- H.noteTempFile tempDir "drep.vkey" drepSKeyFile <- H.noteTempFile tempDir "drep.skey" - H.noteShowM_ $ execCardanoCLI - [ "conway", "governance", "drep", "key-gen" - , "--verification-key-file", drepVKeyFile - , "--signing-key-file", drepSKeyFile - ] + H.noteShowM_ $ + execCardanoCLI + [ "conway" + , "governance" + , "drep" + , "key-gen" + , "--verification-key-file" + , drepVKeyFile + , "--signing-key-file" + , drepSKeyFile + ] outFile <- H.noteTempFile tempDir "drep-upd-cert.txt" - H.noteShowM_ $ execCardanoCLI - [ "conway", "governance", "drep", "update-certificate" - , "--drep-verification-key-file", drepVKeyFile - , "--drep-metadata-url", metadataUrl - , "--drep-metadata-hash", "52e69500a92d80f2126c836a4903dc582006709f004cf7a28ed648f732dff8d2" - , "--out-file", outFile - ] + H.noteShowM_ $ + execCardanoCLI + [ "conway" + , "governance" + , "drep" + , "update-certificate" + , "--drep-verification-key-file" + , drepVKeyFile + , "--drep-metadata-url" + , metadataUrl + , "--drep-metadata-hash" + , "52e69500a92d80f2126c836a4903dc582006709f004cf7a28ed648f732dff8d2" + , "--out-file" + , outFile + ] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/Hash.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/Hash.hs index c887b17698..6106d27cee 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/Hash.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Governance/Hash.hs @@ -16,21 +16,32 @@ import qualified Hedgehog.Extras as H -- @cabal test cardano-cli-test --test-options '-p "/governance committee key hash/"'@ hprop_governance_committee_key_hash :: Property hprop_governance_committee_key_hash = - let supplyValues = [ "key-gen-cold", "key-gen-hot" ] in - propertyOnce $ forM_ supplyValues $ \flag -> - H.moduleWorkspace "tmp" $ \tempDir -> do - verificationKeyFile <- noteTempFile tempDir "key-gen.vkey" - signingKeyFile <- noteTempFile tempDir "key-gen.skey" - - void $ execCardanoCLI - [ "conway", "governance", "committee", flag - , "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - ] - - result <- execCardanoCLI - [ "conway", "governance", "committee", "key-hash" - , "--verification-key-file", verificationKeyFile - ] - - H.assert $ result =~ id @String "^[a-f0-9]{56}$" + let supplyValues = ["key-gen-cold", "key-gen-hot"] + in propertyOnce $ forM_ supplyValues $ \flag -> + H.moduleWorkspace "tmp" $ \tempDir -> do + verificationKeyFile <- noteTempFile tempDir "key-gen.vkey" + signingKeyFile <- noteTempFile tempDir "key-gen.skey" + + void $ + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , flag + , "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + ] + + result <- + execCardanoCLI + [ "conway" + , "governance" + , "committee" + , "key-hash" + , "--verification-key-file" + , verificationKeyFile + ] + + H.assert $ result =~ id @String "^[a-f0-9]{56}$" diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/ITN.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/ITN.hs index 52d8d094bc..0d2b1af04f 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/ITN.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/ITN.hs @@ -5,7 +5,8 @@ module Test.Cli.ITN , hprop_convertITNExtendedSigningKey , hprop_convertITNKeys , hprop_golden_bech32Decode - ) where + ) +where import Cardano.CLI.EraBased.Run.Key (decodeBech32) @@ -51,17 +52,25 @@ hprop_convertITNKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do H.assertFilesExist [itnVerKeyFp, itnSignKeyFp] -- Generate haskell stake verification key - void $ execCardanoCLI - [ "key","convert-itn-key" - , "--itn-verification-key-file", itnVerKeyFp - , "--out-file", outputHaskellVerKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-itn-key" + , "--itn-verification-key-file" + , itnVerKeyFp + , "--out-file" + , outputHaskellVerKeyFp + ] -- Generate haskell signing key - void $ execCardanoCLI - [ "key","convert-itn-key" - , "--itn-signing-key-file", itnSignKeyFp - , "--out-file", outputHaskellSignKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-itn-key" + , "--itn-signing-key-file" + , itnSignKeyFp + , "--out-file" + , outputHaskellSignKeyFp + ] -- Check for existence of the converted ITN keys H.assertFilesExist [outputHaskellVerKeyFp, outputHaskellSignKeyFp] @@ -69,10 +78,11 @@ hprop_convertITNKeys = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do -- | 1. Convert a bech32 ITN extended signing key to a haskell stake signing key hprop_convertITNExtendedSigningKey :: Property hprop_convertITNExtendedSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - let itnExtendedSignKey = mconcat - [ "ed25519e_sk1qpcplz38tg4fusw0fkqljzspe9qmj06ldu9lgcve99v4fphuk9a535kwj" - , "f38hkyn0shcycyaha4k9tmjy6xgvzaz7stw5t7rqjadyjcwfyx6k" - ] + let itnExtendedSignKey = + mconcat + [ "ed25519e_sk1qpcplz38tg4fusw0fkqljzspe9qmj06ldu9lgcve99v4fphuk9a535kwj" + , "f38hkyn0shcycyaha4k9tmjy6xgvzaz7stw5t7rqjadyjcwfyx6k" + ] -- ITN input file paths itnSignKeyFp <- noteTempFile tempDir "itnExtendedSignKey.key" @@ -85,11 +95,15 @@ hprop_convertITNExtendedSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \t H.assertFilesExist [itnSignKeyFp] -- Generate haskell signing key - void $ execCardanoCLI - [ "key","convert-itn-extended-key" - , "--itn-signing-key-file", itnSignKeyFp - , "--out-file", outputHaskellSignKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-itn-extended-key" + , "--itn-signing-key-file" + , itnSignKeyFp + , "--out-file" + , outputHaskellSignKeyFp + ] -- Check for existence of the converted ITN keys H.assertFilesExist [outputHaskellSignKeyFp] @@ -97,11 +111,12 @@ hprop_convertITNExtendedSigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \t -- | 1. Convert a bech32 ITN BIP32 signing key to a haskell stake signing key hprop_convertITNBIP32SigningKey :: Property hprop_convertITNBIP32SigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do - let itnExtendedSignKey = mconcat - [ "xprv1spkw5suj39723c40mr55gwh7j3vryjv2zdm4e47xs0deka" - , "jcza9ud848ckdqf48md9njzc5pkujfxwu2j8wdvtxkx02n3s2qa" - , "euhqnfx6zu9dyccpua6vf5x3kur9hsganq2kl0yw7y9hpunts0e9kc5xv3pz0yj" - ] + let itnExtendedSignKey = + mconcat + [ "xprv1spkw5suj39723c40mr55gwh7j3vryjv2zdm4e47xs0deka" + , "jcza9ud848ckdqf48md9njzc5pkujfxwu2j8wdvtxkx02n3s2qa" + , "euhqnfx6zu9dyccpua6vf5x3kur9hsganq2kl0yw7y9hpunts0e9kc5xv3pz0yj" + ] -- ITN input file paths itnSignKeyFp <- noteTempFile tempDir "itnBIP32SignKey.key" @@ -115,11 +130,15 @@ hprop_convertITNBIP32SigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \temp H.assertFilesExist [itnSignKeyFp] -- Generate haskell signing key - void $ execCardanoCLI - [ "key","convert-itn-bip32-key" - , "--itn-signing-key-file", itnSignKeyFp - , "--out-file", outputHaskellSignKeyFp - ] + void $ + execCardanoCLI + [ "key" + , "convert-itn-bip32-key" + , "--itn-signing-key-file" + , itnSignKeyFp + , "--out-file" + , outputHaskellSignKeyFp + ] -- Check for existence of the converted ITN keys H.assertFilesExist [outputHaskellSignKeyFp] @@ -128,10 +147,10 @@ hprop_convertITNBIP32SigningKey = propertyOnce . H.moduleWorkspace "tmp" $ \temp -- using 'itnVerKey' & 'itnSignKey' as inputs. hprop_golden_bech32Decode :: Property hprop_golden_bech32Decode = propertyOnce $ do - (vHumReadPart, vDataPart , _) <- H.evalEither $ decodeBech32 itnVerKey + (vHumReadPart, vDataPart, _) <- H.evalEither $ decodeBech32 itnVerKey Just vDataPartBase16 <- pure (dataPartToBase16 vDataPart) - (sHumReadPart, sDataPart , _) <- H.evalEither $ decodeBech32 itnSignKey + (sHumReadPart, sDataPart, _) <- H.evalEither $ decodeBech32 itnSignKey Just sDataPartBase16 <- pure (dataPartToBase16 sDataPart) -- Based on https://slowli.github.io/bech32-buffer/ which are in Base16 @@ -142,13 +161,11 @@ hprop_golden_bech32Decode = propertyOnce $ do -- ITN Verification key decode check expectedHumanReadPartVerificationKey === Bech32.humanReadablePartToText vHumReadPart - expectedDataPartVerificationKey === vDataPartBase16 - + expectedDataPartVerificationKey === vDataPartBase16 -- ITN Signing key decode check expectedHumanReadPartSigningKey === Bech32.humanReadablePartToText sHumReadPart expectedDataPartSigningKey === sDataPartBase16 - - where - dataPartToBase16 :: Bech32.DataPart -> Maybe ByteString - dataPartToBase16 = fmap Base16.encode . Bech32.dataPartToBytes + where + dataPartToBase16 :: Bech32.DataPart -> Maybe ByteString + dataPartToBase16 = fmap Base16.encode . Bech32.dataPartToBytes diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs index 1e1f448d45..daad72d4c6 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/JSON.hs @@ -4,7 +4,8 @@ module Test.Cli.JSON ( hprop_json_roundtrip_delegations_and_rewards , hprop_roundtrip_kes_period_info_output_JSON - ) where + ) +where import Cardano.Api.Shelley diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/MonadWarning.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/MonadWarning.hs index 144ced8780..871689de6c 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/MonadWarning.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/MonadWarning.hs @@ -1,6 +1,7 @@ module Test.Cli.MonadWarning ( hprop_monad_warning - ) where + ) +where import Cardano.CLI.Types.MonadWarning (MonadWarning, reportIssue, runWarningStateT) @@ -13,14 +14,14 @@ hprop_monad_warning :: Property hprop_monad_warning = property $ do (-8, [warning]) === duplicateNumber (-4) (4, []) === duplicateNumber 2 - where - duplicateNumber :: Int -> (Int, [String]) - duplicateNumber n = runState (runWarningStateT $ computeWithWarning n :: State [String] Int) [] + where + duplicateNumber :: Int -> (Int, [String]) + duplicateNumber n = runState (runWarningStateT $ computeWithWarning n :: State [String] Int) [] - computeWithWarning :: (MonadWarning m) => Int -> m Int - computeWithWarning x = do - when (x < 0) $ reportIssue warning - return (x * 2) + computeWithWarning :: MonadWarning m => Int -> m Int + computeWithWarning x = do + when (x < 0) $ reportIssue warning + return (x * 2) - warning :: String - warning = "Input value is negative!" + warning :: String + warning = "Input value is negative!" diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise1.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise1.hs index f46dbc6d80..fb012aae3e 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise1.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise1.hs @@ -3,7 +3,8 @@ module Test.Cli.Pioneers.Exercise1 ( hprop_buildShelleyPaymentAddress , hprop_buildShelleyStakeAddress - ) where + ) +where import Control.Monad (void) @@ -23,20 +24,27 @@ hprop_buildShelleyPaymentAddress = propertyOnce . H.moduleWorkspace "tmp" $ \tem signKey <- noteTempFile tempDir "payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] H.assertFilesExist [verKey, signKey] -- Build shelley payment address - void $ execCardanoCLI - [ "address", "build" - , "--payment-verification-key-file", verKey - , "--mainnet" - ] + void $ + execCardanoCLI + [ "address" + , "build" + , "--payment-verification-key-file" + , verKey + , "--mainnet" + ] -- | 1. We generate a key payment pair -- 2. We generate a staking key pair @@ -52,25 +60,37 @@ hprop_buildShelleyStakeAddress = propertyOnce . H.moduleWorkspace "tmp" $ \tempD paymentSignKey <- noteTempFile tempDir "payment-signing-key-file" -- Generate payment verification key - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", paymentVerKey - , "--signing-key-file", paymentSignKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , paymentVerKey + , "--signing-key-file" + , paymentSignKey + ] -- Generate stake verification key - void $ execCardanoCLI - [ "stake-address","key-gen" - , "--verification-key-file", stakeVerKey - , "--signing-key-file", stakeSignKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , stakeVerKey + , "--signing-key-file" + , stakeSignKey + ] H.assertFilesExist [stakeVerKey, stakeSignKey, paymentVerKey, paymentSignKey] -- Build shelley stake address - void $ execCardanoCLI - [ "address", "build" - , "--payment-verification-key-file", paymentVerKey - , "--stake-verification-key-file", stakeVerKey - , "--mainnet" - ] + void $ + execCardanoCLI + [ "address" + , "build" + , "--payment-verification-key-file" + , paymentVerKey + , "--stake-verification-key-file" + , stakeVerKey + , "--mainnet" + ] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise2.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise2.hs index 77f1ef815a..7b756d4373 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise2.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise2.hs @@ -2,7 +2,8 @@ module Test.Cli.Pioneers.Exercise2 ( hprop_createTransaction - ) where + ) +where import Control.Monad (void) @@ -24,36 +25,55 @@ hprop_createTransaction = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> d transactionFile <- noteTempFile tempDir "transaction-file" -- Generate payment signing key to sign transaction - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", paymentVerKey - , "--signing-key-file", paymentSignKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , paymentVerKey + , "--signing-key-file" + , paymentSignKey + ] H.assertFilesExist [paymentVerKey, paymentSignKey] -- Create transaction body - void $ execCardanoCLI - [ "transaction", "build-raw" - , "--tx-in", "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" - , "--auxiliary-script-file", "test/cardano-cli-test/files/input/shelley/multisig/scripts/all" - , "--tx-in", "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" - , "--auxiliary-script-file", "test/cardano-cli-test/files/input/shelley/multisig/scripts/all" - , "--tx-out", "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3+100000000" - , "--fee", "1000000" - , "--invalid-hereafter", "500000" - , "--out-file", transactionBodyFile - ] + void $ + execCardanoCLI + [ "transaction" + , "build-raw" + , "--tx-in" + , "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" + , "--auxiliary-script-file" + , "test/cardano-cli-test/files/input/shelley/multisig/scripts/all" + , "--tx-in" + , "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" + , "--auxiliary-script-file" + , "test/cardano-cli-test/files/input/shelley/multisig/scripts/all" + , "--tx-out" + , "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3+100000000" + , "--fee" + , "1000000" + , "--invalid-hereafter" + , "500000" + , "--out-file" + , transactionBodyFile + ] H.assertFilesExist [transactionBodyFile] -- Sign transaction - void $ execCardanoCLI - [ "transaction", "sign" - , "--tx-body-file", transactionBodyFile - , "--signing-key-file", paymentSignKey - , "--mainnet" - , "--out-file", transactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--tx-body-file" + , transactionBodyFile + , "--signing-key-file" + , paymentSignKey + , "--mainnet" + , "--out-file" + , transactionFile + ] H.assertFilesExist [paymentVerKey, paymentSignKey, transactionBodyFile, transactionFile] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise3.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise3.hs index f51ff3091e..4847b8d064 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise3.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise3.hs @@ -2,7 +2,8 @@ module Test.Cli.Pioneers.Exercise3 ( hprop_createOperationalCertificate - ) where + ) +where import Control.Monad (void) @@ -27,32 +28,49 @@ hprop_createOperationalCertificate = propertyOnce . H.moduleWorkspace "tmp" $ \t operationalCert <- noteTempFile tempDir "operational-certificate-file" -- Create KES key pair - void $ execCardanoCLI - [ "node","key-gen-KES" - , "--verification-key-file", kesVerKey - , "--signing-key-file", kesSignKey - ] + void $ + execCardanoCLI + [ "node" + , "key-gen-KES" + , "--verification-key-file" + , kesVerKey + , "--signing-key-file" + , kesSignKey + ] H.assertFilesExist [kesSignKey, kesVerKey] -- Create cold key pair - void $ execCardanoCLI - [ "node","key-gen" - , "--cold-verification-key-file", coldVerKey - , "--cold-signing-key-file", coldSignKey - , "--operational-certificate-issue-counter", operationalCertCounter - ] + void $ + execCardanoCLI + [ "node" + , "key-gen" + , "--cold-verification-key-file" + , coldVerKey + , "--cold-signing-key-file" + , coldSignKey + , "--operational-certificate-issue-counter" + , operationalCertCounter + ] H.assertFilesExist [coldVerKey, coldSignKey, operationalCertCounter] -- Create operational certificate - void $ execCardanoCLI - [ "node","issue-op-cert" - , "--kes-verification-key-file", kesVerKey - , "--cold-signing-key-file", coldSignKey - , "--operational-certificate-issue-counter", operationalCertCounter - , "--kes-period", "1000" - , "--out-file", operationalCert - ] - - H.assertFilesExist [kesVerKey, kesSignKey, coldVerKey, coldSignKey, operationalCertCounter, operationalCert] + void $ + execCardanoCLI + [ "node" + , "issue-op-cert" + , "--kes-verification-key-file" + , kesVerKey + , "--cold-signing-key-file" + , coldSignKey + , "--operational-certificate-issue-counter" + , operationalCertCounter + , "--kes-period" + , "1000" + , "--out-file" + , operationalCert + ] + + H.assertFilesExist + [kesVerKey, kesSignKey, coldVerKey, coldSignKey, operationalCertCounter, operationalCert] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise4.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise4.hs index 69d5b8c56a..860929a29f 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise4.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise4.hs @@ -2,7 +2,8 @@ module Test.Cli.Pioneers.Exercise4 ( hprop_createStakeAddressRegistrationCertificate - ) where + ) +where import Control.Monad (void) @@ -22,18 +23,27 @@ hprop_createStakeAddressRegistrationCertificate = propertyOnce . H.moduleWorkspa stakeRegCert <- noteTempFile tempDir "stake-registration-certificate-file" -- Generate stake verification key - void $ execCardanoCLI - [ "stake-address", "key-gen" - , "--verification-key-file", verKey - , "--signing-key-file", signKey - ] + void $ + execCardanoCLI + [ "stake-address" + , "key-gen" + , "--verification-key-file" + , verKey + , "--signing-key-file" + , signKey + ] H.assertFilesExist [verKey, signKey] -- Create stake address registration certificate - void $ execCardanoCLI - [ "babbage", "stake-address", "registration-certificate" - , "--stake-verification-key-file", verKey - , "--out-file", stakeRegCert - ] + void $ + execCardanoCLI + [ "babbage" + , "stake-address" + , "registration-certificate" + , "--stake-verification-key-file" + , verKey + , "--out-file" + , stakeRegCert + ] H.assertFilesExist [verKey, signKey, stakeRegCert] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise5.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise5.hs index ce7c47ae39..e6e2d1be27 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise5.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise5.hs @@ -2,7 +2,8 @@ module Test.Cli.Pioneers.Exercise5 ( hprop_createLegacyZeroTxOutTransaction - ) where + ) +where import Control.Monad (void) @@ -24,33 +25,49 @@ hprop_createLegacyZeroTxOutTransaction = propertyOnce . H.moduleWorkspace "tmp" transactionFile <- noteTempFile tempDir "transaction-file" -- Generate payment signing key to sign transaction - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", paymentVerKey - , "--signing-key-file", paymentSignKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , paymentVerKey + , "--signing-key-file" + , paymentSignKey + ] H.assertFilesExist [paymentVerKey, paymentSignKey] -- Create transaction body - void $ execCardanoCLI - [ "transaction", "build-raw" - , "--tx-in", "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" - , "--tx-out", "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3+0" - , "--fee", "1000000" - , "--invalid-hereafter", "500000" - , "--out-file", transactionBodyFile - ] + void $ + execCardanoCLI + [ "transaction" + , "build-raw" + , "--tx-in" + , "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" + , "--tx-out" + , "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3+0" + , "--fee" + , "1000000" + , "--invalid-hereafter" + , "500000" + , "--out-file" + , transactionBodyFile + ] H.assertFilesExist [transactionBodyFile] -- Sign transaction - void $ execCardanoCLI - [ "transaction", "sign" - , "--tx-body-file", transactionBodyFile - , "--signing-key-file", paymentSignKey - , "--mainnet" - , "--out-file", transactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--tx-body-file" + , transactionBodyFile + , "--signing-key-file" + , paymentSignKey + , "--mainnet" + , "--out-file" + , transactionFile + ] H.assertFilesExist [paymentVerKey, paymentSignKey, transactionBodyFile, transactionFile] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise6.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise6.hs index 83cfd8a5c8..50d1b8825a 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise6.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Pioneers/Exercise6.hs @@ -2,7 +2,8 @@ module Test.Cli.Pioneers.Exercise6 ( hprop_createZeroLovelaceTxOutTransaction - ) where + ) +where import Control.Monad (void) @@ -24,33 +25,49 @@ hprop_createZeroLovelaceTxOutTransaction = propertyOnce . H.moduleWorkspace "tmp transactionFile <- noteTempFile tempDir "transaction-file" -- Generate payment signing key to sign transaction - void $ execCardanoCLI - [ "address","key-gen" - , "--verification-key-file", paymentVerKey - , "--signing-key-file", paymentSignKey - ] + void $ + execCardanoCLI + [ "address" + , "key-gen" + , "--verification-key-file" + , paymentVerKey + , "--signing-key-file" + , paymentSignKey + ] H.assertFilesExist [paymentVerKey, paymentSignKey] -- Create transaction body - void $ execCardanoCLI - [ "transaction", "build-raw" - , "--tx-in", "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" - , "--tx-out", "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3 0 lovelace" - , "--fee", "1000000" - , "--invalid-hereafter", "500000" - , "--out-file", transactionBodyFile - ] + void $ + execCardanoCLI + [ "transaction" + , "build-raw" + , "--tx-in" + , "91999ea21177b33ebe6b8690724a0c026d410a11ad7521caa350abdafa5394c3#0" + , "--tx-out" + , "addr1v9wmu83pzajplrtpsq6tsqdgwr98x888trpmah2u0ezznsge7del3 0 lovelace" + , "--fee" + , "1000000" + , "--invalid-hereafter" + , "500000" + , "--out-file" + , transactionBodyFile + ] H.assertFilesExist [transactionBodyFile] -- Sign transaction - void $ execCardanoCLI - [ "transaction", "sign" - , "--tx-body-file", transactionBodyFile - , "--signing-key-file", paymentSignKey - , "--mainnet" - , "--out-file", transactionFile - ] + void $ + execCardanoCLI + [ "transaction" + , "sign" + , "--tx-body-file" + , transactionBodyFile + , "--signing-key-file" + , paymentSignKey + , "--mainnet" + , "--out-file" + , transactionFile + ] H.assertFilesExist [paymentVerKey, paymentSignKey, transactionBodyFile, transactionFile] diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Hash.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Hash.hs index 010bdaad18..529ea9519e 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Hash.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Hash.hs @@ -26,16 +26,23 @@ hash_trip_fun input = H.moduleWorkspace "tmp" $ \tempDir -> do hashFile <- noteTempFile tempDir "hash.txt" - hash <- execCardanoCLI - [ "hash", "anchor-data" - , "--text", input - ] - - void $ execCardanoCLI - [ "hash", "anchor-data" - , "--text", input - , "--out-file", hashFile - ] + hash <- + execCardanoCLI + [ "hash" + , "anchor-data" + , "--text" + , input + ] + + void $ + execCardanoCLI + [ "hash" + , "anchor-data" + , "--text" + , input + , "--out-file" + , hashFile + ] hashFromFile <- H.readFile hashFile diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Query.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Query.hs index aa08c56d38..2930763bca 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Query.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Run/Query.hs @@ -1,6 +1,7 @@ module Test.Cli.Shelley.Run.Query ( hprop_percentage - ) where + ) +where import qualified Cardano.CLI.EraBased.Run.Query as Q import Cardano.Slotting.Time (RelativeTime (..)) diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs index f1a7e5af24..9270456a8e 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Shelley/Transaction/Build.hs @@ -20,16 +20,27 @@ hprop_conway_transaction_build_one_voter_many_votes :: Property hprop_conway_transaction_build_one_voter_many_votes = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do outFile <- H.noteTempFile tempDir "tx.traw" - (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI - [ "conway", "transaction", "build-raw" - , "--tx-in", "6e8c947816e82627aeccb55300074f2894a2051332f62a1c8954e7b588a18be7#0" - , "--tx-out", "addr_test1vpfwv0ezc5g8a4mkku8hhy3y3vp92t7s3ul8g778g5yegsgalc6gc+24910487859" - , "--invalid-hereafter", "24325742" - , "--fee" , "178569" - , "--vote-file", inputDir "vote1.drep.json" - , "--vote-file", inputDir "vote2.drep.json" - , "--out-file", outFile - ] + (exitCode, _stdout, stderr) <- + H.noteShowM $ + execDetailCardanoCLI + [ "conway" + , "transaction" + , "build-raw" + , "--tx-in" + , "6e8c947816e82627aeccb55300074f2894a2051332f62a1c8954e7b588a18be7#0" + , "--tx-out" + , "addr_test1vpfwv0ezc5g8a4mkku8hhy3y3vp92t7s3ul8g778g5yegsgalc6gc+24910487859" + , "--invalid-hereafter" + , "24325742" + , "--fee" + , "178569" + , "--vote-file" + , inputDir "vote1.drep.json" + , "--vote-file" + , inputDir "vote2.drep.json" + , "--out-file" + , outFile + ] exitCode H.=== ExitFailure 1 H.assertWith stderr ("This would cause ignoring some of the votes" `isInfixOf`) diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/VerificationKey.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/VerificationKey.hs index 9a5cb9c62c..a63355e0e4 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/VerificationKey.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/VerificationKey.hs @@ -31,27 +31,38 @@ hprop_verification_key_committee_cold :: Property hprop_verification_key_committee_cold = propertyOnce . H.moduleWorkspace "tmp" $ runOne ["committee", "key-gen-cold"] -runOne :: () +runOne + :: () => (HasCallStack, MonadCatch m, MonadIO m, MonadTest m) - => [String] -- ^ The piece of the command to generate the keys - -> FilePath -- ^ The temporary directory, i.e. where the test is allowed to generate files + => [String] + -- ^ The piece of the command to generate the keys + -> FilePath + -- ^ The temporary directory, i.e. where the test is allowed to generate files -> m () runOne cmd tempDir = GHC.withFrozenCallStack $ do - verificationKeyFile <- noteTempFile tempDir "gen.vkey" - signingKeyFile <- noteTempFile tempDir "gen.skey" + verificationKeyFile <- noteTempFile tempDir "gen.vkey" + signingKeyFile <- noteTempFile tempDir "gen.skey" verificationKeyFileOut <- noteTempFile tempDir "vkey.out" - H.noteM_ $ execCardanoCLI $ - [ "conway", "governance" ] - ++ cmd ++ - [ "--verification-key-file", verificationKeyFile - , "--signing-key-file", signingKeyFile - ] - - H.noteM_ $ execCardanoCLI - [ "conway", "key", "verification-key" - , "--signing-key-file", signingKeyFile - , "--verification-key-file", verificationKeyFileOut - ] + H.noteM_ $ + execCardanoCLI $ + ["conway", "governance"] + ++ cmd + ++ [ "--verification-key-file" + , verificationKeyFile + , "--signing-key-file" + , signingKeyFile + ] + + H.noteM_ $ + execCardanoCLI + [ "conway" + , "key" + , "verification-key" + , "--signing-key-file" + , signingKeyFile + , "--verification-key-file" + , verificationKeyFileOut + ] assertEqualModuloDesc verificationKeyFile verificationKeyFileOut