diff --git a/cabal.project b/cabal.project index 3d76c4cc97..4a68f14979 100644 --- a/cabal.project +++ b/cabal.project @@ -16,14 +16,58 @@ index-state: -- Bump this if you need newer packages from Hackage , hackage.haskell.org 2026-05-18T17:14:36Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2026-05-18T13:56:34Z - -active-repositories: - , :rest - , cardano-haskell-packages:override + , cardano-haskell-packages 2026-05-26T09:41:58Z packages: . +-- cardano-config, part of cardano-base +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-base + tag: 8761e5c7ad09935376ec440cf33919b7544b5975 + --sha256: sha256-uMExJzjeRB3DZi27zBgfdXArxiNen4e9poavE58atuI= + subdir: + cardano-config + +-- kes-agent on branch f-f/allow-crypto-class-2.5 +source-repository-package + type: git + location: https://github.com/f-f/kes-agent.git + tag: 32c1ed675d22a30735d9f22f7afa436a3ef3e64a + --sha256: sha256-o7hFX1JnraS6Xq0WoXQwd9Z8GsPPv0Ls2DWvZ08o0ZU= + subdir: + kes-agent + kes-agent-crypto + +-- cardano-ledger on master 2026-06-18 +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger.git + tag: 8dc1c431e06db2c8b5d44fb4b3cca6419197d763 + --sha256: sha256-xKtgNFxjbJE6UWGvTioGX81NgvlKH3mHEaYMWDm8/UA= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/babbage/impl + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/vector-map + -- We want to always build the test-suites and benchmarks tests: true benchmarks: true @@ -47,13 +91,24 @@ if os (windows) constraints: tasty <1.5.4, --- ouroboros-network dependency after introducing `bracketKeepAlive` (PR#5371) +-- on f-f/allow-quickcheck-218 branch source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: e8d59d8a219563760fc21ba5bc86fab77d886742 - --sha256: sha256-ElgaE5JeDTPfyDQnyZs5ZlOdzlnZYl7z1OgkzCBJjek= + tag: 8b4dcb898b64615f574a7fbdcf119f77c7fbc598 + --sha256: sha256-t1tGV5uZwyKnSSCbaJJAteMYKnQYeO39hUUycMRuC2M= subdir: ouroboros-network cardano-diffusion network-mux + +-- plutus on branch master +source-repository-package + type: git + location: https://github.com/IntersectMBO/plutus.git + tag: b1db04cc425fab303ac3b79d7140dc2a17f29e6d + --sha256: sha256-XtYzjNVx4+IGWpgm+p/YTf56DrJtK0I98umZCTE3U80= + subdir: + plutus-core + plutus-ledger-api + plutus-tx diff --git a/cabal/newer-ghcs.cabal b/cabal/newer-ghcs.cabal index cfe1e81b96..8baeb502cb 100644 --- a/cabal/newer-ghcs.cabal +++ b/cabal/newer-ghcs.cabal @@ -81,6 +81,7 @@ if impl (ghc >= 9.14) , serialise:base , serialise:containers , serialise:time + , tdigest:base , these:base , time-compat:time , transformers:base diff --git a/changelog.d/20260528_154230_fabrizio.ferrai_node_11.1_praos_ledgerview_and_envelope_checks.md b/changelog.d/20260528_154230_fabrizio.ferrai_node_11.1_praos_ledgerview_and_envelope_checks.md new file mode 100644 index 0000000000..50f1774198 --- /dev/null +++ b/changelog.d/20260528_154230_fabrizio.ferrai_node_11.1_praos_ledgerview_and_envelope_checks.md @@ -0,0 +1,14 @@ +### Breaking + +- Renamed `Ouroboros.Consensus.Protocol.Praos.Views.LedgerView` to `PraosLedgerView`, + with the fields renamed from `lv*` to `plv*`. +- Removed `PraosEnvelopeError` from the exports of `Ouroboros.Consensus.Shelley.Protocol.Praos`. +- `EnvelopeCheckError (Praos c)` and `EnvelopeCheckError (TPraos c)` are both now + `Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks.EnvelopeError`. + +### Non-Breaking + +- Add module `Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks`; consolidates + envelope-check logic previously inlined in `Ouroboros.Consensus.Shelley.Protocol.{Praos,TPraos}`. +- Add instance for `Dijkstra` era `EraBlockHeader (Header c) era` in `Ouroboros.Consensus.Protocol.Praos.Header` +- Add `forecastToPraosLedgerView` to `Ouroboros.Consensus.Protocol.Praos.Views`. diff --git a/changelog.d/20260528_154231_fabrizio.ferrai_node_11.1_ledger_forecast_api.md b/changelog.d/20260528_154231_fabrizio.ferrai_node_11.1_ledger_forecast_api.md new file mode 100644 index 0000000000..5db90e84c9 --- /dev/null +++ b/changelog.d/20260528_154231_fabrizio.ferrai_node_11.1_ledger_forecast_api.md @@ -0,0 +1,17 @@ +### Breaking + +- Change `ShelleyBasedEra` class superclass constraints: + - change `SL.ApplyBlock era` to `SL.ApplyTick era`. + - change `SL.GetLedgerView era` to `SL.EraForecast era`. + - remove `NoThunks (PredicateFailure (EraRule "BBODY" era))`. +- `ShelleyCompatible proto era` has three new superclass constraints: + - `EncCBORGroup (SL.BlockBody era)`, + - `SL.EraBlockHeader (ShelleyProtocolHeader proto) era`, + - `SL.ApplyBlock (ShelleyProtocolHeader proto) era`. +- Remove `ShelleyCompatible (TPraos c) BabbageEra`, `ShelleyCompatible (TPraos c) ConwayEra`, + and `ShelleyCompatible (TPraos c) DijkstraEra` instances from `Ouroboros.Consensus.Shelley.HFEras`. + These eras now run under Praos only. +- Remove the `ProtocolHeaderSupportsLedger` class from `Ouroboros.Consensus.Shelley.Protocol.Abstract`. +- `LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era)` instance now requires `SL.ShelleyEraForecast era`. +- `LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era)` instance no longer requires + `ShelleyCompatible (TPraos crypto) era` and instead requires `SL.EraForecast era`. diff --git a/changelog.d/20260528_154232_fabrizio.ferrai_node_11.1_monadic_genesis_data.md b/changelog.d/20260528_154232_fabrizio.ferrai_node_11.1_monadic_genesis_data.md new file mode 100644 index 0000000000..30d378c244 --- /dev/null +++ b/changelog.d/20260528_154232_fabrizio.ferrai_node_11.1_monadic_genesis_data.md @@ -0,0 +1,5 @@ +### Breaking + +- `protocolInfoCardano`, `protocolInfoShelley` and `protocolInfoTPraosShelleyBased` + now take an additional initial argument `SomeHasFS m` and returns + inside `m`. Their callback for creating blocks also returns values in `m`. diff --git a/changelog.d/20260528_154233_fabrizio.ferrai_node_11.1_bump_lower_bounds.md b/changelog.d/20260528_154233_fabrizio.ferrai_node_11.1_bump_lower_bounds.md new file mode 100644 index 0000000000..390a46622e --- /dev/null +++ b/changelog.d/20260528_154233_fabrizio.ferrai_node_11.1_bump_lower_bounds.md @@ -0,0 +1,24 @@ +### Breaking + +- The constraint on the following functions tightens from `Applicative m` to `Monad m`: + - `Ouroboros.Consensus.Storage.ImmutableDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.LedgerDB.Args.defaultArgs` + - `Ouroboros.Consensus.Storage.VolatileDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.PerasCertDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.PerasVoteDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.ChainDB.Impl.Args.updateTracer` + - `Ouroboros.Consensus.Storage.ChainDB.Impl.fromChainDbEnv` + - `Ouroboros.Consensus.Util.Enclose.encloseWith` + - `Ouroboros.Consensus.Storage.LedgerDB.decorateReplayTracerWithGoal` + - `Ouroboros.Consensus.Storage.LedgerDB.decorateReplayTracerWithStart` +- `Ouroboros.Consensus.Network.NodeToClient.showTracers`, + `Ouroboros.Consensus.Network.NodeToNode.showTracers`, and + `Ouroboros.Consensus.Node.Tracers.showTracers` now require `Monad m`. +- Remove the `NoThunks FsPath` orphan instance from `Ouroboros.Consensus.Util.Orphans`; + it is now provided upstream by `cardano-ledger` (`Cardano.Ledger.Orphans` in + `cardano-ledger-core`). +- Remove the orphan `Measure ()` instance from + `Ouroboros.Consensus.Ledger.SupportsMempool`. +- `HasBLSContext` instances for `SIGN` and `VRF` now use `minSigPoPDST` as their base context. +- Upgrade lower bounds for Node 11.1 integration of upstream packages `cardano-base`, + `cardano-ledger`, `kes-agent`, `ouroboros-network`, `validation` diff --git a/flake.lock b/flake.lock index 9f4c5fbbb1..b2584ef224 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1779114033, - "narHash": "sha256-68Yi51Ps5hwP80M0UXw4GTROmyzRL02PEXDEYfVEB4M=", + "lastModified": 1779802675, + "narHash": "sha256-LQN0f9GBBmYMo9tQ/11EvU5tAEOhGtQnU2UP3S78cqg=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "b20f09de9ba3099e0981a3bb9145847e7e2cfc24", + "rev": "b8c7b848cdb6d08e414c37d026c300200f8c1b5b", "type": "github" }, "original": { @@ -66,23 +66,6 @@ "type": "github" } }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", - "owner": "haskell", - "repo": "cabal", - "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, "cabal-34": { "flake": false, "locked": { @@ -220,11 +203,11 @@ "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1770337891, - "narHash": "sha256-4dnPiaOwK6WClPzzbPRIe44y0aErHeBIfkmnzQeNPoQ=", + "lastModified": 1777855637, + "narHash": "sha256-7GxkPvU9bjww6/Ft6gPHxoaY5RWfR6VpM9teEjvNmjY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "f49c9f99f96698a7b60bafa9d69631440e030d48", + "rev": "20af026f2e8265ec7531a921442dbc491f223dc0", "type": "github" }, "original": { @@ -269,7 +252,6 @@ "haskellNix": { "inputs": { "HTTP": "HTTP", - "cabal-32": "cabal-32", "cabal-34": "cabal-34", "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", @@ -310,11 +292,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1770339211, - "narHash": "sha256-012gyltbvjNtzD7SsrDC5Qwu4RdOlcF9FN8SFZUJyKg=", + "lastModified": 1777870306, + "narHash": "sha256-l30vC7T/Ma9/XnQw40xxsGZkdRINsGAeH72LMnIq3cI=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "a8662cd47138b5b574f056365890f913803beabb", + "rev": "8bd5204953012d78f1815d74896a9b08a1045e3e", "type": "github" }, "original": { @@ -619,11 +601,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1770174258, - "narHash": "sha256-x6QYupvHZM7rRpVO4AIC5gUWFprFQ59A95FPC7/Owjg=", + "lastModified": 1775620557, + "narHash": "sha256-10x8/G0x3eR/++XRHPx4MBuqlnc6+N+ajIxXyLkG+nU=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "91ef7ffdeedfb141a4d69dcf9e550abe3e1160c6", + "rev": "3f7b2815307c20a0dfd816bdf4a39ab86af3e0d4", "type": "github" }, "original": { @@ -715,11 +697,11 @@ }, "nixpkgs-2511": { "locked": { - "lastModified": 1764572236, - "narHash": "sha256-hLp6T/vKdrBQolpbN3EhJOKTXZYxJZPzpnoZz+fEGlE=", + "lastModified": 1775749320, + "narHash": "sha256-msT6frWJSQ2WR+0cpk+KPcZdLTLagUIsJwQwIX9JNSo=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b0924ea1889b366de6bb0018a9db70b2c43a15f8", + "rev": "74b87959b2d16f59f54d8559cf3cf26b9d907949", "type": "github" }, "original": { @@ -731,11 +713,11 @@ }, "nixpkgs-unstable": { "locked": { - "lastModified": 1764587062, - "narHash": "sha256-hdFa0TAVQAQLDF31cEW3enWmBP+b592OvHs6WVe3D8k=", + "lastModified": 1775888245, + "narHash": "sha256-nwASzrRDD1JBEu/o8ekKYEXm/oJW6EMCzCRdrwcLe90=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "c1cb7d097cb250f6e1904aacd5f2ba5ffd8a49ce", + "rev": "13043924aaa7375ce482ebe2494338e058282925", "type": "github" }, "original": { @@ -817,11 +799,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1770336962, - "narHash": "sha256-qEr+syH4ckzM5cABE9r3HE7LTM/HTQ0lMMHuSjxb02s=", + "lastModified": 1777854643, + "narHash": "sha256-UJLxngXRJMTPHfJdBZJGJjaSQXYXWgYqPEw7hTDop2A=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "22997e8763f798be7c478b7b1a8604d0264a1f08", + "rev": "12436bd66325b13196b54f4d6cf16c05506786f3", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 82a1c4cf86..65ccc32806 100644 --- a/flake.nix +++ b/flake.nix @@ -83,6 +83,13 @@ ghc912 = hydraJobs.native.haskell912.devShell; ghc912-profiled = hydraJobs.native.haskell912.devShellProfiled; + # 9.14 is not a hydra job yet + ghc914 = import ./nix/shell.nix { + inherit inputs pkgs; + hsPkgs = pkgs.hsPkgs.projectVariants.ghc914; + withHls = false; + }; + agda-spec = pkgs.agda-spec.shell; website = pkgs.mkShell { diff --git a/nix/haskell.nix b/nix/haskell.nix index 92ba89768c..fcc76063ba 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -34,6 +34,7 @@ let flake.variants = { ghc910 = { compiler-nix-name = lib.mkForce "ghc9103"; }; ghc912 = { compiler-nix-name = lib.mkForce "ghc9122"; }; + ghc914 = { compiler-nix-name = lib.mkForce "ghc9141"; }; }; inputMap = { "https://chap.intersectmbo.org/" = inputs.CHaP; diff --git a/nix/shell.nix b/nix/shell.nix index a222d87555..956fe1dc54 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,4 +1,4 @@ -{ inputs, pkgs, hsPkgs }: +{ inputs, pkgs, hsPkgs, withHls ? true }: let inherit (pkgs) lib; @@ -32,7 +32,7 @@ hsPkgs.shellFor { # This is the place for tools that are required to be built with the same GHC # version as used in hsPkgs. - tools = { + tools = lib.optionalAttrs withHls { haskell-language-server = { src = inputs.hls; configureArgs = "--disable-benchmarks --disable-tests"; diff --git a/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs b/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs deleted file mode 100644 index 4aee21cdc7..0000000000 --- a/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs +++ /dev/null @@ -1,155 +0,0 @@ -module DBSynthesizer.Parsers (parseCommandLine) where - -import Cardano.Tools.DBSynthesizer.Types -import Data.Word (Word64) -import Options.Applicative as Opt -import Ouroboros.Consensus.Block.Abstract (SlotNo (..)) - -parseCommandLine :: IO (NodeFilePaths, NodeCredentials, DBSynthesizerOptions) -parseCommandLine = - Opt.customExecParser p opts - where - p = Opt.prefs Opt.showHelpOnEmpty - opts = Opt.info parserCommandLine mempty - -parserCommandLine :: Parser (NodeFilePaths, NodeCredentials, DBSynthesizerOptions) -parserCommandLine = - (,,) - <$> parseNodeFilePaths - <*> parseNodeCredentials - <*> parseDBSynthesizerOptions - -parseNodeFilePaths :: Parser NodeFilePaths -parseNodeFilePaths = - NodeFilePaths - <$> parseNodeConfigFilePath - <*> parseChainDBFilePath - -parseNodeCredentials :: Parser NodeCredentials -parseNodeCredentials = - NodeCredentials - <$> optional parseOperationalCertFilePath - <*> optional parseVrfKeyFilePath - <*> optional parseKesKeyFilePath - <*> optional parseBulkFilePath - -parseDBSynthesizerOptions :: Parser DBSynthesizerOptions -parseDBSynthesizerOptions = - DBSynthesizerOptions - <$> parseForgeOptions - <*> parseOpenMode - -parseForgeOptions :: Parser ForgeLimit -parseForgeOptions = - ForgeLimitSlot - <$> parseSlotLimit - <|> ForgeLimitBlock - <$> parseBlockLimit - <|> ForgeLimitEpoch - <$> parseEpochLimit - -parseChainDBFilePath :: Parser FilePath -parseChainDBFilePath = - strOption - ( long "db" - <> metavar "PATH" - <> help "Path to the Chain DB" - <> completer (bashCompleter "directory") - ) - -parseNodeConfigFilePath :: Parser FilePath -parseNodeConfigFilePath = - strOption - ( long "config" - <> metavar "FILE" - <> help "Path to the node's config.json" - <> completer (bashCompleter "file") - ) - -parseOperationalCertFilePath :: Parser FilePath -parseOperationalCertFilePath = - strOption - ( long "shelley-operational-certificate" - <> metavar "FILE" - <> help "Path to the delegation certificate (in JSON TextEnvelope format)" - <> completer (bashCompleter "file") - ) - -parseKesKeyFilePath :: Parser FilePath -parseKesKeyFilePath = - strOption - ( long "shelley-kes-key" - <> metavar "FILE" - <> help "Path to the KES signing key (in JSON TextEnvelope format)" - <> completer (bashCompleter "file") - ) - -parseVrfKeyFilePath :: Parser FilePath -parseVrfKeyFilePath = - strOption - ( long "shelley-vrf-key" - <> metavar "FILE" - <> help "Path to the VRF signing key (in JSON TextEnvelope format)" - <> completer (bashCompleter "file") - ) - -parseBulkFilePath :: Parser FilePath -parseBulkFilePath = - strOption - ( long "bulk-credentials-file" - <> metavar "FILE" - <> help - "Path to the bulk credentials file (a JSON file containing an array of arrays containing 3 TextEnvelope objects for the opcert, VRF Signing key, KES signing key)" - <> completer (bashCompleter "file") - ) - -parseSlotLimit :: Parser SlotNo -parseSlotLimit = - SlotNo - <$> option - auto - ( short 's' - <> long "slots" - <> metavar "NUMBER" - <> help "Amount of slots to process" - ) - -parseBlockLimit :: Parser Word64 -parseBlockLimit = - option - auto - ( short 'b' - <> long "blocks" - <> metavar "NUMBER" - <> help "Amount of blocks to forge" - ) - -parseEpochLimit :: Parser Word64 -parseEpochLimit = - option - auto - ( short 'e' - <> long "epochs" - <> metavar "NUMBER" - <> help "Amount of epochs to process" - ) - -parseForce :: Parser Bool -parseForce = - switch - ( short 'f' - <> help "Force overwrite an existing Chain DB" - ) - -parseAppend :: Parser Bool -parseAppend = - switch - ( short 'a' - <> help "Append to an existing Chain DB" - ) - -parseOpenMode :: Parser DBSynthesizerOpenMode -parseOpenMode = - (parseForce *> pure OpenCreateForce) - <|> (parseAppend *> pure OpenAppend) - <|> pure OpenCreate diff --git a/ouroboros-consensus-cardano/app/db-synthesizer.hs b/ouroboros-consensus-cardano/app/db-synthesizer.hs deleted file mode 100644 index 45a8cb0a9f..0000000000 --- a/ouroboros-consensus-cardano/app/db-synthesizer.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | This tool synthesizes a valid ChainDB, replicating cardano-node's UX --- --- Usage: db-synthesizer --config FILE --db PATH --- [--shelley-operational-certificate FILE] --- [--shelley-vrf-key FILE] [--shelley-kes-key FILE] --- [--bulk-credentials-file FILE] --- ((-s|--slots NUMBER) | (-b|--blocks NUMBER) | --- (-e|--epochs NUMBER)) [-f | -a] --- --- Available options: --- --config FILE Path to the node's config.json --- --db PATH Path to the Chain DB --- --shelley-operational-certificate FILE --- Path to the delegation certificate --- --shelley-vrf-key FILE Path to the VRF signing key --- --shelley-kes-key FILE Path to the KES signing key --- --bulk-credentials-file FILE --- Path to the bulk credentials file --- -s,--slots NUMBER Amount of slots to process --- -b,--blocks NUMBER Amount of blocks to forge --- -e,--epochs NUMBER Amount of epochs to process --- -f Force overwrite an existing Chain DB --- -a Append to an existing Chain DB -module Main (main) where - -import Cardano.Crypto.Init (cryptoInit) -import Cardano.Tools.DBSynthesizer.Run -import DBSynthesizer.Parsers -import Main.Utf8 (withStdTerminalHandles) -import System.Exit - -main :: IO () -main = withStdTerminalHandles $ do - cryptoInit - (paths, creds, forgeOpts) <- parseCommandLine - let - genTxs _ _ _ _ = pure [] - result <- initialize paths creds forgeOpts >>= either die (uncurry (synthesize genTxs)) - putStrLn $ "--> done; result: " ++ show result diff --git a/ouroboros-consensus-cardano/golden/byron/disk/LedgerTables b/ouroboros-consensus-cardano/golden/byron/disk/LedgerTables deleted file mode 100644 index 874fe2c986..0000000000 --- a/ouroboros-consensus-cardano/golden/byron/disk/LedgerTables +++ /dev/null @@ -1 +0,0 @@ - \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra index b525fa7868..75b07c7040 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo index dc3903d3a6..630347c534 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage index 279d590c81..3e9bb492c1 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway index 5ae5c5065d..8ece780c1a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary index 14d8281f93..30c2cb3540 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley index 7d900c96a8..b141b2f792 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra index 61ec98ae96..4e3092f3e8 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra @@ -1,3 +1 @@ -X cA:^D d -uS| ] -q \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo index 6e6d3158a7..6901f04b4d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo @@ -1 +1 @@ -X 3? GCa\ո1%Eg# +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage index 3c56b72b00..f63ee35806 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage @@ -1 +1 @@ -X M~@)_ur7WH5O2$h h \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway index 8f2268ce3f..11662fb6c0 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway @@ -1 +1 @@ -X K8aLs,а^"5J \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra index 58cd6ad898..9a54c951c5 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra @@ -1 +1 @@ -X #NDB~Dpa1Ux1 \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary index 1235567289..e5a4aa816d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary @@ -1 +1 @@ -X Ճ(x.x_GFߖ} Ԉh+ ޢ \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley index 667dbef8ea..5693f6535d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley @@ -1 +1 @@ -X np+t3NUe<Ҷ= \ No newline at end of file +X H )ȥas lh} ~63 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra index 786e482302..7d4d691d90 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo index 558dfbcca8..aa6d5fda5c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage index 0be195e3f1..4b8ed5f503 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway index 9d1ce51c81..3cd66766a8 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra index 8a87201536..227ccd7125 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary index 1d7d61fa77..daa05ca1be 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley index d41c1aacc8..6f9626dadd 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra index 2d2c467c6f..7039458506 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo index a446de19eb..0b47c7e01a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage index 91d4f95385..53f5d8706d 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway index 7bea7230e7..0f8b86ceed 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra index cffb0066af..341ceb1a6c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary index b07156aa39..caaded6c87 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley index 2aad81040d..27625a11c5 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra index b525fa7868..75b07c7040 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo index dc3903d3a6..630347c534 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage index 279d590c81..3e9bb492c1 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway index 5ae5c5065d..8ece780c1a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary index 14d8281f93..30c2cb3540 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley index 7d900c96a8..b141b2f792 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra index 61ec98ae96..4e3092f3e8 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra @@ -1,3 +1 @@ -X cA:^D d -uS| ] -q \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo index 6e6d3158a7..6901f04b4d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo @@ -1 +1 @@ -X 3? GCa\ո1%Eg# +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage index 3c56b72b00..f63ee35806 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage @@ -1 +1 @@ -X M~@)_ur7WH5O2$h h \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway index 8f2268ce3f..11662fb6c0 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway @@ -1 +1 @@ -X K8aLs,а^"5J \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra index 58cd6ad898..9a54c951c5 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra @@ -1 +1 @@ -X #NDB~Dpa1Ux1 \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary index 1235567289..e5a4aa816d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary @@ -1 +1 @@ -X Ճ(x.x_GFߖ} Ԉh+ ޢ \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley index 667dbef8ea..5693f6535d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley @@ -1 +1 @@ -X np+t3NUe<Ҷ= \ No newline at end of file +X H )ȥas lh} ~63 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra index 786e482302..7d4d691d90 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo index 558dfbcca8..aa6d5fda5c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage index 0be195e3f1..4b8ed5f503 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway index 9d1ce51c81..3cd66766a8 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra index 8a87201536..227ccd7125 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary index 1d7d61fa77..daa05ca1be 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley index d41c1aacc8..6f9626dadd 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig index 586bf617ce..8eae272e43 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip index e64ffada5d..447c219f10 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip @@ -1 +1 @@ - X B!)k8 Pl"5^ \ No newline at end of file + X Cul?ͥU'H&l|IQl \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip index a8d3ebca89..b79d075a8b 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip @@ -1 +1 @@ - X 8ofo&&&nss$& \ No newline at end of file + X x^MBܘ7)XADDBhW \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip index c36241968e..276c5d96c4 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip index 2eeba1fbba..9d362d47b6 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip @@ -1 +1 @@ - X M7!SYǭdGfp; \ No newline at end of file + X F /6om|zj3dJM \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip index e323f98e36..b078a94221 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip index 6ec12660a7..a0245f9ab1 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip @@ -1 +1 @@ - X E maxTxSize then throwError err else @@ -183,6 +187,8 @@ instance TxLimits ByronBlock where Utxo.UTxOValidationTxValidationError $ Utxo.TxValidationTxTooLarge txszNat maxTxSize + txMeasurePhase2 _ _ _ = pure TrivialTxMeasurePhase2 + data instance TxId (GenTx ByronBlock) = ByronTxId !Utxo.TxId | ByronDlgId !Delegation.CertificateId diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index f582e21083..c2be8de040 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -72,7 +72,9 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool ( ByteSize32 , IgnoringOverflow - , TxMeasure + , TrivialTxMeasurePhase2 (..) + , TxMeasurePhase1 + , TxMeasurePhase2 ) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol @@ -124,7 +126,8 @@ type CardanoHardForkConstraints c = -- the calculation of later rewards. In this transition, we consume the -- 'shelleyToAllegraAVVMsToDelete' as deletions in the ledger tables. instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where - type HardForkTxMeasure (CardanoEras c) = DijkstraMeasure + type HardForkTxMeasurePhase1 (CardanoEras c) = AlonzoMeasure + type HardForkTxMeasurePhase2 (CardanoEras c) = RefScriptSize hardForkEraTranslation = EraTranslation @@ -215,15 +218,15 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where ) $ PNil - hardForkInjTxMeasure = + hardForkInjTxMeasurePhase1 = fromByteSize `o` fromByteSize `o` fromByteSize `o` fromByteSize - `o` fromAlonzo - `o` fromAlonzo - `o` fromConway - `o` fromDijkstra + `o` id + `o` id + `o` id + `o` id `o` nil where nil :: SOP.NS f '[] -> a @@ -231,19 +234,43 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where infixr 9 `o` o :: - (TxMeasure x -> a) -> - (SOP.NS WrapTxMeasure xs -> a) -> - SOP.NS WrapTxMeasure (x : xs) -> + (TxMeasurePhase1 x -> a) -> + (SOP.NS WrapTxMeasurePhase1 xs -> a) -> + SOP.NS WrapTxMeasurePhase1 (x : xs) -> a o f g = \case - SOP.Z (WrapTxMeasure x) -> f x + SOP.Z (WrapTxMeasurePhase1 x) -> f x SOP.S y -> g y - fromByteSize :: IgnoringOverflow ByteSize32 -> DijkstraMeasure - fromByteSize x = fromAlonzo $ AlonzoMeasure x mempty - fromAlonzo x = fromConway $ ConwayMeasure x mempty - fromConway x = fromDijkstra $ DijkstraMeasure x - fromDijkstra x = x + fromByteSize :: IgnoringOverflow ByteSize32 -> AlonzoMeasure + fromByteSize x = AlonzoMeasure x mempty + + hardForkInjTxMeasurePhase2 = + fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` id + `o` id + `o` nil + where + nil :: SOP.NS f '[] -> a + nil = \case {} + + infixr 9 `o` + o :: + (TxMeasurePhase2 x -> a) -> + (SOP.NS WrapTxMeasurePhase2 xs -> a) -> + SOP.NS WrapTxMeasurePhase2 (x : xs) -> + a + o f g = \case + SOP.Z (WrapTxMeasurePhase2 x) -> f x + SOP.S y -> g y + + fromTrivial :: TrivialTxMeasurePhase2 -> RefScriptSize + fromTrivial TrivialTxMeasurePhase2 = mempty class TiebreakerView (BlockProtocol blk) ~ PraosTiebreakerView c => HasPraosTiebreakerView c blk instance TiebreakerView (BlockProtocol blk) ~ PraosTiebreakerView c => HasPraosTiebreakerView c blk @@ -395,8 +422,9 @@ crossEraForecastByronToShelleyWrapper = | forecastFor < maxFor = return $ WrapLedgerView $ - SL.mkInitialShelleyLedgerView - (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley)) + SL.forecastToTPraosLedgerView $ + SL.mkInitialShelleyForecast + (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley)) | otherwise = throwError $ OutsideForecastRange diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index a964daa928..344f1d6b7e 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -87,7 +87,6 @@ import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Tables -import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -114,6 +113,7 @@ import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Assert +import System.FS.API (SomeHasFS (..)) {------------------------------------------------------------------------------- SerialiseHFC @@ -580,23 +580,27 @@ protocolInfoCardano :: ( CardanoHardForkConstraints c , KESAgentContext c m ) => + SomeHasFS m -> CardanoProtocolParams c -> - ( ProtocolInfo (CardanoBlock c) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] - ) -protocolInfoCardano paramsCardano + m + ( ProtocolInfo (CardanoBlock c) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] + ) +protocolInfoCardano (SomeHasFS hasFS) paramsCardano | SL.Mainnet <- SL.sgNetworkId genesisShelley , length credssShelleyBased > 1 = error "Multiple Shelley-based credentials not allowed for mainnet" - | otherwise = - assertWithMsg - (validateGenesis genesisShelley) - ( ProtocolInfo - { pInfoConfig = cfg - , pInfoInitLedger = initExtLedgerStateCardano - } - , pure . mkBlockForgings - ) + | otherwise = do + initExtLedgerStateCardano <- mkInitExtLedgerStateCardano + pure $ + assertWithMsg + (validateGenesis genesisShelley) + ( ProtocolInfo + { pInfoConfig = cfg + , pInfoInitLedger = initExtLedgerStateCardano + } + , pure . mkBlockForgings + ) where CardanoProtocolParams { byronProtocolParams @@ -930,49 +934,56 @@ protocolInfoCardano paramsCardano -- data from the genesis config (if provided) in the ledger state. For -- example, this includes initial staking and initial funds (useful for -- testing/benchmarking). - initExtLedgerStateCardano :: ExtLedgerState (CardanoBlock c) ValuesMK - initExtLedgerStateCardano = - ExtLedgerState - { headerState = initHeaderState - , ledgerState = overShelleyBasedLedgerState initLedgerState - } + mkInitExtLedgerStateCardano :: m (ExtLedgerState (CardanoBlock c) ValuesMK) + mkInitExtLedgerStateCardano = do + let HardForkLedgerState st = initLedgerState + st' <- hsequence' (hap perEraInjections st) + pure + ExtLedgerState + { headerState = initHeaderState + , ledgerState = HardForkLedgerState st' + } where - overShelleyBasedLedgerState (HardForkLedgerState st) = - HardForkLedgerState $ hap (fn id :* registerAny) st - initHeaderState :: HeaderState (CardanoBlock c) initLedgerState :: LedgerState (CardanoBlock c) ValuesMK ExtLedgerState initLedgerState initHeaderState = injectInitialExtLedgerState cfg $ initExtLedgerStateByron - registerAny :: NP (Flip LedgerState ValuesMK -.-> Flip LedgerState ValuesMK) (CardanoShelleyEras c) - registerAny = - hcmap (Proxy @IsShelleyBlock) injectIntoTestState $ - WrapTransitionConfig transitionConfigShelley - :* WrapTransitionConfig transitionConfigAllegra - :* WrapTransitionConfig transitionConfigMary - :* WrapTransitionConfig transitionConfigAlonzo - :* WrapTransitionConfig transitionConfigBabbage - :* WrapTransitionConfig transitionConfigConway - :* WrapTransitionConfig transitionConfigDijkstra - :* Nil - - injectIntoTestState :: - ShelleyBasedEra era => + perEraInjections :: + NP + (Flip LedgerState ValuesMK -.-> (m :.: Flip LedgerState ValuesMK)) + (CardanoEras c) + perEraInjections = + fn (Comp . pure) + :* hcmap (Proxy @IsShelleyBlock) shelleyInjection shelleyTcfgs + + shelleyInjection :: + forall proto era. + Shelley.ShelleyCompatible proto era => WrapTransitionConfig (ShelleyBlock proto era) -> - (Flip LedgerState ValuesMK -.-> Flip LedgerState ValuesMK) (ShelleyBlock proto era) - injectIntoTestState (WrapTransitionConfig tcfg) = fn $ \(Flip st) -> - -- We need to unstow the injected values - Flip $ - unstowLedgerTables $ - forgetLedgerTables $ - st - { Shelley.shelleyLedgerState = - L.injectIntoTestState - tcfg - (Shelley.shelleyLedgerState $ stowLedgerTables st) - } + (Flip LedgerState ValuesMK -.-> (m :.: Flip LedgerState ValuesMK)) + (ShelleyBlock proto era) + shelleyInjection (WrapTransitionConfig tcfg) = fn $ \(Flip stIn) -> Comp $ do + let stowed = stowLedgerTables stIn + newNES <- + L.injectIntoTestState + hasFS + tcfg + (Shelley.shelleyLedgerState stowed) + pure . Flip . unstowLedgerTables $ + stowed{Shelley.shelleyLedgerState = newNES} + + shelleyTcfgs :: NP WrapTransitionConfig (CardanoShelleyEras c) + shelleyTcfgs = + WrapTransitionConfig transitionConfigShelley + :* WrapTransitionConfig transitionConfigAllegra + :* WrapTransitionConfig transitionConfigMary + :* WrapTransitionConfig transitionConfigAlonzo + :* WrapTransitionConfig transitionConfigBabbage + :* WrapTransitionConfig transitionConfigConway + :* WrapTransitionConfig transitionConfigDijkstra + :* Nil -- \| For each element in the list, a block forging thread will be started. -- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index 9ef2642934..148c00057a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -27,7 +27,7 @@ module Ouroboros.Consensus.Shelley.Eras , StandardCrypto ) where -import Cardano.Binary +import Cardano.Binary (FromCBOR, ToCBOR) import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Allegra.Translation () import Cardano.Ledger.Alonzo (AlonzoEra, ApplyTxError (AlonzoApplyTxError)) @@ -57,7 +57,6 @@ import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.Shelley.Rules as SL import qualified Cardano.Ledger.Shelley.Transition as SL -import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except import Control.State.Transition (PredicateFailure) import Data.Data (Proxy (Proxy)) @@ -95,11 +94,9 @@ class ( Core.EraBlockBody era , Core.EraGov era , SL.ApplyTx era - , SL.ApplyBlock era + , SL.ApplyTick era , SL.EraTransition era - , -- TODO This constraint is quite tight, since it fixes things to the - -- original TPraos ledger view. We would like to ultimately remove it. - SL.GetLedgerView era + , SL.EraForecast era , NoThunks (SL.StashedAVVMAddresses era) , EncCBOR (SL.StashedAVVMAddresses era) , DecCBOR (SL.StashedAVVMAddresses era) @@ -111,7 +108,6 @@ class , EncCBOR (PredicateFailure (EraRule "UTXOW" era)) , Eq (PredicateFailure (EraRule "BBODY" era)) , Show (PredicateFailure (EraRule "BBODY" era)) - , NoThunks (PredicateFailure (EraRule "BBODY" era)) , NoThunks (Core.TranslationContext era) , ToCBOR (Core.TranslationContext era) , FromCBOR (Core.TranslationContext era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 566d5c3f60..f7c92317e4 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -16,9 +16,11 @@ module Ouroboros.Consensus.Shelley.HFEras , StandardShelleyBlock ) where +import Cardano.Ledger.Dijkstra.Era (DijkstraEraBlockHeader (..)) import Cardano.Protocol.Crypto import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import Ouroboros.Consensus.Protocol.Praos.Header (Header) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.Eras @@ -77,29 +79,11 @@ instance TPraos.PraosCrypto c => ShelleyCompatible (TPraos c) AlonzoEra --- This instance is required since the ledger view forecast function for --- Praos/Babbage still goes through the forecast for TPraos. Once this is --- addressed, we could remove this instance. -instance - (Praos.PraosCrypto c, TPraos.PraosCrypto c) => - ShelleyCompatible (TPraos c) BabbageEra - instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) BabbageEra --- This instance is required since the ledger view forecast function for --- Praos/Conway still goes through the forecast for TPraos. Once this is --- addressed, we could remove this instance. -instance - (Praos.PraosCrypto c, TPraos.PraosCrypto c) => - ShelleyCompatible (TPraos c) ConwayEra - instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) ConwayEra --- This instance is required since the ledger view forecast function for --- Praos/Dijkstra still goes through the forecast for TPraos. Once this is --- addressed, we could remove this instance. -instance - (Praos.PraosCrypto c, TPraos.PraosCrypto c) => - ShelleyCompatible (TPraos c) DijkstraEra - instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) DijkstraEra + +instance Crypto c => DijkstraEraBlockHeader (Header c) DijkstraEra where + prevNonceBlockHeaderL = error "Not implemented. Peras placeholder" diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index def77f1549..dc2550b46e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -46,13 +46,15 @@ import Cardano.Ledger.Binary , FullByteString (..) , serialize ) +import Cardano.Ledger.Binary.Group (EncCBORGroup) import qualified Cardano.Ledger.Binary.Plain as Plain +import qualified Cardano.Ledger.Block as SL (EraBlockHeader) import Cardano.Ledger.Core as SL ( eraDecoder , eraProtVerLow , toEraCBOR ) -import qualified Cardano.Ledger.Core as SL (TranslationContext, hashBlockBody) +import qualified Cardano.Ledger.Core as SL (BlockBody, TranslationContext, hashBlockBody) import Cardano.Ledger.Hashes (HASH) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto) @@ -103,12 +105,15 @@ type instance BlockProtocol (ShelleyBlock proto era) = proto class ( ShelleyBasedEra era , ShelleyProtocol proto + , EncCBORGroup (SL.BlockBody era) , -- Header constraints Eq (ShelleyProtocolHeader proto) , Show (ShelleyProtocolHeader proto) , NoThunks (ShelleyProtocolHeader proto) , EncCBOR (ShelleyProtocolHeader proto) , DecCBOR (Annotator (ShelleyProtocolHeader proto)) + , SL.EraBlockHeader (ShelleyProtocolHeader proto) era + , SL.ApplyBlock (ShelleyProtocolHeader proto) era , Show (CannotForgeError proto) , Show (SL.TranslationContext era) , -- Currently the chain select view is identical diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs index b660170620..b9cf4cc14f 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs @@ -139,4 +139,5 @@ compactGenesis genesis = genesis { SL.sgInitialFunds = mempty , SL.sgStaking = SL.emptyGenesisStaking + , SL.sgExtraConfig = SL.SNothing } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 6e6c81bf20..d4466dd50e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -4,9 +4,13 @@ module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where import qualified Cardano.Ledger.Core as Core (TopTx, Tx) -import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL) +import qualified Cardano.Ledger.Core as SL + ( blockBodySize + , hashBlockBody + , mkBasicBlockBody + , txSeqBlockBodyL + ) import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx) -import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize) import qualified Cardano.Protocol.TPraos.BHeader as SL import Control.Exception import qualified Data.Sequence.Strict as Seq @@ -80,7 +84,7 @@ forgeShelleyBlock SL.mkBasicBlockBody & SL.txSeqBlockBodyL .~ Seq.fromList (fmap extractTx txs) - actualBodySize = SL.bBodySize protocolVersion body + actualBodySize = SL.blockBodySize protocolVersion body extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index f3cfcc4eca..5df48eac50 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -58,7 +58,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger , BigEndianTxIn (..) ) where -import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView) import qualified Cardano.Ledger.BaseTypes as SL (TxIx (..), epochInfoPure) import Cardano.Ledger.BaseTypes.NonZero (unNonZero) import Cardano.Ledger.Binary.Decoding @@ -131,8 +130,8 @@ import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Protocol () import Ouroboros.Consensus.Shelley.Protocol.Abstract ( EnvelopeCheckError + , ShelleyProtocolHeader , envelopeChecks - , mkHeaderView ) import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.CBOR @@ -660,7 +659,7 @@ applyHelper :: ShelleyCompatible proto era => ( SL.Globals -> SL.NewEpochState era -> - SL.Block SL.BHeaderView era -> + SL.Block (ShelleyProtocolHeader proto) era -> Either (SL.BlockTransitionError era) ( LedgerResult @@ -687,10 +686,7 @@ applyHelper f cfg blk stBefore = do f globals tickedShelleyLedgerState - ( let b = shelleyBlockRaw blk - h' = mkHeaderView (SL.blockHeader b) - in SL.Block h' (SL.blockBody b) - ) + (shelleyBlockRaw blk) let track :: LedgerState (ShelleyBlock proto era) ValuesMK -> diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 464ceb63ad..4c062544fd 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -34,8 +34,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool -- * Exported for tests , AlonzoMeasure (..) - , ConwayMeasure (..) - , DijkstraMeasure (..) + , RefScriptSize (..) , fromExUnits ) where @@ -116,7 +115,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger , getPParams ) import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) -import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet) +import Ouroboros.Consensus.Util (ShowProxy (..), coerceMapKeys, coerceSet) import Ouroboros.Consensus.Util.Condense import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) import Ouroboros.Network.SizeInBytes @@ -513,22 +512,28 @@ wrapCBORinCBOROverhead size = + fromIntegral size instance ShelleyCompatible p ShelleyEra => TxLimits (ShelleyBlock p ShelleyEra) where - type TxMeasure (ShelleyBlock p ShelleyEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (ShelleyBlock p ShelleyEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (ShelleyBlock p ShelleyEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txInBlockSize st tx - blockCapacityTxMeasure _cfg = txsMaxBytes + txMeasurePhase1 _cfg st tx = runValidation $ txInBlockSize st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . txsMaxBytes instance ShelleyCompatible p AllegraEra => TxLimits (ShelleyBlock p AllegraEra) where - type TxMeasure (ShelleyBlock p AllegraEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (ShelleyBlock p AllegraEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (ShelleyBlock p AllegraEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txInBlockSize st tx - blockCapacityTxMeasure _cfg = txsMaxBytes + txMeasurePhase1 _cfg st tx = runValidation $ txInBlockSize st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . txsMaxBytes instance ShelleyCompatible p MaryEra => TxLimits (ShelleyBlock p MaryEra) where - type TxMeasure (ShelleyBlock p MaryEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (ShelleyBlock p MaryEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (ShelleyBlock p MaryEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txInBlockSize st tx - blockCapacityTxMeasure _cfg = txsMaxBytes + txMeasurePhase1 _cfg st tx = runValidation $ txInBlockSize st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . txsMaxBytes ----- @@ -553,11 +558,10 @@ instance Monoid AlonzoMeasure where mappend = (<>) mempty = AlonzoMeasure mempty mempty -instance TxMeasureMetrics AlonzoMeasure where +instance TxMeasurePhase1Metrics AlonzoMeasure where txMeasureMetricTxSizeBytes = txMeasureMetricTxSizeBytes . byteSize txMeasureMetricExUnitsMemory = exUnitsMem' . exUnits txMeasureMetricExUnitsSteps = exUnitsSteps' . exUnits - txMeasureMetricRefScriptsSizeBytes _ = mempty fromExUnits :: ExUnits -> ExUnits' Natural fromExUnits = unWrapExUnits @@ -583,7 +587,7 @@ txMeasureAlonzo :: , ExUnitsTooBigUTxO era , MaxTxSizeUTxO era ) => - TickedLedgerState (ShelleyBlock proto era) ValuesMK -> + TickedLedgerState (ShelleyBlock proto era) EmptyMK -> GenTx (ShelleyBlock proto era) -> V.Validation (TxErrorSG era) AlonzoMeasure txMeasureAlonzo st tx@(ShelleyTx _txid tx') = @@ -657,76 +661,21 @@ instance ShelleyCompatible p AlonzoEra => TxLimits (ShelleyBlock p AlonzoEra) where - type TxMeasure (ShelleyBlock p AlonzoEra) = AlonzoMeasure + type TxMeasurePhase1 (ShelleyBlock p AlonzoEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p AlonzoEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txMeasureAlonzo st tx - blockCapacityTxMeasure _cfg = blockCapacityAlonzoMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . blockCapacityAlonzoMeasure ----- -newtype DijkstraMeasure = DijkstraMeasure - { conwayMeasure :: ConwayMeasure - } - deriving stock (Eq, Generic, Show) - deriving anyclass NoThunks - deriving newtype (Semigroup, Monoid, HasByteSize, TxMeasureMetrics) - deriving - Measure - via (InstantiatedAt Generic DijkstraMeasure) +newtype RefScriptSize = RefScriptSize {refScriptsSize :: IgnoringOverflow ByteSize32} + deriving (Eq, Generic, Show) + deriving newtype (NoThunks, Measure, Semigroup, Monoid) -blockCapacityDijkstraMeasure :: - forall proto era mk. - ( ShelleyCompatible proto era - , SL.ConwayEraPParams era - ) => - TickedLedgerState (ShelleyBlock proto era) mk -> - DijkstraMeasure -blockCapacityDijkstraMeasure = DijkstraMeasure . blockCapacityConwayMeasure - -txMeasureDijkstra :: - forall proto era. - ( ShelleyCompatible proto era - , L.AlonzoEraTxWits era - , L.BabbageEraTxBody era - , SL.ConwayEraPParams era - , ExUnitsTooBigUTxO era - , MaxTxSizeUTxO era - , TxRefScriptsSizeTooBig era - ) => - TickedLedgerState (ShelleyBlock proto era) ValuesMK -> - GenTx (ShelleyBlock proto era) -> - V.Validation (TxErrorSG era) DijkstraMeasure -txMeasureDijkstra st = fmap DijkstraMeasure . txMeasureConway st - ------ - -data ConwayMeasure = ConwayMeasure - { alonzoMeasure :: !AlonzoMeasure - , refScriptsSize :: !(IgnoringOverflow ByteSize32) - } - deriving stock (Eq, Generic, Show) - deriving anyclass NoThunks - deriving - Measure - via (InstantiatedAt Generic ConwayMeasure) - -instance Semigroup ConwayMeasure where - ConwayMeasure a1 r1 <> ConwayMeasure a2 r2 = - ConwayMeasure (a1 <> a2) (r1 <> r2) - -instance Monoid ConwayMeasure where - mappend = (<>) - mempty = ConwayMeasure mempty mempty - -instance HasByteSize ConwayMeasure where - txMeasureByteSize = txMeasureByteSize . alonzoMeasure - -instance TxMeasureMetrics ConwayMeasure where - txMeasureMetricTxSizeBytes = txMeasureMetricTxSizeBytes . alonzoMeasure - txMeasureMetricExUnitsMemory = txMeasureMetricExUnitsMemory . alonzoMeasure - txMeasureMetricExUnitsSteps = txMeasureMetricExUnitsSteps . alonzoMeasure - txMeasureMetricRefScriptsSizeBytes = - unIgnoringOverflow . refScriptsSize +instance TxMeasurePhase2Metrics RefScriptSize where + txMeasureMetricRefScriptsSizeBytes = unIgnoringOverflow . refScriptsSize blockCapacityConwayMeasure :: forall proto era mk. @@ -734,35 +683,31 @@ blockCapacityConwayMeasure :: , SL.ConwayEraPParams era ) => TickedLedgerState (ShelleyBlock proto era) mk -> - ConwayMeasure + (AlonzoMeasure, RefScriptSize) blockCapacityConwayMeasure st = - ConwayMeasure - { alonzoMeasure = blockCapacityAlonzoMeasure st - , refScriptsSize = - IgnoringOverflow $ - ByteSize32 (pparams ^. SL.ppMaxRefScriptSizePerBlockG) - } + ( blockCapacityAlonzoMeasure st + , RefScriptSize $ + IgnoringOverflow $ + ByteSize32 (pparams ^. SL.ppMaxRefScriptSizePerBlockG) + ) where pparams = getPParams $ tickedShelleyLedgerState st -txMeasureConway :: +txMeasureRefScripts :: forall proto era. ( ShelleyCompatible proto era - , L.AlonzoEraTxWits era , L.BabbageEraTxBody era - , ExUnitsTooBigUTxO era - , MaxTxSizeUTxO era , TxRefScriptsSizeTooBig era , SL.ConwayEraPParams era ) => TickedLedgerState (ShelleyBlock proto era) ValuesMK -> GenTx (ShelleyBlock proto era) -> - V.Validation (TxErrorSG era) ConwayMeasure -txMeasureConway st tx@(ShelleyTx _txid tx') = - ConwayMeasure <$> txMeasureAlonzo st tx <*> refScriptBytes + V.Validation (TxErrorSG era) RefScriptSize +txMeasureRefScripts st (ShelleyTx _txid tx') = + RefScriptSize <$> refScriptBytes where - utxo = SL.getUTxO . tickedShelleyLedgerState $ st - txsz = SL.txNonDistinctRefScriptsSize utxo tx' :: Int + ValuesMK utxo = getLedgerTables $ projectLedgerTables st + txsz = SL.txNonDistinctRefScriptsSize (SL.UTxO $ coerceMapKeys utxo) tx' :: Int pparams = getPParams $ tickedShelleyLedgerState st @@ -800,25 +745,31 @@ instance ShelleyCompatible p BabbageEra => TxLimits (ShelleyBlock p BabbageEra) where - type TxMeasure (ShelleyBlock p BabbageEra) = AlonzoMeasure + type TxMeasurePhase1 (ShelleyBlock p BabbageEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p BabbageEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txMeasureAlonzo st tx - blockCapacityTxMeasure _cfg = blockCapacityAlonzoMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . blockCapacityAlonzoMeasure instance ShelleyCompatible p ConwayEra => TxLimits (ShelleyBlock p ConwayEra) where - type TxMeasure (ShelleyBlock p ConwayEra) = ConwayMeasure + type TxMeasurePhase1 (ShelleyBlock p ConwayEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p ConwayEra) = RefScriptSize txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txMeasureConway st tx - blockCapacityTxMeasure _cfg = blockCapacityConwayMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg st tx = runValidation $ txMeasureRefScripts st tx + blockCapacityTxMeasure _cfg = uncurry TxMeasure . blockCapacityConwayMeasure instance ShelleyCompatible p DijkstraEra => TxLimits (ShelleyBlock p DijkstraEra) where - type TxMeasure (ShelleyBlock p DijkstraEra) = DijkstraMeasure - txMeasure _cfg st tx = runValidation $ txMeasureDijkstra st tx - blockCapacityTxMeasure _cfg = blockCapacityDijkstraMeasure + type TxMeasurePhase1 (ShelleyBlock p DijkstraEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p DijkstraEra) = RefScriptSize + blockCapacityTxMeasure _cfg = uncurry TxMeasure . blockCapacityConwayMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg st tx = runValidation $ txMeasureRefScripts st tx txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index 6584bf196f..d4aec71134 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -5,23 +5,20 @@ module Ouroboros.Consensus.Shelley.Ledger.PeerSelection () where +import Cardano.Base.IP (unIPv4, unIPv6) +import qualified Cardano.Ledger.Api.State.Query as SL import Cardano.Ledger.BaseTypes -import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.Shelley.API as SL -import qualified Cardano.Ledger.State as SL import Control.DeepSeq (force) -import Data.Bifunctor (second) import Data.Foldable (toList) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Sequence.Strict (StrictSeq) import Data.Text.Encoding (encodeUtf8) -import Lens.Micro.Extras (view) import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger @@ -29,39 +26,24 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where getPeers ShelleyLedgerState{shelleyLedgerState} = catMaybes - [ (poolStake,) <$> Map.lookup stakePool poolLedgerRelayAccessPoints - | (stakePool, poolStake) <- orderByStake poolDistr + [ (PoolStake stake,) <$> ledgerRelayAccessPoints relays + | (_stakePool, (stake, relays)) <- stakeOrdered ] where - poolDistr :: SL.PoolDistr - poolDistr = SL.nesPd shelleyLedgerState - - futurePoolParams :: Map (SL.KeyHash SL.StakePool) SL.StakePoolParams - futurePoolParams = SL.psFutureStakePoolParams pstate - - stakePoolsState :: Map (SL.KeyHash SL.StakePool) SL.StakePoolState - stakePoolsState = SL.psStakePools pstate - - -- Sort stake pools by descending stake - orderByStake :: - SL.PoolDistr -> - [(SL.KeyHash SL.StakePool, PoolStake)] - orderByStake = - sortOn (Down . snd) - . map (second (PoolStake . SL.individualPoolStake)) - . Map.toList - . SL.unPoolDistr + stakeOrdered = + sortOn (Down . fst . snd) . Map.toList $ + SL.queryStakePoolRelays shelleyLedgerState relayToLedgerRelayAccessPoint :: SL.StakePoolRelay -> Maybe LedgerRelayAccessPoint relayToLedgerRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) = - Just $ LedgerRelayAccessAddress (IPv4 ipv4) (fromIntegral port) + Just $ LedgerRelayAccessAddress (IPv4 (unIPv4 ipv4)) (fromIntegral port) relayToLedgerRelayAccessPoint ( SL.SingleHostAddr (SJust (Port port)) SNothing (SJust ipv6) ) = - Just $ LedgerRelayAccessAddress (IPv6 ipv6) (fromIntegral port) + Just $ LedgerRelayAccessAddress (IPv6 (unIPv6 ipv6)) (fromIntegral port) -- no IP address or no port number relayToLedgerRelayAccessPoint (SL.SingleHostAddr SNothing _ _) = Nothing relayToLedgerRelayAccessPoint (SL.SingleHostAddr _ SNothing _) = Nothing @@ -74,31 +56,11 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto relayToLedgerRelayAccessPoint (SL.MultiHostName dnsName) = Just $ LedgerRelayAccessSRVDomain (encodeUtf8 $ dnsToText dnsName) - -- Note that a stake pool can have multiple registered relays ledgerRelayAccessPoints :: - (LedgerRelayAccessPoint -> StakePoolRelay) -> StrictSeq SL.StakePoolRelay -> Maybe (NonEmpty StakePoolRelay) - ledgerRelayAccessPoints injStakePoolRelay = + ledgerRelayAccessPoints = NE.nonEmpty . force - . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint) + . mapMaybe (fmap CurrentRelay . relayToLedgerRelayAccessPoint) . toList - - -- Combine the stake pools registered in the future and the current pool - -- parameters, and remove duplicates. - poolLedgerRelayAccessPoints :: - Map (SL.KeyHash SL.StakePool) (NonEmpty StakePoolRelay) - poolLedgerRelayAccessPoints = - Map.unionWith - (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) - (Map.mapMaybe (ledgerRelayAccessPoints FutureRelay . SL.sppRelays) futurePoolParams) - (Map.mapMaybe (ledgerRelayAccessPoints CurrentRelay . SL.spsRelays) stakePoolsState) - - pstate :: SL.PState era - pstate = - view SL.certPStateL - . SL.lsCertState - . SL.esLState - . SL.nesEs - $ shelleyLedgerState diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index a25d1315bb..641b3d0f42 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -67,7 +67,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import Lens.Micro -import Lens.Micro.Extras (view) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Basics @@ -429,7 +428,7 @@ instance mkSerialised (encodeShelleyResult maxBound query') $ answerPureBlockQuery cfg query' ext GetFilteredDelegationsAndRewardAccounts creds -> - getFilteredDelegationsAndRewardAccounts st creds + SL.queryStakePoolDelegsAndRewards st creds GetGenesisConfig -> shelleyLedgerCompactGenesis lcfg DebugNewEpochState -> @@ -451,13 +450,7 @@ instance GetPoolDistr mPoolIds -> fromLedgerPoolDistr $ answerPureBlockQuery cfg (GetPoolDistr2 mPoolIds) ext GetStakeDelegDeposits stakeCreds -> - let lookupDeposit = - SL.lookupDepositDState (view SL.certDStateL $ SL.lsCertState $ SL.esLState $ SL.nesEs st) - lookupInsert acc cred = - case lookupDeposit cred of - Nothing -> acc - Just deposit -> Map.insert cred deposit acc - in Set.foldl' lookupInsert Map.empty stakeCreds + SL.queryAccountsDeposits st stakeCreds GetConstitution -> SL.queryConstitution st GetGovState -> @@ -469,7 +462,7 @@ instance GetCommitteeMembersState coldCreds hotCreds statuses -> SL.queryCommitteeMembersState coldCreds hotCreds statuses st GetFilteredVoteDelegatees stakeCreds -> - getFilteredVoteDelegatees st stakeCreds + SL.queryDRepDelegatees st stakeCreds GetAccountState -> SL.queryChainAccountState st GetSPOStakeDistr keys -> @@ -820,30 +813,6 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot getEpochState :: SL.NewEpochState era -> SL.EpochState era getEpochState = SL.nesEs -getDState :: SL.EraCertState era => SL.NewEpochState era -> SL.DState era -getDState = view SL.certDStateL . SL.lsCertState . SL.esLState . SL.nesEs - -getFilteredDelegationsAndRewardAccounts :: - SL.EraCertState era => - SL.NewEpochState era -> - Set (SL.Credential SL.Staking) -> - (Delegations, Map (SL.Credential SL.Staking) Coin) -getFilteredDelegationsAndRewardAccounts = SL.queryStakePoolDelegsAndRewards - -getFilteredVoteDelegatees :: - (SL.EraCertState era, CG.ConwayEraAccounts era) => - SL.NewEpochState era -> - Set (SL.Credential SL.Staking) -> - VoteDelegatees -getFilteredVoteDelegatees ss creds - | Set.null creds = - Map.mapMaybe (^. CG.dRepDelegationAccountStateL) accountsMap - | otherwise = - Map.mapMaybe (^. CG.dRepDelegationAccountStateL) accountsMapRestricted - where - accountsMap = getDState ss ^. SL.accountsL . SL.accountsMapL - accountsMapRestricted = Map.restrictKeys accountsMap creds - {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} @@ -1072,7 +1041,7 @@ encodeShelleyResult v query = case query of GetRatifyState{} -> LC.toEraCBOR @era GetFuturePParams{} -> LC.toEraCBOR @era GetLedgerPeerSnapshot'{} -> encodeLedgerPeerSnapshot (ledgerPeerSnapshotSupportsSRV v) - QueryStakePoolDefaultVote{} -> toCBOR + QueryStakePoolDefaultVote{} -> LC.toEraCBOR @era GetPoolDistr2{} -> LC.toEraCBOR @era GetStakeDistribution2{} -> LC.toEraCBOR @era GetMaxMajorProtocolVersion -> toCBOR @@ -1121,7 +1090,7 @@ decodeShelleyResult v query = case query of GetRatifyState{} -> LC.fromEraCBOR @era GetFuturePParams{} -> LC.fromEraCBOR @era GetLedgerPeerSnapshot' _ ledgerPeersKind -> decodeLedgerPeerSnapshot ledgerPeersKind - QueryStakePoolDefaultVote{} -> fromCBOR + QueryStakePoolDefaultVote{} -> LC.fromEraCBOR @era GetPoolDistr2{} -> LC.fromEraCBOR @era GetStakeDistribution2 -> LC.fromEraCBOR @era GetMaxMajorProtocolVersion -> fromCBOR diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs index fdbd91fbf1..d3f24f2343 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs @@ -88,6 +88,7 @@ instance FromCBOR LegacyShelleyGenesis where sgGenDelegs sgInitialFunds sgStaking + SNothing activeSlotsCoeffEncCBOR :: PositiveUnitInterval -> Encoding activeSlotsCoeffEncCBOR = enforceEncodingVersion shelleyProtVer . encCBOR . unboundRational diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 2a53ef71b0..00f15b7209 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | This module contains 'SupportsProtocol' instances tying the ledger and @@ -18,7 +17,6 @@ import qualified Cardano.Ledger.Core as LedgerCore import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except (MonadError (throwError)) -import Data.Coerce (coerce) import qualified Lens.Micro import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast @@ -27,9 +25,8 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol (..) ) -import Ouroboros.Consensus.Ledger.Tables.Utils -import Ouroboros.Consensus.Protocol.Abstract (translateLedgerView) import Ouroboros.Consensus.Protocol.Praos (Praos) +import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger.Block @@ -40,17 +37,21 @@ import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Shelley.Protocol.TPraos () instance - (SL.PraosCrypto crypto, ShelleyCompatible (TPraos crypto) era) => + ( ShelleyCompatible (TPraos crypto) era + , SL.ShelleyEraForecast era + , SL.PraosCrypto crypto + ) => LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era) where - protocolLedgerView _cfg = SL.currentLedgerView . tickedShelleyLedgerState + protocolLedgerView _cfg = + SL.forecastToTPraosLedgerView . SL.currentForecast . tickedShelleyLedgerState -- Extra context available in -- https://github.com/IntersectMBO/ouroboros-consensus/blob/main/docs/website/contents/for-developers/HardWonWisdom.md#why-doesnt-ledger-code-ever-return-pasthorizonexception ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> if | NotOrigin for == at -> - return $ SL.currentLedgerView shelleyLedgerState + return $ SL.forecastToTPraosLedgerView (SL.currentForecast shelleyLedgerState) | for < maxFor -> return $ futureLedgerView for | otherwise -> @@ -66,12 +67,10 @@ instance swindow = SL.stabilityWindow globals at = ledgerTipSlot ledgerState - futureLedgerView :: SlotNo -> SL.LedgerView - futureLedgerView = - either - (\e -> error ("futureLedgerView failed: " <> show e)) - id - . SL.futureLedgerView globals shelleyLedgerState + futureLedgerView :: SlotNo -> SL.TPraosLedgerView + futureLedgerView for = + SL.forecastToTPraosLedgerView $ + SL.futureForecast globals for shelleyLedgerState -- Exclusive upper bound maxFor :: SlotNo @@ -79,8 +78,8 @@ instance instance ( ShelleyCompatible (Praos crypto) era - , ShelleyCompatible (TPraos crypto) era - , SL.PraosCrypto crypto + , SL.EraForecast era + , Praos.PraosCrypto crypto ) => LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era) where @@ -91,28 +90,38 @@ instance pparam :: forall a. Lens.Micro.Lens' (LedgerCore.PParams era) a -> a pparam lens = getPParams nes Lens.Micro.^. lens - in Praos.LedgerView - { Praos.lvPoolDistr = nesPd - , Praos.lvMaxBodySize = pparam LedgerCore.ppMaxBBSizeL - , Praos.lvMaxHeaderSize = pparam LedgerCore.ppMaxBHSizeL - , Praos.lvProtocolVersion = pparam LedgerCore.ppProtocolVersionL + in Praos.PraosLedgerView + { Praos.plvPoolDistr = nesPd + , Praos.plvMaxBodySize = pparam LedgerCore.ppMaxBBSizeL + , Praos.plvMaxHeaderSize = pparam LedgerCore.ppMaxBHSizeL + , Praos.plvProtocolVersion = pparam LedgerCore.ppProtocolVersionL } - -- \| Currently the Shelley+ ledger is hard-coded to produce a TPraos ledger - -- view. Since we can convert them, we piggy-back on this to get a Praos - -- ledger view. Ultimately, we will want to liberalise the ledger code - -- slightly. - ledgerViewForecastAt cfg st = - mapForecast (translateLedgerView (Proxy @(TPraos crypto, Praos crypto))) $ - ledgerViewForecastAt @(ShelleyBlock (TPraos crypto) era) cfg st' + ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> + if + | NotOrigin for == at -> + return $ + Praos.forecastToPraosLedgerView (SL.currentForecast shelleyLedgerState) + | for < maxFor -> + return $ futureLedgerView for + | otherwise -> + throwError $ + OutsideForecastRange + { outsideForecastAt = at + , outsideForecastMaxFor = maxFor + , outsideForecastFor = for + } where - st' :: LedgerState (ShelleyBlock (TPraos crypto) era) EmptyMK - st' = - ShelleyLedgerState - { shelleyLedgerTip = coerceTip <$> shelleyLedgerTip st - , shelleyLedgerState = shelleyLedgerState st - , shelleyLedgerTransition = shelleyLedgerTransition st - , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = shelleyLedgerLatestPerasCertRound st - } - coerceTip (ShelleyTip slot block hash) = ShelleyTip slot block (coerce hash) + ShelleyLedgerState{shelleyLedgerState} = ledgerState + globals = shelleyLedgerGlobals cfg + swindow = SL.stabilityWindow globals + at = ledgerTipSlot ledgerState + + futureLedgerView :: SlotNo -> Praos.PraosLedgerView + futureLedgerView for = + Praos.forecastToPraosLedgerView $ + SL.futureForecast globals for shelleyLedgerState + + -- Exclusive upper bound + maxFor :: SlotNo + maxFor = addSlots swindow $ succWithOrigin at diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 65fc57fa7a..cf9c67372a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -67,6 +67,7 @@ import Ouroboros.Consensus.Shelley.Node.Serialisation () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Consensus.Util.Assert import Ouroboros.Consensus.Util.IOLike +import System.FS.API (SomeHasFS (..)) {------------------------------------------------------------------------------- BlockForging @@ -161,17 +162,21 @@ protocolInfoShelley :: , ShelleyCompatible (TPraos c) ShelleyEra , MonadKESAgent m ) => + SomeHasFS m -> SL.ShelleyGenesis -> ProtocolParamsShelleyBased c -> SL.ProtVer -> - ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] - ) + m + ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] + ) protocolInfoShelley + fs shelleyGenesis protocolParamsShelleyBased protVer = protocolInfoTPraosShelleyBased + fs protocolParamsShelleyBased (L.mkShelleyTransitionConfig shelleyGenesis) protVer @@ -181,27 +186,37 @@ protocolInfoTPraosShelleyBased :: ( ShelleyCompatible (TPraos c) era , KESAgentContext c m ) => + SomeHasFS m -> ProtocolParamsShelleyBased c -> L.TransitionConfig era -> -- | see 'shelleyProtVer', mutatis mutandi SL.ProtVer -> - ( ProtocolInfo (ShelleyBlock (TPraos c) era) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)] - ) + m + ( ProtocolInfo (ShelleyBlock (TPraos c) era) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)] + ) protocolInfoTPraosShelleyBased + (SomeHasFS hasFS) ProtocolParamsShelleyBased { shelleyBasedInitialNonce = initialNonce , shelleyBasedLeaderCredentials = credentialss } transitionCfg protVer = - assertWithMsg (validateGenesis genesis) $ - ( ProtocolInfo - { pInfoConfig = topLevelConfig - , pInfoInitLedger = initExtLedgerState - } - , \tr -> pure $ mkBlockForging tr <$> credentialss - ) + assertWithMsg (validateGenesis genesis) $ do + initLedgerState <- mkInitLedgerState + let initExtLedgerState = + ExtLedgerState + { ledgerState = initLedgerState + , headerState = genesisHeaderState initChainDepState + } + pure + ( ProtocolInfo + { pInfoConfig = topLevelConfig + , pInfoInitLedger = initExtLedgerState + } + , \tr -> pure $ mkBlockForging tr <$> credentialss + ) where mkBlockForging :: Tracer.Tracer m KESAgentClientTrace -> @@ -272,27 +287,24 @@ protocolInfoTPraosShelleyBased , shelleyStorageConfigSecurityParam = tpraosSecurityParam tpraosParams } - initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK - initLedgerState = - unstowLedgerTables - ShelleyLedgerState - { shelleyLedgerTip = Origin - , shelleyLedgerState = - L.injectIntoTestState transitionCfg $ - L.createInitialState transitionCfg - , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} - , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = SNothing - } + mkInitLedgerState :: m (LedgerState (ShelleyBlock (TPraos c) era) ValuesMK) + mkInitLedgerState = do + injected <- + L.injectIntoTestState + hasFS + transitionCfg + (L.createInitialState transitionCfg) + pure $ + unstowLedgerTables + ShelleyLedgerState + { shelleyLedgerTip = Origin + , shelleyLedgerState = injected + , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} + , shelleyLedgerTables = emptyLedgerTables + , shelleyLedgerLatestPerasCertRound = SNothing + } initChainDepState :: TPraosState initChainDepState = TPraosState Origin $ SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis) - - initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK - initExtLedgerState = - ExtLedgerState - { ledgerState = initLedgerState - , headerState = genesisHeaderState initChainDepState - } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs index 6c60e92e49..6e19ef646a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs @@ -17,7 +17,6 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , ProtocolHeaderSupportsKES (..) - , ProtocolHeaderSupportsLedger (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (..) , ShelleyProtocol @@ -27,7 +26,6 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR)) import qualified Cardano.Crypto.Hash as Hash import Cardano.Crypto.VRF (OutputVRF) -import Cardano.Ledger.BHeaderView (BHeaderView) import Cardano.Ledger.BaseTypes (ProtVer) import Cardano.Ledger.Hashes ( EraIndependentBlockBody @@ -182,12 +180,6 @@ class ProtocolHeaderSupportsProtocol proto where pTieBreakVRFValue :: ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto)) --- | Indicates that the protocol header supports the Shelley ledger. We may need --- to generalise this if, in the future, the ledger requires different things --- from the protocol. -class ProtocolHeaderSupportsLedger proto where - mkHeaderView :: ShelleyProtocolHeader proto -> BHeaderView - {------------------------------------------------------------------------------- Key constraints -------------------------------------------------------------------------------} @@ -198,7 +190,6 @@ class , ProtocolHeaderSupportsEnvelope proto , ProtocolHeaderSupportsKES proto , ProtocolHeaderSupportsProtocol proto - , ProtocolHeaderSupportsLedger proto , Serialise (ChainDepState proto) , SignedHeader (ShelleyProtocolHeader proto) , HasMaxMajorProtVer proto diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs new file mode 100644 index 0000000000..e08ea857d1 --- /dev/null +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +module Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks + ( EnvelopeError (..) + , EnvelopeHeaderView (..) + , envelopeCheck + ) where + +import Cardano.Ledger.BaseTypes (Version) +import Cardano.Ledger.Chain (ChainChecksPParams (ccMaxBBSize, ccMaxBHSize)) +import Control.Monad (unless) +import Control.Monad.Except (Except, throwError) +import Data.Word (Word16, Word32) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +data EnvelopeError + = -- | This is a subtle case. + -- + -- This node is explicitly rejecting the header, but the header isn't + -- necessarily _directly_ at fault. + -- + -- This rejection specifically happens when the ticked ledger state being + -- used to validate this header contains a protocol major version (the + -- first 'Version') that exceeds the maximum major protocol version allowed + -- for this era this specific node's configuration (the second 'Version'). + -- The only thing the header did "wrong" was extend such a ledger state. + -- + -- Note that the ChainSync client ensures that that ledger state is ticked + -- starting from one of the latest k+1 ledger states on the node's current + -- chain (modulo STM scheduling). + -- + -- For Cardano and for now at least, this max major prot ver is typically + -- hardcoded in the source code (subject only to whether or not the + -- run-time config files enable "experimental" eras). + -- + -- Hence, most likely, the appropriate rectifying action is for the node + -- operator to update their node software and/or config; hence the name + -- 'ObsoleteNode'. (Or if they're intentionally testing an experimental + -- era, they forgot to set the appropriate config flag.) + -- + -- TODO Would it be more intuitive to instead enforce this when validating + -- the block that results in a ledger state with a major prot ver that + -- violates the config's limit? Would the errors the user sees be more or + -- less helpful? Etc. + -- + -- TODO (cont'd) It's not even obviously that specific ledger + -- state's/block's fault, since the protocol version is the consequence of + -- on-chain governance. Is it the voters' fault? Is the fault of the first + -- block that was after the voting deadline? So "extending the ledger state + -- that resulting from ticking after applying the block after the epoch + -- that extended the ancestor block that was after the voting deadline that + -- ..." is merely one step more removed. And this 'envelopeChecks' approach + -- does avoid the surprise (since the rejection doesn't even depend on the + -- block's non-header content either) where the header could be validated + -- but its underlying block could not. See + -- . + ObsoleteNode !Version !Version + | HeaderSizeTooLarge !Int !Word16 + | BlockSizeTooLarge !Word32 !Word32 + deriving (Eq, Generic, Show) + +instance NoThunks EnvelopeError + +data EnvelopeHeaderView = EnvelopeHeaderView + { ehvProtVer :: !Version + -- ^ The version against which to compare the node's max. + , ehvHeaderSize :: !Int + , ehvBodySize :: !Word32 + } + +-- | Shared envelope-check logic between Praos and TPraos. +-- 'ehvProtVer' is the block header declared protocol version in TPraos, and +-- the ledger view's protocol version in Praos - see docs for EnvelopeError +envelopeCheck :: + Version -> + ChainChecksPParams -> + EnvelopeHeaderView -> + Except EnvelopeError () +envelopeCheck maxpv ccd EnvelopeHeaderView{ehvProtVer, ehvHeaderSize, ehvBodySize} = do + unless (ehvProtVer <= maxpv) $ + throwError $ + ObsoleteNode ehvProtVer maxpv + unless (ehvHeaderSize <= fromIntegral @Word16 @Int (ccMaxBHSize ccd)) $ + throwError $ + HeaderSizeTooLarge ehvHeaderSize (ccMaxBHSize ccd) + unless (ehvBodySize <= ccMaxBBSize ccd) $ + throwError $ + BlockSizeTooLarge ehvBodySize (ccMaxBBSize ccd) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index da514a421f..8de84c6498 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -1,27 +1,19 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Shelley.Protocol.Praos (PraosEnvelopeError (..)) where +module Ouroboros.Consensus.Shelley.Protocol.Praos () where import qualified Cardano.Crypto.KES as KES import Cardano.Crypto.VRF (certifiedOutput) -import Cardano.Ledger.BHeaderView -import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), Version) -import Cardano.Ledger.Keys (hashKey) +import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) import Cardano.Protocol.TPraos.OCert ( OCert (ocertKESPeriod, ocertVkHot) ) import qualified Cardano.Protocol.TPraos.OCert as SL -import Control.Monad (unless) -import Control.Monad.Except (throwError) import Data.Either (isRight) -import Data.Word (Word16, Word32) -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Protocol.Praos.Common ( MaxMajorProtVer (MaxMajorProtVer) @@ -38,65 +30,21 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , ProtocolHeaderSupportsKES (..) - , ProtocolHeaderSupportsLedger (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (ShelleyHash) , ShelleyProtocol , ShelleyProtocolHeader ) +import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks + ( EnvelopeError + , EnvelopeHeaderView (..) + , envelopeCheck + ) type instance ProtoCrypto (Praos c) = c type instance ShelleyProtocolHeader (Praos c) = Header c -data PraosEnvelopeError - = -- | This is a subtle case. - -- - -- This node is explicitly rejecting the header, but the header isn't - -- necessarily _directly_ at fault. - -- - -- This rejection specifically happens when the ticked ledger state being - -- used to validate this header contains a protocol major version (the - -- first 'Version') that exceeds the maximum major protocol version allowed - -- for this era this specific node's configuration (the second 'Version'). - -- The only thing the header did "wrong" was extend such a ledger state. - -- - -- Note that the ChainSync client ensures that that ledger state is ticked - -- starting from one of the latest k+1 ledger states on the node's current - -- chain (modulo STM scheduling). - -- - -- For Cardano and for now at least, this max major prot ver is typically - -- hardcoded in the source code (subject only to whether or not the - -- run-time config files enable "experimental" eras). - -- - -- Hence, most likely, the appropriate rectifying action is for the node - -- operator to update their node software and/or config; hence the name - -- 'ObsoleteNode'. (Or if they're intentionally testing an experimental - -- era, they forgot to set the appropriate config flag.) - -- - -- TODO Would it be more intuitive to instead enforce this when validating - -- the block that results in a ledger state with a major prot ver that - -- violates the config's limit? Would the errors the user sees be more or - -- less helpful? Etc. - -- - -- TODO (cont'd) It's not even obviously that specific ledger - -- state's/block's fault, since the protocol version is the consequence of - -- on-chain governance. Is it the voters' fault? Is the fault of the first - -- block that was after the voting deadline? So "extending the ledger state - -- that resulting from ticking after applying the block after the epoch - -- that extended the ancestor block that was after the voting deadline that - -- ..." is merely one step more removed. And this 'envelopeChecks' approach - -- does avoid the surprise (since the rejection doesn't even depend on the - -- block's non-header content either) where the header could be validated - -- but its underlying block could not. See - -- . - ObsoleteNode Version Version - | HeaderSizeTooLarge Int Word16 - | BlockSizeTooLarge Word32 Word32 - deriving (Eq, Generic, Show) - -instance NoThunks PraosEnvelopeError - instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where pHeaderHash hdr = ShelleyHash $ headerHash hdr pHeaderPrevHash (Header body _) = hbPrev body @@ -106,23 +54,25 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where pHeaderSize hdr = fromIntegral $ headerSize hdr pHeaderBlockSize (Header body _) = fromIntegral $ hbBodySize body - type EnvelopeCheckError _ = PraosEnvelopeError + type EnvelopeCheckError _ = EnvelopeError - envelopeChecks cfg lv hdr = do - unless (m <= maxpv) $ throwError (ObsoleteNode m maxpv) - unless (bhviewHSize bhv <= fromIntegral @Word16 @Int maxHeaderSize) $ - throwError $ - HeaderSizeTooLarge (bhviewHSize bhv) maxHeaderSize - unless (bhviewBSize bhv <= maxBodySize) $ - throwError $ - BlockSizeTooLarge (bhviewBSize bhv) maxBodySize + envelopeChecks cfg lv hdr = + envelopeCheck maxpv ccd $ + EnvelopeHeaderView + { ehvProtVer = m + , ehvHeaderSize = headerSize hdr + , ehvBodySize = hbBodySize body + } where - pp = praosParams cfg - (MaxMajorProtVer maxpv) = praosMaxMajorPV pp - (ProtVer m _) = lvProtocolVersion lv - maxHeaderSize = lvMaxHeaderSize lv - maxBodySize = lvMaxBodySize lv - bhv = mkHeaderView hdr + Header body _ = hdr + MaxMajorProtVer maxpv = praosMaxMajorPV (praosParams cfg) + ProtVer m _ = plvProtocolVersion lv + ccd = + ChainChecksPParams + { ccMaxBHSize = plvMaxHeaderSize lv + , ccMaxBBSize = plvMaxBodySize lv + , ccProtocolVersion = plvProtocolVersion lv + } instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams cfg @@ -191,19 +141,6 @@ instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where -- here instead. pTieBreakVRFValue = certifiedOutput . hbVrfRes . headerBody -instance PraosCrypto c => ProtocolHeaderSupportsLedger (Praos c) where - mkHeaderView hdr@Header{headerBody} = - BHeaderView - { bhviewID = hashKey $ hbVk headerBody - , bhviewBSize = hbBodySize headerBody - , bhviewHSize = headerSize hdr - , bhviewBHash = hbBodyHash headerBody - , bhviewSlot = hbSlotNo headerBody - , bhviewProtVer = hbProtVer headerBody - , -- TODO(Peras): instantiate this for Peras when needed - bhviewPrevEpochNonce = Nothing - } - type instance Signed (Header c) = HeaderBody c instance PraosCrypto c => SignedHeader (Header c) where headerSigned = headerBody diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index b881e05ddf..b918153524 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -8,9 +7,8 @@ module Ouroboros.Consensus.Shelley.Protocol.TPraos () where import qualified Cardano.Crypto.KES as SL import Cardano.Crypto.VRF (certifiedOutput) -import Cardano.Ledger.Chain (ChainPredicateFailure) +import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) import Cardano.Ledger.Hashes (originalBytesSize) -import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.TPraos.API (PraosCrypto) import qualified Cardano.Protocol.TPraos.API as SL import qualified Cardano.Protocol.TPraos.BHeader as SL @@ -39,12 +37,15 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , ProtocolHeaderSupportsKES (..) - , ProtocolHeaderSupportsLedger (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (..) , ShelleyProtocol , ShelleyProtocolHeader - , protocolHeaderView + ) +import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks + ( EnvelopeError + , EnvelopeHeaderView (..) + , envelopeCheck ) type instance ProtoCrypto (TPraos c) = c @@ -60,15 +61,20 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where pHeaderSize = fromIntegral . originalBytesSize pHeaderBlockSize = fromIntegral @Word32 @Natural . SL.bsize . SL.bhbody - type EnvelopeCheckError _ = ChainPredicateFailure + type EnvelopeCheckError _ = EnvelopeError envelopeChecks cfg lv hdr = - SL.chainChecks - maxPV - (SL.lvChainChecks lv) - (SL.makeHeaderView (protocolHeaderView @(TPraos c) hdr) Nothing) + envelopeCheck maxPV ccd $ + EnvelopeHeaderView + { ehvProtVer = m + , ehvHeaderSize = originalBytesSize hdr + , ehvBodySize = SL.bsize bhb + } where - MaxMajorProtVer maxPV = tpraosMaxMajorPV $ tpraosParams cfg + bhb = SL.bhbody hdr + ccd = SL.tplvChainChecks lv + ProtVer m _ = SL.bprotver bhb + MaxMajorProtVer maxPV = tpraosMaxMajorPV (tpraosParams cfg) instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where configSlotsPerKESPeriod cfg = tpraosSlotsPerKESPeriod $ tpraosParams cfg @@ -132,9 +138,6 @@ instance PraosCrypto c => ProtocolHeaderSupportsProtocol (TPraos c) where -- detailed discussion. pTieBreakVRFValue = certifiedOutput . SL.bheaderL . SL.bhbody -instance PraosCrypto c => ProtocolHeaderSupportsLedger (TPraos c) where - mkHeaderView = (flip SL.makeHeaderView) Nothing - type instance Signed (SL.BHeader c) = SL.BHBody c instance PraosCrypto c => SignedHeader (SL.BHeader c) where diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs index 5d71e3a09b..5d80d83799 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs @@ -61,10 +61,12 @@ instance LedgerSupportsMempool ByronSpecBlock where mkMempoolApplyTxError = nothingMkMempoolApplyTxError instance TxLimits ByronSpecBlock where - type TxMeasure ByronSpecBlock = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 ByronSpecBlock = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 ByronSpecBlock = TrivialTxMeasurePhase2 -- Dummy values, as these are not used in practice. txWireSize = const . fromIntegral $ (0 :: Int) - blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 1 + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow $ ByteSize32 1) TrivialTxMeasurePhase2 - txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase1 _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs index b21722da90..146b706cb8 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs @@ -17,6 +17,7 @@ module Test.Consensus.Cardano.ProtocolInfo -- * ProtocolInfo elaboration , mkSimpleTestProtocolInfo + , mkSimpleTestProtocolInfoForging , mkTestProtocolInfo , protocolVersionZero ) where @@ -70,6 +71,9 @@ import Ouroboros.Consensus.Shelley.Node , ShelleyGenesis , ShelleyLeaderCredentials ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import qualified Test.Cardano.Ledger.Alonzo.Examples as Alonzo import qualified Test.Cardano.Ledger.Conway.Examples as Conway import qualified Test.Cardano.Ledger.Dijkstra.Examples as Dijkstra @@ -179,7 +183,7 @@ mkSimpleTestProtocolInfo :: ShelleySlotLengthInSeconds -> SL.ProtVer -> CardanoHardForkTriggers -> - ProtocolInfo (CardanoBlock c) + IO (ProtocolInfo (CardanoBlock c)) mkSimpleTestProtocolInfo decentralizationParam securityParam @@ -187,8 +191,44 @@ mkSimpleTestProtocolInfo shelleySlotLengthInSeconds protocolVersion hardForkTriggers = - fst $ + (\(protocolInfo, _, _) -> protocolInfo) + <$> mkSimpleTestProtocolInfoForging + decentralizationParam + securityParam + byronSlotLenghtInSeconds + shelleySlotLengthInSeconds + protocolVersion + hardForkTriggers + +-- | Like 'mkSimpleTestProtocolInfo', but additionally returns the block +-- forgers and the Shelley genesis. Callers that forge (eg db-synthesizer) +-- need the forgers, and the genesis for its epoch length. +mkSimpleTestProtocolInfoForging :: + forall c. + (CardanoHardForkConstraints c, AgentCrypto c) => + -- | Network decentralization parameter. + Shelley.DecentralizationParam -> + SecurityParam -> + ByronSlotLengthInSeconds -> + ShelleySlotLengthInSeconds -> + SL.ProtVer -> + CardanoHardForkTriggers -> + IO + ( ProtocolInfo (CardanoBlock c) + , Tracer.Tracer IO KESAgentClientTrace -> IO [MkBlockForging IO (CardanoBlock c)] + , ShelleyGenesis + ) +mkSimpleTestProtocolInfoForging + decentralizationParam + securityParam + byronSlotLenghtInSeconds + shelleySlotLengthInSeconds + protocolVersion + hardForkTriggers = do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty + (protocolInfo, blockForging) <- mkTestProtocolInfo @IO + fs (CoreNodeId 0, coreNodeShelley) shelleyGenesis aByronProtocolVersion @@ -198,6 +238,7 @@ mkSimpleTestProtocolInfo (Just $ PBftSignatureThreshold 1) protocolVersion hardForkTriggers + pure (protocolInfo, blockForging, shelleyGenesis) where aByronProtocolVersion = CC.Update.ProtocolVersion 0 0 0 @@ -243,6 +284,7 @@ mkTestProtocolInfo :: ( CardanoHardForkConstraints c , KESAgentContext c m ) => + SomeHasFS m -> -- | Id of the node for which the protocol info will be elaborated. (CoreNodeId, Shelley.CoreNode c) -> -- | These nodes will be part of the initial delegation mapping, and funds @@ -260,10 +302,12 @@ mkTestProtocolInfo :: SL.ProtVer -> -- | Specification of the era to which the initial state should hard-fork to. CardanoHardForkTriggers -> - ( ProtocolInfo (CardanoBlock c) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] - ) + m + ( ProtocolInfo (CardanoBlock c) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] + ) mkTestProtocolInfo + fs (coreNodeId, coreNode) shelleyGenesis aByronProtocolVersion @@ -274,6 +318,7 @@ mkTestProtocolInfo protocolVersion hardForkTriggers = protocolInfoCardano + fs ( CardanoProtocolParams ProtocolParamsByron { byronGenesis = genesisByron diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 8c50f1767a..11fcdb7d42 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -67,7 +67,7 @@ import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope import Data.Void (Void) -import Lens.Micro ((^.)) +import Lens.Micro ((%~), (&), (.~), (^.)) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Forging (MkBlockForging) import Ouroboros.Consensus.Cardano.CanHardFork @@ -102,6 +102,7 @@ import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (eitherToMaybe) import Ouroboros.Consensus.Util.IndexedMemPack +import System.FS.API (SomeHasFS) import Test.ThreadNet.TxGen import Test.ThreadNet.TxGen.Shelley () @@ -188,7 +189,12 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , LedgerSupportsPeras (ShelleyBlock proto2 era2) , TxLimits (ShelleyBlock proto1 era1) , TxLimits (ShelleyBlock proto2 era2) - , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2)) + , TranslateTxMeasure + (TxMeasurePhase1 (ShelleyBlock proto1 era1)) + (TxMeasurePhase1 (ShelleyBlock proto2 era2)) + , TranslateTxMeasure + (TxMeasurePhase2 (ShelleyBlock proto1 era1)) + (TxMeasurePhase2 (ShelleyBlock proto2 era2)) , SL.PreviousEra era2 ~ era1 , SL.TranslateEra era2 SL.NewEpochState , SL.TranslateEra era2 (SL.Tx SL.TopTx) @@ -205,23 +211,26 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = class TranslateTxMeasure a b where translateTxMeasure :: a -> b +-- Phase 1 measures + instance TranslateTxMeasure (IgnoringOverflow ByteSize32) (IgnoringOverflow ByteSize32) where translateTxMeasure = id instance TranslateTxMeasure (IgnoringOverflow ByteSize32) AlonzoMeasure where translateTxMeasure x = AlonzoMeasure x mempty -instance TranslateTxMeasure (IgnoringOverflow ByteSize32) ConwayMeasure where - translateTxMeasure = - translateTxMeasure . (\x -> x :: AlonzoMeasure) . translateTxMeasure - instance TranslateTxMeasure AlonzoMeasure AlonzoMeasure where translateTxMeasure = id -instance TranslateTxMeasure AlonzoMeasure ConwayMeasure where - translateTxMeasure x = ConwayMeasure x mempty +-- Phase 2 measures + +instance TranslateTxMeasure TrivialTxMeasurePhase2 TrivialTxMeasurePhase2 where + translateTxMeasure = id + +instance TranslateTxMeasure TrivialTxMeasurePhase2 RefScriptSize where + translateTxMeasure TrivialTxMeasurePhase2 = mempty -instance TranslateTxMeasure ConwayMeasure ConwayMeasure where +instance TranslateTxMeasure RefScriptSize RefScriptSize where translateTxMeasure = id instance @@ -235,8 +244,11 @@ instance CanHardFork (ShelleyBasedHardForkEras proto1 era1 proto2 era2) where type - HardForkTxMeasure (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = - TxMeasure (ShelleyBlock proto2 era2) + HardForkTxMeasurePhase1 (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = + TxMeasurePhase1 (ShelleyBlock proto2 era2) + type + HardForkTxMeasurePhase2 (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = + TxMeasurePhase2 (ShelleyBlock proto2 era2) hardForkEraTranslation = EraTranslation @@ -308,9 +320,13 @@ instance . SL.translateEra transCtxt . Comp - hardForkInjTxMeasure = \case - (Z (WrapTxMeasure x)) -> translateTxMeasure x - S (Z (WrapTxMeasure x)) -> x + hardForkInjTxMeasurePhase1 = \case + (Z (WrapTxMeasurePhase1 x)) -> translateTxMeasure x + S (Z (WrapTxMeasurePhase1 x)) -> x + + hardForkInjTxMeasurePhase2 = \case + (Z (WrapTxMeasurePhase2 x)) -> translateTxMeasure x + S (Z (WrapTxMeasurePhase2 x)) -> x instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => @@ -393,54 +409,84 @@ protocolInfoShelleyBasedHardFork :: ( KESAgentContext (ProtoCrypto proto2) m , ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 ) => + SomeHasFS m -> ProtocolParamsShelleyBased (ProtoCrypto proto1) -> SL.ProtVer -> SL.ProtVer -> L.TransitionConfig era2 -> TriggerHardFork -> - ( ProtocolInfo (ShelleyBasedHardForkBlock proto1 era1 proto2 era2) - , Tracer.Tracer m KESAgentClientTrace -> - m [MkBlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)] - ) + m + ( ProtocolInfo (ShelleyBasedHardForkBlock proto1 era1 proto2 era2) + , Tracer.Tracer m KESAgentClientTrace -> + m [MkBlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)] + ) protocolInfoShelleyBasedHardFork + fs protocolParamsShelleyBased protVer1 protVer2 transCfg2 - hardForkTrigger = - protocolInfoBinary - -- Era 1 - protocolInfo1 - blockForging1 - eraParams1 - tpraosParams - toPartialLedgerConfig1 - -- Era 2 - protocolInfo2 - blockForging2 - eraParams2 - tpraosParams - toPartialLedgerConfig2 + hardForkTrigger = do + (protocolInfo1, blockForging1) <- + protocolInfoTPraosShelleyBased + fs + protocolParamsShelleyBased + transCfgEra1 + protVer1 + (protocolInfo2, blockForging2) <- + protocolInfoTPraosShelleyBased + fs + ProtocolParamsShelleyBased + { shelleyBasedInitialNonce + , shelleyBasedLeaderCredentials + } + transCfgEra2 + protVer2 + pure $ + protocolInfoBinary + -- Era 1 + protocolInfo1 + blockForging1 + eraParams1 + tpraosParams + toPartialLedgerConfig1 + -- Era 2 + protocolInfo2 + blockForging2 + eraParams2 + tpraosParams + toPartialLedgerConfig2 where ProtocolParamsShelleyBased { shelleyBasedInitialNonce , shelleyBasedLeaderCredentials } = protocolParamsShelleyBased + -- Override the protocol version inside the Shelley genesis carried by a + -- transition config. Each era's 'createInitialState' enforces + -- 'eraProtVerLow <= curProtVer <= eraProtVerHigh', so a single shared + -- genesis PV cannot satisfy both era1 and era2; we derive a per-era copy. + overrideGenesisPV :: + forall era. + L.EraTransition era => + SL.ProtVer -> + L.TransitionConfig era -> + L.TransitionConfig era + overrideGenesisPV pv = + L.tcShelleyGenesisL %~ \sg -> + sg{SL.sgProtocolParams = SL.sgProtocolParams sg & SL.ppProtocolVersionL .~ pv} + + transCfgEra1 :: L.TransitionConfig era1 + transCfgEra1 = (transCfg2 ^. L.tcPreviousEraConfigL) & overrideGenesisPV protVer1 + + transCfgEra2 :: L.TransitionConfig era2 + transCfgEra2 = transCfg2 & overrideGenesisPV protVer2 + -- Era 1 genesis :: SL.ShelleyGenesis genesis = transCfg2 ^. L.tcShelleyGenesisL - protocolInfo1 :: ProtocolInfo (ShelleyBlock proto1 era1) - blockForging1 :: - Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto1 era1)] - (protocolInfo1, blockForging1) = - protocolInfoTPraosShelleyBased - protocolParamsShelleyBased - (transCfg2 ^. L.tcPreviousEraConfigL) - protVer1 - eraParams1 :: History.EraParams eraParams1 = shelleyEraParams genesis @@ -455,18 +501,6 @@ protocolInfoShelleyBasedHardFork -- Era 2 - protocolInfo2 :: ProtocolInfo (ShelleyBlock proto2 era2) - blockForging2 :: - Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto2 era2)] - (protocolInfo2, blockForging2) = - protocolInfoTPraosShelleyBased - ProtocolParamsShelleyBased - { shelleyBasedInitialNonce - , shelleyBasedLeaderCredentials - } - transCfg2 - protVer2 - eraParams2 :: History.EraParams eraParams2 = shelleyEraParams genesis diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Any.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Any.hs deleted file mode 100644 index 5a0250d830..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Any.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Api.Any - ( module Cardano.Api.Any - , module Cbor - , module Proxy - ) where - -import Cardano.Ledger.Binary as Cbor - ( DecCBOR (..) - , EncCBOR (..) - , FromCBOR (..) - , ToCBOR (..) - ) -import qualified Cardano.Ledger.Binary.Plain as CBOR -import Control.Exception (Exception (..), IOException, throwIO) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 (decode, encode) -import Data.Kind (Constraint, Type) -import Data.Proxy as Proxy (Proxy (..)) -import Data.Text as Text (Text) -import qualified Data.Text.Encoding as Text (decodeUtf8) -import System.IO (Handle) - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/HasTypeProxy.hs - -class HasTypeProxy t where - -- | A family of singleton types used in this API to indicate which type to - -- use where it would otherwise be ambiguous or merely unclear. - -- - -- Values of this type are passed to deserialisation functions for example. - data AsType t - - proxyToAsType :: Proxy t -> AsType t - -data FromSomeType (c :: Type -> Constraint) b where - FromSomeType :: c a => AsType a -> (a -> b) -> FromSomeType c b - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Hash.hs - -data family Hash keyrole :: Type - -class CastHash roleA roleB where - castHash :: Hash roleA -> Hash roleB - -instance HasTypeProxy a => HasTypeProxy (Hash a) where - data AsType (Hash a) = AsHash (AsType a) - proxyToAsType _ = AsHash (proxyToAsType (Proxy :: Proxy a)) - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseRaw.hs - -class HasTypeProxy a => SerialiseAsRawBytes a where - serialiseToRawBytes :: a -> ByteString - - deserialiseFromRawBytes :: AsType a -> ByteString -> Maybe a - -serialiseToRawBytesHex :: SerialiseAsRawBytes a => a -> ByteString -serialiseToRawBytesHex = Base16.encode . serialiseToRawBytes - -serialiseToRawBytesHexText :: SerialiseAsRawBytes a => a -> Text -serialiseToRawBytesHexText = Text.decodeUtf8 . serialiseToRawBytesHex - -deserialiseFromRawBytesHex :: - SerialiseAsRawBytes a => - AsType a -> ByteString -> Maybe a -deserialiseFromRawBytesHex proxy hex = - case Base16.decode hex of - Right raw -> deserialiseFromRawBytes proxy raw - Left _msg -> Nothing - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseAsCBOR.hs - -class HasTypeProxy a => SerialiseAsCBOR a where - serialiseToCBOR :: a -> ByteString - deserialiseFromCBOR :: AsType a -> ByteString -> Either CBOR.DecoderError a - - default serialiseToCBOR :: ToCBOR a => a -> ByteString - serialiseToCBOR = CBOR.serialize' - - default deserialiseFromCBOR :: - FromCBOR a => - AsType a -> - ByteString -> - Either CBOR.DecoderError a - deserialiseFromCBOR _proxy = CBOR.decodeFull' - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Error.hs - -class Show e => Error e where - displayError :: e -> String - -instance Error () where - displayError () = "" - --- | The preferred approach is to use 'Except' or 'ExceptT', but you can if --- necessary use IO exceptions. -throwErrorAsException :: Error e => e -> IO a -throwErrorAsException e = throwIO (ErrorAsException e) - -data ErrorAsException where - ErrorAsException :: Error e => e -> ErrorAsException - -instance Show ErrorAsException where - show (ErrorAsException e) = show e - -instance Exception ErrorAsException where - displayException (ErrorAsException e) = displayError e - -data FileError e - = FileError FilePath e - | FileErrorTempFile - -- | Target path - FilePath - -- | Temporary path - FilePath - Handle - | FileIOError FilePath IOException - deriving Show - -instance Error e => Error (FileError e) where - displayError (FileErrorTempFile targetPath tempPath h) = - "Error creating temporary file at: " - ++ tempPath - ++ "/n" - ++ "Target path: " - ++ targetPath - ++ "/n" - ++ "Handle: " - ++ show h - displayError (FileIOError path ioe) = - path ++ ": " ++ displayException ioe - displayError (FileError path e) = - path ++ ": " ++ displayError e - -instance Error IOException where - displayError = show - ---- WARNING: STUB for Bech32 - -class (HasTypeProxy a, SerialiseAsRawBytes a) => SerialiseAsBech32 a where - -- | The human readable prefix to use when encoding this value to Bech32. - bech32PrefixFor :: a -> Text - - -- | The set of human readable prefixes that can be used for this type. - bech32PrefixesPermitted :: AsType a -> [Text] - --- serialiseToBech32 :: SerialiseAsBech32 a => a -> Text -serialiseToBech32 :: a -> Text -serialiseToBech32 _ = error "serialiseToBech32: stub not implemented" - --- deserialiseFromBech32 :: SerialiseAsBech32 a => AsType a -> Text -> Either Bech32DecodeError a -deserialiseFromBech32 :: AsType a -> Text -> Either Bech32DecodeError a -deserialiseFromBech32 _ _ = error "deserialiseFromBech32: stub not implemented" - -data Bech32DecodeError - -instance Show Bech32DecodeError where - show = const "Bech32DecodeError: stub not implemented" - -instance Error Bech32DecodeError where - displayError = show diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs deleted file mode 100644 index d80a781a2c..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Key.hs - -module Cardano.Api.Key - ( AsType (AsVerificationKey, AsSigningKey) - , CastSigningKeyRole (..) - , CastVerificationKeyRole (..) - , Key (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.SerialiseTextEnvelope -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Seed as Crypto -import Data.Kind (Type) - --- | An interface for cryptographic keys used for signatures with a 'SigningKey' --- and a 'VerificationKey' key. --- --- This interface does not provide actual signing or verifying functions since --- this API is concerned with the management of keys: generating and --- serialising. -class - ( Eq (VerificationKey keyrole) - , Show (VerificationKey keyrole) - , SerialiseAsRawBytes (Hash keyrole) - , HasTextEnvelope (VerificationKey keyrole) - , HasTextEnvelope (SigningKey keyrole) - ) => - Key keyrole - where - -- | The type of cryptographic verification key, for each key role. - data VerificationKey keyrole :: Type - - -- | The type of cryptographic signing key, for each key role. - data SigningKey keyrole :: Type - - -- | Get the corresponding verification key from a signing key. - getVerificationKey :: SigningKey keyrole -> VerificationKey keyrole - - -- | Generate a 'SigningKey' deterministically, given a 'Crypto.Seed'. The - -- required size of the seed is given by 'deterministicSigningKeySeedSize'. - deterministicSigningKey :: AsType keyrole -> Crypto.Seed -> SigningKey keyrole - - deterministicSigningKeySeedSize :: AsType keyrole -> Word - - verificationKeyHash :: VerificationKey keyrole -> Hash keyrole - - -- | Generate a 'SigningKey' using a seed from operating system entropy. - generateSigningKey :: AsType keyrole -> IO (SigningKey keyrole) - generateSigningKey keytype = do - -- - -- For KES we can override this to keep the seed and key in mlocked memory - -- at all times. - -- - seed <- Crypto.readSeedFromSystemEntropy seedSize - return $! deterministicSigningKey keytype seed - where - seedSize = deterministicSigningKeySeedSize keytype - -instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where - data AsType (VerificationKey a) = AsVerificationKey (AsType a) - proxyToAsType _ = AsVerificationKey (proxyToAsType (Proxy :: Proxy a)) - -instance HasTypeProxy a => HasTypeProxy (SigningKey a) where - data AsType (SigningKey a) = AsSigningKey (AsType a) - proxyToAsType _ = AsSigningKey (proxyToAsType (Proxy :: Proxy a)) - --- | Some key roles share the same representation and it is sometimes --- legitimate to change the role of a key. -class CastVerificationKeyRole keyroleA keyroleB where - -- | Change the role of a 'VerificationKey', if the representation permits. - castVerificationKey :: VerificationKey keyroleA -> VerificationKey keyroleB - -class CastSigningKeyRole keyroleA keyroleB where - -- | Change the role of a 'SigningKey', if the representation permits. - castSigningKey :: SigningKey keyroleA -> SigningKey keyroleB diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysByron.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysByron.hs deleted file mode 100644 index f81e639945..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysByron.hs +++ /dev/null @@ -1,308 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/KeysByron.hs - --- | Byron key types and their 'Key' class instances -module Cardano.Api.KeysByron - ( -- * Key types - ByronKey - , ByronKeyLegacy - - -- * Data family instances - , AsType (..) - , Hash (..) - , SigningKey (..) - , VerificationKey (..) - - -- * Legacy format - , ByronKeyFormat (..) - , IsByronKey (..) - , SomeByronSigningKey (..) - , toByronSigningKey - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.KeysShelley -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import qualified Cardano.Chain.Common as Byron -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Hashing as Byron -import qualified Cardano.Crypto.Seed as Crypto -import qualified Cardano.Crypto.Signing as Byron -import qualified Cardano.Crypto.Signing as Crypto -import qualified Cardano.Crypto.Wallet as Crypto.HD -import Cardano.Ledger.Binary - ( byronProtVer - , toPlainDecoder - , toPlainEncoding - ) -import Cardano.Prelude (cborError, toCborError) -import qualified Codec.CBOR.Decoding as CBOR -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Write as CBOR (toStrictByteString) -import Control.Monad -import qualified Data.ByteString.Lazy as LB -import Data.String (IsString) -import Data.Text (Text) -import qualified Data.Text as Text - --- | Byron-era payment keys. Used for Byron addresses and witnessing --- transactions that spend from these addresses. --- --- These use Ed25519 but with a 32byte \"chaincode\" used in HD derivation. --- The inclusion of the chaincode is a design mistake but one that cannot --- be corrected for the Byron era. The Shelley era 'PaymentKey's do not include --- a chaincode. It is safe to use a zero or random chaincode for new Byron keys. --- --- This is a type level tag, used with other interfaces like 'Key'. -data ByronKey - -data ByronKeyLegacy - -class IsByronKey key where - byronKeyFormat :: ByronKeyFormat key - -data ByronKeyFormat key where - ByronLegacyKeyFormat :: ByronKeyFormat ByronKeyLegacy - ByronModernKeyFormat :: ByronKeyFormat ByronKey - -data SomeByronSigningKey - = AByronSigningKeyLegacy (SigningKey ByronKeyLegacy) - | AByronSigningKey (SigningKey ByronKey) - -toByronSigningKey :: SomeByronSigningKey -> Byron.SigningKey -toByronSigningKey bWit = - case bWit of - AByronSigningKeyLegacy (ByronSigningKeyLegacy sKey) -> sKey - AByronSigningKey (ByronSigningKey sKey) -> sKey - --- --- Byron key --- - -instance Key ByronKey where - newtype VerificationKey ByronKey - = ByronVerificationKey Byron.VerificationKey - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey ByronKey - = ByronSigningKey Byron.SigningKey - deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType ByronKey -> Crypto.Seed -> SigningKey ByronKey - deterministicSigningKey AsByronKey seed = - ByronSigningKey (snd (Crypto.runMonadRandomWithSeed seed Byron.keyGen)) - - deterministicSigningKeySeedSize :: AsType ByronKey -> Word - deterministicSigningKeySeedSize AsByronKey = 32 - - getVerificationKey :: SigningKey ByronKey -> VerificationKey ByronKey - getVerificationKey (ByronSigningKey sk) = - ByronVerificationKey (Byron.toVerification sk) - - verificationKeyHash :: VerificationKey ByronKey -> Hash ByronKey - verificationKeyHash (ByronVerificationKey vkey) = - ByronKeyHash (Byron.hashKey vkey) - -instance HasTypeProxy ByronKey where - data AsType ByronKey = AsByronKey - proxyToAsType _ = AsByronKey - -instance HasTextEnvelope (VerificationKey ByronKey) where - textEnvelopeType _ = "PaymentVerificationKeyByron_ed25519_bip32" - -instance HasTextEnvelope (SigningKey ByronKey) where - textEnvelopeType _ = "PaymentSigningKeyByron_ed25519_bip32" - -instance SerialiseAsRawBytes (VerificationKey ByronKey) where - serialiseToRawBytes (ByronVerificationKey (Byron.VerificationKey xvk)) = - Crypto.HD.unXPub xvk - - deserialiseFromRawBytes (AsVerificationKey AsByronKey) bs = - either - (const Nothing) - (Just . ByronVerificationKey . Byron.VerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey ByronKey) where - serialiseToRawBytes (ByronSigningKey (Byron.SigningKey xsk)) = - CBOR.toStrictByteString $ encCBORXPrv xsk - where - encCBORXPrv = toPlainEncoding byronProtVer . Crypto.encCBORXPrv - - deserialiseFromRawBytes (AsSigningKey AsByronKey) bs = - either - (const Nothing) - (Just . ByronSigningKey . Byron.SigningKey) - (snd <$> CBOR.deserialiseFromBytes decCBORXPrv (LB.fromStrict bs)) - where - decCBORXPrv = toPlainDecoder Nothing byronProtVer Byron.decCBORXPrv - -newtype instance Hash ByronKey = ByronKeyHash Byron.KeyHash - deriving (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash ByronKey) where - serialiseToRawBytes (ByronKeyHash (Byron.KeyHash vkh)) = - Byron.abstractHashToBytes vkh - - deserialiseFromRawBytes (AsHash AsByronKey) bs = - ByronKeyHash . Byron.KeyHash <$> Byron.abstractHashFromBytes bs - -instance CastVerificationKeyRole ByronKey PaymentExtendedKey where - castVerificationKey (ByronVerificationKey vk) = - PaymentExtendedVerificationKey - (Byron.unVerificationKey vk) - -instance CastVerificationKeyRole ByronKey PaymentKey where - castVerificationKey = - ( castVerificationKey :: - VerificationKey PaymentExtendedKey -> - VerificationKey PaymentKey - ) - . ( castVerificationKey :: - VerificationKey ByronKey -> - VerificationKey PaymentExtendedKey - ) - -instance IsByronKey ByronKey where - byronKeyFormat = ByronModernKeyFormat - --- --- Legacy Byron key --- - -instance Key ByronKeyLegacy where - newtype VerificationKey ByronKeyLegacy - = ByronVerificationKeyLegacy Byron.VerificationKey - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey ByronKeyLegacy) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey ByronKeyLegacy - = ByronSigningKeyLegacy Byron.SigningKey - deriving (Show, IsString) via UsingRawBytesHex (SigningKey ByronKeyLegacy) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType ByronKeyLegacy -> Crypto.Seed -> SigningKey ByronKeyLegacy - deterministicSigningKey _ _ = error "Please generate a non legacy Byron key instead" - - deterministicSigningKeySeedSize :: AsType ByronKeyLegacy -> Word - deterministicSigningKeySeedSize AsByronKeyLegacy = 32 - - getVerificationKey :: SigningKey ByronKeyLegacy -> VerificationKey ByronKeyLegacy - getVerificationKey (ByronSigningKeyLegacy sk) = - ByronVerificationKeyLegacy (Byron.toVerification sk) - - verificationKeyHash :: VerificationKey ByronKeyLegacy -> Hash ByronKeyLegacy - verificationKeyHash (ByronVerificationKeyLegacy vkey) = - ByronKeyHashLegacy (Byron.hashKey vkey) - -instance HasTypeProxy ByronKeyLegacy where - data AsType ByronKeyLegacy = AsByronKeyLegacy - proxyToAsType _ = AsByronKeyLegacy - -instance HasTextEnvelope (VerificationKey ByronKeyLegacy) where - textEnvelopeType _ = "PaymentVerificationKeyByronLegacy_ed25519_bip32" - -instance HasTextEnvelope (SigningKey ByronKeyLegacy) where - textEnvelopeType _ = "PaymentSigningKeyByronLegacy_ed25519_bip32" - -newtype instance Hash ByronKeyLegacy = ByronKeyHashLegacy Byron.KeyHash - deriving (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash ByronKeyLegacy) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash ByronKeyLegacy) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash ByronKeyLegacy) where - serialiseToRawBytes (ByronKeyHashLegacy (Byron.KeyHash vkh)) = - Byron.abstractHashToBytes vkh - - deserialiseFromRawBytes (AsHash AsByronKeyLegacy) bs = - ByronKeyHashLegacy . Byron.KeyHash <$> Byron.abstractHashFromBytes bs - -instance SerialiseAsRawBytes (VerificationKey ByronKeyLegacy) where - serialiseToRawBytes (ByronVerificationKeyLegacy (Byron.VerificationKey xvk)) = - Crypto.HD.unXPub xvk - - deserialiseFromRawBytes (AsVerificationKey AsByronKeyLegacy) bs = - either - (const Nothing) - (Just . ByronVerificationKeyLegacy . Byron.VerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey ByronKeyLegacy) where - serialiseToRawBytes (ByronSigningKeyLegacy (Byron.SigningKey xsk)) = - Crypto.HD.unXPrv xsk - - deserialiseFromRawBytes (AsSigningKey AsByronKeyLegacy) bs = - either - (const Nothing) - (Just . ByronSigningKeyLegacy . snd) - (CBOR.deserialiseFromBytes decodeLegacyDelegateKey $ LB.fromStrict bs) - where - -- 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 -> CBOR.Decoder s () - enforceSize lbl requestedSize = CBOR.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 -> CBOR.Decoder s () - matchSize requestedSize lbl actualSize = - when (actualSize /= requestedSize) $ - cborError - ( lbl - <> " failed the size check. Expected " - <> Text.pack (show requestedSize) - <> ", found " - <> Text.pack (show actualSize) - ) - - decodeXPrv :: CBOR.Decoder s Crypto.HD.XPrv - decodeXPrv = CBOR.decodeBytesCanonical >>= toCborError . Crypto.HD.xprv - - -- \| Decoder for a Byron/Classic signing key. - -- Lifted from cardano-sl legacy codebase. - decodeLegacyDelegateKey :: CBOR.Decoder s Byron.SigningKey - decodeLegacyDelegateKey = do - enforceSize "UserSecret" 4 - _ <- do - enforceSize "vss" 1 - CBOR.decodeBytes - pkey <- do - enforceSize "pkey" 1 - Byron.SigningKey <$> decodeXPrv - _ <- do - CBOR.decodeListLenIndef - CBOR.decodeSequenceLenIndef (flip (:)) [] reverse CBOR.decodeNull - _ <- do - enforceSize "wallet" 0 - pure pkey - -instance CastVerificationKeyRole ByronKeyLegacy ByronKey where - castVerificationKey (ByronVerificationKeyLegacy vk) = - ByronVerificationKey vk - -instance IsByronKey ByronKeyLegacy where - byronKeyFormat = ByronLegacyKeyFormat diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs deleted file mode 100644 index 3b4c9e2596..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/KeysPraos.hs - --- | Praos consensus key types and their 'Key' class instances -module Cardano.Api.KeysPraos - ( -- * Key types - UnsoundPureKesKey - , VrfKey - - -- * Data family instances - , AsType (..) - , Hash (..) - , SigningKey (..) - , VerificationKey (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Crypto.KES.Class as Crypto -import qualified Cardano.Crypto.VRF.Class as Crypto -import Cardano.Ledger.Hashes (HASH) -import Cardano.Protocol.Crypto (Crypto (..), StandardCrypto) -import Data.String (IsString (..)) - --- --- KES keys --- - -data UnsoundPureKesKey - -instance HasTypeProxy UnsoundPureKesKey where - data AsType UnsoundPureKesKey = AsUnsoundPureKesKey - proxyToAsType _ = AsUnsoundPureKesKey - -instance Key UnsoundPureKesKey where - newtype VerificationKey UnsoundPureKesKey - = KesVerificationKey (Crypto.VerKeyKES (KES StandardCrypto)) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey UnsoundPureKesKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey UnsoundPureKesKey - = KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass (EncCBOR, DecCBOR, SerialiseAsCBOR) - - -- This loses the mlock safety of the seed, since it starts from a normal in-memory seed. - deterministicSigningKey :: AsType UnsoundPureKesKey -> Crypto.Seed -> SigningKey UnsoundPureKesKey - deterministicSigningKey AsUnsoundPureKesKey = - KesSigningKey . Crypto.unsoundPureGenKeyKES - - deterministicSigningKeySeedSize :: AsType UnsoundPureKesKey -> Word - deterministicSigningKeySeedSize AsUnsoundPureKesKey = - Crypto.seedSizeKES proxy - where - proxy :: Proxy (KES StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey - getVerificationKey (KesSigningKey sk) = - KesVerificationKey (Crypto.unsoundPureDeriveVerKeyKES sk) - - verificationKeyHash :: VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey - verificationKeyHash (KesVerificationKey vkey) = - UnsoundPureKesKeyHash (Crypto.hashVerKeyKES vkey) - -instance SerialiseAsRawBytes (VerificationKey UnsoundPureKesKey) where - serialiseToRawBytes (KesVerificationKey vk) = - Crypto.rawSerialiseVerKeyKES vk - - deserialiseFromRawBytes (AsVerificationKey AsUnsoundPureKesKey) bs = - KesVerificationKey - <$> Crypto.rawDeserialiseVerKeyKES bs - -instance SerialiseAsRawBytes (SigningKey UnsoundPureKesKey) where - serialiseToRawBytes (KesSigningKey sk) = - Crypto.rawSerialiseUnsoundPureSignKeyKES sk - - deserialiseFromRawBytes (AsSigningKey AsUnsoundPureKesKey) bs = - KesSigningKey <$> Crypto.rawDeserialiseUnsoundPureSignKeyKES bs - -instance SerialiseAsBech32 (VerificationKey UnsoundPureKesKey) where - bech32PrefixFor _ = "kes_vk" - bech32PrefixesPermitted _ = ["kes_vk"] - -instance SerialiseAsBech32 (SigningKey UnsoundPureKesKey) where - bech32PrefixFor _ = "kes_sk" - bech32PrefixesPermitted _ = ["kes_sk"] - -newtype instance Hash UnsoundPureKesKey - = UnsoundPureKesKeyHash - ( Crypto.Hash - HASH - (Crypto.VerKeyKES (KES StandardCrypto)) - ) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash UnsoundPureKesKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash UnsoundPureKesKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash UnsoundPureKesKey) where - serialiseToRawBytes (UnsoundPureKesKeyHash vkh) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsUnsoundPureKesKey) bs = - UnsoundPureKesKeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey UnsoundPureKesKey) where - textEnvelopeType _ = - "KesVerificationKey_" - <> fromString (Crypto.algorithmNameKES proxy) - where - proxy :: Proxy (KES StandardCrypto) - proxy = Proxy - -instance HasTextEnvelope (SigningKey UnsoundPureKesKey) where - textEnvelopeType _ = - "KesSigningKey_" - <> fromString (Crypto.algorithmNameKES proxy) - where - proxy :: Proxy (KES StandardCrypto) - proxy = Proxy - --- --- VRF keys --- - -data VrfKey - -instance HasTypeProxy VrfKey where - data AsType VrfKey = AsVrfKey - proxyToAsType _ = AsVrfKey - -instance Key VrfKey where - newtype VerificationKey VrfKey - = VrfVerificationKey (Crypto.VerKeyVRF (VRF StandardCrypto)) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey VrfKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey VrfKey - = VrfSigningKey (Crypto.SignKeyVRF (VRF StandardCrypto)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey VrfKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType VrfKey -> Crypto.Seed -> SigningKey VrfKey - deterministicSigningKey AsVrfKey seed = - VrfSigningKey (Crypto.genKeyVRF seed) - - deterministicSigningKeySeedSize :: AsType VrfKey -> Word - deterministicSigningKeySeedSize AsVrfKey = - Crypto.seedSizeVRF proxy - where - proxy :: Proxy (VRF StandardCrypto) - proxy = Proxy - - getVerificationKey :: SigningKey VrfKey -> VerificationKey VrfKey - getVerificationKey (VrfSigningKey sk) = - VrfVerificationKey (Crypto.deriveVerKeyVRF sk) - - verificationKeyHash :: VerificationKey VrfKey -> Hash VrfKey - verificationKeyHash (VrfVerificationKey vkey) = - VrfKeyHash (Crypto.hashVerKeyVRF vkey) - -instance SerialiseAsRawBytes (VerificationKey VrfKey) where - serialiseToRawBytes (VrfVerificationKey vk) = - Crypto.rawSerialiseVerKeyVRF vk - - deserialiseFromRawBytes (AsVerificationKey AsVrfKey) bs = - VrfVerificationKey <$> Crypto.rawDeserialiseVerKeyVRF bs - -instance SerialiseAsRawBytes (SigningKey VrfKey) where - serialiseToRawBytes (VrfSigningKey sk) = - Crypto.rawSerialiseSignKeyVRF sk - - deserialiseFromRawBytes (AsSigningKey AsVrfKey) bs = - VrfSigningKey <$> Crypto.rawDeserialiseSignKeyVRF bs - -instance SerialiseAsBech32 (VerificationKey VrfKey) where - bech32PrefixFor _ = "vrf_vk" - bech32PrefixesPermitted _ = ["vrf_vk"] - -instance SerialiseAsBech32 (SigningKey VrfKey) where - bech32PrefixFor _ = "vrf_sk" - bech32PrefixesPermitted _ = ["vrf_sk"] - -newtype instance Hash VrfKey - = VrfKeyHash - ( Crypto.Hash - HASH - (Crypto.VerKeyVRF (VRF StandardCrypto)) - ) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash VrfKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash VrfKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash VrfKey) where - serialiseToRawBytes (VrfKeyHash vkh) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsVrfKey) bs = - VrfKeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey VrfKey) where - textEnvelopeType _ = "VrfVerificationKey_" <> fromString (Crypto.algorithmNameVRF proxy) - where - proxy :: Proxy (VRF StandardCrypto) - proxy = Proxy - -instance HasTextEnvelope (SigningKey VrfKey) where - textEnvelopeType _ = "VrfSigningKey_" <> fromString (Crypto.algorithmNameVRF proxy) - where - proxy :: Proxy (VRF StandardCrypto) - proxy = Proxy diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs deleted file mode 100644 index 10abdafdd8..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs +++ /dev/null @@ -1,1235 +0,0 @@ --- The Shelley ledger uses promoted data kinds which we have to use, but we do --- not export any from this API. We also use them unticked as nature intended. -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/KeysShelley.hs - --- | Shelley key types and their 'Key' class instances -module Cardano.Api.KeysShelley - ( -- * Key types - GenesisDelegateExtendedKey - , GenesisDelegateKey - , GenesisExtendedKey - , GenesisKey - , GenesisUTxOKey - , PaymentExtendedKey - , PaymentKey - , StakeExtendedKey - , StakeKey - , StakePoolKey - - -- * Data family instances - , AsType (..) - , Hash (..) - , SigningKey (..) - , VerificationKey (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.SerialiseUsing -import Cardano.Crypto.DSIGN (SignKeyDSIGN) -import qualified Cardano.Crypto.DSIGN.Class as Crypto -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Crypto.Seed as Crypto -import qualified Cardano.Crypto.Wallet as Crypto.HD -import Cardano.Ledger.Keys (DSIGN) -import qualified Cardano.Ledger.Keys as Shelley -import Data.Aeson.Types - ( FromJSON (..) - , ToJSON (..) - , ToJSONKey (..) - , toJSONKeyText - , withText - ) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Maybe -import Data.String (IsString (..)) -import qualified Data.Text as Text - --- --- Shelley payment keys --- - --- | Shelley-era payment keys. Used for Shelley payment addresses and witnessing --- transactions that spend from these addresses. --- --- This is a type level tag, used with other interfaces like 'Key'. -data PaymentKey - -instance HasTypeProxy PaymentKey where - data AsType PaymentKey = AsPaymentKey - proxyToAsType _ = AsPaymentKey - -instance Key PaymentKey where - newtype VerificationKey PaymentKey - = PaymentVerificationKey (Shelley.VKey Shelley.Payment) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey PaymentKey - = PaymentSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType PaymentKey -> Crypto.Seed -> SigningKey PaymentKey - deterministicSigningKey AsPaymentKey seed = - PaymentSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType PaymentKey -> Word - deterministicSigningKeySeedSize AsPaymentKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey PaymentKey -> VerificationKey PaymentKey - getVerificationKey (PaymentSigningKey sk) = - PaymentVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey PaymentKey -> Hash PaymentKey - verificationKeyHash (PaymentVerificationKey vkey) = - PaymentKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey PaymentKey) where - serialiseToRawBytes (PaymentVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsPaymentKey) bs = - PaymentVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey PaymentKey) where - serialiseToRawBytes (PaymentSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsPaymentKey) bs = - PaymentSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -instance SerialiseAsBech32 (VerificationKey PaymentKey) where - bech32PrefixFor _ = "addr_vk" - bech32PrefixesPermitted _ = ["addr_vk"] - -instance SerialiseAsBech32 (SigningKey PaymentKey) where - bech32PrefixFor _ = "addr_sk" - bech32PrefixesPermitted _ = ["addr_sk"] - -newtype instance Hash PaymentKey - = PaymentKeyHash (Shelley.KeyHash Shelley.Payment) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash PaymentKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash PaymentKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash PaymentKey) where - serialiseToRawBytes (PaymentKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsPaymentKey) bs = - PaymentKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey PaymentKey) where - textEnvelopeType _ = - "PaymentVerificationKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey PaymentKey) where - textEnvelopeType _ = - "PaymentSigningKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- --- Shelley payment extended ed25519 keys --- - --- | Shelley-era payment keys using extended ed25519 cryptographic keys. --- --- They can be used for Shelley payment addresses and witnessing --- transactions that spend from these addresses. --- --- These extended keys are used by HD wallets. So this type provides --- interoperability with HD wallets. The ITN CLI also supported this key type. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'PaymentKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'PaymentKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data PaymentExtendedKey - -instance HasTypeProxy PaymentExtendedKey where - data AsType PaymentExtendedKey = AsPaymentExtendedKey - proxyToAsType _ = AsPaymentExtendedKey - -instance Key PaymentExtendedKey where - newtype VerificationKey PaymentExtendedKey - = PaymentExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey PaymentExtendedKey) - - newtype SigningKey PaymentExtendedKey - = PaymentExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey PaymentExtendedKey) - - deterministicSigningKey :: - AsType PaymentExtendedKey -> - Crypto.Seed -> - SigningKey PaymentExtendedKey - deterministicSigningKey AsPaymentExtendedKey seed = - PaymentExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType PaymentExtendedKey -> Word - deterministicSigningKeySeedSize AsPaymentExtendedKey = 32 - - getVerificationKey :: - SigningKey PaymentExtendedKey -> - VerificationKey PaymentExtendedKey - getVerificationKey (PaymentExtendedSigningKey sk) = - PaymentExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey PaymentExtendedKey -> - Hash PaymentExtendedKey - verificationKeyHash (PaymentExtendedVerificationKey vk) = - PaymentExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey PaymentExtendedKey) where - toCBOR (PaymentExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey PaymentExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . PaymentExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey PaymentExtendedKey) where - toCBOR (PaymentExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey PaymentExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . PaymentExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsPaymentExtendedKey) bs = - either - (const Nothing) - (Just . PaymentExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsPaymentExtendedKey) bs = - either - (const Nothing) - (Just . PaymentExtendedSigningKey) - (Crypto.HD.xprv bs) - -instance SerialiseAsBech32 (VerificationKey PaymentExtendedKey) where - bech32PrefixFor _ = "addr_xvk" - bech32PrefixesPermitted _ = ["addr_xvk"] - -instance SerialiseAsBech32 (SigningKey PaymentExtendedKey) where - bech32PrefixFor _ = "addr_xsk" - bech32PrefixesPermitted _ = ["addr_xsk"] - -newtype instance Hash PaymentExtendedKey - = PaymentExtendedKeyHash (Shelley.KeyHash Shelley.Payment) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash PaymentExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash PaymentExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash PaymentExtendedKey) where - serialiseToRawBytes (PaymentExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsPaymentExtendedKey) bs = - PaymentExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey PaymentExtendedKey) where - textEnvelopeType _ = "PaymentExtendedVerificationKeyShelley_ed25519_bip32" - -instance HasTextEnvelope (SigningKey PaymentExtendedKey) where - textEnvelopeType _ = "PaymentExtendedSigningKeyShelley_ed25519_bip32" - -instance CastVerificationKeyRole PaymentExtendedKey PaymentKey where - castVerificationKey (PaymentExtendedVerificationKey vk) = - PaymentVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Stake keys --- - -data StakeKey - -instance HasTypeProxy StakeKey where - data AsType StakeKey = AsStakeKey - proxyToAsType _ = AsStakeKey - -instance Key StakeKey where - newtype VerificationKey StakeKey - = StakeVerificationKey (Shelley.VKey Shelley.Staking) - deriving stock Eq - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeKey) - - newtype SigningKey StakeKey - = StakeSigningKey (SignKeyDSIGN DSIGN) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeKey) - - deterministicSigningKey :: AsType StakeKey -> Crypto.Seed -> SigningKey StakeKey - deterministicSigningKey AsStakeKey seed = - StakeSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType StakeKey -> Word - deterministicSigningKeySeedSize AsStakeKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey StakeKey -> VerificationKey StakeKey - getVerificationKey (StakeSigningKey sk) = - StakeVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey StakeKey -> Hash StakeKey - verificationKeyHash (StakeVerificationKey vkey) = - StakeKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey StakeKey) where - serialiseToRawBytes (StakeVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsStakeKey) bs = - StakeVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey StakeKey) where - serialiseToRawBytes (StakeSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsStakeKey) bs = - StakeSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -instance SerialiseAsBech32 (VerificationKey StakeKey) where - bech32PrefixFor _ = "stake_vk" - bech32PrefixesPermitted _ = ["stake_vk"] - -instance SerialiseAsBech32 (SigningKey StakeKey) where - bech32PrefixFor _ = "stake_sk" - bech32PrefixesPermitted _ = ["stake_sk"] - -newtype instance Hash StakeKey - = StakeKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash StakeKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakeKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash StakeKey) where - serialiseToRawBytes (StakeKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsStakeKey) bs = - StakeKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey StakeKey) where - textEnvelopeType _ = - "StakeVerificationKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey StakeKey) where - textEnvelopeType _ = - "StakeSigningKeyShelley_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- --- Shelley stake extended ed25519 keys --- - --- | Shelley-era stake keys using extended ed25519 cryptographic keys. --- --- They can be used for Shelley stake addresses and witnessing transactions --- that use stake addresses. --- --- These extended keys are used by HD wallets. So this type provides --- interoperability with HD wallets. The ITN CLI also supported this key type. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'StakeKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'StakeKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data StakeExtendedKey - -instance HasTypeProxy StakeExtendedKey where - data AsType StakeExtendedKey = AsStakeExtendedKey - proxyToAsType _ = AsStakeExtendedKey - -instance Key StakeExtendedKey where - newtype VerificationKey StakeExtendedKey - = StakeExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakeExtendedKey) - - newtype SigningKey StakeExtendedKey - = StakeExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakeExtendedKey) - - deterministicSigningKey :: - AsType StakeExtendedKey -> - Crypto.Seed -> - SigningKey StakeExtendedKey - deterministicSigningKey AsStakeExtendedKey seed = - StakeExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType StakeExtendedKey -> Word - deterministicSigningKeySeedSize AsStakeExtendedKey = 32 - - getVerificationKey :: - SigningKey StakeExtendedKey -> - VerificationKey StakeExtendedKey - getVerificationKey (StakeExtendedSigningKey sk) = - StakeExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey StakeExtendedKey -> - Hash StakeExtendedKey - verificationKeyHash (StakeExtendedVerificationKey vk) = - StakeExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey StakeExtendedKey) where - toCBOR (StakeExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey StakeExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . StakeExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey StakeExtendedKey) where - toCBOR (StakeExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey StakeExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . StakeExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsStakeExtendedKey) bs = - either - (const Nothing) - (Just . StakeExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsStakeExtendedKey) bs = - either - (const Nothing) - (Just . StakeExtendedSigningKey) - (Crypto.HD.xprv bs) - -instance SerialiseAsBech32 (VerificationKey StakeExtendedKey) where - bech32PrefixFor _ = "stake_xvk" - bech32PrefixesPermitted _ = ["stake_xvk"] - -instance SerialiseAsBech32 (SigningKey StakeExtendedKey) where - bech32PrefixFor _ = "stake_xsk" - bech32PrefixesPermitted _ = ["stake_xsk"] - -newtype instance Hash StakeExtendedKey - = StakeExtendedKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash StakeExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakeExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash StakeExtendedKey) where - serialiseToRawBytes (StakeExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsStakeExtendedKey) bs = - StakeExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey StakeExtendedKey) where - textEnvelopeType _ = "StakeExtendedVerificationKeyShelley_ed25519_bip32" - -instance HasTextEnvelope (SigningKey StakeExtendedKey) where - textEnvelopeType _ = "StakeExtendedSigningKeyShelley_ed25519_bip32" - -instance CastVerificationKeyRole StakeExtendedKey StakeKey where - castVerificationKey (StakeExtendedVerificationKey vk) = - StakeVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Genesis keys --- - -data GenesisKey - -instance HasTypeProxy GenesisKey where - data AsType GenesisKey = AsGenesisKey - proxyToAsType _ = AsGenesisKey - -instance Key GenesisKey where - newtype VerificationKey GenesisKey - = GenesisVerificationKey (Shelley.VKey Shelley.GenesisRole) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisKey - = GenesisSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisKey -> Crypto.Seed -> SigningKey GenesisKey - deterministicSigningKey AsGenesisKey seed = - GenesisSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisKey -> Word - deterministicSigningKeySeedSize AsGenesisKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey GenesisKey -> VerificationKey GenesisKey - getVerificationKey (GenesisSigningKey sk) = - GenesisVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisKey -> Hash GenesisKey - verificationKeyHash (GenesisVerificationKey vkey) = - GenesisKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey GenesisKey) where - serialiseToRawBytes (GenesisVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsGenesisKey) bs = - GenesisVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey GenesisKey) where - serialiseToRawBytes (GenesisSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisKey) bs = - GenesisSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -newtype instance Hash GenesisKey - = GenesisKeyHash (Shelley.KeyHash Shelley.GenesisRole) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisKey) where - serialiseToRawBytes (GenesisKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisKey) bs = - GenesisKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisKey) where - textEnvelopeType _ = - "GenesisVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey GenesisKey) where - textEnvelopeType _ = - "GenesisSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- --- Shelley genesis extended ed25519 keys --- - --- | Shelley-era genesis keys using extended ed25519 cryptographic keys. --- --- These serve the same role as normal genesis keys, but are here to support --- legacy Byron genesis keys which used extended keys. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'GenesisKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'GenesisKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data GenesisExtendedKey - -instance HasTypeProxy GenesisExtendedKey where - data AsType GenesisExtendedKey = AsGenesisExtendedKey - proxyToAsType _ = AsGenesisExtendedKey - -instance Key GenesisExtendedKey where - newtype VerificationKey GenesisExtendedKey - = GenesisExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisExtendedKey) - - newtype SigningKey GenesisExtendedKey - = GenesisExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisExtendedKey) - - deterministicSigningKey :: - AsType GenesisExtendedKey -> - Crypto.Seed -> - SigningKey GenesisExtendedKey - deterministicSigningKey AsGenesisExtendedKey seed = - GenesisExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType GenesisExtendedKey -> Word - deterministicSigningKeySeedSize AsGenesisExtendedKey = 32 - - getVerificationKey :: - SigningKey GenesisExtendedKey -> - VerificationKey GenesisExtendedKey - getVerificationKey (GenesisExtendedSigningKey sk) = - GenesisExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey GenesisExtendedKey -> - Hash GenesisExtendedKey - verificationKeyHash (GenesisExtendedVerificationKey vk) = - GenesisExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey GenesisExtendedKey) where - toCBOR (GenesisExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey GenesisExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey GenesisExtendedKey) where - toCBOR (GenesisExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey GenesisExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsGenesisExtendedKey) bs = - either - (const Nothing) - (Just . GenesisExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsGenesisExtendedKey) bs = - either - (const Nothing) - (Just . GenesisExtendedSigningKey) - (Crypto.HD.xprv bs) - -newtype instance Hash GenesisExtendedKey - = GenesisExtendedKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisExtendedKey) where - serialiseToRawBytes (GenesisExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisExtendedKey) bs = - GenesisExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisExtendedKey) where - textEnvelopeType _ = "GenesisExtendedVerificationKey_ed25519_bip32" - -instance HasTextEnvelope (SigningKey GenesisExtendedKey) where - textEnvelopeType _ = "GenesisExtendedSigningKey_ed25519_bip32" - -instance CastVerificationKeyRole GenesisExtendedKey GenesisKey where - castVerificationKey (GenesisExtendedVerificationKey vk) = - GenesisVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Genesis delegate keys --- - -data GenesisDelegateKey - -instance HasTypeProxy GenesisDelegateKey where - data AsType GenesisDelegateKey = AsGenesisDelegateKey - proxyToAsType _ = AsGenesisDelegateKey - -instance Key GenesisDelegateKey where - newtype VerificationKey GenesisDelegateKey - = GenesisDelegateVerificationKey (Shelley.VKey Shelley.GenesisDelegate) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisDelegateKey - = GenesisDelegateSigningKey ((SignKeyDSIGN DSIGN)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisDelegateKey -> Crypto.Seed -> SigningKey GenesisDelegateKey - deterministicSigningKey AsGenesisDelegateKey seed = - GenesisDelegateSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisDelegateKey -> Word - deterministicSigningKeySeedSize AsGenesisDelegateKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey GenesisDelegateKey -> VerificationKey GenesisDelegateKey - getVerificationKey (GenesisDelegateSigningKey sk) = - GenesisDelegateVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisDelegateKey -> Hash GenesisDelegateKey - verificationKeyHash (GenesisDelegateVerificationKey vkey) = - GenesisDelegateKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateKey) bs = - GenesisDelegateVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateKey) bs = - GenesisDelegateSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -newtype instance Hash GenesisDelegateKey - = GenesisDelegateKeyHash (Shelley.KeyHash Shelley.GenesisDelegate) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisDelegateKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisDelegateKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisDelegateKey) where - serialiseToRawBytes (GenesisDelegateKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisDelegateKey) bs = - GenesisDelegateKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisDelegateKey) where - textEnvelopeType _ = - "GenesisDelegateVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey GenesisDelegateKey) where - textEnvelopeType _ = - "GenesisDelegateSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance CastVerificationKeyRole GenesisDelegateKey StakePoolKey where - castVerificationKey (GenesisDelegateVerificationKey (Shelley.VKey vkey)) = - StakePoolVerificationKey (Shelley.VKey vkey) - -instance CastSigningKeyRole GenesisDelegateKey StakePoolKey where - castSigningKey (GenesisDelegateSigningKey skey) = - StakePoolSigningKey skey - --- --- Shelley genesis delegate extended ed25519 keys --- - --- | Shelley-era genesis keys using extended ed25519 cryptographic keys. --- --- These serve the same role as normal genesis keys, but are here to support --- legacy Byron genesis keys which used extended keys. --- --- The extended verification keys can be converted (via 'castVerificationKey') --- to ordinary keys (i.e. 'VerificationKey' 'GenesisKey') but this is /not/ the --- case for the signing keys. The signing keys can be used to witness --- transactions directly, with verification via their non-extended verification --- key ('VerificationKey' 'GenesisKey'). --- --- This is a type level tag, used with other interfaces like 'Key'. -data GenesisDelegateExtendedKey - -instance HasTypeProxy GenesisDelegateExtendedKey where - data AsType GenesisDelegateExtendedKey = AsGenesisDelegateExtendedKey - proxyToAsType _ = AsGenesisDelegateExtendedKey - -instance Key GenesisDelegateExtendedKey where - newtype VerificationKey GenesisDelegateExtendedKey - = GenesisDelegateExtendedVerificationKey Crypto.HD.XPub - deriving stock Eq - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisDelegateExtendedKey) - - newtype SigningKey GenesisDelegateExtendedKey - = GenesisDelegateExtendedSigningKey Crypto.HD.XPrv - deriving anyclass SerialiseAsCBOR - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisDelegateExtendedKey) - - deterministicSigningKey :: - AsType GenesisDelegateExtendedKey -> - Crypto.Seed -> - SigningKey GenesisDelegateExtendedKey - deterministicSigningKey AsGenesisDelegateExtendedKey seed = - GenesisDelegateExtendedSigningKey - (Crypto.HD.generate seedbs BS.empty) - where - (seedbs, _) = Crypto.getBytesFromSeedT 32 seed - - deterministicSigningKeySeedSize :: AsType GenesisDelegateExtendedKey -> Word - deterministicSigningKeySeedSize AsGenesisDelegateExtendedKey = 32 - - getVerificationKey :: - SigningKey GenesisDelegateExtendedKey -> - VerificationKey GenesisDelegateExtendedKey - getVerificationKey (GenesisDelegateExtendedSigningKey sk) = - GenesisDelegateExtendedVerificationKey (Crypto.HD.toXPub sk) - - -- \| We use the hash of the normal non-extended pub key so that it is - -- consistent with the one used in addresses and signatures. - verificationKeyHash :: - VerificationKey GenesisDelegateExtendedKey -> - Hash GenesisDelegateExtendedKey - verificationKeyHash (GenesisDelegateExtendedVerificationKey vk) = - GenesisDelegateExtendedKeyHash - . Shelley.KeyHash - . Crypto.castHash - $ Crypto.hashWith Crypto.HD.xpubPublicKey vk - -instance ToCBOR (VerificationKey GenesisDelegateExtendedKey) where - toCBOR (GenesisDelegateExtendedVerificationKey xpub) = - toCBOR (Crypto.HD.unXPub xpub) - -instance FromCBOR (VerificationKey GenesisDelegateExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisDelegateExtendedVerificationKey) - (Crypto.HD.xpub (bs :: ByteString)) - -instance ToCBOR (SigningKey GenesisDelegateExtendedKey) where - toCBOR (GenesisDelegateExtendedSigningKey xprv) = - toCBOR (Crypto.HD.unXPrv xprv) - -instance FromCBOR (SigningKey GenesisDelegateExtendedKey) where - fromCBOR = do - bs <- fromCBOR - either - fail - (return . GenesisDelegateExtendedSigningKey) - (Crypto.HD.xprv (bs :: ByteString)) - -instance SerialiseAsRawBytes (VerificationKey GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedVerificationKey xpub) = - Crypto.HD.unXPub xpub - - deserialiseFromRawBytes (AsVerificationKey AsGenesisDelegateExtendedKey) bs = - either - (const Nothing) - (Just . GenesisDelegateExtendedVerificationKey) - (Crypto.HD.xpub bs) - -instance SerialiseAsRawBytes (SigningKey GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedSigningKey xprv) = - Crypto.HD.unXPrv xprv - - deserialiseFromRawBytes (AsSigningKey AsGenesisDelegateExtendedKey) bs = - either - (const Nothing) - (Just . GenesisDelegateExtendedSigningKey) - (Crypto.HD.xprv bs) - -newtype instance Hash GenesisDelegateExtendedKey - = GenesisDelegateExtendedKeyHash (Shelley.KeyHash Shelley.Staking) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisDelegateExtendedKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisDelegateExtendedKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisDelegateExtendedKey) where - serialiseToRawBytes (GenesisDelegateExtendedKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisDelegateExtendedKey) bs = - GenesisDelegateExtendedKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisDelegateExtendedKey) where - textEnvelopeType _ = "GenesisDelegateExtendedVerificationKey_ed25519_bip32" - -instance HasTextEnvelope (SigningKey GenesisDelegateExtendedKey) where - textEnvelopeType _ = "GenesisDelegateExtendedSigningKey_ed25519_bip32" - -instance CastVerificationKeyRole GenesisDelegateExtendedKey GenesisDelegateKey where - castVerificationKey (GenesisDelegateExtendedVerificationKey vk) = - GenesisDelegateVerificationKey - . Shelley.VKey - . fromMaybe impossible - . Crypto.rawDeserialiseVerKeyDSIGN - . Crypto.HD.xpubPublicKey - $ vk - where - impossible = - error "castVerificationKey: byron and shelley key sizes do not match!" - --- --- Genesis UTxO keys --- - -data GenesisUTxOKey - -instance HasTypeProxy GenesisUTxOKey where - data AsType GenesisUTxOKey = AsGenesisUTxOKey - proxyToAsType _ = AsGenesisUTxOKey - -instance Key GenesisUTxOKey where - newtype VerificationKey GenesisUTxOKey - = GenesisUTxOVerificationKey (Shelley.VKey Shelley.Payment) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisUTxOKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey GenesisUTxOKey - = GenesisUTxOSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey GenesisUTxOKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType GenesisUTxOKey -> Crypto.Seed -> SigningKey GenesisUTxOKey - deterministicSigningKey AsGenesisUTxOKey seed = - GenesisUTxOSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType GenesisUTxOKey -> Word - deterministicSigningKeySeedSize AsGenesisUTxOKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey GenesisUTxOKey -> VerificationKey GenesisUTxOKey - getVerificationKey (GenesisUTxOSigningKey sk) = - GenesisUTxOVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey GenesisUTxOKey -> Hash GenesisUTxOKey - verificationKeyHash (GenesisUTxOVerificationKey vkey) = - GenesisUTxOKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsGenesisUTxOKey) bs = - GenesisUTxOVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsGenesisUTxOKey) bs = - GenesisUTxOSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -newtype instance Hash GenesisUTxOKey - = GenesisUTxOKeyHash (Shelley.KeyHash Shelley.Payment) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisUTxOKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisUTxOKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash GenesisUTxOKey) where - serialiseToRawBytes (GenesisUTxOKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsGenesisUTxOKey) bs = - GenesisUTxOKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance HasTextEnvelope (VerificationKey GenesisUTxOKey) where - textEnvelopeType _ = - "GenesisUTxOVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey GenesisUTxOKey) where - textEnvelopeType _ = - "GenesisUTxOSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - --- TODO: use a different type from the stake pool key, since some operations --- need a genesis key specifically - -instance CastVerificationKeyRole GenesisUTxOKey PaymentKey where - castVerificationKey (GenesisUTxOVerificationKey (Shelley.VKey vkey)) = - PaymentVerificationKey (Shelley.VKey vkey) - -instance CastSigningKeyRole GenesisUTxOKey PaymentKey where - castSigningKey (GenesisUTxOSigningKey skey) = - PaymentSigningKey skey - --- --- stake pool keys --- - -data StakePoolKey - -instance HasTypeProxy StakePoolKey where - data AsType StakePoolKey = AsStakePoolKey - proxyToAsType _ = AsStakePoolKey - -instance Key StakePoolKey where - newtype VerificationKey StakePoolKey - = StakePoolVerificationKey (Shelley.VKey Shelley.StakePool) - deriving stock Eq - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey StakePoolKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - newtype SigningKey StakePoolKey - = StakePoolSigningKey (SignKeyDSIGN DSIGN) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey StakePoolKey) - deriving newtype (ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR - - deterministicSigningKey :: AsType StakePoolKey -> Crypto.Seed -> SigningKey StakePoolKey - deterministicSigningKey AsStakePoolKey seed = - StakePoolSigningKey (Crypto.genKeyDSIGN seed) - - deterministicSigningKeySeedSize :: AsType StakePoolKey -> Word - deterministicSigningKeySeedSize AsStakePoolKey = - Crypto.seedSizeDSIGN proxy - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - - getVerificationKey :: SigningKey StakePoolKey -> VerificationKey StakePoolKey - getVerificationKey (StakePoolSigningKey sk) = - StakePoolVerificationKey (Shelley.VKey (Crypto.deriveVerKeyDSIGN sk)) - - verificationKeyHash :: VerificationKey StakePoolKey -> Hash StakePoolKey - verificationKeyHash (StakePoolVerificationKey vkey) = - StakePoolKeyHash (Shelley.hashKey vkey) - -instance SerialiseAsRawBytes (VerificationKey StakePoolKey) where - serialiseToRawBytes (StakePoolVerificationKey (Shelley.VKey vk)) = - Crypto.rawSerialiseVerKeyDSIGN vk - - deserialiseFromRawBytes (AsVerificationKey AsStakePoolKey) bs = - StakePoolVerificationKey . Shelley.VKey - <$> Crypto.rawDeserialiseVerKeyDSIGN bs - -instance SerialiseAsRawBytes (SigningKey StakePoolKey) where - serialiseToRawBytes (StakePoolSigningKey sk) = - Crypto.rawSerialiseSignKeyDSIGN sk - - deserialiseFromRawBytes (AsSigningKey AsStakePoolKey) bs = - StakePoolSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs - -instance SerialiseAsBech32 (VerificationKey StakePoolKey) where - bech32PrefixFor _ = "pool_vk" - bech32PrefixesPermitted _ = ["pool_vk"] - -instance SerialiseAsBech32 (SigningKey StakePoolKey) where - bech32PrefixFor _ = "pool_sk" - bech32PrefixesPermitted _ = ["pool_sk"] - -newtype instance Hash StakePoolKey - = StakePoolKeyHash (Shelley.KeyHash Shelley.StakePool) - deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash StakePoolKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash StakePoolKey) - deriving anyclass SerialiseAsCBOR - -instance SerialiseAsRawBytes (Hash StakePoolKey) where - serialiseToRawBytes (StakePoolKeyHash (Shelley.KeyHash vkh)) = - Crypto.hashToBytes vkh - - deserialiseFromRawBytes (AsHash AsStakePoolKey) bs = - StakePoolKeyHash . Shelley.KeyHash <$> Crypto.hashFromBytes bs - -instance SerialiseAsBech32 (Hash StakePoolKey) where - bech32PrefixFor _ = "pool" - bech32PrefixesPermitted _ = ["pool"] - -instance ToJSON (Hash StakePoolKey) where - toJSON = toJSON . serialiseToBech32 - -instance ToJSONKey (Hash StakePoolKey) where - toJSONKey = toJSONKeyText serialiseToBech32 - -instance FromJSON (Hash StakePoolKey) where - parseJSON = withText "PoolId" $ \str -> - case deserialiseFromBech32 (AsHash AsStakePoolKey) str of - Left err -> - fail $ - "Error deserialising Hash StakePoolKey: " - <> Text.unpack str - <> " Error: " - <> displayError err - Right h -> pure h - -instance HasTextEnvelope (VerificationKey StakePoolKey) where - textEnvelopeType _ = - "StakePoolVerificationKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy - -instance HasTextEnvelope (SigningKey StakePoolKey) where - textEnvelopeType _ = - "StakePoolSigningKey_" - <> fromString (Crypto.algorithmNameDSIGN proxy) - where - proxy :: Proxy Shelley.DSIGN - proxy = Proxy diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs deleted file mode 100644 index 979cefa97c..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/OperationalCertificate.hs - --- | Operational certificates -module Cardano.Api.OperationalCertificate - ( -- OperationalCertIssueError (..) - OperationalCertificate (..) - , OperationalCertificateIssueCounter (..) - , Shelley.KESPeriod (..) - , getHotKey - , getKesPeriod - , getOpCertCount - -- , issueOperationalCertificate - - -- * Data family instances - , AsType (..) - ) where - -import Cardano.Api.Any -import Cardano.Api.Key -import Cardano.Api.KeysByron -import Cardano.Api.KeysPraos -import Cardano.Api.KeysShelley -import Cardano.Api.SerialiseTextEnvelope -import qualified Cardano.Ledger.Binary as CBOR - ( CBORGroup (..) - , shelleyProtVer - , toPlainDecoder - , toPlainEncoding - ) -import Cardano.Protocol.Crypto (StandardCrypto) -import qualified Cardano.Protocol.TPraos.OCert as Shelley -import Data.Word - --- ---------------------------------------------------------------------------- --- Operational certificates --- - -data OperationalCertificate - = OperationalCertificate - !(Shelley.OCert StandardCrypto) - !(VerificationKey StakePoolKey) - deriving (Eq, Show) - deriving anyclass SerialiseAsCBOR - -data OperationalCertificateIssueCounter - = OperationalCertificateIssueCounter - { opCertIssueCount :: !Word64 - , opCertIssueColdKey :: !(VerificationKey StakePoolKey) -- For consistency checking - } - deriving (Eq, Show) - deriving anyclass SerialiseAsCBOR - -instance ToCBOR OperationalCertificate where - toCBOR = CBOR.toPlainEncoding CBOR.shelleyProtVer . encCBOR - -instance FromCBOR OperationalCertificate where - fromCBOR = CBOR.toPlainDecoder Nothing CBOR.shelleyProtVer decCBOR - -instance ToCBOR OperationalCertificateIssueCounter where - toCBOR = CBOR.toPlainEncoding CBOR.shelleyProtVer . encCBOR - -instance FromCBOR OperationalCertificateIssueCounter where - fromCBOR = CBOR.toPlainDecoder Nothing CBOR.shelleyProtVer decCBOR - -instance EncCBOR OperationalCertificate where - encCBOR (OperationalCertificate ocert vkey) = - encCBOR (CBOR.CBORGroup ocert, vkey) - -instance DecCBOR OperationalCertificate where - decCBOR = do - (CBOR.CBORGroup ocert, vkey) <- decCBOR - return (OperationalCertificate ocert vkey) - -instance EncCBOR OperationalCertificateIssueCounter where - encCBOR (OperationalCertificateIssueCounter counter vkey) = - encCBOR (counter, vkey) - -instance DecCBOR OperationalCertificateIssueCounter where - decCBOR = do - (counter, vkey) <- decCBOR - return (OperationalCertificateIssueCounter counter vkey) - -instance HasTypeProxy OperationalCertificate where - data AsType OperationalCertificate = AsOperationalCertificate - proxyToAsType _ = AsOperationalCertificate - -instance HasTypeProxy OperationalCertificateIssueCounter where - data AsType OperationalCertificateIssueCounter = AsOperationalCertificateIssueCounter - proxyToAsType _ = AsOperationalCertificateIssueCounter - -instance HasTextEnvelope OperationalCertificate where - textEnvelopeType _ = "NodeOperationalCertificate" - -getHotKey :: OperationalCertificate -> VerificationKey UnsoundPureKesKey -getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert - -getKesPeriod :: OperationalCertificate -> Word -getKesPeriod (OperationalCertificate cert _) = Shelley.unKESPeriod $ Shelley.ocertKESPeriod cert - -getOpCertCount :: OperationalCertificate -> Word64 -getOpCertCount (OperationalCertificate cert _) = Shelley.ocertN cert diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs deleted file mode 100644 index da084cc8da..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs +++ /dev/null @@ -1,129 +0,0 @@ --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs - -module Cardano.Api.Protocol.Types - ( BlockType (..) - , Protocol (..) - , ProtocolClient (..) - , ProtocolClientInfoArgs (..) - , ProtocolInfoArgs (..) - ) where - -import Cardano.Chain.Slotting (EpochSlots) -import qualified Control.Tracer as Tracer -import Data.Bifunctor (bimap) -import Ouroboros.Consensus.Block.Forging (MkBlockForging (..)) -import Ouroboros.Consensus.Byron.ByronHFC (ByronBlockHFC) -import Ouroboros.Consensus.Cardano -import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.Node -import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary -import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus - ( LedgerSupportsProtocol - ) -import Ouroboros.Consensus.Node.ProtocolInfo - ( ProtocolClientInfo (..) - , ProtocolInfo (..) - ) -import Ouroboros.Consensus.Node.Run (RunNode) -import Ouroboros.Consensus.Protocol.Praos.AgentClient -import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus -import qualified Ouroboros.Consensus.Shelley.Eras as Consensus (ShelleyEra) -import Ouroboros.Consensus.Shelley.HFEras () -import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus - ( ShelleyBlock - ) -import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () -import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) -import Ouroboros.Consensus.Util.IOLike - -class (RunNode blk, IOLike m) => Protocol m blk where - data ProtocolInfoArgs m blk - protocolInfo :: - ProtocolInfoArgs m blk -> - ( ProtocolInfo blk - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m blk] - ) - --- | Node client support for each consensus protocol. --- --- This is like 'Protocol' but for clients of the node, so with less onerous --- requirements than to run a node. -class RunNode blk => ProtocolClient blk where - data ProtocolClientInfoArgs blk - protocolClientInfo :: ProtocolClientInfoArgs blk -> ProtocolClientInfo blk - --- | Run PBFT against the Byron ledger -instance IOLike m => Protocol m ByronBlockHFC where - data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron - protocolInfo (ProtocolInfoArgsByron params) = - ( inject $ protocolInfoByron params - , \_ -> pure . map (MkBlockForging . pure . inject) $ blockForgingByron params - ) - -instance - ( CardanoHardForkConstraints StandardCrypto - , IOLike m - , MonadKESAgent m - ) => - Protocol m (CardanoBlock StandardCrypto) - where - data ProtocolInfoArgs m (CardanoBlock StandardCrypto) - = ProtocolInfoArgsCardano - (CardanoProtocolParams StandardCrypto) - - protocolInfo (ProtocolInfoArgsCardano paramsCardano) = - protocolInfoCardano paramsCardano - -instance ProtocolClient ByronBlockHFC where - data ProtocolClientInfoArgs ByronBlockHFC - = ProtocolClientInfoArgsByron EpochSlots - protocolClientInfo (ProtocolClientInfoArgsByron epochSlots) = - inject $ protocolClientInfoByron epochSlots - -instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto) where - data ProtocolClientInfoArgs (CardanoBlock StandardCrypto) - = ProtocolClientInfoArgsCardano EpochSlots - protocolClientInfo (ProtocolClientInfoArgsCardano epochSlots) = - protocolClientInfoCardano epochSlots - -instance - ( IOLike m - , MonadKESAgent m - , Consensus.LedgerSupportsProtocol - ( Consensus.ShelleyBlock - (Consensus.TPraos StandardCrypto) - ShelleyEra - ) - ) => - Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - where - data ProtocolInfoArgs m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - = ProtocolInfoArgsShelley - ShelleyGenesis - (ProtocolParamsShelleyBased StandardCrypto) - ProtVer - protocolInfo (ProtocolInfoArgsShelley genesis shelleyBasedProtocolParams' protVer) = - bimap inject injectBlockForging $ protocolInfoShelley genesis shelleyBasedProtocolParams' protVer - where - injectBlockForging bf tr = fmap (map inject) $ bf tr - -instance - Consensus.LedgerSupportsProtocol - ( Consensus.ShelleyBlock - (Consensus.TPraos StandardCrypto) - Consensus.ShelleyEra - ) => - ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - where - data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - = ProtocolClientInfoArgsShelley - protocolClientInfo ProtocolClientInfoArgsShelley = - inject protocolClientInfoShelley - -data BlockType blk where - ByronBlockType :: BlockType ByronBlockHFC - ShelleyBlockType :: BlockType (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) - CardanoBlockType :: BlockType (CardanoBlock StandardCrypto) - -deriving instance Eq (BlockType blk) -deriving instance Show (BlockType blk) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseTextEnvelope.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseTextEnvelope.hs deleted file mode 100644 index 086c88557b..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseTextEnvelope.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseTextEnvelope.hs - --- | TextEnvelope Serialisation -module Cardano.Api.SerialiseTextEnvelope - ( FromSomeType (..) - , HasTextEnvelope (..) - , TextEnvelope (..) - , TextEnvelopeDescr (..) - , TextEnvelopeError (..) - , TextEnvelopeType (..) - , deserialiseFromTextEnvelope - , deserialiseFromTextEnvelopeAnyOf - , readFileTextEnvelope - , readFileTextEnvelopeAnyOf - , readTextEnvelopeFromFile - , readTextEnvelopeOfTypeFromFile - , serialiseToTextEnvelope - - -- * Data family instances - , AsType (..) - ) where - -import Cardano.Api.Any -import Cardano.Ledger.Binary (DecoderError) -import Control.Monad (unless) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Control.Monad.Trans.Except.Extra - ( firstExceptT - , handleIOExceptT - , hoistEither - ) -import Data.Aeson as Aeson - ( FromJSON (..) - , ToJSON (..) - , eitherDecodeStrict' - , object - , withObject - , (.:) - , (.=) - ) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import Data.String (IsString) -import qualified Data.Text.Encoding as Text - --- ---------------------------------------------------------------------------- --- Text envelopes --- - -newtype TextEnvelopeType = TextEnvelopeType String - deriving (Eq, Show) - deriving newtype (IsString, Semigroup, ToJSON, FromJSON) - -newtype TextEnvelopeDescr = TextEnvelopeDescr String - deriving (Eq, Show) - deriving newtype (IsString, Semigroup, ToJSON, FromJSON) - --- | A 'TextEnvelope' is a structured envelope for serialised binary values --- with an external format with a semi-readable textual format. --- --- It contains a \"type\" field, e.g. \"PublicKeyByron\" or \"TxSignedShelley\" --- to indicate the type of the encoded data. This is used as a sanity check --- and to help readers. --- --- It also contains a \"title\" field which is free-form, and could be used --- to indicate the role or purpose to a reader. -data TextEnvelope = TextEnvelope - { teType :: !TextEnvelopeType - , teDescription :: !TextEnvelopeDescr - , teRawCBOR :: !ByteString - } - deriving (Eq, Show) - -instance HasTypeProxy TextEnvelope where - data AsType TextEnvelope = AsTextEnvelope - proxyToAsType _ = AsTextEnvelope - -instance ToJSON TextEnvelope where - toJSON TextEnvelope{teType, teDescription, teRawCBOR} = - object - [ "type" .= teType - , "description" .= teDescription - , "cborHex" .= Text.decodeUtf8 (Base16.encode teRawCBOR) - ] - -instance FromJSON TextEnvelope where - parseJSON = withObject "TextEnvelope" $ \v -> - TextEnvelope - <$> (v .: "type") - <*> (v .: "description") - <*> (parseJSONBase16 =<< v .: "cborHex") - where - parseJSONBase16 v = - either fail return . Base16.decode . Text.encodeUtf8 =<< parseJSON v - --- | The errors that the pure 'TextEnvelope' parsing\/decoding functions can return. -data TextEnvelopeError - = -- | expected, actual - TextEnvelopeTypeError ![TextEnvelopeType] !TextEnvelopeType - | TextEnvelopeDecodeError !DecoderError - | TextEnvelopeAesonDecodeError !String - deriving (Eq, Show) - -instance Error TextEnvelopeError where - displayError tee = - case tee of - TextEnvelopeTypeError - [TextEnvelopeType expType] - (TextEnvelopeType actType) -> - "TextEnvelope type error: " - <> " Expected: " - <> expType - <> " Actual: " - <> actType - TextEnvelopeTypeError expTypes (TextEnvelopeType actType) -> - "TextEnvelope type error: " - <> " Expected one of: " - <> List.intercalate - ", " - [expType | TextEnvelopeType expType <- expTypes] - <> " Actual: " - <> actType - TextEnvelopeAesonDecodeError decErr -> "TextEnvelope aeson decode error: " <> decErr - TextEnvelopeDecodeError decErr -> "TextEnvelope decode error: " <> show decErr - --- | Check that the \"type\" of the 'TextEnvelope' is as expected. --- --- For example, one might check that the type is \"TxSignedShelley\". -expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelope -> Either TextEnvelopeError () -expectTextEnvelopeOfType expectedType TextEnvelope{teType = actualType} = - unless (expectedType == actualType) $ - Left (TextEnvelopeTypeError [expectedType] actualType) - --- ---------------------------------------------------------------------------- --- Serialisation in text envelope format --- - -class SerialiseAsCBOR a => HasTextEnvelope a where - textEnvelopeType :: AsType a -> TextEnvelopeType - - textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr - textEnvelopeDefaultDescr _ = "" - -serialiseToTextEnvelope :: - forall a. - HasTextEnvelope a => - Maybe TextEnvelopeDescr -> a -> TextEnvelope -serialiseToTextEnvelope mbDescr a = - TextEnvelope - { teType = textEnvelopeType ttoken - , teDescription = fromMaybe (textEnvelopeDefaultDescr a) mbDescr - , teRawCBOR = serialiseToCBOR a - } - where - ttoken :: AsType a - ttoken = proxyToAsType Proxy - -deserialiseFromTextEnvelope :: - HasTextEnvelope a => - AsType a -> - TextEnvelope -> - Either TextEnvelopeError a -deserialiseFromTextEnvelope ttoken te = do - expectTextEnvelopeOfType (textEnvelopeType ttoken) te - first TextEnvelopeDecodeError $ - deserialiseFromCBOR ttoken (teRawCBOR te) -- TODO: You have switched from CBOR to JSON - -deserialiseFromTextEnvelopeAnyOf :: - [FromSomeType HasTextEnvelope b] -> - TextEnvelope -> - Either TextEnvelopeError b -deserialiseFromTextEnvelopeAnyOf types te = - case List.find matching types of - Nothing -> - Left (TextEnvelopeTypeError expectedTypes actualType) - Just (FromSomeType ttoken f) -> - first TextEnvelopeDecodeError $ - f <$> deserialiseFromCBOR ttoken (teRawCBOR te) - where - actualType = teType te - expectedTypes = - [ textEnvelopeType ttoken - | FromSomeType ttoken _f <- types - ] - - matching (FromSomeType ttoken _f) = actualType == textEnvelopeType ttoken - -readFileTextEnvelope :: - HasTextEnvelope a => - AsType a -> - FilePath -> - IO (Either (FileError TextEnvelopeError) a) -readFileTextEnvelope ttoken path = - runExceptT $ do - content <- handleIOExceptT (FileIOError path) $ BS.readFile path - firstExceptT (FileError path) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content - deserialiseFromTextEnvelope ttoken te - -readFileTextEnvelopeAnyOf :: - [FromSomeType HasTextEnvelope b] -> - FilePath -> - IO (Either (FileError TextEnvelopeError) b) -readFileTextEnvelopeAnyOf types path = - runExceptT $ do - content <- handleIOExceptT (FileIOError path) $ BS.readFile path - firstExceptT (FileError path) $ hoistEither $ do - te <- first TextEnvelopeAesonDecodeError $ Aeson.eitherDecodeStrict' content - deserialiseFromTextEnvelopeAnyOf types te - -readTextEnvelopeFromFile :: - FilePath -> - IO (Either (FileError TextEnvelopeError) TextEnvelope) -readTextEnvelopeFromFile path = - runExceptT $ do - bs <- - handleIOExceptT (FileIOError path) $ - BS.readFile path - firstExceptT (FileError path . TextEnvelopeAesonDecodeError) - . hoistEither - $ Aeson.eitherDecodeStrict' bs - -readTextEnvelopeOfTypeFromFile :: - TextEnvelopeType -> - FilePath -> - IO (Either (FileError TextEnvelopeError) TextEnvelope) -readTextEnvelopeOfTypeFromFile expectedType path = - runExceptT $ do - te <- ExceptT (readTextEnvelopeFromFile path) - firstExceptT (FileError path) $ - hoistEither $ - expectTextEnvelopeOfType expectedType te - return te diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs deleted file mode 100644 index 7cbe767594..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/SerialiseUsing.hs - --- | Raw binary serialisation -module Cardano.Api.SerialiseUsing - ( UsingRawBytes (..) - , UsingRawBytesHex (..) - ) where - -import Cardano.Api.Any -import Data.Aeson.Types - ( FromJSON - , FromJSONKey - , ToJSON (..) - , ToJSONKey - ) -import qualified Data.Aeson.Types as Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BSC -import Data.String (IsString (..)) -import qualified Data.Text.Encoding as Text -import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) - --- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances, --- based on the 'SerialiseAsRawBytes' instance. Eg: --- --- > deriving (ToCBOR, FromCBOR) via (UsingRawBytes Blah) -newtype UsingRawBytes a = UsingRawBytes a - -instance (SerialiseAsRawBytes a, Typeable a) => ToCBOR (UsingRawBytes a) where - toCBOR (UsingRawBytes x) = toCBOR (serialiseToRawBytes x) - -instance (SerialiseAsRawBytes a, Typeable a) => FromCBOR (UsingRawBytes a) where - fromCBOR = do - bs <- fromCBOR - case deserialiseFromRawBytes ttoken bs of - Just x -> return (UsingRawBytes x) - Nothing -> fail ("cannot deserialise as a " ++ tname) - where - ttoken = proxyToAsType (Proxy :: Proxy a) - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) - -instance (SerialiseAsRawBytes a, Typeable a) => EncCBOR (UsingRawBytes a) - -instance (SerialiseAsRawBytes a, Typeable a) => DecCBOR (UsingRawBytes a) - --- | For use with @deriving via@, to provide instances for any\/all of 'Show', --- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex --- encoding, based on the 'SerialiseAsRawBytes' instance. --- --- > deriving (Show, IsString) via (UsingRawBytesHex Blah) --- > deriving (ToJSON, FromJSON) via (UsingRawBytesHex Blah) --- > deriving (ToJSONKey, FromJSONKey) via (UsingRawBytesHex Blah) -newtype UsingRawBytesHex a = UsingRawBytesHex a - -instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where - show (UsingRawBytesHex x) = show (serialiseToRawBytesHex x) - -instance SerialiseAsRawBytes a => IsString (UsingRawBytesHex a) where - fromString = either error id . deserialiseFromRawBytesBase16 . BSC.pack - -instance SerialiseAsRawBytes a => ToJSON (UsingRawBytesHex a) where - toJSON (UsingRawBytesHex x) = toJSON (serialiseToRawBytesHexText x) - -instance (SerialiseAsRawBytes a, Typeable a) => FromJSON (UsingRawBytesHex a) where - parseJSON = - Aeson.withText tname $ - either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 - where - tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a) - -instance SerialiseAsRawBytes a => ToJSONKey (UsingRawBytesHex a) where - toJSONKey = - Aeson.toJSONKeyText $ \(UsingRawBytesHex x) -> serialiseToRawBytesHexText x - -instance (SerialiseAsRawBytes a, Typeable a) => FromJSONKey (UsingRawBytesHex a) where - fromJSONKey = - Aeson.FromJSONKeyTextParser $ - either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8 - -deserialiseFromRawBytesBase16 :: - SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a) -deserialiseFromRawBytesBase16 str = - case Base16.decode str of - Right raw -> case deserialiseFromRawBytes ttoken raw of - Just x -> Right (UsingRawBytesHex x) - Nothing -> Left ("cannot deserialise " ++ show str) - Left msg -> Left ("invalid hex " ++ show str ++ ", " ++ msg) - where - ttoken = proxyToAsType (Proxy :: Proxy a) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Alonzo.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Alonzo.hs deleted file mode 100644 index a84605a9d3..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Alonzo.hs +++ /dev/null @@ -1,54 +0,0 @@ --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Alonzo.hs - -module Cardano.Node.Protocol.Alonzo - ( AlonzoProtocolInstantiationError (..) - - -- * Reusable parts - , readGenesis - , validateGenesis - ) where - -import Cardano.Api.Any -import qualified Cardano.Ledger.Alonzo.Genesis as Alonzo -import Cardano.Node.Protocol.Shelley - ( GenesisReadError - , readGenesisAny - ) -import Cardano.Node.Types -import Cardano.Prelude -import Prelude (String) - --- --- Alonzo genesis --- - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - ExceptT - GenesisReadError - IO - (Alonzo.AlonzoGenesis, GenesisHash) -readGenesis = readGenesisAny - -validateGenesis :: - Alonzo.AlonzoGenesis -> - ExceptT AlonzoProtocolInstantiationError IO () -validateGenesis _ = return () -- TODO alonzo: do the validation - -data AlonzoProtocolInstantiationError - = InvalidCostModelError !FilePath - | CostModelExtractionError !FilePath - | AlonzoCostModelFileError !(FileError ()) - | AlonzoCostModelDecodeError !FilePath !String - deriving Show - -instance Error AlonzoProtocolInstantiationError where - displayError (InvalidCostModelError fp) = - "Invalid cost model: " <> show fp - displayError (CostModelExtractionError fp) = - "Error extracting the cost model at: " <> show fp - displayError (AlonzoCostModelFileError err) = - displayError err - displayError (AlonzoCostModelDecodeError fp err) = - "Error decoding cost model at: " <> show fp <> " Error: " <> err diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Byron.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Byron.hs deleted file mode 100644 index 93c6624553..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Byron.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Byron.hs - -module Cardano.Node.Protocol.Byron - ( -- * Errors - ByronProtocolInstantiationError (..) - - -- * Reusable parts - , readGenesis - , readLeaderCredentials - ) where - -import Cardano.Api.Any -import Cardano.Api.KeysByron -import qualified Cardano.Chain.Genesis as Genesis -import qualified Cardano.Chain.UTxO as UTxO -import qualified Cardano.Crypto.Hash as Crypto -import qualified Cardano.Crypto.Hashing as Byron.Crypto -import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic) -import Cardano.Node.Types -import Cardano.Prelude -import Control.Monad.Trans.Except.Extra - ( bimapExceptT - , firstExceptT - , hoistEither - , hoistMaybe - , left - ) -import qualified Data.ByteString.Lazy as LB -import Data.Text as Text (unpack) -import Ouroboros.Consensus.Cardano -import Prelude hiding (show, (.)) - ------------------------------------------------------------------------------- --- Byron protocol --- - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - RequiresNetworkMagic -> - ExceptT - ByronProtocolInstantiationError - IO - Genesis.Config -readGenesis (GenesisFile file) mbExpectedGenesisHash ncReqNetworkMagic = do - (genesisData, genesisHash) <- - firstExceptT (GenesisReadError file) $ - Genesis.readGenesisData file - checkExpectedGenesisHash genesisHash - return - Genesis.Config - { Genesis.configGenesisData = genesisData - , Genesis.configGenesisHash = genesisHash - , Genesis.configReqNetMagic = ncReqNetworkMagic - , Genesis.configUTxOConfiguration = UTxO.defaultUTxOConfiguration - -- TODO: add config support for the UTxOConfiguration if needed - } - where - checkExpectedGenesisHash :: - Genesis.GenesisHash -> - ExceptT ByronProtocolInstantiationError IO () - checkExpectedGenesisHash actual' = - case mbExpectedGenesisHash of - Just expected - | actual /= expected -> - throwError (GenesisHashMismatch actual expected) - where - actual = fromByronGenesisHash actual' - _ -> return () - - fromByronGenesisHash :: Genesis.GenesisHash -> GenesisHash - fromByronGenesisHash (Genesis.GenesisHash h) = - GenesisHash - . fromMaybe impossible - . Crypto.hashFromBytes - . Byron.Crypto.hashToBytes - $ h - where - impossible = - panic "fromByronGenesisHash: old and new crypto libs disagree on hash size" - -readLeaderCredentials :: - Genesis.Config -> - Maybe ProtocolFilepaths -> - ExceptT - ByronProtocolInstantiationError - IO - (Maybe ByronLeaderCredentials) -readLeaderCredentials _ Nothing = return Nothing -readLeaderCredentials - genesisConfig - ( Just - ProtocolFilepaths - { byronCertFile - , byronKeyFile - } - ) = - case (byronCertFile, byronKeyFile) of - (Nothing, Nothing) -> pure Nothing - (Just _, Nothing) -> left SigningKeyFilepathNotSpecified - (Nothing, Just _) -> left DelegationCertificateFilepathNotSpecified - (Just delegCertFile, Just signingKeyFile) -> do - signingKeyFileBytes <- liftIO $ LB.readFile signingKeyFile - delegCertFileBytes <- liftIO $ LB.readFile delegCertFile - ByronSigningKey signingKey <- - hoistMaybe (SigningKeyDeserialiseFailure signingKeyFile) $ - deserialiseFromRawBytes (AsSigningKey AsByronKey) $ - LB.toStrict signingKeyFileBytes - delegCert <- - firstExceptT (CanonicalDecodeFailure delegCertFile) - . hoistEither - $ canonicalDecodePretty delegCertFileBytes - - bimapExceptT CredentialsError Just - . hoistEither - $ mkByronLeaderCredentials genesisConfig signingKey delegCert "Byron" - ------------------------------------------------------------------------------- --- Byron Errors --- - -data ByronProtocolInstantiationError - = CanonicalDecodeFailure !FilePath !Text - | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected - | DelegationCertificateFilepathNotSpecified - | GenesisConfigurationError !FilePath !Genesis.ConfigurationError - | GenesisReadError !FilePath !Genesis.GenesisDataError - | CredentialsError !ByronLeaderCredentialsError - | SigningKeyDeserialiseFailure !FilePath - | SigningKeyFilepathNotSpecified - deriving Show - -instance Error ByronProtocolInstantiationError where - displayError (CanonicalDecodeFailure fp failure) = - "Canonical decode failure in " - <> fp - <> " Canonical failure: " - <> Text.unpack failure - displayError (GenesisHashMismatch actual expected) = - "Wrong Byron genesis file: the actual hash is " - <> show actual - <> ", but the expected Byron genesis hash given in the node configuration " - <> "file is " - <> show expected - displayError DelegationCertificateFilepathNotSpecified = - "Delegation certificate filepath not specified" - -- TODO: Implement configuration error render function in cardano-ledger - displayError (GenesisConfigurationError fp genesisConfigError) = - "Genesis configuration error in: " - <> toS fp - <> " Error: " - <> show genesisConfigError - displayError (GenesisReadError fp err) = - "There was an error parsing the genesis file: " - <> toS fp - <> " Error: " - <> show err - -- TODO: Implement ByronLeaderCredentialsError render function in ouroboros-network - displayError (CredentialsError byronLeaderCredentialsError) = - "Byron leader credentials error: " <> show byronLeaderCredentialsError - displayError (SigningKeyDeserialiseFailure fp) = - "Signing key deserialisation error in: " <> toS fp - displayError SigningKeyFilepathNotSpecified = - "Signing key filepath not specified" diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs deleted file mode 100644 index c177f1b3a1..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Cardano.hs - -module Cardano.Node.Protocol.Cardano - ( mkConsensusProtocolCardano - - -- * Errors - , CardanoProtocolInstantiationError (..) - ) where - -import Cardano.Api.Any (Error (..)) -import qualified Cardano.Chain.Update as Byron -import qualified Cardano.Ledger.Api.Transition as SL -import Cardano.Ledger.BaseTypes -import Cardano.Ledger.Dijkstra.PParams -import qualified Cardano.Node.Protocol.Alonzo as Alonzo -import qualified Cardano.Node.Protocol.Byron as Byron -import qualified Cardano.Node.Protocol.Conway as Conway -import Cardano.Node.Protocol.Shelley (readGenesisAny) -import qualified Cardano.Node.Protocol.Shelley as Shelley -import Cardano.Node.Types -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Except.Extra (firstExceptT) -import Data.Maybe (fromMaybe) -import Ouroboros.Consensus.Cardano -import qualified Ouroboros.Consensus.Cardano as Consensus -import Ouroboros.Consensus.Cardano.Condense () -import Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams (..)) -import Ouroboros.Consensus.Config (emptyCheckpointsMap) -import Ouroboros.Consensus.HardFork.Combinator.Condense () -import Ouroboros.Consensus.Shelley.Crypto (StandardCrypto) - ------------------------------------------------------------------------------- --- Real Cardano protocol --- - --- | Make 'SomeConsensusProtocol' using the Cardano instance. --- --- The Cardano protocol instance is currently the sequential composition of --- the Byron and Shelley protocols, and will likely be extended in future --- with further sequentially composed protocol revisions. --- --- The use of 'SomeConsensusProtocol' lets us handle multiple protocols in a --- generic way. --- --- This also serves a purpose as a sanity check that we have all the necessary --- type class instances available. -mkConsensusProtocolCardano :: - NodeByronProtocolConfiguration -> - NodeShelleyProtocolConfiguration -> - NodeAlonzoProtocolConfiguration -> - NodeConwayProtocolConfiguration -> - Maybe NodeDijkstraProtocolConfiguration -> - NodeHardForkProtocolConfiguration -> - Maybe ProtocolFilepaths -> - ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto) -mkConsensusProtocolCardano - NodeByronProtocolConfiguration - { npcByronGenesisFile - , npcByronGenesisFileHash - , npcByronReqNetworkMagic - , npcByronPbftSignatureThresh - , npcByronApplicationName - , npcByronApplicationVersion - , npcByronSupportedProtocolVersionMajor - , npcByronSupportedProtocolVersionMinor - , npcByronSupportedProtocolVersionAlt - } - NodeShelleyProtocolConfiguration - { npcShelleyGenesisFile - , npcShelleyGenesisFileHash - } - NodeAlonzoProtocolConfiguration - { npcAlonzoGenesisFile - , npcAlonzoGenesisFileHash - } - NodeConwayProtocolConfiguration - { npcConwayGenesisFile - , npcConwayGenesisFileHash - } - npcDijkstraProtocolConfig - NodeHardForkProtocolConfiguration - { npcTestEnableDevelopmentHardForkEras - , -- During testing of the latest unreleased era, we conditionally - -- declared that we knew about it. We do so only when a config option - -- for testing development/unstable eras is used. This lets us include - -- not-yet-ready eras in released node versions without mainnet nodes - -- prematurely advertising that they could hard fork into the new era. - npcTestShelleyHardForkAtEpoch - , npcTestAllegraHardForkAtEpoch - , npcTestMaryHardForkAtEpoch - , npcTestAlonzoHardForkAtEpoch - , npcTestBabbageHardForkAtEpoch - , npcTestConwayHardForkAtEpoch - , npcTestDijkstraHardForkAtEpoch - } - files = do - byronGenesis <- - firstExceptT CardanoProtocolInstantiationErrorByron $ - Byron.readGenesis - npcByronGenesisFile - npcByronGenesisFileHash - npcByronReqNetworkMagic - - byronLeaderCredentials <- - firstExceptT CardanoProtocolInstantiationErrorByron $ - Byron.readLeaderCredentials byronGenesis files - - (shelleyGenesis, shelleyGenesisHash) <- - firstExceptT CardanoProtocolInstantiationShelleyGenesisReadError $ - Shelley.readGenesis - npcShelleyGenesisFile - npcShelleyGenesisFileHash - - (alonzoGenesis, _alonzoGenesisHash) <- - firstExceptT CardanoProtocolInstantiationAlonzoGenesisReadError $ - Alonzo.readGenesis - npcAlonzoGenesisFile - npcAlonzoGenesisFileHash - - (conwayGenesis, _conwayGenesisHash) <- - firstExceptT CardanoProtocolInstantiationConwayGenesisReadError $ - Conway.readGenesis - npcConwayGenesisFile - npcConwayGenesisFileHash - - dijkstraGenesis <- case npcDijkstraProtocolConfig of - Nothing -> pure emptyDijkstraGenesis - Just - ( NodeDijkstraProtocolConfiguration - { npcDijkstraGenesisFile - , npcDijkstraGenesisFileHash - } - ) -> do - (dijkstraGenesis, _dijkstraGenesisHash) <- - firstExceptT CardanoProtocolInstantiationDijkstraGenesisReadError $ - readGenesisAny - npcDijkstraGenesisFile - npcDijkstraGenesisFileHash - pure dijkstraGenesis - - shelleyLeaderCredentials <- - firstExceptT CardanoProtocolInstantiationPraosLeaderCredentialsError $ - Shelley.readLeaderCredentials files - - let transitionLedgerConfig = - SL.mkLatestTransitionConfig shelleyGenesis alonzoGenesis conwayGenesis dijkstraGenesis - - -- TODO: all these protocol versions below are confusing and unnecessary. - -- It could and should all be automated and these config entries eliminated. - return $! - CardanoProtocolParams - Consensus.ProtocolParamsByron - { byronGenesis = byronGenesis - , byronPbftSignatureThreshold = - PBftSignatureThreshold <$> npcByronPbftSignatureThresh - , -- This is /not/ the Byron protocol version. It is the protocol - -- version that this node will use in blocks it creates. It is used - -- in the Byron update mechanism to signal that this block-producing - -- node is ready to move to the new protocol. For example, when the - -- protocol version (according to the ledger state) is 0, this setting - -- should be 1 when we are ready to move. Similarly when the current - -- protocol version is 1, this should be 2 to indicate we are ready - -- to move into the Shelley era. - byronProtocolVersion = - Byron.ProtocolVersion - npcByronSupportedProtocolVersionMajor - npcByronSupportedProtocolVersionMinor - npcByronSupportedProtocolVersionAlt - , byronSoftwareVersion = - Byron.SoftwareVersion - npcByronApplicationName - npcByronApplicationVersion - , byronLeaderCredentials = byronLeaderCredentials - } - Consensus.ProtocolParamsShelleyBased - { shelleyBasedInitialNonce = - Shelley.genesisHashToPraosNonce - shelleyGenesisHash - , shelleyBasedLeaderCredentials = shelleyLeaderCredentials - } - -- The 'CardanoHardForkTriggers' specify the parameters needed to - -- transition between two eras. The comments below also apply for all - -- subsequent hard forks. - -- - -- Byron to Shelley hard fork parameters - Consensus.CardanoHardForkTriggers' - { triggerHardForkShelley = - -- What will trigger the Byron -> Shelley hard fork? - case npcTestShelleyHardForkAtEpoch of - -- This specifies the major protocol version number update that will - -- trigger us moving to the Shelley protocol. - -- - -- Version 0 is Byron with Ouroboros classic - -- Version 1 is Byron with Ouroboros Permissive BFT - -- Version 2 is Shelley - -- Version 3 is Allegra - -- Version 4 is Mary - -- Version 5 is Alonzo - -- Version 6 is Alonzo (intra era hardfork) - -- Version 7 is Babbage - -- Version 8 is Babbage (intra era hardfork) - -- Version 9 is Conway - -- Version 10 is Conway (intra era hardfork) - -- Version 11 is Conway (intra era hardfork) - -- Version 12 is Dijkstra - -- - -- But we also provide an override to allow for simpler test setups - -- such as triggering at the 0 -> 1 transition . - -- - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - -- Alternatively, for testing we can transition at a specific epoch. - -- - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - , -- Shelley to Allegra hard fork parameters - triggerHardForkAllegra = - case npcTestAllegraHardForkAtEpoch of - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - , -- Allegra to Mary hard fork parameters - triggerHardForkMary = - case npcTestMaryHardForkAtEpoch of - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - , -- Mary to Alonzo hard fork parameters - triggerHardForkAlonzo = - case npcTestAlonzoHardForkAtEpoch of - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - , -- Alonzo to Babbage hard fork parameters - triggerHardForkBabbage = - case npcTestBabbageHardForkAtEpoch of - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - , -- Babbage to Conway hard fork parameters - triggerHardForkConway = - case npcTestConwayHardForkAtEpoch of - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - , -- Conway to Dijkstra hard fork parameters - triggerHardForkDijkstra = - case npcTestDijkstraHardForkAtEpoch of - Nothing -> Consensus.CardanoTriggerHardForkAtDefaultVersion - Just epochNo -> Consensus.CardanoTriggerHardForkAtEpoch epochNo - } - transitionLedgerConfig - emptyCheckpointsMap - -- IMPORTANT: this Protver below has to be kept in sync with the values - -- used in the node in cardano-node/src/Cardano/Node/Protocol/Cardano.hs - -- in function mkSomeConsensusProtocolCardano. - ( if npcTestEnableDevelopmentHardForkEras - then ProtVer (natVersion @11) 0 - else ProtVer (natVersion @10) 7 - ) - --- | An empty Dijkstra genesis to be provided when none is specified in the config. -emptyDijkstraGenesis :: SL.DijkstraGenesis -emptyDijkstraGenesis = - let upgradePParamsDef = - UpgradeDijkstraPParams - { udppMaxRefScriptSizePerBlock = 1048576 - , udppMaxRefScriptSizePerTx = 204800 - , udppRefScriptCostStride = unsafeNonZero 25600 - , udppRefScriptCostMultiplier = fromMaybe (error "impossible") $ boundRational 1.2 - } - in SL.DijkstraGenesis{SL.dgUpgradePParams = upgradePParamsDef} - ------------------------------------------------------------------------------- --- Errors --- - -data CardanoProtocolInstantiationError - = CardanoProtocolInstantiationErrorByron - Byron.ByronProtocolInstantiationError - | CardanoProtocolInstantiationShelleyGenesisReadError - Shelley.GenesisReadError - | CardanoProtocolInstantiationAlonzoGenesisReadError - Shelley.GenesisReadError - | CardanoProtocolInstantiationConwayGenesisReadError - Shelley.GenesisReadError - | CardanoProtocolInstantiationDijkstraGenesisReadError - Shelley.GenesisReadError - | CardanoProtocolInstantiationPraosLeaderCredentialsError - Shelley.PraosLeaderCredentialsError - | CardanoProtocolInstantiationErrorAlonzo - Alonzo.AlonzoProtocolInstantiationError - deriving Show - -instance Error CardanoProtocolInstantiationError where - displayError (CardanoProtocolInstantiationErrorByron err) = - displayError err - displayError (CardanoProtocolInstantiationShelleyGenesisReadError err) = - "Shelley related: " <> displayError err - displayError (CardanoProtocolInstantiationAlonzoGenesisReadError err) = - "Alonzo related: " <> displayError err - displayError (CardanoProtocolInstantiationConwayGenesisReadError err) = - "Conway related: " <> displayError err - displayError (CardanoProtocolInstantiationDijkstraGenesisReadError err) = - "Dijkstra related: " <> displayError err - displayError (CardanoProtocolInstantiationPraosLeaderCredentialsError err) = - displayError err - displayError (CardanoProtocolInstantiationErrorAlonzo err) = - displayError err diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Conway.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Conway.hs deleted file mode 100644 index 72d1e6e5cf..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Conway.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE EmptyDataDeriving #-} - --- TODO DUPLICATE? -- as-if adapted? from: cardano-node/src/Cardano/Node/Protocol/Conway.hs - -module Cardano.Node.Protocol.Conway - ( ConwayProtocolInstantiationError - - -- * Reusable parts - , readGenesis - , validateGenesis - ) where - -import qualified Cardano.Ledger.Conway.Genesis as Conway -import Cardano.Node.Protocol.Shelley - ( GenesisReadError - , readGenesisAny - ) -import Cardano.Node.Types -import Cardano.Prelude - --- --- Conway genesis --- - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - ExceptT - GenesisReadError - IO - (Conway.ConwayGenesis, GenesisHash) -readGenesis = readGenesisAny - -validateGenesis :: - Conway.ConwayGenesis -> - ExceptT ConwayProtocolInstantiationError IO () -validateGenesis _ = return () -- TODO conway: do the validation - -data ConwayProtocolInstantiationError - {- TODO - = InvalidCostModelError !FilePath - | CostModelExtractionError !FilePath - | ConwayCostModelFileError !(FileError ()) - | ConwayCostModelDecodeError !FilePath !String - -} - deriving Show - -{- TODO -instance Error ConwayProtocolInstantiationError where - displayError (InvalidCostModelError fp) = - "Invalid cost model: " <> show fp - displayError (CostModelExtractionError fp) = - "Error extracting the cost model at: " <> show fp - displayError (ConwayCostModelFileError err) = - displayError err - displayError (ConwayCostModelDecodeError fp err) = - "Error decoding cost model at: " <> show fp <> " Error: " <> err - --} diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs deleted file mode 100644 index 1e2997df63..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Shelley.hs - -module Cardano.Node.Protocol.Shelley - ( -- * Errors - GenesisReadError (..) - , GenesisValidationError (..) - , PraosLeaderCredentialsError (..) - , ShelleyProtocolInstantiationError (..) - - -- * Reusable parts - , genesisHashToPraosNonce - , readGenesis - , readGenesisAny - , readLeaderCredentials - , validateGenesis - ) where - -import Cardano.Api.Any hiding (FileError (..)) -import qualified Cardano.Api.Any as Api (FileError (..)) -import Cardano.Api.Key -import Cardano.Api.KeysPraos as Praos -import Cardano.Api.KeysShelley -import Cardano.Api.OperationalCertificate -import Cardano.Api.SerialiseTextEnvelope -import qualified Cardano.Crypto.Hash.Class as Crypto -import Cardano.Ledger.Keys (coerceKeyRole) -import qualified Cardano.Ledger.Shelley.Genesis as Shelley -import Cardano.Node.Types -import Cardano.Prelude -import Cardano.Protocol.Crypto (StandardCrypto) -import Control.Monad.Trans.Except.Extra - ( firstExceptT - , handleIOExceptT - , hoistEither - , left - , newExceptT - ) -import qualified Data.Aeson as Aeson (FromJSON (..), eitherDecodeStrict') -import qualified Data.ByteString as BS -import qualified Data.Text as T -import Ouroboros.Consensus.Protocol.Praos.Common - ( PraosCanBeLeader (..) - , PraosCredentialsSource (..) - ) -import Ouroboros.Consensus.Shelley.Node - ( Nonce (..) - , ShelleyGenesis (..) - , ShelleyLeaderCredentials (..) - ) -import Prelude (String, id) - ------------------------------------------------------------------------------- --- Shelley protocol --- - -genesisHashToPraosNonce :: GenesisHash -> Nonce -genesisHashToPraosNonce (GenesisHash h) = Nonce (Crypto.castHash h) - -readGenesis :: - GenesisFile -> - Maybe GenesisHash -> - ExceptT - GenesisReadError - IO - (ShelleyGenesis, GenesisHash) -readGenesis = readGenesisAny - -readGenesisAny :: - Aeson.FromJSON genesis => - GenesisFile -> - Maybe GenesisHash -> - ExceptT GenesisReadError IO (genesis, GenesisHash) -readGenesisAny (GenesisFile file) mbExpectedGenesisHash = do - content <- - handleIOExceptT (GenesisReadFileError file) - $ BS.readFile file - let genesisHash = GenesisHash (Crypto.hashWith id content) - checkExpectedGenesisHash genesisHash - genesis <- - firstExceptT (GenesisDecodeError file) - $ hoistEither - $ Aeson.eitherDecodeStrict' content - return (genesis, genesisHash) - where - checkExpectedGenesisHash :: - GenesisHash -> - ExceptT GenesisReadError IO () - checkExpectedGenesisHash actual = - case mbExpectedGenesisHash of - Just expected - | actual /= expected -> - throwError (GenesisHashMismatch actual expected) - _ -> return () - -validateGenesis :: - ShelleyGenesis -> - ExceptT GenesisValidationError IO () -validateGenesis genesis = - firstExceptT GenesisValidationErrors - . hoistEither - $ Shelley.validateGenesis genesis - -readLeaderCredentials :: - Maybe ProtocolFilepaths -> - ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] -readLeaderCredentials Nothing = return [] -readLeaderCredentials (Just pfp) = - -- The set of credentials is a sum total of what comes from the CLI, - -- as well as what's in the bulk credentials file. - (<>) - <$> readLeaderCredentialsSingleton pfp - <*> readLeaderCredentialsBulk pfp - -readLeaderCredentialsSingleton :: - ProtocolFilepaths -> - ExceptT - PraosLeaderCredentialsError - IO - [ShelleyLeaderCredentials StandardCrypto] --- It's OK to supply none of the files on the CLI -readLeaderCredentialsSingleton - ProtocolFilepaths - { shelleyCertFile = Nothing - , shelleyVRFFile = Nothing - , shelleyKESFile = Nothing - } = pure [] --- Or to supply all of the files -readLeaderCredentialsSingleton - ProtocolFilepaths - { shelleyCertFile = Just opCertFile - , shelleyVRFFile = Just vrfFile - , shelleyKESFile = Just kesFile - } = do - vrfSKey <- - firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfFile) - - (opCert, kesSKey) <- opCertKesKeyCheck kesFile opCertFile - - return [mkPraosLeaderCredentials opCert vrfSKey kesSKey] - --- But not OK to supply some of the files without the others. -readLeaderCredentialsSingleton ProtocolFilepaths{shelleyCertFile = Nothing} = - left OCertNotSpecified -readLeaderCredentialsSingleton ProtocolFilepaths{shelleyVRFFile = Nothing} = - left VRFKeyNotSpecified -readLeaderCredentialsSingleton ProtocolFilepaths{shelleyKESFile = Nothing} = - left KESKeyNotSpecified - -opCertKesKeyCheck :: - -- | KES key - FilePath -> - -- | Operational certificate - FilePath -> - ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey UnsoundPureKesKey) -opCertKesKeyCheck kesFile certFile = do - opCert <- - firstExceptT FileError (newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile) - kesSKey <- - firstExceptT - FileError - (newExceptT $ readFileTextEnvelope (AsSigningKey AsUnsoundPureKesKey) kesFile) - let opCertSpecifiedKesKeyhash = verificationKeyHash $ getHotKey opCert - suppliedKesKeyHash = verificationKeyHash $ getVerificationKey kesSKey - -- Specified KES key in operational certificate should match the one - -- supplied to the node. - if suppliedKesKeyHash /= opCertSpecifiedKesKeyhash - then left $ MismatchedKesKey kesFile certFile - else return (opCert, kesSKey) - -data ShelleyCredentials - = ShelleyCredentials - { scCert :: (TextEnvelope, FilePath) - , scVrf :: (TextEnvelope, FilePath) - , scKes :: (TextEnvelope, FilePath) - } - -readLeaderCredentialsBulk :: - ProtocolFilepaths -> - ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] -readLeaderCredentialsBulk ProtocolFilepaths{shelleyBulkCredsFile = mfp} = - mapM parseShelleyCredentials =<< readBulkFile mfp - where - parseShelleyCredentials :: - ShelleyCredentials -> - ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) - parseShelleyCredentials ShelleyCredentials{scCert, scVrf, scKes} = - mkPraosLeaderCredentials - <$> parseEnvelope AsOperationalCertificate scCert - <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf - <*> parseEnvelope (AsSigningKey AsUnsoundPureKesKey) scKes - - readBulkFile :: - Maybe FilePath -> - ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials] - readBulkFile Nothing = pure [] - readBulkFile (Just fp) = do - content <- - handleIOExceptT (CredentialsReadError fp) - $ BS.readFile fp - envelopes <- - firstExceptT (EnvelopeParseError fp) - $ hoistEither - $ Aeson.eitherDecodeStrict' content - pure $ uncurry mkCredentials <$> zip [0 ..] envelopes - where - mkCredentials :: - Int -> - (TextEnvelope, TextEnvelope, TextEnvelope) -> - ShelleyCredentials - mkCredentials ix (teCert, teVrf, teKes) = - let loc ty = fp <> "." <> show ix <> ty - in ShelleyCredentials - (teCert, loc "cert") - (teVrf, loc "vrf") - (teKes, loc "kes") - -mkPraosLeaderCredentials :: - OperationalCertificate -> - SigningKey VrfKey -> - SigningKey UnsoundPureKesKey -> - ShelleyLeaderCredentials StandardCrypto -mkPraosLeaderCredentials - (OperationalCertificate opcert (StakePoolVerificationKey vkey)) - (VrfSigningKey vrfKey) - (KesSigningKey kesKey) = - ShelleyLeaderCredentials - { shelleyLeaderCredentialsCanBeLeader = - PraosCanBeLeader - { praosCanBeLeaderColdVerKey = coerceKeyRole vkey - , praosCanBeLeaderSignKeyVRF = vrfKey - , praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound opcert kesKey - } - , shelleyLeaderCredentialsLabel = "Shelley" - } - -parseEnvelope :: - HasTextEnvelope a => - AsType a -> - (TextEnvelope, String) -> - ExceptT PraosLeaderCredentialsError IO a -parseEnvelope as (te, loc) = - firstExceptT (FileError . Api.FileError loc) - . hoistEither - $ deserialiseFromTextEnvelope as te - ------------------------------------------------------------------------------- --- Errors --- - -data ShelleyProtocolInstantiationError - = GenesisReadError GenesisReadError - | GenesisValidationError GenesisValidationError - | PraosLeaderCredentialsError PraosLeaderCredentialsError - deriving Show - -instance Error ShelleyProtocolInstantiationError where - displayError (GenesisReadError err) = displayError err - displayError (GenesisValidationError err) = displayError err - displayError (PraosLeaderCredentialsError err) = displayError err - -data GenesisReadError - = GenesisReadFileError !FilePath !IOException - | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected - | GenesisDecodeError !FilePath !String - deriving Show - -instance Error GenesisReadError where - displayError (GenesisReadFileError fp err) = - "There was an error reading the genesis file: " - <> toS fp - <> " Error: " - <> show err - displayError (GenesisHashMismatch actual expected) = - "Wrong genesis file: the actual hash is " - <> show actual - <> ", but the expected genesis hash given in the node " - <> "configuration file is " - <> show expected - displayError (GenesisDecodeError fp err) = - "There was an error parsing the genesis file: " - <> toS fp - <> " Error: " - <> show err - -newtype GenesisValidationError = GenesisValidationErrors [Shelley.ValidationErr] - deriving Show - -instance Error GenesisValidationError where - displayError (GenesisValidationErrors vErrs) = - T.unpack (unlines (map Shelley.describeValidationErr vErrs)) - -data PraosLeaderCredentialsError - = CredentialsReadError !FilePath !IOException - | EnvelopeParseError !FilePath !String - | FileError !(Api.FileError TextEnvelopeError) - | OCertNotSpecified - | VRFKeyNotSpecified - | KESKeyNotSpecified - | MismatchedKesKey - FilePath - -- KES signing key - FilePath - -- Operational certificate - deriving Show - -instance Error PraosLeaderCredentialsError where - displayError (CredentialsReadError fp err) = - "There was an error reading a credentials file: " - <> toS fp - <> " Error: " - <> show err - displayError (EnvelopeParseError fp err) = - "There was an error parsing a credentials envelope: " - <> toS fp - <> " Error: " - <> show err - displayError (FileError fileErr) = displayError fileErr - displayError (MismatchedKesKey kesFp certFp) = - "The KES key provided at: " - <> show kesFp - <> " does not match the KES key specified in the operational certificate at: " - <> show certFp - displayError OCertNotSpecified = missingFlagMessage "shelley-operational-certificate" - displayError VRFKeyNotSpecified = missingFlagMessage "shelley-vrf-key" - displayError KESKeyNotSpecified = missingFlagMessage "shelley-kes-key" - -missingFlagMessage :: String -> String -missingFlagMessage flag = - "To create blocks, the --" <> flag <> " must also be specified" diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs deleted file mode 100644 index 8e46c045d3..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Types.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Types.hs - -module Cardano.Node.Types - ( -- * Configuration - AdjustFilePaths (..) - , ConfigError (..) - , ConfigYamlFilePath (..) - , DbFile (..) - , GenesisFile (..) - , GenesisHash (..) - , MaxConcurrencyBulkSync (..) - , MaxConcurrencyDeadline (..) - , ProtocolFilepaths (..) - - -- * Consensus protocol configuration - , NodeAlonzoProtocolConfiguration (..) - , NodeByronProtocolConfiguration (..) - , NodeConwayProtocolConfiguration (..) - , NodeDijkstraProtocolConfiguration (..) - , NodeHardForkProtocolConfiguration (..) - , NodeProtocolConfigurationCardano (..) - , NodeShelleyProtocolConfiguration (..) - , VRFPrivateKeyFilePermissionError (..) - , renderVRFPrivateKeyFilePermissionError - ) where - -import qualified Cardano.Chain.Update as Byron -import Cardano.Crypto (RequiresNetworkMagic) -import qualified Cardano.Crypto.Hash as Crypto -import Data.Aeson -import Data.String (IsString) -import Data.Text as Text (Text, pack, unpack) -import Data.Word (Word16, Word8) -import Ouroboros.Consensus.Block.Abstract (EpochNo) - --- | Errors for the cardano-config module. -data ConfigError - = ConfigErrorFileNotFound FilePath - | ConfigErrorNoEKG - deriving Show - --- | Filepath of the configuration yaml file. This file determines --- all the configuration settings required for the cardano node --- (logging, tracing, protocol, slot length etc) -newtype ConfigYamlFilePath = ConfigYamlFilePath - {unConfigPath :: FilePath} - deriving newtype (Eq, Show) - -newtype DbFile = DbFile - {unDB :: FilePath} - deriving newtype (Eq, Show) - -newtype GenesisFile = GenesisFile - {unGenesisFile :: FilePath} - deriving stock (Eq, Ord) - deriving newtype (IsString, Show) - -instance FromJSON GenesisFile where - parseJSON (String genFp) = pure . GenesisFile $ Text.unpack genFp - parseJSON invalid = - fail $ - "Parsing of GenesisFile failed due to type mismatch. " - <> "Encountered: " - <> show invalid - -newtype MaxConcurrencyBulkSync = MaxConcurrencyBulkSync - {unMaxConcurrencyBulkSync :: Word} - deriving stock (Eq, Ord) - deriving newtype (FromJSON, Show) - -newtype MaxConcurrencyDeadline = MaxConcurrencyDeadline - {unMaxConcurrencyDeadline :: Word} - deriving stock (Eq, Ord) - deriving newtype (FromJSON, Show) - -{- --- | Newtype wrapper which provides 'FromJSON' instance for 'DiffusionMode'. --- -newtype NodeDiffusionMode - = NodeDiffusionMode { getDiffusionMode :: DiffusionMode } - deriving newtype Show - -instance FromJSON NodeDiffusionMode where - parseJSON (String str) = - case str of - "InitiatorOnly" - -> pure $ NodeDiffusionMode InitiatorOnlyDiffusionMode - "InitiatorAndResponder" - -> pure $ NodeDiffusionMode InitiatorAndResponderDiffusionMode - _ -> fail "Parsing NodeDiffusionMode failed: can be either 'InitiatorOnly' or 'InitiatorAndResponder'" - parseJSON _ = fail "Parsing NodeDiffusionMode failed" --} - -class AdjustFilePaths a where - adjustFilePaths :: (FilePath -> FilePath) -> a -> a - -data ProtocolFilepaths - = ProtocolFilepaths - { byronCertFile :: !(Maybe FilePath) - , byronKeyFile :: !(Maybe FilePath) - , shelleyKESFile :: !(Maybe FilePath) - , shelleyVRFFile :: !(Maybe FilePath) - , shelleyCertFile :: !(Maybe FilePath) - , shelleyBulkCredsFile :: !(Maybe FilePath) - } - deriving (Eq, Show) - -newtype GenesisHash = GenesisHash (Crypto.Hash Crypto.Blake2b_256 Crypto.ByteString) - deriving newtype (Eq, Show, ToJSON, FromJSON) - -data NodeProtocolConfigurationCardano - = NodeProtocolConfigurationCardano - NodeByronProtocolConfiguration - NodeShelleyProtocolConfiguration - NodeAlonzoProtocolConfiguration - NodeConwayProtocolConfiguration - NodeDijkstraProtocolConfiguration - NodeHardForkProtocolConfiguration - deriving (Eq, Show) - -data NodeShelleyProtocolConfiguration - = NodeShelleyProtocolConfiguration - { npcShelleyGenesisFile :: !GenesisFile - , npcShelleyGenesisFileHash :: !(Maybe GenesisHash) - } - deriving (Eq, Show) - -data NodeAlonzoProtocolConfiguration - = NodeAlonzoProtocolConfiguration - { npcAlonzoGenesisFile :: !GenesisFile - , npcAlonzoGenesisFileHash :: !(Maybe GenesisHash) - } - deriving (Eq, Show) - -data NodeByronProtocolConfiguration - = NodeByronProtocolConfiguration - { npcByronGenesisFile :: !GenesisFile - , npcByronGenesisFileHash :: !(Maybe GenesisHash) - , npcByronReqNetworkMagic :: !RequiresNetworkMagic - , npcByronPbftSignatureThresh :: !(Maybe Double) - , -- TODO: eliminate these two: it can be hard-coded - - npcByronApplicationName :: !Byron.ApplicationName - -- ^ Update application name. - , npcByronApplicationVersion :: !Byron.NumSoftwareVersion - -- ^ Application (ie software) version. - , -- TODO: eliminate these: it can be done automatically in consensus - - npcByronSupportedProtocolVersionMajor :: !Word16 - -- ^ These declare the version of the protocol that the node is prepared - -- to run. This is usually the version of the protocol in use on the - -- chain now, but during protocol updates this version will be the one - -- that we declare that we are ready to move to. This is the endorsement - -- mechanism for determining when enough block producers are ready to - -- move to the next version. - , npcByronSupportedProtocolVersionMinor :: !Word16 - , npcByronSupportedProtocolVersionAlt :: !Word8 - } - deriving (Eq, Show) - -data NodeConwayProtocolConfiguration - = NodeConwayProtocolConfiguration - { npcConwayGenesisFile :: !GenesisFile - , npcConwayGenesisFileHash :: !(Maybe GenesisHash) - } - deriving (Eq, Show) - -data NodeDijkstraProtocolConfiguration - = NodeDijkstraProtocolConfiguration - { npcDijkstraGenesisFile :: !GenesisFile - , npcDijkstraGenesisFileHash :: !(Maybe GenesisHash) - } - deriving (Eq, Show) - --- | Configuration relating to a hard forks themselves, not the specific eras. -data NodeHardForkProtocolConfiguration - = NodeHardForkProtocolConfiguration - { npcTestEnableDevelopmentHardForkEras :: Bool - -- ^ During the development and integration of new eras we wish to be - -- able to test the hard fork transition into the new era, but we do not - -- wish to generally have the node advertise that it understands the new - -- era. Avoiding advertising new development eras until they are ready - -- makes it practical to include new not-yet-ready eras into the main - -- release version of the node without the danger that operators on the - -- mainnet will prematurely advertise that their nodes are capable of - -- crossing the next hard fork. - -- - -- It should /always/ remain at the default of false for nodes running - -- on the mainnet. - -- - -- This flag should be set to true for nodes taking part in testnets for - -- testing the new era. - , npcTestShelleyHardForkAtEpoch :: Maybe EpochNo - -- ^ For testing purposes we support specifying that the hard fork - -- happens at an exact epoch number (ie the first epoch of the new era). - -- - -- Obviously if this is used, all the nodes in the test cluster must be - -- configured the same, or they will disagree. - , npcTestAllegraHardForkAtEpoch :: Maybe EpochNo - -- ^ For testing purposes we support specifying that the hard fork - -- happens at an exact epoch number (ie the first epoch of the new era). - -- - -- Obviously if this is used, all the nodes in the test cluster must be - -- configured the same, or they will disagree. - , npcTestMaryHardForkAtEpoch :: Maybe EpochNo - -- ^ For testing purposes we support specifying that the hard fork - -- happens at an exact epoch number (ie the first epoch of the new era). - -- - -- Obviously if this is used, all the nodes in the test cluster must be - -- configured the same, or they will disagree. - , npcTestAlonzoHardForkAtEpoch :: Maybe EpochNo - -- ^ For testing purposes we support specifying that the hard fork - -- happens at an exact epoch number (ie the first epoch of the new era). - -- - -- Obviously if this is used, all the nodes in the test cluster must be - -- configured the same, or they will disagree. - , npcTestBabbageHardForkAtEpoch :: Maybe EpochNo - , npcTestConwayHardForkAtEpoch :: Maybe EpochNo - , npcTestDijkstraHardForkAtEpoch :: Maybe EpochNo - } - deriving (Eq, Show) - -instance AdjustFilePaths NodeProtocolConfigurationCardano where - adjustFilePaths f (NodeProtocolConfigurationCardano pcb pcs pca pcc pcd pch) = - NodeProtocolConfigurationCardano - (adjustFilePaths f pcb) - (adjustFilePaths f pcs) - (adjustFilePaths f pca) - (adjustFilePaths f pcc) - (adjustFilePaths f pcd) - pch - -instance AdjustFilePaths NodeByronProtocolConfiguration where - adjustFilePaths - f - x@NodeByronProtocolConfiguration - { npcByronGenesisFile - } = - x{npcByronGenesisFile = adjustFilePaths f npcByronGenesisFile} - -instance AdjustFilePaths NodeShelleyProtocolConfiguration where - adjustFilePaths - f - x@NodeShelleyProtocolConfiguration - { npcShelleyGenesisFile - } = - x{npcShelleyGenesisFile = adjustFilePaths f npcShelleyGenesisFile} - -instance AdjustFilePaths NodeAlonzoProtocolConfiguration where - adjustFilePaths - f - x@NodeAlonzoProtocolConfiguration - { npcAlonzoGenesisFile - } = - x{npcAlonzoGenesisFile = adjustFilePaths f npcAlonzoGenesisFile} - -instance AdjustFilePaths NodeConwayProtocolConfiguration where - adjustFilePaths - f - x@NodeConwayProtocolConfiguration - { npcConwayGenesisFile - } = - x{npcConwayGenesisFile = adjustFilePaths f npcConwayGenesisFile} - -instance AdjustFilePaths NodeDijkstraProtocolConfiguration where - adjustFilePaths - f - x@NodeDijkstraProtocolConfiguration - { npcDijkstraGenesisFile - } = - x{npcDijkstraGenesisFile = adjustFilePaths f npcDijkstraGenesisFile} - -instance AdjustFilePaths GenesisFile where - adjustFilePaths f (GenesisFile p) = GenesisFile (f p) - -instance AdjustFilePaths a => AdjustFilePaths (Maybe a) where - adjustFilePaths f = fmap (adjustFilePaths f) - -data VRFPrivateKeyFilePermissionError - = OtherPermissionsExist FilePath - | GroupPermissionsExist FilePath - | GenericPermissionsExist FilePath - deriving Show - -renderVRFPrivateKeyFilePermissionError :: VRFPrivateKeyFilePermissionError -> Text -renderVRFPrivateKeyFilePermissionError err = - case err of - OtherPermissionsExist fp -> - "VRF private key file at: " - <> Text.pack fp - <> " has \"other\" file permissions. Please remove all \"other\" file permissions." - GroupPermissionsExist fp -> - "VRF private key file at: " - <> Text.pack fp - <> "has \"group\" file permissions. Please remove all \"group\" file permissions." - GenericPermissionsExist fp -> - "VRF private key file at: " - <> Text.pack fp - <> "has \"generic\" file permissions. Please remove all \"generic\" file permissions." diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 69a008d1f8..988ad1f5b5 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -37,7 +37,7 @@ import Cardano.Tools.DBAnalyser.Types import Control.Monad (join, unless, void, when) import Control.Monad.Except (runExcept) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Int (Int64) import Data.List (intercalate) import qualified Data.Map.Strict as Map diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs index 7e4f57c20a..bf6640e1b2 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs @@ -22,6 +22,9 @@ import Cardano.Crypto (RequiresNetworkMagic (..)) import qualified Cardano.Crypto as Crypto import qualified Cardano.Crypto.Hash.Class as CryptoClass import Cardano.Crypto.Raw (Raw) +import qualified Cardano.Configuration.File as Cfg +import qualified Cardano.Configuration.File.Protocol as Cfg +import qualified Cardano.Configuration.File.Storage as Cfg import qualified Cardano.Ledger.Api.Era as L import qualified Cardano.Ledger.Api.Transition as SL import Cardano.Ledger.BaseTypes (boundRational, unsafeNonZero) @@ -30,24 +33,22 @@ import Cardano.Ledger.Dijkstra.PParams import qualified Cardano.Ledger.Shelley.LedgerState as Shelley.LedgerState import qualified Cardano.Ledger.Shelley.UTxO as Shelley.UTxO import Cardano.Ledger.TxIn (TxIn) -import Cardano.Node.Types (AdjustFilePaths (..)) import Cardano.Protocol.Crypto import qualified Cardano.Tools.DBAnalyser.Block.Byron as BlockByron import Cardano.Tools.DBAnalyser.Block.Shelley () import Cardano.Tools.DBAnalyser.HasAnalysis -import Control.Monad (when) import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as BS import qualified Data.Compact as Compact +import Data.Functor.Identity (runIdentity) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.SOP.BasicFunctors import Data.SOP.Functors import Data.SOP.Strict import qualified Data.SOP.Telescope as Telescope -import Data.String (IsString (..)) +import Data.Word (Word64) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.Ledger (ByronBlock) import qualified Ouroboros.Consensus.Byron.Ledger.Ledger as Byron.Ledger @@ -71,12 +72,13 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Shelley.HFEras () import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Block - ( IsShelleyBlock - , ShelleyBlock - , ShelleyBlockLedgerEra + ( ShelleyBlock ) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import System.Directory (makeAbsolute) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) import System.FilePath (takeDirectory, ()) import TextBuilder (TextBuilder) import qualified TextBuilder as Builder @@ -134,25 +136,55 @@ instance HasProtocolInfo (CardanoBlock StandardCrypto) where } mkProtocolInfo CardanoBlockArgs{configFile, threshold} = do - relativeToConfig :: (FilePath -> FilePath) <- - () . takeDirectory <$> makeAbsolute configFile - - cc :: CardanoConfig <- - either (error . show) (return . adjustFilePaths relativeToConfig) - =<< Aeson.eitherDecodeFileStrict' configFile + absoluteConfig <- makeAbsolute configFile + let configDir = takeDirectory absoluteConfig + relativeToConfig :: FilePath -> FilePath + relativeToConfig = (configDir ) + + -- The node configuration is parsed by the shared 'cardano-config' package + -- rather than by a parser local to db-analyser. Genesis file paths in the + -- configuration are relative to the configuration file's directory. + ncff <- Cfg.parseConfigurationFiles configFile + let protoCfg = runIdentity (Cfg.protocolConfiguration ncff) + testCfg = runIdentity (Cfg.testingConfiguration ncff) + byronCfg = Cfg.byronGenesis protoCfg + + byronGenesisPath = relativeToConfig $ Cfg.hashed (Cfg.byronGenesisFile byronCfg) + shelleyGenesisPath = relativeToConfig $ Cfg.hashed (Cfg.shelleyGenesis protoCfg) + alonzoGenesisPath = relativeToConfig $ Cfg.hashed (Cfg.alonzoGenesis protoCfg) + conwayGenesisPath = relativeToConfig $ Cfg.hashed (Cfg.conwayGenesis protoCfg) + dijkstraGenesisPath = relativeToConfig . Cfg.hashed <$> Cfg.experimentalGenesis testCfg + + -- 'cardano-config' merges in its bundled defaults (which set + -- @RequiresNetworkMagic@ to @RequiresNoMagic@) before handing us the + -- configuration, so this field is normally populated; we treat an + -- absent value as that same default. + requiresNetworkMagic = case Cfg.byronReqNetworkMagic byronCfg of + Just Cfg.RequiresNoMagic -> RequiresNoMagic + Just Cfg.RequiresMagic -> RequiresMagic + Nothing -> RequiresNoMagic + + -- 'cardano-config' stores hashes as cardano-crypto-class + -- 'Hash Blake2b_256', whereas Byron expects a 'Crypto.Hash Raw'. Both + -- are the same 32 Blake2b-256 digest bytes, so we transfer them via the + -- raw bytes. + byronGenesisHash :: Maybe (Crypto.Hash Raw) + byronGenesisHash = + (Crypto.abstractHashFromBytes . CryptoClass.hashToBytes) + =<< Cfg.hash (Cfg.byronGenesisFile byronCfg) genesisByron <- - BlockByron.openGenesisByron (byronGenesisPath cc) (byronGenesisHash cc) (requiresNetworkMagic cc) + BlockByron.openGenesisByron byronGenesisPath byronGenesisHash requiresNetworkMagic genesisShelley <- either (error . show) return - =<< Aeson.eitherDecodeFileStrict' (shelleyGenesisPath cc) + =<< Aeson.eitherDecodeFileStrict' shelleyGenesisPath genesisAlonzo <- either (error . show) return - =<< Aeson.eitherDecodeFileStrict' (alonzoGenesisPath cc) + =<< Aeson.eitherDecodeFileStrict' alonzoGenesisPath genesisConway <- either (error . show) return - =<< Aeson.eitherDecodeFileStrict' (conwayGenesisPath cc) - genesisDijkstra <- case dijkstraGenesisPath cc of + =<< Aeson.eitherDecodeFileStrict' conwayGenesisPath + genesisDijkstra <- case dijkstraGenesisPath of Nothing -> pure emptyDijkstraGenesis Just fp -> either (error . show) return @@ -161,33 +193,38 @@ instance HasProtocolInfo (CardanoBlock StandardCrypto) where let transCfg = SL.mkLatestTransitionConfig genesisShelley genesisAlonzo genesisConway genesisDijkstra - initialNonce <- case shelleyGenesisHash cc of + initialNonce <- case Nonce . CryptoClass.castHash <$> Cfg.hash (Cfg.shelleyGenesis protoCfg) of Just h -> pure h Nothing -> do - content <- BS.readFile (shelleyGenesisPath cc) + content <- BS.readFile shelleyGenesisPath pure $ Nonce $ CryptoClass.castHash $ CryptoClass.hashWith id $ content - return $ - mkCardanoProtocolInfo - genesisByron - threshold - transCfg - initialNonce - (cfgHardForkTriggers cc) + let fs = SomeHasFS (ioHasFS (MountPoint configDir)) + + mkCardanoProtocolInfo + fs + genesisByron + threshold + transCfg + initialNonce + (mkHardForkTriggers testCfg) mkLSMConfig CardanoBlockArgs{configFile} = do -- The export path is interpreted relative to the LedgerDB filesystem root, - -- not the config file, so we read the config without adjusting file paths. - cc :: CardanoConfig <- - either (error . show) return - =<< Aeson.eitherDecodeFileStrict' configFile + -- not the config file, so we do not adjust file paths here. + ncff <- Cfg.parseConfigurationFiles configFile + let storeCfg = runIdentity (Cfg.storageConfiguration ncff) + exportPath = case Cfg.ledgerDbConfiguration storeCfg of + Just ldbCfg + | Just (Cfg.V2LSM _ e) <- Cfg.backendSelector ldbCfg -> e + _ -> Nothing pure LSMConfig - { lsmConfigExportPath = lsmLedgerDBExportPath cc + { lsmConfigExportPath = exportPath } -- | An empty Dijkstra genesis to be provided when none is specified in the config. @@ -202,118 +239,44 @@ emptyDijkstraGenesis = } in SL.DijkstraGenesis{SL.dgUpgradePParams = upgradePParamsDef} -data CardanoConfig = CardanoConfig - { requiresNetworkMagic :: RequiresNetworkMagic - -- ^ @RequiresNetworkMagic@ field - , byronGenesisPath :: FilePath - -- ^ @ByronGenesisFile@ field - , byronGenesisHash :: Maybe (Crypto.Hash Raw) - -- ^ @ByronGenesisHash@ field - , shelleyGenesisPath :: FilePath - -- ^ @ShelleyGenesisFile@ field - -- | @ShelleyGenesisHash@ field - , shelleyGenesisHash :: Maybe Nonce - , alonzoGenesisPath :: FilePath - -- ^ @AlonzoGenesisFile@ field - , conwayGenesisPath :: FilePath - -- ^ @ConwayGenesisFile@ field - , dijkstraGenesisPath :: Maybe FilePath - -- ^ @DijkstraGenesisFile@ field - , cfgHardForkTriggers :: CardanoHardForkTriggers - -- ^ @Test*HardForkAtEpoch@ for each Shelley era - , lsmLedgerDBExportPath :: Maybe FilePath - -- ^ @LedgerDB.LSMExportPath@ field: the directory (relative to the LSM-trees - -- LedgerDB filesystem root) into which the LSM backend exports snapshots as it - -- takes them. Only meaningful for the LSM backend. - } - -instance AdjustFilePaths CardanoConfig where - adjustFilePaths f cc = - cc - { byronGenesisPath = f $ byronGenesisPath cc - , shelleyGenesisPath = f $ shelleyGenesisPath cc - , alonzoGenesisPath = f $ alonzoGenesisPath cc - , conwayGenesisPath = f $ conwayGenesisPath cc - , dijkstraGenesisPath = f <$> dijkstraGenesisPath cc - -- Byron, Shelley, Alonzo, and Conway are the only eras that have genesis - -- data. The actual genesis block is a Byron block, therefore we needed a - -- genesis file. To transition to Shelley, we needed to add some additional - -- genesis data (eg some initial values of new protocol parametrers like - -- @d@). Similarly in Alonzo (eg Plutus interpreter parameters/limits) and - -- in Conway too (ie keys of the new genesis delegates). - -- - -- In contrast, the Allegra, Mary, and Babbage eras did not introduce any new - -- genesis data. - } - -instance Aeson.FromJSON CardanoConfig where - parseJSON = Aeson.withObject "CardanoConfigFile" $ \v -> do - requiresNetworkMagic <- v Aeson..: "RequiresNetworkMagic" - - byronGenesisPath <- v Aeson..: "ByronGenesisFile" - byronGenesisHash <- v Aeson..:? "ByronGenesisHash" - - shelleyGenesisPath <- v Aeson..: "ShelleyGenesisFile" - shelleyGenesisHash <- - v Aeson..:? "ShelleyGenesisHash" >>= \case - Nothing -> pure Nothing - Just hex -> case CryptoClass.hashFromTextAsHex hex of - Nothing -> fail "could not parse ShelleyGenesisHash as a hex string" - Just h -> pure $ Just $ Nonce h - - alonzoGenesisPath <- v Aeson..: "AlonzoGenesisFile" - - conwayGenesisPath <- v Aeson..: "ConwayGenesisFile" - - dijkstraGenesisPath <- v Aeson..:? "DijkstraGenesisFile" - - -- The LSM settings live in the @LedgerDB@ object (the rest of which is - -- parsed by the node, not here). @LSMExportPath@ is a directory path. - lsmLedgerDBExportPath <- - v Aeson..:? "LedgerDB" >>= \case - Nothing -> pure Nothing - Just ledgerDB -> ledgerDB Aeson..:? "LSMExportPath" - - triggers <- do - let parseTrigger :: - forall blk era. - (IsShelleyBlock blk, ShelleyBlockLedgerEra blk ~ era) => - (Aeson.Parser :.: CardanoHardForkTrigger) blk - parseTrigger = - Comp $ - (fmap CardanoTriggerHardForkAtEpoch <$> (v Aeson..:? nm)) - Aeson..!= CardanoTriggerHardForkAtDefaultVersion - where - nm = fromString $ "Test" <> L.eraName @era <> "HardForkAtEpoch" - - triggers <- hsequence' $ hcpure (Proxy @IsShelleyBlock) parseTrigger - - let isBad :: NP CardanoHardForkTrigger xs -> Bool - isBad = \case - CardanoTriggerHardForkAtDefaultVersion - :* CardanoTriggerHardForkAtEpoch{} - :* _ -> True - _ :* np -> isBad np - Nil -> False - fmap (\() -> triggers) $ - when (isBad triggers) $ - fail $ - "if the Cardano config file sets a Test*HardForkEpoch," - <> " it must also set it for all previous eras." - - pure $ - CardanoConfig - { requiresNetworkMagic = requiresNetworkMagic - , byronGenesisPath = byronGenesisPath - , byronGenesisHash = byronGenesisHash - , shelleyGenesisPath = shelleyGenesisPath - , shelleyGenesisHash = shelleyGenesisHash - , alonzoGenesisPath = alonzoGenesisPath - , conwayGenesisPath = conwayGenesisPath - , dijkstraGenesisPath = dijkstraGenesisPath - , cfgHardForkTriggers = CardanoHardForkTriggers triggers - , lsmLedgerDBExportPath = lsmLedgerDBExportPath +-- | Build the 'CardanoHardForkTriggers' from the @Testing@ section of the +-- configuration: each era hard-forks at its configured epoch, or at the +-- default protocol version when no epoch is given. +-- +-- If an era is configured to hard-fork at a specific epoch, then so must all +-- earlier eras; otherwise the configuration is rejected. +mkHardForkTriggers :: Cfg.TestingConfiguration Maybe -> CardanoHardForkTriggers +mkHardForkTriggers testCfg + | any (\(earlier, later) -> isNothing earlier && isJust later) (zip epochs (drop 1 epochs)) = + error + "if the Cardano config file sets a Test*HardForkAtEpoch, it must also set it for all previous eras." + | otherwise = + CardanoHardForkTriggers' + { triggerHardForkShelley = toTrigger (Cfg.testShelleyHardForkAtEpoch testCfg) + , triggerHardForkAllegra = toTrigger (Cfg.testAllegraHardForkAtEpoch testCfg) + , triggerHardForkMary = toTrigger (Cfg.testMaryHardForkAtEpoch testCfg) + , triggerHardForkAlonzo = toTrigger (Cfg.testAlonzoHardForkAtEpoch testCfg) + , triggerHardForkBabbage = toTrigger (Cfg.testBabbageHardForkAtEpoch testCfg) + , triggerHardForkConway = toTrigger (Cfg.testConwayHardForkAtEpoch testCfg) + , triggerHardForkDijkstra = toTrigger (Cfg.testDijkstraHardForkAtEpoch testCfg) } + where + -- In Shelley-era order; mirrors the field order of 'CardanoHardForkTriggers''. + epochs = + [ Cfg.testShelleyHardForkAtEpoch testCfg + , Cfg.testAllegraHardForkAtEpoch testCfg + , Cfg.testMaryHardForkAtEpoch testCfg + , Cfg.testAlonzoHardForkAtEpoch testCfg + , Cfg.testBabbageHardForkAtEpoch testCfg + , Cfg.testConwayHardForkAtEpoch testCfg + , Cfg.testDijkstraHardForkAtEpoch testCfg + ] + + toTrigger :: Maybe Word64 -> CardanoHardForkTrigger blk + toTrigger = + maybe + CardanoTriggerHardForkAtDefaultVersion + (CardanoTriggerHardForkAtEpoch . EpochNo) instance HasAnalysis (CardanoBlock StandardCrypto) where countTxOutputs = analyseBlock countTxOutputs @@ -427,15 +390,17 @@ getShelleyBasedUtxo = type CardanoBlockArgs = Args (CardanoBlock StandardCrypto) mkCardanoProtocolInfo :: + SomeHasFS IO -> Byron.Genesis.Config -> Maybe PBftSignatureThreshold -> SL.TransitionConfig L.LatestKnownEra -> Nonce -> CardanoHardForkTriggers -> - ProtocolInfo (CardanoBlock StandardCrypto) -mkCardanoProtocolInfo genesisByron signatureThreshold transitionConfig initialNonce triggers = - fst $ - protocolInfoCardano @_ @IO + IO (ProtocolInfo (CardanoBlock StandardCrypto)) +mkCardanoProtocolInfo fs genesisByron signatureThreshold transitionConfig initialNonce triggers = + fst + <$> protocolInfoCardano @_ @IO + fs ( CardanoProtocolParams ProtocolParamsByron { byronGenesis = genesisByron @@ -454,7 +419,6 @@ mkCardanoProtocolInfo genesisByron signatureThreshold transitionConfig initialNo emptyCheckpointsMap (ProtVer (L.eraProtVerHigh @L.LatestKnownEra) 0) ) - where castHeaderHash :: HeaderHash ByronBlock -> diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs index 281d1e7d1a..626aafc511 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs @@ -51,6 +51,11 @@ import Ouroboros.Consensus.Shelley.Node , protocolInfoShelley ) import Ouroboros.Network.SizeInBytes (SizeInBytes (SizeInBytes)) +import System.Directory (makeAbsolute) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) +import System.FilePath (takeDirectory) import TextBuilder (decimal) -- | Usable for each Shelley-based era @@ -145,17 +150,21 @@ instance HasProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra) where config <- either (error . show) return =<< Aeson.eitherDecodeFileStrict' configFileShelley - return $ mkShelleyProtocolInfo config initialNonce + configDir <- takeDirectory <$> makeAbsolute configFileShelley + let fs = SomeHasFS (ioHasFS (MountPoint configDir)) + mkShelleyProtocolInfo fs config initialNonce type ShelleyBlockArgs = Args (ShelleyBlock (TPraos StandardCrypto) ShelleyEra) mkShelleyProtocolInfo :: + SomeHasFS IO -> ShelleyGenesis -> Nonce -> - ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra) -mkShelleyProtocolInfo genesis initialNonce = - fst $ - protocolInfoShelley @IO + IO (ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)) +mkShelleyProtocolInfo fs genesis initialNonce = + fst + <$> protocolInfoShelley @IO + fs genesis ProtocolParamsShelleyBased { shelleyBasedInitialNonce = initialNonce diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 24b7406cc4..b3950d758b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -16,8 +16,7 @@ import Cardano.Tools.DBAnalyser.Types import Control.Monad (unless) import Control.Monad.Trans.Class import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (mkTracer, nullTracer, (>$<)) import Data.Singletons (Sing, SingI (..)) import qualified Debug.Trace as Debug import Ouroboros.Consensus.Block @@ -159,8 +158,8 @@ analyse :: analyse dbaConfig args = withRegistry $ \registry -> do lock <- newMVar () - chainDBTracer <- mkTracer lock verbose - analysisTracer <- mkTracer lock True + chainDBTracer <- mkVerboseTracer lock verbose + analysisTracer <- mkVerboseTracer lock True LSMConfig{lsmConfigExportPath} <- mkLSMConfig args lsmSalt <- fst . genWord64 <$> newStdGen ProtocolInfo{pInfoInitLedger = genesisLedger, pInfoConfig = cfg} <- @@ -270,10 +269,10 @@ analyse dbaConfig args = (ImmutableDB.openDBInternal immutableDbArgs) (ImmutableDB.closeDB . fst) - mkTracer _ False = return nullTracer - mkTracer lock True = do + mkVerboseTracer _ False = return nullTracer + mkVerboseTracer lock True = do startTime <- getMonotonicTime - return $ Tracer $ \ev -> withLock $ do + return $ mkTracer $ \ev -> withLock $ do traceTime <- getMonotonicTime let diff = diffTime traceTime startTime hPutStrLn stderr $ printf "[%.6fs] %s" (realToFrac diff :: Double) (show ev) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs index 1739fe7ad0..cd5c12b386 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs @@ -24,9 +24,8 @@ import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo) import Control.Monad (unless) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), stdoutTracer, traceWith) +import Control.Tracer (Tracer, mkTracer, stdoutTracer, traceWith, (>$<)) import Data.Foldable (for_) -import Data.Functor.Contravariant ((>$<)) import Data.List (intercalate, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -84,7 +83,7 @@ run Opts{dbDirs, configFile, verbose, dotOut, dryRun} = do immutalise (configBlock cfg) (tracer <> dotTracer) dryRun where tracer = prettyTrace verbose >$< stdoutTracer - dotTracer = Tracer $ \case + dotTracer = mkTracer $ \case TraceAllCandidates candidates -> do let dot = dotCandidates $ fst <$> candidates whenJust dotOut $ flip Dot.encodeToFile dot diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs deleted file mode 100644 index c13c6083f7..0000000000 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tools.DBSynthesizer.Orphans () where - -import qualified Cardano.Chain.Update as Byron (ApplicationName (..)) -import Cardano.Crypto (RequiresNetworkMagic (..)) -import Cardano.Node.Types - ( AdjustFilePaths (..) - , NodeByronProtocolConfiguration (..) - , NodeHardForkProtocolConfiguration (..) - ) -import Cardano.Tools.DBSynthesizer.Types -import Control.Monad (when) -import Data.Aeson as Aeson - ( FromJSON (..) - , withObject - , (.!=) - , (.:) - , (.:?) - ) - -instance FromJSON NodeConfigStub where - parseJSON val = withObject "NodeConfigStub" (parse' val) val - where - parse' o v = do - proto <- v .: "Protocol" - when (proto /= ("Cardano" :: String)) $ - fail $ - "nodeConfig.Protocol expected: Cardano; found: " ++ proto - NodeConfigStub o - <$> v .: "AlonzoGenesisFile" - <*> v .: "ShelleyGenesisFile" - <*> v .: "ByronGenesisFile" - <*> v .: "ConwayGenesisFile" - <*> v .:? "DijkstraGenesisFile" - -instance AdjustFilePaths NodeConfigStub where - adjustFilePaths f nc = - nc - { ncsAlonzoGenesisFile = f $ ncsAlonzoGenesisFile nc - , ncsShelleyGenesisFile = f $ ncsShelleyGenesisFile nc - , ncsByronGenesisFile = f $ ncsByronGenesisFile nc - , ncsConwayGenesisFile = f $ ncsConwayGenesisFile nc - , ncsDijkstraGenesisFile = fmap f $ ncsDijkstraGenesisFile nc - } - -instance AdjustFilePaths NodeCredentials where - adjustFilePaths f nc = - nc - { credCertFile = f <$> credCertFile nc - , credVRFFile = f <$> credVRFFile nc - , credKESFile = f <$> credKESFile nc - , credBulkFile = f <$> credBulkFile nc - } - --- DUPLICATE: mirroring parsers from cardano-node/src/Cardano/Node/Configuration/POM.hs - -instance FromJSON NodeHardForkProtocolConfiguration where - parseJSON = withObject "NodeHardForkProtocolConfiguration" $ \v -> - NodeHardForkProtocolConfiguration - <$> v - .:? "TestEnableDevelopmentHardForkEras" - .!= False - <*> v .:? "TestShelleyHardForkAtEpoch" - <*> v .:? "TestAllegraHardForkAtEpoch" - <*> v .:? "TestMaryHardForkAtEpoch" - <*> v .:? "TestAlonzoHardForkAtEpoch" - <*> v .:? "TestBabbageHardForkAtEpoch" - <*> v .:? "TestConwayHardForkAtEpoch" - <*> v .:? "TestDijkstraHardForkAtEpoch" - -instance FromJSON NodeByronProtocolConfiguration where - parseJSON = withObject "NodeByronProtocolConfiguration" $ \v -> - NodeByronProtocolConfiguration - <$> v .: "ByronGenesisFile" - <*> v .:? "ByronGenesisHash" - <*> v - .:? "RequiresNetworkMagic" - .!= RequiresNoMagic - <*> v .:? "PBftSignatureThreshold" - <*> pure (Byron.ApplicationName "cardano-sl") - <*> v - .:? "ApplicationVersion" - .!= 1 - <*> v .: "LastKnownBlockVersion-Major" - <*> v .: "LastKnownBlockVersion-Minor" - <*> v - .: "LastKnownBlockVersion-Alt" - .!= 0 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 29ef5554d5..fd5e13b262 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -2,52 +2,29 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Tools.DBSynthesizer.Run - ( initialize - , synthesize + ( synthesize ) where -import Cardano.Api.Any (displayError) -import Cardano.Node.Protocol.Cardano (mkConsensusProtocolCardano) -import Cardano.Node.Types +import qualified Cardano.Slotting.Slot as Slot import Cardano.Tools.DBSynthesizer.Forging -import Cardano.Tools.DBSynthesizer.Orphans () import Cardano.Tools.DBSynthesizer.Types import Control.Monad (filterM) -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Except.Extra - ( firstExceptT - , handleIOExceptT - , hoistEither - , runExceptT - ) import Control.ResourceRegistry import Control.Tracer -import Data.Aeson as Aeson - ( FromJSON - , Result (..) - , Value - , eitherDecodeFileStrict' - , eitherDecodeStrict' - , fromJSON - ) import Data.Bool (bool) -import Data.ByteString as BS (ByteString, readFile) import Data.Functor (($>)) import qualified Data.Set as Set import qualified Ouroboros.Consensus.Block.Forging as BlockForging import Ouroboros.Consensus.Cardano.Block -import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.Cardano.Node () import Ouroboros.Consensus.Config (TopLevelConfig, configStorage) import qualified Ouroboros.Consensus.Node as Node (stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node ( nodeImmutableDbChunkInfo ) import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentClientTrace) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () -import Ouroboros.Consensus.Shelley.Node - ( ShelleyGenesis (..) - , validateGenesis - ) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB @@ -55,103 +32,33 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory import Ouroboros.Consensus.Util.IOLike (atomically) -import Ouroboros.Network.Block +import Ouroboros.Network.Block hiding (GenesisHash) import Ouroboros.Network.Point (WithOrigin (..)) import System.Directory -import System.FilePath (takeDirectory, ()) +import System.FilePath (()) import System.Random (newStdGen) -initialize :: - NodeFilePaths -> - NodeCredentials -> - DBSynthesizerOptions -> - IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) -initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do - relativeToConfig :: (FilePath -> FilePath) <- - () . takeDirectory <$> makeAbsolute nfpConfig - runExceptT $ do - conf <- initConf relativeToConfig - proto <- initProtocol relativeToConfig conf - pure (conf, proto) - where - initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig - initConf relativeToConfig = do - inp <- handleIOExceptT show (BS.readFile nfpConfig) - configStub <- adjustFilePaths relativeToConfig <$> readJson inp - shelleyGenesis <- readFileJson $ ncsShelleyGenesisFile configStub - _ <- hoistEither $ validateGenesis shelleyGenesis - let - protocolCredentials = - ProtocolFilepaths - { byronCertFile = Nothing - , byronKeyFile = Nothing - , shelleyKESFile = credKESFile creds - , shelleyVRFFile = credVRFFile creds - , shelleyCertFile = credCertFile creds - , shelleyBulkCredsFile = credBulkFile creds - } - pure - DBSynthesizerConfig - { confConfigStub = configStub - , confOptions = synthOptions - , confProtocolCredentials = protocolCredentials - , confShelleyGenesis = shelleyGenesis - , confDbDir = nfpChainDB - } - - initProtocol :: - (FilePath -> FilePath) -> - DBSynthesizerConfig -> - ExceptT String IO (CardanoProtocolParams StandardCrypto) - initProtocol relativeToConfig DBSynthesizerConfig{confConfigStub, confProtocolCredentials} = do - hfConfig :: NodeHardForkProtocolConfiguration <- - hoistEither hfConfig_ - byronConfig :: NodeByronProtocolConfiguration <- - adjustFilePaths relativeToConfig <$> hoistEither byConfig_ - - firstExceptT displayError $ - mkConsensusProtocolCardano - byronConfig - shelleyConfig - alonzoConfig - conwayConfig - dijkstraConfig - hfConfig - (Just confProtocolCredentials) - where - shelleyConfig = NodeShelleyProtocolConfiguration (GenesisFile $ ncsShelleyGenesisFile confConfigStub) Nothing - alonzoConfig = NodeAlonzoProtocolConfiguration (GenesisFile $ ncsAlonzoGenesisFile confConfigStub) Nothing - conwayConfig = NodeConwayProtocolConfiguration (GenesisFile $ ncsConwayGenesisFile confConfigStub) Nothing - dijkstraConfig = - fmap - (\x -> NodeDijkstraProtocolConfiguration (GenesisFile x) Nothing) - (ncsDijkstraGenesisFile confConfigStub) - hfConfig_ = eitherParseJson $ ncsNodeConfig confConfigStub - byConfig_ = eitherParseJson $ ncsNodeConfig confConfigStub - -readJson :: (Monad m, FromJSON a) => ByteString -> ExceptT String m a -readJson = hoistEither . eitherDecodeStrict' - -readFileJson :: FromJSON a => FilePath -> ExceptT String IO a -readFileJson f = handleIOExceptT show (eitherDecodeFileStrict' f) >>= hoistEither - -eitherParseJson :: FromJSON a => Aeson.Value -> Either String a -eitherParseJson v = case fromJSON v of - Error err -> Left err - Success a -> Right a - +-- | Forge a ChainDB from a ready-made Cardano 'ProtocolInfo' and its block +-- forgers (as produced by 'protocolInfoCardano'). Constructing the protocol +-- from a node configuration is the caller's responsibility, keeping this +-- function free of any node/api configuration machinery. synthesize :: ( TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto) ) -> - DBSynthesizerConfig -> - (CardanoProtocolParams StandardCrypto) -> + DBSynthesizerOptions -> + Slot.EpochSize -> + -- | The directory of the ChainDB to forge into. + FilePath -> + ( ProtocolInfo (CardanoBlock StandardCrypto) + , Tracer IO KESAgentClientTrace -> + IO [BlockForging.MkBlockForging IO (CardanoBlock StandardCrypto)] + ) -> IO ForgeResult -synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = +synthesize genTxs confOptions epochSize confDbDir (ProtocolInfo{pInfoConfig, pInfoInitLedger}, mkForgers) = withRegistry $ \registry -> do snapshotDelayRng <- newStdGen let - epochSize = sgEpochLength confShelleyGenesis chunkInfo = Node.nodeImmutableDbChunkInfo (configStorage pInfoConfig) flavargs = LedgerDB.LedgerDbBackendArgsV2 $ SomeBackendArgs InMemArgs dbArgs = @@ -199,12 +106,6 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir { synthOpenMode , synthLimit } = confOptions - ( ProtocolInfo - { pInfoConfig - , pInfoInitLedger - } - , mkForgers - ) = protocolInfoCardano runP preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB mode db = diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs index 5ab84d040a..24c739e3f2 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs @@ -1,34 +1,7 @@ module Cardano.Tools.DBSynthesizer.Types (module Cardano.Tools.DBSynthesizer.Types) where -import Cardano.Node.Types (ProtocolFilepaths) -import Data.Aeson as Aeson (Value) import Data.Word (Word64) import Ouroboros.Consensus.Block.Abstract (SlotNo) -import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis) - -data NodeConfigStub = NodeConfigStub - { ncsNodeConfig :: !Aeson.Value - , ncsAlonzoGenesisFile :: !FilePath - , ncsShelleyGenesisFile :: !FilePath - , ncsByronGenesisFile :: !FilePath - , ncsConwayGenesisFile :: !FilePath - , ncsDijkstraGenesisFile :: !(Maybe FilePath) - } - deriving Show - -data NodeFilePaths = NodeFilePaths - { nfpConfig :: !FilePath - , nfpChainDB :: !FilePath - } - deriving Show - -data NodeCredentials = NodeCredentials - { credCertFile :: !(Maybe FilePath) - , credVRFFile :: !(Maybe FilePath) - , credKESFile :: !(Maybe FilePath) - , credBulkFile :: !(Maybe FilePath) - } - deriving Show data ForgeLimit = ForgeLimitBlock !Word64 @@ -50,12 +23,3 @@ data DBSynthesizerOptions = DBSynthesizerOptions , synthOpenMode :: !DBSynthesizerOpenMode } deriving Show - -data DBSynthesizerConfig = DBSynthesizerConfig - { confConfigStub :: NodeConfigStub - , confOptions :: DBSynthesizerOptions - , confProtocolCredentials :: ProtocolFilepaths - , confShelleyGenesis :: ShelleyGenesis - , confDbDir :: FilePath - } - deriving Show diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs index bc616275cd..6583da3db6 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs @@ -43,7 +43,7 @@ truncate :: truncate DBTruncaterConfig{dbDir, truncateAfter, verbose} args = do withRegistry $ \registry -> do lock <- mkLock - immutableDBTracer <- mkTracer lock verbose + immutableDBTracer <- mkVerboseTracer lock verbose ProtocolInfo { pInfoConfig = config } <- @@ -113,11 +113,11 @@ findLast p iter = mkLock :: MonadMVar m => m (StrictMVar m ()) mkLock = newMVar () -mkTracer :: Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a) -mkTracer _ False = pure mempty -mkTracer lock True = do +mkVerboseTracer :: Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a) +mkVerboseTracer _ False = pure mempty +mkVerboseTracer lock True = do startTime <- getMonotonicTime - pure $ Tracer $ \ev -> do + pure $ mkTracer $ \ev -> do bracket_ (takeMVar lock) (putMVar lock ()) $ do traceTime <- getMonotonicTime let diff = diffTime traceTime startTime diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index 7bc4e47ad5..30331fd825 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -10,7 +10,6 @@ import Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as BL -import Data.Functor.Contravariant ((>$<)) import Data.Void (Void) import qualified Network.Mux as Mux import Network.Socket (SockAddr (..)) @@ -67,7 +66,7 @@ serve sockAddr application = withIOManager \iocp -> { haHandshakeTracer = show >$< stdoutTracer , haBearerTracer = show >$< stdoutTracer , haHandshakeCodec = N2N.nodeToNodeHandshakeCodec - , haVersionDataCodec = Handshake.cborTermVersionDataCodec N2N.nodeToNodeCodecCBORTerm + , haVersionDataCodec = N2N.nodeToNodeVersionDataCodec , haAcceptVersion = Handshake.acceptableVersion , haQueryVersion = Handshake.queryVersion , haTimeLimits = Handshake.timeLimitsHandshake diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index 6705b96832..f4a3e1ee02 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -102,21 +102,10 @@ mkLedgerTables tx = zip exampleTxIns exampleTxOuts where exampleTxIns :: [BigEndianTxIn] - exampleTxIns = case toList (tx ^. (LC.bodyTxL . LC.allInputsTxBodyF)) of - [] -> error "No transaction inputs were provided to construct the ledger tables" - -- We require at least one transaction input (and one - -- transaction output) in the example provided by - -- cardano-ledger to make sure that we test the serialization - -- of ledger tables with at least one non-trivial example. - -- - -- Also all transactions in Cardano have at least one input for - -- automatic replay protection. - xs -> map BigEndianTxIn xs + exampleTxIns = map BigEndianTxIn $ toList (tx ^. (LC.bodyTxL . LC.allInputsTxBodyF)) exampleTxOuts :: [LC.TxOut era] - exampleTxOuts = case toList (tx ^. (LC.bodyTxL . LC.outputsTxBodyL)) of - [] -> error "No transaction outputs were provided to construct the ledger tables" - xs -> xs + exampleTxOuts = toList (tx ^. (LC.bodyTxL . LC.outputsTxBodyL)) fromShelleyLedgerExamples :: ShelleyCompatible (TPraos StandardCrypto) era => @@ -144,13 +133,14 @@ fromShelleyLedgerExamples , exampleExtLedgerState = unlabelled extLedgerState , exampleSlotNo = unlabelled slotNo , exampleLedgerConfig = unlabelled ledgerConfig - , exampleLedgerTables = unlabelled $ mkLedgerTables leTx + , exampleLedgerTables = unlabelled $ mkLedgerTables emptyTx } where + emptyTx = mkBasicTx mkBasicTxBody blk = mkShelleyBlock pleBlock hash = ShelleyHash $ SL.unHashHeader pleHashHeader serialisedBlock = Serialised "" - tx = mkShelleyTx leTx + tx = mkShelleyTx emptyTx slotNo = SlotNo 42 serialisedHeader = SerialisedHeaderFromDepPair $ GenDepPair (NestedCtxt CtxtShelley) (Serialised "
") @@ -255,13 +245,14 @@ fromShelleyLedgerExamplesPraos , exampleResult = results , exampleAnnTip = unlabelled annTip , exampleLedgerState = unlabelled ledgerState - , exampleLedgerTables = unlabelled $ mkLedgerTables leTx + , exampleLedgerTables = unlabelled $ mkLedgerTables emptyTx , exampleChainDepState = unlabelled chainDepState , exampleExtLedgerState = unlabelled extLedgerState , exampleSlotNo = unlabelled slotNo , exampleLedgerConfig = unlabelled ledgerConfig } where + emptyTx = mkBasicTx mkBasicTxBody blk = mkShelleyBlock $ let SL.Block hdr1 bdy = pleBlock @@ -287,7 +278,7 @@ fromShelleyLedgerExamplesPraos hSig = coerce bhSig hash = ShelleyHash $ SL.unHashHeader pleHashHeader serialisedBlock = Serialised "" - tx = mkShelleyTx leTx + tx = mkShelleyTx emptyTx slotNo = SlotNo 42 serialisedHeader = SerialisedHeaderFromDepPair $ GenDepPair (NestedCtxt CtxtShelley) (Serialised "
") diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs index c5a2176a81..43e1ef4756 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs @@ -33,9 +33,6 @@ import Ouroboros.Consensus.Shelley.Node.Common () import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Network.Block (mkSerialised) -import Test.Cardano.Ledger.AllegraEraGen () -import Test.Cardano.Ledger.Alonzo.AlonzoEraGen () -import Test.Cardano.Ledger.MaryEraGen () import Test.Cardano.Ledger.Shelley.Constants ( defaultConstants , numCoreNodes @@ -46,7 +43,6 @@ import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ( genCoherentBlock ) import Test.Cardano.Ledger.Shelley.Serialisation.Generators () -import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators () import Test.Cardano.Protocol.TPraos.Arbitrary (genBlock) import Test.Consensus.Protocol.Serialisation.Generators () import Test.Consensus.Shelley.MockCrypto (CanMock) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs index edec78f3e5..7ee36d51a5 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs @@ -24,6 +24,7 @@ import Cardano.Ledger.BaseTypes (Seed) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Core as Core import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses) +import Cardano.Ledger.Shelley.Rules (UTXOW) import Cardano.Protocol.Crypto (Crypto (..)) import qualified Cardano.Protocol.TPraos.API as SL import qualified Cardano.Protocol.TPraos.BHeader as SL @@ -81,7 +82,7 @@ type CanMock proto era = , Arbitrary (Core.Tx Core.TopTx era) , Arbitrary (Core.TxOut era) , Arbitrary (Core.Value era) - , Arbitrary (PredicateFailure (SL.ShelleyUTXOW era)) + , Arbitrary (PredicateFailure (UTXOW era)) , Arbitrary (Core.TxWits era) , Arbitrary (StashedAVVMAddresses era) , Arbitrary (Core.GovState era) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index e89415eda4..bd788684ba 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -121,6 +121,7 @@ import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Util.Assert import Quiet (Quiet (..)) +import System.FS.API (SomeHasFS) import qualified Test.Cardano.Ledger.Core.KeyPair as TL ( KeyPair (..) , mkWitnessesVKey @@ -346,8 +347,18 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = , sgMaxLovelaceSupply = maxLovelaceSupply , sgProtocolParams = pparams , sgGenDelegs = coreNodesToGenesisMapping - , sgInitialFunds = ListMap.fromMap initialFunds - , sgStaking = initialStake + , sgInitialFunds = mempty + , sgStaking = SL.emptyGenesisStaking + , sgExtraConfig = + SL.SJust + SL.ShelleyExtraConfig + { SL.secInitialFunds = + SL.EmbeddedInjection (ListMap.fromMap initialFunds) + , SL.secStakePools = + SL.EmbeddedInjection (SL.sgsPools initialStake) + , SL.secStakeCredentials = + SL.EmbeddedInjection (SL.sgsStake initialStake) + } } where checkMaxLovelaceSupply :: Either String () @@ -463,15 +474,18 @@ mkProtocolShelley :: ( KESAgentContext c m , ShelleyCompatible (TPraos c) ShelleyEra ) => + SomeHasFS m -> ShelleyGenesis -> SL.Nonce -> ProtVer -> CoreNode c -> - ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] - ) -mkProtocolShelley genesis initialNonce protVer coreNode = + m + ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] + ) +mkProtocolShelley fs genesis initialNonce protVer coreNode = protocolInfoShelley + fs genesis ProtocolParamsShelleyBased { shelleyBasedInitialNonce = initialNonce diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs index 8f8399b43a..4b1076f4f6 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs @@ -1118,12 +1118,13 @@ prop_simple_real_pbft_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - mkProtocolByronAndHardForkTxs - params - nid - genesisConfig - genesisSecrets - theProposedProtocolVersion + pure $ + mkProtocolByronAndHardForkTxs + params + nid + genesisConfig + genesisSecrets + theProposedProtocolVersion , mkRekeyM = Just $ fromRekeyingToRekeyM diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs index 6cb0899866..c06f454503 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs @@ -158,7 +158,7 @@ setupTestOutput setup@SetupDualByron{..} = setupGenesis (setupParams setup) [coreNodeId] - plainTestNodeInitialization pInfo (fmap (fmap (MkBlockForging . pure)) bfs) + pure $ plainTestNodeInitialization pInfo (fmap (fmap (MkBlockForging . pure)) bfs) , mkRekeyM = Nothing -- TODO } where diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs index 187058c057..79319020ef 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Test that we can submit transactions to the mempool using the local @@ -10,8 +11,7 @@ module Test.Consensus.Cardano.MiniProtocol.LocalTxSubmission.Server (tests) wher import Cardano.Ledger.BaseTypes (knownNonZeroBounded) import Control.Monad (void) -import Control.Tracer (Tracer, nullTracer, stdoutTracer) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (Tracer, nullTracer, stdoutTracer, (>$<)) import Data.SOP.Strict (index_NS) import qualified Data.SOP.Telescope as Telescope import Network.TypedProtocol.Proofs (connect) @@ -66,17 +66,16 @@ tests = where localServerPassesRegressionTests era = testCase ("Passes the regression tests (" ++ show era ++ ")") $ do - let - pInfo :: ProtocolInfo (CardanoBlock StandardCrypto) - pInfo = - mkSimpleTestProtocolInfo - (Shelley.DecentralizationParam 1) - (Consensus.SecurityParam $ knownNonZeroBounded @10) - (ByronSlotLengthInSeconds 1) - (ShelleySlotLengthInSeconds 1) - protocolVersionZero - (hardForkInto era) + (pInfo :: ProtocolInfo (CardanoBlock StandardCrypto)) <- + mkSimpleTestProtocolInfo + (Shelley.DecentralizationParam 1) + (Consensus.SecurityParam $ knownNonZeroBounded @10) + (ByronSlotLengthInSeconds 1) + (ShelleySlotLengthInSeconds 1) + protocolVersionZero + (hardForkInto era) + let eraIndex = index_NS . Telescope.tip diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs index bfaa3f776f..15458a3995 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs @@ -29,15 +29,19 @@ tests = prop_cardanoBlockSanityChecks :: QC.Property prop_cardanoBlockSanityChecks = - forAllBlind genSimpleTestProtocolInfo (prop_sanityChecks . pInfoConfig) + forAllBlind arbitrary $ \setup -> + QC.ioProperty $ do + pinfo <- mkSimpleTestProtocolInfoFromSetup setup + pure $ prop_sanityChecks (pInfoConfig pinfo) prop_intentionallyBrokenConfigDoesNotSanityCheck :: QC.Property prop_intentionallyBrokenConfigDoesNotSanityCheck = - forAllBlind genSimpleTestProtocolInfo $ \pinfo -> - let saneTopLevelConfig = - pInfoConfig pinfo - brokenConfig = breakTopLevelConfig saneTopLevelConfig - in expectFailure $ prop_sanityChecks brokenConfig + forAllBlind arbitrary $ \setup -> + QC.ioProperty $ do + pinfo <- mkSimpleTestProtocolInfoFromSetup setup + let saneTopLevelConfig = pInfoConfig pinfo + brokenConfig = breakTopLevelConfig saneTopLevelConfig + pure $ expectFailure $ prop_sanityChecks brokenConfig breakTopLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto) -> TopLevelConfig (CardanoBlock StandardCrypto) @@ -55,17 +59,17 @@ breakTopLevelConfig tlc = } } -genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto)) -genSimpleTestProtocolInfo = do - setup <- arbitrary - pure $ - mkSimpleTestProtocolInfo - (decentralizationParam setup) - (securityParam setup) - (byronSlotLength setup) - (shelleySlotLength setup) - protocolVersionZero - (hardForkTriggers setup) +mkSimpleTestProtocolInfoFromSetup :: + SimpleTestProtocolInfoSetup -> + IO (ProtocolInfo (CardanoBlock StandardCrypto)) +mkSimpleTestProtocolInfoFromSetup setup = + mkSimpleTestProtocolInfo + (decentralizationParam setup) + (securityParam setup) + (byronSlotLength setup) + (shelleySlotLength setup) + protocolVersionZero + (hardForkTriggers setup) data SimpleTestProtocolInfoSetup = SimpleTestProtocolInfoSetup { decentralizationParam :: Shelley.DecentralizationParam diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs index 720631ff0f..e802e22851 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs @@ -40,6 +40,9 @@ import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis (..) ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -234,7 +237,8 @@ prop_simple_allegraMary_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty let protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce @@ -245,30 +249,32 @@ prop_simple_allegraMary_convergence } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 - (protocolInfo, blockForging) = - protocolInfoShelleyBasedHardFork - protocolParamsShelleyBased - (SL.ProtVer majorVersion1 0) - (SL.ProtVer majorVersion2 0) - ( L.mkTransitionConfig L.NoGenesis $ - L.mkTransitionConfig L.NoGenesis $ - L.mkShelleyTransitionConfig genesisShelley - ) - hardForkTrigger - in TestNodeInitialization - { tniCrucialTxs = - if not setupHardFork - then [] - else - fmap GenTxShelley1 $ - Shelley.mkMASetDecentralizationParamTxs - coreNodes - (SL.ProtVer majorVersion2 0) - (SlotNo $ unNumSlots numSlots) -- never expire - setupD -- unchanged - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging nullTracer - } + (protocolInfo, blockForging) <- + protocolInfoShelleyBasedHardFork + fs + protocolParamsShelleyBased + (SL.ProtVer majorVersion1 0) + (SL.ProtVer majorVersion2 0) + ( L.mkTransitionConfig L.NoGenesis $ + L.mkTransitionConfig L.NoGenesis $ + L.mkShelleyTransitionConfig genesisShelley + ) + hardForkTrigger + pure $ + TestNodeInitialization + { tniCrucialTxs = + if not setupHardFork + then [] + else + fmap GenTxShelley1 $ + Shelley.mkMASetDecentralizationParamTxs + coreNodes + (SL.ProtVer majorVersion2 0) + (SlotNo $ unNumSlots numSlots) -- never expire + setupD -- unchanged + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } @@ -379,8 +385,8 @@ prop_simple_allegraMary_convergence -- | The major protocol version of the first era in this test majorVersion1 :: SL.Version -majorVersion1 = SL.natVersion @2 +majorVersion1 = SL.natVersion @3 -- | The major protocol version of the second era in this test majorVersion2 :: SL.Version -majorVersion2 = SL.natVersion @3 +majorVersion2 = SL.natVersion @4 diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs index f110909cb6..8c7dd8508a 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs @@ -38,7 +38,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word64) import Lens.Micro -import Ouroboros.Consensus.Block.Forging (MkBlockForging) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Byron.Ledger (LedgerState (..)) import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) @@ -60,12 +59,14 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.PBFT import Ouroboros.Consensus.Protocol.Praos.AgentClient - ( KESAgentClientTrace - , KESAgentContext + ( KESAgentContext ) import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.Node +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Cardano.ProtocolInfo ( hardForkOnDefaultProtocolVersions , mkTestProtocolInfo @@ -490,7 +491,7 @@ mkProtocolCardanoAndHardForkTxs :: ShelleyGenesis -> SL.Nonce -> Shelley.CoreNode c -> - TestNodeInitialization m (CardanoBlock c) + m (TestNodeInitialization m (CardanoBlock c)) mkProtocolCardanoAndHardForkTxs pbftParams coreNodeId @@ -499,12 +500,30 @@ mkProtocolCardanoAndHardForkTxs propPV genesisShelley initialNonce - coreNodeShelley = - TestNodeInitialization - { tniCrucialTxs = crucialTxs - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging Tracer.nullTracer - } + coreNodeShelley = do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty + (setByronProtVer -> protocolInfo, blockForging) <- + mkTestProtocolInfo + fs + (coreNodeId, coreNodeShelley) + genesisShelley + propPV + initialNonce + genesisByron + generatedSecretsByron + (Just $ PBftSignatureThreshold 1) -- Trivialize the PBFT signature + -- window so that the forks induced by + -- the network partition are as deep + -- as possible. + -- This test only enters the Shelley era. + (SL.ProtVer shelleyMajorVersion 0) + hardForkOnDefaultProtocolVersions + pure + TestNodeInitialization + { tniCrucialTxs = crucialTxs + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging Tracer.nullTracer + } where crucialTxs :: [GenTx (CardanoBlock c)] crucialTxs = @@ -521,24 +540,6 @@ mkProtocolCardanoAndHardForkTxs generatedSecretsByron propPV - protocolInfo :: ProtocolInfo (CardanoBlock c) - blockForging :: Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] - (setByronProtVer -> protocolInfo, blockForging) = - mkTestProtocolInfo - (coreNodeId, coreNodeShelley) - genesisShelley - propPV - initialNonce - genesisByron - generatedSecretsByron - (Just $ PBftSignatureThreshold 1) -- Trivialize the PBFT signature - -- window so that the forks induced by - -- the network partition are as deep - -- as possible. - -- This test only enters the Shelley era. - (SL.ProtVer shelleyMajorVersion 0) - hardForkOnDefaultProtocolVersions - {------------------------------------------------------------------------------- Constants -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs index 41aec461cc..0a2a7577a8 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs @@ -45,7 +45,11 @@ import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis (..) ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import qualified Test.Cardano.Ledger.Alonzo.Examples as SL +import Test.Cardano.Ledger.Shelley.Examples (leTranslationContext) import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -243,7 +247,8 @@ prop_simple_allegraAlonzo_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty let protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce @@ -254,31 +259,33 @@ prop_simple_allegraAlonzo_convergence } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 - (protocolInfo, blockForging) = - protocolInfoShelleyBasedHardFork - protocolParamsShelleyBased - (SL.ProtVer majorVersion1 0) - (SL.ProtVer majorVersion2 0) - ( L.mkTransitionConfig alonzoGenesis $ - L.mkTransitionConfig L.NoGenesis $ - L.mkTransitionConfig L.NoGenesis $ - L.mkShelleyTransitionConfig shelleyGenesis - ) - hardForkTrigger - in TestNodeInitialization - { tniCrucialTxs = - if not setupHardFork - then [] - else - fmap GenTxShelley1 $ - Shelley.mkMASetDecentralizationParamTxs - coreNodes - (SL.ProtVer majorVersion2 0) - (SlotNo $ unNumSlots numSlots) -- never expire - setupD -- unchanged - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging nullTracer - } + (protocolInfo, blockForging) <- + protocolInfoShelleyBasedHardFork + fs + protocolParamsShelleyBased + (SL.ProtVer majorVersion1 0) + (SL.ProtVer majorVersion2 0) + ( L.mkTransitionConfig alonzoGenesis $ + L.mkTransitionConfig L.NoGenesis $ + L.mkTransitionConfig L.NoGenesis $ + L.mkShelleyTransitionConfig shelleyGenesis + ) + hardForkTrigger + pure $ + TestNodeInitialization + { tniCrucialTxs = + if not setupHardFork + then [] + else + fmap GenTxShelley1 $ + Shelley.mkMASetDecentralizationParamTxs + coreNodes + (SL.ProtVer majorVersion2 0) + (SlotNo $ unNumSlots numSlots) -- never expire + setupD -- unchanged + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } @@ -313,7 +320,7 @@ prop_simple_allegraAlonzo_convergence coreNodes alonzoGenesis :: AlonzoGenesis - alonzoGenesis = SL.exampleAlonzoGenesis + alonzoGenesis = leTranslationContext SL.ledgerExamples -- the Shelley ledger is designed to use a fixed epoch size, so this test -- does not randomize it @@ -392,8 +399,8 @@ prop_simple_allegraAlonzo_convergence -- | The major protocol version of the first era in this test majorVersion1 :: SL.Version -majorVersion1 = SL.natVersion @1 +majorVersion1 = SL.natVersion @4 -- | The major protocol version of the second era in this test majorVersion2 :: SL.Version -majorVersion2 = SL.natVersion @2 +majorVersion2 = SL.natVersion @5 diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs index 6335c25764..c9938b54e3 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs @@ -40,6 +40,9 @@ import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis (..) ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -244,7 +247,8 @@ prop_simple_shelleyAllegra_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty let protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce @@ -255,29 +259,31 @@ prop_simple_shelleyAllegra_convergence } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 - (protocolInfo, blockForging) = - protocolInfoShelleyBasedHardFork - protocolParamsShelleyBased - (SL.ProtVer majorVersion1 0) - (SL.ProtVer majorVersion2 0) - ( L.mkTransitionConfig L.NoGenesis $ - L.mkShelleyTransitionConfig genesisShelley - ) - hardForkTrigger - in TestNodeInitialization - { tniCrucialTxs = - if not setupHardFork - then [] - else - fmap GenTxShelley1 $ - Shelley.mkSetDecentralizationParamTxs - coreNodes - (SL.ProtVer majorVersion2 0) - (SlotNo $ unNumSlots numSlots) -- never expire - setupD -- unchanged - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging nullTracer - } + (protocolInfo, blockForging) <- + protocolInfoShelleyBasedHardFork + fs + protocolParamsShelleyBased + (SL.ProtVer majorVersion1 0) + (SL.ProtVer majorVersion2 0) + ( L.mkTransitionConfig L.NoGenesis $ + L.mkShelleyTransitionConfig genesisShelley + ) + hardForkTrigger + pure $ + TestNodeInitialization + { tniCrucialTxs = + if not setupHardFork + then [] + else + fmap GenTxShelley1 $ + Shelley.mkSetDecentralizationParamTxs + coreNodes + (SL.ProtVer majorVersion2 0) + (SlotNo $ unNumSlots numSlots) -- never expire + setupD -- unchanged + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } @@ -388,8 +394,8 @@ prop_simple_shelleyAllegra_convergence -- | The major protocol version of the first era in this test majorVersion1 :: SL.Version -majorVersion1 = SL.natVersion @1 +majorVersion1 = SL.natVersion @2 -- | The major protocol version of the second era in this test majorVersion2 :: SL.Version -majorVersion2 = SL.natVersion @2 +majorVersion2 = SL.natVersion @3 diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs index 862a0d7c8b..995186abc4 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs @@ -9,7 +9,6 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ) import Ouroboros.Consensus.Shelley.Ledger.Mempool ( AlonzoMeasure (..) - , ConwayMeasure (..) , fromExUnits ) import Test.Cardano.Ledger.Alonzo.Binary.Twiddle () @@ -24,18 +23,17 @@ tests = ] -- | 'Measure.<=' and @'pointWiseExUnits' (<=)@ must agree -leqCoherence :: Word32 -> Word32 -> ExUnits -> ExUnits -> Property -leqCoherence w1 w2 eu1 eu2 = +leqCoherence :: Word32 -> ExUnits -> ExUnits -> Property +leqCoherence w1 eu1 eu2 = actual === expected where - -- ConwayMeasure is the fullest TxMeasure and mainnet's + -- 'AlonzoMeasure' is the phase 1 measure that carries the ExUnits, and the + -- one whose ordering must agree with 'pointWiseExUnits'. The reference script + -- size lives in a separate phase 2 measure dimension that is irrelevant here. inj eu = - ConwayMeasure - ( AlonzoMeasure - (IgnoringOverflow $ ByteSize32 w1) - (fromExUnits eu) - ) - (IgnoringOverflow $ ByteSize32 w2) + AlonzoMeasure + (IgnoringOverflow $ ByteSize32 w1) + (fromExUnits eu) actual = inj eu1 Measure.<= inj eu2 expected = pointWiseExUnits (<=) eu1 eu2 diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs index f8353e957a..a5ae09a77a 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs @@ -37,6 +37,9 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.ShelleyHFC () +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -278,26 +281,29 @@ prop_simple_real_tpraos_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> - let (protocolInfo, blockForging) = - mkProtocolShelley - genesisConfig - setupInitialNonce - nextProtVer - (coreNodes !! fromIntegral nid) - in TestNodeInitialization - { tniProtocolInfo = protocolInfo - , tniCrucialTxs = - if not includingDUpdateTx - then [] - else - mkSetDecentralizationParamTxs - coreNodes - nextProtVer - sentinel -- Does not expire during test - setupD2 - , tniBlockForging = blockForging nullTracer - } + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty + (protocolInfo, blockForging) <- + mkProtocolShelley + fs + genesisConfig + setupInitialNonce + nextProtVer + (coreNodes !! fromIntegral nid) + pure $ + TestNodeInitialization + { tniProtocolInfo = protocolInfo + , tniCrucialTxs = + if not includingDUpdateTx + then [] + else + mkSetDecentralizationParamTxs + coreNodes + nextProtVer + sentinel -- Does not expire during test + setupD2 + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 1b588d0515..7a42a24536 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Main.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Main.hs @@ -1,122 +1,80 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + module Main (main) where -import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano -import qualified Cardano.Tools.DBAnalyser.Run as DBAnalyser -import Cardano.Tools.DBAnalyser.Types -import qualified Cardano.Tools.DBImmutaliser.Run as DBImmutaliser +import Cardano.Ledger.BaseTypes (knownNonZeroBounded) import qualified Cardano.Tools.DBSynthesizer.Run as DBSynthesizer import Cardano.Tools.DBSynthesizer.Types -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Block (StandardCrypto) +import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) +import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..)) +import Test.Consensus.Cardano.ProtocolInfo + ( ByronSlotLengthInSeconds (..) + , Era (..) + , ShelleySlotLengthInSeconds (..) + , hardForkInto + , mkSimpleTestProtocolInfoForging + , protocolVersionZero + ) import qualified Test.Cardano.Tools.Headers import Test.Tasty import Test.Tasty.HUnit +import qualified Test.ThreadNet.Infra.Shelley as Shelley import Test.Util.TestEnv -nodeConfig, chainDB :: FilePath -nodeConfig = "ouroboros-consensus-cardano/test/tools-test/disk/config/config.json" +-- | The ChainDB the synthesizer forges into. +chainDB :: FilePath chainDB = "ouroboros-consensus-cardano/test/tools-test/disk/chaindb" +-- | The forge limits are kept well within the KES validity window of the +-- test protocol (see 'mkSimpleTestProtocolInfoForging', which uses a small +-- number of KES-valid slots), so that both the create and the subsequent +-- append step can still forge blocks. testSynthOptionsCreate :: DBSynthesizerOptions testSynthOptionsCreate = DBSynthesizerOptions - { synthLimit = ForgeLimitEpoch 1 + { synthLimit = ForgeLimitSlot 40 , synthOpenMode = OpenCreateForce } testSynthOptionsAppend :: DBSynthesizerOptions testSynthOptionsAppend = DBSynthesizerOptions - { synthLimit = ForgeLimitSlot 8192 + { synthLimit = ForgeLimitSlot 40 , synthOpenMode = OpenAppend } -testNodeFilePaths :: NodeFilePaths -testNodeFilePaths = - NodeFilePaths - { nfpConfig = nodeConfig - , nfpChainDB = chainDB - } - -testNodeCredentials :: NodeCredentials -testNodeCredentials = - NodeCredentials - { credCertFile = Nothing - , credVRFFile = Nothing - , credKESFile = Nothing - , credBulkFile = Just "ouroboros-consensus-cardano/test/tools-test/disk/config/bulk-creds-k2.json" - } - -testImmutaliserConfig :: DBImmutaliser.Opts -testImmutaliserConfig = - DBImmutaliser.Opts - { DBImmutaliser.dbDirs = - DBImmutaliser.DBDirs - { DBImmutaliser.immDBDir = chainDB <> "/immutable" - , DBImmutaliser.volDBDir = chainDB <> "/volatile" - } - , DBImmutaliser.configFile = nodeConfig - , DBImmutaliser.verbose = False - , DBImmutaliser.dotOut = Nothing - , DBImmutaliser.dryRun = False - } - -testAnalyserConfig :: DBAnalyserConfig -testAnalyserConfig = - DBAnalyserConfig - { dbDir = chainDB - , ldbBackend = V2InMem - , verbose = False - , selectDB = SelectImmutableDB Origin - , validation = Just ValidateAllBlocks - , analysis = CountBlocks - , confLimit = Unlimited - } - -testBlockArgs :: Cardano.Args (CardanoBlock StandardCrypto) -testBlockArgs = Cardano.CardanoBlockArgs nodeConfig Nothing - --- | A multi-step test including synthesis and analysis 'SomeConsensusProtocol' using the Cardano instance. --- --- 1. step: synthesize a ChainDB from scratch and count the amount of blocks forged. --- 2. step: append to the previous ChainDB and coutn the amount of blocks forged. --- 3. step: copy the VolatileDB into the ImmutableDB. --- 3. step: analyze the ImmutableDB resulting from previous steps and confirm the total block count. - +-- | Synthesize a ChainDB from scratch and then append to it, checking that +-- both steps forge blocks. -- +-- The protocol is built in-process from 'mkSimpleTestProtocolInfoForging' +-- rather than from a node configuration file; constructing a forging-capable +-- protocol from a real configuration is exercised downstream, where the +-- configuration-loading machinery lives. blockCountTest :: (String -> IO ()) -> Assertion blockCountTest logStep = do + logStep "building test protocol" + (protocolInfo, blockForging, shelleyGenesis) <- + mkSimpleTestProtocolInfoForging @StandardCrypto + (Shelley.DecentralizationParam 1) + (SecurityParam $ knownNonZeroBounded @10) + (ByronSlotLengthInSeconds 1) + (ShelleySlotLengthInSeconds 1) + protocolVersionZero + (hardForkInto Conway) + let protocol = (protocolInfo, blockForging) + epochSize = sgEpochLength shelleyGenesis + logStep "running synthesis - create" - (options, protocol) <- - either assertFailure pure - =<< DBSynthesizer.initialize - testNodeFilePaths - testNodeCredentials - testSynthOptionsCreate - resultCreate <- DBSynthesizer.synthesize genTxs options protocol - let blockCountCreate = resultForged resultCreate - blockCountCreate > 0 @? "no blocks have been forged during create step" + resultCreate <- + DBSynthesizer.synthesize genTxs testSynthOptionsCreate epochSize chainDB protocol + resultForged resultCreate > 0 @? "no blocks have been forged during create step" logStep "running synthesis - append" resultAppend <- - DBSynthesizer.synthesize genTxs options{confOptions = testSynthOptionsAppend} protocol - let blockCountAppend = resultForged resultAppend - blockCountAppend > 0 @? "no blocks have been forged during append step" - - logStep "copy volatile to immutable DB" - DBImmutaliser.run testImmutaliserConfig - - logStep "running analysis" - resultAnalysis <- DBAnalyser.analyse testAnalyserConfig testBlockArgs - - let blockCount = blockCountCreate + blockCountAppend - resultAnalysis == Just (ResultCountBlock blockCount) - @? "wrong number of blocks encountered during analysis \ - \ (counted: " - ++ show resultAnalysis - ++ "; expected: " - ++ show blockCount - ++ ")" + DBSynthesizer.synthesize genTxs testSynthOptionsAppend epochSize chainDB protocol + resultForged resultAppend > 0 @? "no blocks have been forged during append step" where genTxs _ _ _ _ = pure [] @@ -124,7 +82,7 @@ tests :: TestTree tests = testGroup "cardano-tools" - [ testCaseSteps "synthesize and analyse: blockCount\n" blockCountTest + [ testCaseSteps "synthesize: blockCount\n" blockCountTest , Test.Cardano.Tools.Headers.tests ] diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/alonzo-genesis.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/alonzo-genesis.json deleted file mode 100644 index 093071bb39..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/alonzo-genesis.json +++ /dev/null @@ -1,194 +0,0 @@ -{ - "lovelacePerUTxOWord": 34482, - "executionPrices": { - "prSteps": { - "numerator": 721, - "denominator": 10000000 - }, - "prMem": { - "numerator": 577, - "denominator": 10000 - } - }, - "maxTxExUnits": { - "exUnitsMem": 14000000, - "exUnitsSteps": 10000000000 - }, - "maxBlockExUnits": { - "exUnitsMem": 56000000, - "exUnitsSteps": 40000000000 - }, - "maxValueSize": 5000, - "collateralPercentage": 150, - "maxCollateralInputs": 3, - "costModels": { - "PlutusV1": { - "sha2_256-memory-arguments": 4, - "equalsString-cpu-arguments-constant": 1000, - "cekDelayCost-exBudgetMemory": 100, - "lessThanEqualsByteString-cpu-arguments-intercept": 103599, - "divideInteger-memory-arguments-minimum": 1, - "appendByteString-cpu-arguments-slope": 621, - "blake2b-cpu-arguments-slope": 29175, - "iData-cpu-arguments": 150000, - "encodeUtf8-cpu-arguments-slope": 1000, - "unBData-cpu-arguments": 150000, - "multiplyInteger-cpu-arguments-intercept": 61516, - "cekConstCost-exBudgetMemory": 100, - "nullList-cpu-arguments": 150000, - "equalsString-cpu-arguments-intercept": 150000, - "trace-cpu-arguments": 150000, - "mkNilData-memory-arguments": 32, - "lengthOfByteString-cpu-arguments": 150000, - "cekBuiltinCost-exBudgetCPU": 29773, - "bData-cpu-arguments": 150000, - "subtractInteger-cpu-arguments-slope": 0, - "unIData-cpu-arguments": 150000, - "consByteString-memory-arguments-intercept": 0, - "divideInteger-memory-arguments-slope": 1, - "divideInteger-cpu-arguments-model-arguments-slope": 118, - "listData-cpu-arguments": 150000, - "headList-cpu-arguments": 150000, - "chooseData-memory-arguments": 32, - "equalsInteger-cpu-arguments-intercept": 136542, - "sha3_256-cpu-arguments-slope": 82363, - "sliceByteString-cpu-arguments-slope": 5000, - "unMapData-cpu-arguments": 150000, - "lessThanInteger-cpu-arguments-intercept": 179690, - "mkCons-cpu-arguments": 150000, - "appendString-memory-arguments-intercept": 0, - "modInteger-cpu-arguments-model-arguments-slope": 118, - "ifThenElse-cpu-arguments": 1, - "mkNilPairData-cpu-arguments": 150000, - "lessThanEqualsInteger-cpu-arguments-intercept": 145276, - "addInteger-memory-arguments-slope": 1, - "chooseList-memory-arguments": 32, - "constrData-memory-arguments": 32, - "decodeUtf8-cpu-arguments-intercept": 150000, - "equalsData-memory-arguments": 1, - "subtractInteger-memory-arguments-slope": 1, - "appendByteString-memory-arguments-intercept": 0, - "lengthOfByteString-memory-arguments": 4, - "headList-memory-arguments": 32, - "listData-memory-arguments": 32, - "consByteString-cpu-arguments-intercept": 150000, - "unIData-memory-arguments": 32, - "remainderInteger-memory-arguments-minimum": 1, - "bData-memory-arguments": 32, - "lessThanByteString-cpu-arguments-slope": 248, - "encodeUtf8-memory-arguments-intercept": 0, - "cekStartupCost-exBudgetCPU": 100, - "multiplyInteger-memory-arguments-intercept": 0, - "unListData-memory-arguments": 32, - "remainderInteger-cpu-arguments-model-arguments-slope": 118, - "cekVarCost-exBudgetCPU": 29773, - "remainderInteger-memory-arguments-slope": 1, - "cekForceCost-exBudgetCPU": 29773, - "sha2_256-cpu-arguments-slope": 29175, - "equalsInteger-memory-arguments": 1, - "indexByteString-memory-arguments": 1, - "addInteger-memory-arguments-intercept": 1, - "chooseUnit-cpu-arguments": 150000, - "sndPair-cpu-arguments": 150000, - "cekLamCost-exBudgetCPU": 29773, - "fstPair-cpu-arguments": 150000, - "quotientInteger-memory-arguments-minimum": 1, - "decodeUtf8-cpu-arguments-slope": 1000, - "lessThanInteger-memory-arguments": 1, - "lessThanEqualsInteger-cpu-arguments-slope": 1366, - "fstPair-memory-arguments": 32, - "modInteger-memory-arguments-intercept": 0, - "unConstrData-cpu-arguments": 150000, - "lessThanEqualsInteger-memory-arguments": 1, - "chooseUnit-memory-arguments": 32, - "sndPair-memory-arguments": 32, - "addInteger-cpu-arguments-intercept": 197209, - "decodeUtf8-memory-arguments-slope": 8, - "equalsData-cpu-arguments-intercept": 150000, - "mapData-cpu-arguments": 150000, - "mkPairData-cpu-arguments": 150000, - "quotientInteger-cpu-arguments-constant": 148000, - "consByteString-memory-arguments-slope": 1, - "cekVarCost-exBudgetMemory": 100, - "indexByteString-cpu-arguments": 150000, - "unListData-cpu-arguments": 150000, - "equalsInteger-cpu-arguments-slope": 1326, - "cekStartupCost-exBudgetMemory": 100, - "subtractInteger-cpu-arguments-intercept": 197209, - "divideInteger-cpu-arguments-model-arguments-intercept": 425507, - "divideInteger-memory-arguments-intercept": 0, - "cekForceCost-exBudgetMemory": 100, - "blake2b-cpu-arguments-intercept": 2477736, - "remainderInteger-cpu-arguments-constant": 148000, - "tailList-cpu-arguments": 150000, - "encodeUtf8-cpu-arguments-intercept": 150000, - "equalsString-cpu-arguments-slope": 1000, - "lessThanByteString-memory-arguments": 1, - "multiplyInteger-cpu-arguments-slope": 11218, - "appendByteString-cpu-arguments-intercept": 396231, - "lessThanEqualsByteString-cpu-arguments-slope": 248, - "modInteger-memory-arguments-slope": 1, - "addInteger-cpu-arguments-slope": 0, - "equalsData-cpu-arguments-slope": 10000, - "decodeUtf8-memory-arguments-intercept": 0, - "chooseList-cpu-arguments": 150000, - "constrData-cpu-arguments": 150000, - "equalsByteString-memory-arguments": 1, - "cekApplyCost-exBudgetCPU": 29773, - "quotientInteger-memory-arguments-slope": 1, - "verifySignature-cpu-arguments-intercept": 3345831, - "unMapData-memory-arguments": 32, - "mkCons-memory-arguments": 32, - "sliceByteString-memory-arguments-slope": 1, - "sha3_256-memory-arguments": 4, - "ifThenElse-memory-arguments": 1, - "mkNilPairData-memory-arguments": 32, - "equalsByteString-cpu-arguments-slope": 247, - "appendString-cpu-arguments-intercept": 150000, - "quotientInteger-cpu-arguments-model-arguments-slope": 118, - "cekApplyCost-exBudgetMemory": 100, - "equalsString-memory-arguments": 1, - "multiplyInteger-memory-arguments-slope": 1, - "cekBuiltinCost-exBudgetMemory": 100, - "remainderInteger-memory-arguments-intercept": 0, - "sha2_256-cpu-arguments-intercept": 2477736, - "remainderInteger-cpu-arguments-model-arguments-intercept": 425507, - "lessThanEqualsByteString-memory-arguments": 1, - "tailList-memory-arguments": 32, - "mkNilData-cpu-arguments": 150000, - "chooseData-cpu-arguments": 150000, - "unBData-memory-arguments": 32, - "blake2b-memory-arguments": 4, - "iData-memory-arguments": 32, - "nullList-memory-arguments": 32, - "cekDelayCost-exBudgetCPU": 29773, - "subtractInteger-memory-arguments-intercept": 1, - "lessThanByteString-cpu-arguments-intercept": 103599, - "consByteString-cpu-arguments-slope": 1000, - "appendByteString-memory-arguments-slope": 1, - "trace-memory-arguments": 32, - "divideInteger-cpu-arguments-constant": 148000, - "cekConstCost-exBudgetCPU": 29773, - "encodeUtf8-memory-arguments-slope": 8, - "quotientInteger-cpu-arguments-model-arguments-intercept": 425507, - "mapData-memory-arguments": 32, - "appendString-cpu-arguments-slope": 1000, - "modInteger-cpu-arguments-constant": 148000, - "verifySignature-cpu-arguments-slope": 1, - "unConstrData-memory-arguments": 32, - "quotientInteger-memory-arguments-intercept": 0, - "equalsByteString-cpu-arguments-constant": 150000, - "sliceByteString-memory-arguments-intercept": 0, - "mkPairData-memory-arguments": 32, - "equalsByteString-cpu-arguments-intercept": 112536, - "appendString-memory-arguments-slope": 1, - "lessThanInteger-cpu-arguments-slope": 497, - "modInteger-cpu-arguments-model-arguments-intercept": 425507, - "modInteger-memory-arguments-minimum": 1, - "sha3_256-cpu-arguments-intercept": 0, - "verifySignature-memory-arguments": 1, - "cekLamCost-exBudgetMemory": 100, - "sliceByteString-cpu-arguments-intercept": 150000 - } - } -} diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/bulk-creds-k2.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/bulk-creds-k2.json deleted file mode 100644 index fc64d6855b..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/bulk-creds-k2.json +++ /dev/null @@ -1,34 +0,0 @@ -[ - [ - { - "type": "NodeOperationalCertificate", - "description": "", - "cborHex": "82845820465dad8c08ecfe932f70bf287903d2d1973ac224f61cd0f9914ed052853f736b000058402cf9b1523a570f5a3333e1a602d3212e187b1e4b6b147b7cbc94657039de7e79e8ca6dc964cb7368b135c9607151e715d2ea9ccad9f3f550077b79fa3f64d1095820974aab238e812402dc9dbce33dd28203ae6df68616290a1b4aac347e881057bb" -} - , { - "type": "VrfSigningKey_PraosVRF", - "description": "VRF Signing Key", - "cborHex": "584040c0bd2dd8acfaded1d93c4844c2130058f86067af2e065dd3ae001e964a5f18b08644bf6ed9d404ba94c9ba9299a2ab53f36c57c02c38139f2138b6c71302c7" -} - , { - "type": "KesSigningKey_ed25519_kes_2^6", - "description": "KES Signing Key", - "cborHex": "5902606d23bd6e50df9416e52e9ee2cca23ac00f1ae78a62e50afcfc3cc8159b1e9ac888593015ae9c6124e33f143416b5c12195e3a2b947a00ef34e185f672b1047df6f5180047fffdaefea6337b2384087095873ba2d09ba74d1e826bbeec148e2db19ecb1db2e6d28748cf06cd36711d16fbced7fa2d5e0c1111832c36982196b417bd16ed77a4fd795fa22e2d394f3cb8940ca406431f4b105d6e9a47e5bcb4d5f86fa466b8228fcf17056f5e006ed522538c7ed32ad8724d3c63f5443907081f5f54f72868cb1475d05bb79d11a4c6abbed543c4898fc2f157aeb99adb27c31ca22ac195d04b13a0a1a3d118599d7ff8073d90063afcc87586e77b9795f73776e0f0bbf690440a243e729880cbcded7fc778f31cc873791296b1e43f87c869e197f1fd345fdf368136c936c53124caad8786379a194d3b348752b90dbfdd1199a3f8f8388940d5585825e2cffe7108b821d54351b6de2c9c4c8308d157b4b25070c77efc22a327e074e2ec01eac2bf9169a97d65cc826fbe827d0da045e5b680953b17a47b240b5e52653ad495d6ca90513f110d5a8353e92b416273a1bbc05e99050cd38dcb7a1f0e9d73aa0fbac201359fb26faa9235a851480b25dcf0ebe95cb2998b3f10f1baaabde842266c31ede1289ae1212cc9ae57a00262ada16dcd662f40c90ee1032e00dd4b6d1f17a0956517c8c38c354cb65b16bf6ace5d1d056205bd9f596020677ac06747335512dc9bafff75858a92cd6e947da98865ab364e6933d94a999afe22a0e8cbf3b8151e07073b343aa6632607f16d578a94e4f3b7050c2ee5e43a9279fd907e3deb75b244cb707423b06d71ab93b60b6fc23fa28" -} - ], [ - { - "type": "NodeOperationalCertificate", - "description": "", - "cborHex": "82845820a5ae7caf7a79b7f750d3d6da9a31d6523bdc0b99cc9dbfbdc11122e3ae07e8280000584071c1947b93fac5684a327a102f522d7b31daccfe8ef69ed0c36ed4618910245756bfe607b5a2bf7725045564b77ee18bfd7ed086b957d856a5491b51fbaedf065820e41015edc7b39489226d27c51dbe84c636466b3e29758a95445297614a8050bf" -} - , { - "type": "VrfSigningKey_PraosVRF", - "description": "VRF Signing Key", - "cborHex": "5840e2164474b17216bffb9494b8cdfc6d82f31f24e3f4dede8316221c11f616d75306a90f0597762346dd9eee0017623aca4745105f75b6d0d44355b26395372934" -} - , { - "type": "KesSigningKey_ed25519_kes_2^6", - "description": "KES Signing Key", - "cborHex": "59026076ae5c10752636ec89a8e9d25b74a7862f60d276246d13fa11bda92cfaf1417fe924137ee2a71629dcbbe950bb991dc8935033e3a4414b019510feb5f2c56d29de8e5249591afc25d214c024eac3c1186c26136a8719ca647c3c554aff75301df40a7243f0cea69d0da41b0edd95c35cc6644a433e1a59898f70a88b9578635c7f2a0dae07f48267c63e281eaeb4e9aad2e22f46229c4ee9f32e231f081a32c9b4ee2e7a940b2aa19d596f5b160abc0f83c66cd8c26d8f7226f4556d4a406e0b978df024d42a1a9236d58e8c64733aae1ee6e3258a27bfaf060b6c2913fc9babf1758bad0fe98819873bf34828f7ab5515d888f0c107f4c4010423f6ce7523de1cb543b0b471a48af5e367b75d856a36f5899c8019f91d321c22d012ee466e509d49ca12ed800448ad43ee1575de56abad60d0cd1d2bb9b541573504040c3b495d078e558c9ad0015d89e36515d4451c7adc87fdfe21cf21609684093e4d59c143c077e1127e25a0bb1fb8549c503b519f01f6092a3d3452341da2fb8687e07b340575532fe529cadd9701c300770930c4da09feed3a7f9b4d1253efe0fd1dc01122d7bf2324ff0779df1c65ef3886ca5196c4c5107c36dfc3dd292b9f90f2b55e380763e756b7f6b04d45d45e61aba849736babb9224adbf27a8880f1ecc23dd0bbe61a5b73fa269cc100bf3f6cbd17163f31d38aa22db320d37cbb767821de066a0f2b40f11bfc00404963d8418f54e9191f08d3c46319263b69cf51222c2ae4500627980856833e796e4435768172cb98b8b33ed5970a92ab3f046050c9f5aeeafa151f9d11b93c425b68cace42f87c51dee5f0a38071b3a8da23743d699c" -} - ]] diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/byron-genesis.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/byron-genesis.json deleted file mode 100644 index aec652492f..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/byron-genesis.json +++ /dev/null @@ -1,42 +0,0 @@ -{ "bootStakeholders": - { "ce2950ee9b35c74336371a7393b2f1fa64d4af1831180076b106208d": 1 } -, "heavyDelegation": - { "ce2950ee9b35c74336371a7393b2f1fa64d4af1831180076b106208d": - { "omega": 0 - , "issuerPk": - "0Te/2OpdrE4IFuj6ZCSky8a/oeM9xE0phU0rQJE7v3Zg0wZop+bcZaKVe8qRk1zl0DM5vGIk5+XHZGhv7xh3rQ==" - , "delegatePk": - "ojky67+tV35+CmAFX7hkCCpPgz7EwrU8HCMDk7qEgoynuLaByN8S4ek4HjQXPq/b3vZFd08+Ip2BN/nC+e6Alg==" - , "cert": - "a8e1514662b6edd544f9e22d3bc8a961e6cfe5b1db35378188bb4fcd848e27c977952c8e73c29757b8b5b6b6c0b52254357383272c0b83e24cb91558907e8d04" - } } -, "startTime": 1655366659 -, "nonAvvmBalances": - { "2657WMsDfac5TVJguqJE11Z1tdx9HP72E9Roz32GVecUrX7oScFb1sXPzC43EnLUx": - "30000" - , "2657WMsDfac5V9qqEUfJm252BN5L81ni6CZyDS31cN7XZrAtsyqbz4yGr42bKG5B7": - "270000" - } -, "blockVersionData": - { "scriptVersion": 0 - , "slotDuration": "20000" - , "maxBlockSize": "641000" - , "maxHeaderSize": "200000" - , "maxTxSize": "4096" - , "maxProposalSize": "700" - , "mpcThd": "200000" - , "heavyDelThd": "300000" - , "updateVoteThd": "100000" - , "updateProposalThd": "100000" - , "updateImplicit": "10000" - , "softforkRule": - { "initThd": "900000" - , "minThd": "600000" - , "thdDecrement": "100000" - } - , "txFeePolicy": { "summand": "0" , "multiplier": "439460" } - , "unlockStakeEpoch": "184467" - } -, "protocolConsts": { "k": 2160 , "protocolMagic": 42 } -, "avvmDistr": {} -} \ No newline at end of file diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/config.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/config.json deleted file mode 100644 index 2dc14f69ca..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/config.json +++ /dev/null @@ -1,116 +0,0 @@ -{ - "AcceptedConnectionsLimit": { - "delay": 5, - "hardLimit": 512, - "softLimit": 384 - }, - "AlonzoGenesisFile": "alonzo-genesis.json", - "ApplicationName": "cardano-sl", - "ApplicationVersion": 0, - "ByronGenesisFile": "byron-genesis.json", - "ConwayGenesisFile": "conway-genesis.json", - "DijkstraGenesisFile": "dijkstra-genesis.json", - "EnableP2P": false, - "LastKnownBlockVersion-Alt": 0, - "LastKnownBlockVersion-Major": 3, - "LastKnownBlockVersion-Minor": 0, - "MaxKnownMajorProtocolVersion": 2, - "MempoolCapacityBytesOverride": "NoOverride", - "Protocol": "Cardano", - "ProtocolIdleTimeout": 5, - "RequiresNetworkMagic": "RequiresMagic", - "ShelleyGenesisFile": "shelley-genesis.json", - "TargetNumberOfActivePeers": 20, - "TargetNumberOfEstablishedPeers": 50, - "TargetNumberOfKnownPeers": 100, - "TargetNumberOfRootPeers": 100, - "TestAllegraHardForkAtEpoch": 0, - "TestAlonzoHardForkAtEpoch": 0, - "TestBabbageHardForkAtEpoch": 0, - "TestEnableDevelopmentHardForkEras": true, - "TestEnableDevelopmentNetworkProtocols": true, - "TestMaryHardForkAtEpoch": 0, - "TestShelleyHardForkAtEpoch": 0, - "TimeWaitTimeout": 60, - "TraceOptions": { - "": { - "backends": [ - "Stdout MachineFormat", - "EKGBackend", - "Forwarder" - ], - "severity": "Notice" - }, - "AcceptPolicy": { - "severity": "Info" - }, - "BlockFetchClient": { - "detail": "DMinimal", - "severity": "Info" - }, - "BlockFetchClient.CompletedBlockFetch": { - "maxFrequency": 2 - }, - "BlockFetchServer": { - "severity": "Info" - }, - "ChainDB": { - "severity": "Info" - }, - "ChainDB.AddBlockEvent.AddBlockValidation.ValidCandidate": { - "maxFrequency": 2 - }, - "ChainDB.AddBlockEvent.AddedBlockToQueue": { - "maxFrequency": 2 - }, - "ChainDB.AddBlockEvent.AddedBlockToVolatileDB": { - "maxFrequency": 2 - }, - "ChainDB.CopyToImmutableDBEvent.CopiedBlockToImmutableDB": { - "maxFrequency": 2 - }, - "ChainSyncClient": { - "detail": "DMinimal", - "severity": "Info" - }, - "ChainSyncServerBlock": { - "severity": "Info" - }, - "ChainSyncServerHeader": { - "severity": "Info" - }, - "DNSResolver": { - "severity": "Info" - }, - "DNSSubscription": { - "severity": "Info" - }, - "DiffusionInit": { - "severity": "Info" - }, - "ErrorPolicy": { - "severity": "Info" - }, - "Forge": { - "severity": "Info" - }, - "IpSubscription": { - "severity": "Info" - }, - "LocalErrorPolicy": { - "severity": "Info" - }, - "Mempool": { - "severity": "Info" - }, - "Resources": { - "severity": "Info" - }, - "TxSubmission2": { - "detail": "DMinimal" - } - }, - "TurnOnLogMetrics": true, - "TurnOnLogging": true, - "UseTraceDispatcher": true -} diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/conway-genesis.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/conway-genesis.json deleted file mode 100644 index 08e1aed42a..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/conway-genesis.json +++ /dev/null @@ -1,77 +0,0 @@ -{ - "poolVotingThresholds": { - "committeeNormal": 0, - "committeeNoConfidence": 0, - "hardForkInitiation": 0, - "motionNoConfidence": 0, - "ppSecurityGroup": 0 - }, - "dRepVotingThresholds": { - "motionNoConfidence": 0, - "committeeNormal": 0, - "committeeNoConfidence": 0, - "updateToConstitution": 0, - "hardForkInitiation": 0, - "ppNetworkGroup": 0, - "ppEconomicGroup": 0, - "ppTechnicalGroup": 0, - "ppGovGroup": 0, - "treasuryWithdrawal": 0 - }, - "committeeMinSize": 0, - "committeeMaxTermLength": 0, - "govActionLifetime": 0, - "govActionDeposit": 0, - "dRepDeposit": 0, - "dRepActivity": 0, - "minFeeRefScriptCostPerByte": 0, - "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], - "constitution": { - "anchor": { - "url": "", - "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" - } - }, - "committee": { - "members": { - "keyHash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": 1, - "scriptHash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": 2 - }, - "threshold": 0.5 - }, - "delegs": { - "keyHash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": { - "dRep": "drep-alwaysAbstain" - }, - "keyHash-35bc5e86c42afbc593ab4cdd78301005df84ba67fa1f12f95f8ee103": { - "dRep": "drep-alwaysNoConfidence" - }, - "scriptHash-afbc5005df84ba5f8ee93ab435bc5e83067fa1f12f9c42cdd7110386": { - "dRep": "drep-keyHash-78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd" - }, - "keyHash-df93ab435bc5eafbc500583067fa1f12f9110386c42cdd784ba5f8ee": { - "dRep": "drep-scriptHash-01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b" - }, - "keyHash-5df84bcdd7a5f8ee93aafbc500b435bc5e83067fa1f12f9110386c42": { - "poolId": "0335bc5e86c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd" - }, - "keyHash-8ee93a5df84bc42cdd7a5fafbc500b435bc5e83067fa1f12f9110386": { - "poolId": "086c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd335bc5e", - "dRep": "drep-alwaysAbstain" - } - }, - "initialDReps": { - "keyHash-78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd": { - "expiry": 1000, - "deposit": 5000 - }, - "scriptHash-01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b": { - "expiry": 300, - "deposit": 6000, - "anchor": { - "url": "example.com", - "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" - } - } - } -} diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/dijkstra-genesis.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/dijkstra-genesis.json deleted file mode 100644 index c33c675572..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/dijkstra-genesis.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "maxRefScriptSizePerBlock": 1048576, - "maxRefScriptSizePerTx": 204800, - "refScriptCostStride": 25600, - "refScriptCostMultiplier": 1.2 -} diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/shelley-genesis.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/shelley-genesis.json deleted file mode 100644 index 7755bcd224..0000000000 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/shelley-genesis.json +++ /dev/null @@ -1,83 +0,0 @@ -{ - "activeSlotsCoeff": 0.05, - "epochLength": 432000, - "genDelegs": {}, - "initialFunds": { - "0032635dc627da054f2a9e99559c56e16b02cf5f9237ba586ee1e648336b47a4e6e19ac5257fc97bd220bd9ae368aa2d775d86315ab7ef058f": 999500000000000, - "0064f4987ff07483636803f71f5f8442dad7f7fc46d83e2242d1548ad5d1f6f71a04ca856cc569fd068b069a555999c4776ad50b4cdd049d13": 999500000000000, - "602b43cb2b891e2dc9f5b07e051fb8d221a4a88ca161d95e859aa9ad8a": 9000000000000 - }, - "maxKESEvolutions": 60, - "maxLovelaceSupply": 2010000000000000, - "networkId": "Testnet", - "networkMagic": 42, - "protocolParams": { - "a0": 0.3, - "decentralisationParam": 0, - "eMax": 18, - "extraEntropy": { - "tag": "NeutralNonce" - }, - "keyDeposit": 400000, - "maxBlockBodySize": 81920, - "maxBlockHeaderSize": 1100, - "maxTxSize": 16384, - "minFeeA": 0, - "minFeeB": 0, - "minPoolCost": 0, - "minUTxOValue": 0, - "nOpt": 50, - "poolDeposit": 500000000, - "protocolVersion": { - "major": 5, - "minor": 0 - }, - "rho": 0.0022, - "tau": 0.05 - }, - "securityParam": 2160, - "slotLength": 1, - "slotsPerKESPeriod": 129600, - "staking": { - "pools": { - "1dc0a846ec816bdcc5288c0b57871a0400e86728ad0851132e43883f": { - "cost": 0, - "margin": 0, - "metadata": null, - "owners": [], - "pledge": 0, - "publicKey": "1dc0a846ec816bdcc5288c0b57871a0400e86728ad0851132e43883f", - "relays": [], - "rewardAccount": { - "credential": { - "key hash": "22c700325ec932f59048a7258e89b5f166604f184e0809d16a495550" - }, - "network": "Testnet" - }, - "vrf": "ee8fdadab21abed48fadee52492596841c561640920d1c022fa8ae51d206c714" - }, - "d3e16257b8c608ec4b2cb89621d7ddb60fc08839c1b491a598615fb5": { - "cost": 0, - "margin": 0, - "metadata": null, - "owners": [], - "pledge": 0, - "publicKey": "d3e16257b8c608ec4b2cb89621d7ddb60fc08839c1b491a598615fb5", - "relays": [], - "rewardAccount": { - "credential": { - "key hash": "3832f1051268ab7a7765142f21d695b7aaf40c576bf2d1a71894f0a4" - }, - "network": "Testnet" - }, - "vrf": "bbc57641002e501cf8bf98b776ba082c604e6af7c482f716934ed08d19c22733" - } - }, - "stake": { - "6b47a4e6e19ac5257fc97bd220bd9ae368aa2d775d86315ab7ef058f": "d3e16257b8c608ec4b2cb89621d7ddb60fc08839c1b491a598615fb5", - "d1f6f71a04ca856cc569fd068b069a555999c4776ad50b4cdd049d13": "1dc0a846ec816bdcc5288c0b57871a0400e86728ad0851132e43883f" - } - }, - "systemStart": "2022-06-16T08:04:19Z", - "updateQuorum": 5 -} diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs index 29d754ef69..1134ff70d7 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs @@ -376,7 +376,8 @@ nullTracers = } showTracers :: - ( Show peer + ( Monad m + , Show peer , Show (GenTx blk) , Show (GenTxId blk) , Show (ApplyTxErr blk) @@ -386,10 +387,10 @@ showTracers :: Tracer m String -> Tracers m peer blk e showTracers tr = Tracers - { tChainSyncTracer = showTracing tr - , tTxSubmissionTracer = showTracing tr - , tStateQueryTracer = showTracing tr - , tTxMonitorTracer = showTracing tr + { tChainSyncTracer = show >$< tr + , tTxSubmissionTracer = show >$< tr + , tStateQueryTracer = show >$< tr + , tTxMonitorTracer = show >$< tr } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 53d85783fb..1092ff660a 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -616,7 +616,8 @@ nullTracers = } showTracers :: - ( Show blk + ( Monad m + , Show blk , Show ntnAddr , Show (Header blk) , Show (GenTx blk) @@ -627,16 +628,16 @@ showTracers :: Tracer m String -> Tracers m ntnAddr blk e showTracers tr = Tracers - { tChainSyncTracer = showTracing tr - , tChainSyncSerialisedTracer = showTracing tr - , tBlockFetchTracer = showTracing tr - , tBlockFetchSerialisedTracer = showTracing tr - , tTxSubmission2Tracer = showTracing tr - , tPerasCertDiffusionTracer = showTracing tr - , tPerasVoteDiffusionTracer = showTracing tr - , tKeepAliveTracer = showTracing tr - , tPeerSharingTracer = showTracing tr - , tTxLogicTracer = showTracing tr + { tChainSyncTracer = show >$< tr + , tChainSyncSerialisedTracer = show >$< tr + , tBlockFetchTracer = show >$< tr + , tBlockFetchSerialisedTracer = show >$< tr + , tTxSubmission2Tracer = show >$< tr + , tPerasCertDiffusionTracer = show >$< tr + , tPerasVoteDiffusionTracer = show >$< tr + , tKeepAliveTracer = show >$< tr + , tPeerSharingTracer = show >$< tr + , tTxLogicTracer = show >$< tr } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index dc48b9d317..c1865e5204 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -18,7 +18,7 @@ module Ouroboros.Consensus.Node.Tracers ) where import Control.Exception (SomeException) -import Control.Tracer (Tracer, nullTracer, showTracing) +import Control.Tracer (Tracer, nullTracer, (>$<)) import Data.Text (Text) import Data.Time (UTCTime) import Ouroboros.Consensus.Block @@ -181,7 +181,8 @@ nullTracers = } showTracers :: - ( Show blk + ( Monad m + , Show blk , Show (GenTx blk) , Show (Validated (GenTx blk)) , Show (GenTxId blk) @@ -190,40 +191,41 @@ showTracers :: , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , Show (TxMeasure blk) + , Show (TxMeasurePhase1 blk) + , Show (TxMeasurePhase2 blk) , Show remotePeer , LedgerSupportsProtocol blk ) => Tracer m String -> Tracers m remotePeer localPeer blk showTracers tr = Tracers - { chainSyncClientTracer = showTracing tr - , chainSyncServerHeaderTracer = showTracing tr - , chainSyncServerBlockTracer = showTracing tr - , blockFetchDecisionTracer = showTracing tr - , blockFetchClientTracer = showTracing tr - , blockFetchServerTracer = showTracing tr - , txInboundTracer = showTracing tr - , txOutboundTracer = showTracing tr - , localTxSubmissionServerTracer = showTracing tr - , txLogicTracer = showTracing tr - , txCountersTracer = showTracing tr - , mempoolTracer = showTracing tr - , perasCertDiffusionInboundTracer = showTracing tr - , perasCertDiffusionOutboundTracer = showTracing tr - , perasVoteDiffusionInboundTracer = showTracing tr - , perasVoteDiffusionOutboundTracer = showTracing tr - , forgeTracer = showTracing tr - , blockchainTimeTracer = showTracing tr - , forgeStateInfoTracer = showTracing tr - , keepAliveClientTracer = showTracing tr - , consensusSanityCheckTracer = showTracing tr - , consensusErrorTracer = showTracing tr - , gsmTracer = showTracing tr - , gddTracer = showTracing tr - , csjTracer = showTracing tr - , dbfTracer = showTracing tr - , kesAgentTracer = showTracing tr + { chainSyncClientTracer = show >$< tr + , chainSyncServerHeaderTracer = show >$< tr + , chainSyncServerBlockTracer = show >$< tr + , blockFetchDecisionTracer = show >$< tr + , blockFetchClientTracer = show >$< tr + , blockFetchServerTracer = show >$< tr + , txInboundTracer = show >$< tr + , txOutboundTracer = show >$< tr + , localTxSubmissionServerTracer = show >$< tr + , txLogicTracer = show >$< tr + , txCountersTracer = show >$< tr + , mempoolTracer = show >$< tr + , perasCertDiffusionInboundTracer = show >$< tr + , perasCertDiffusionOutboundTracer = show >$< tr + , perasVoteDiffusionInboundTracer = show >$< tr + , perasVoteDiffusionOutboundTracer = show >$< tr + , forgeTracer = show >$< tr + , blockchainTimeTracer = show >$< tr + , forgeStateInfoTracer = show >$< tr + , keepAliveClientTracer = show >$< tr + , consensusSanityCheckTracer = show >$< tr + , consensusErrorTracer = show >$< tr + , gsmTracer = show >$< tr + , gddTracer = show >$< tr + , csjTracer = show >$< tr + , dbfTracer = show >$< tr + , kesAgentTracer = show >$< tr } {------------------------------------------------------------------------------- @@ -405,7 +407,8 @@ deriving instance , Eq (Validated (GenTx blk)) , Eq (ForgeStateUpdateError blk) , Eq (CannotForge blk) - , Eq (TxMeasure blk) + , Eq (TxMeasurePhase1 blk) + , Eq (TxMeasurePhase2 blk) ) => Eq (TraceForgeEvent blk) deriving instance @@ -414,7 +417,8 @@ deriving instance , Show (Validated (GenTx blk)) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , Show (TxMeasure blk) + , Show (TxMeasurePhase1 blk) + , Show (TxMeasurePhase2 blk) ) => Show (TraceForgeEvent blk) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs index 5cc1b112a0..1c943ccb5f 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs @@ -202,7 +202,7 @@ deriving instance -- that 'TestConfigB' can occur in contexts (such as in 'PropGeneralArgs') for -- which the @m@ parameter is irrelevant and hence unknown. data TestConfigMB m blk = TestConfigMB - { nodeInfo :: CoreNodeId -> TestNodeInitialization m blk + { nodeInfo :: CoreNodeId -> m (TestNodeInitialization m blk) , mkRekeyM :: Maybe (m (RekeyM m blk)) -- ^ 'runTestNetwork' immediately runs this action once in order to -- initialize an 'RekeyM' value that it then reuses throughout the test diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index ee17e0a1fb..0d69a0269d 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -61,7 +61,6 @@ import qualified Control.Monad.Except as Exc import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as Lazy -import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity (Identity) import qualified Data.List as List import qualified Data.List.NonEmpty as NE @@ -244,7 +243,7 @@ data ThreadNetworkArgs m blk = ThreadNetworkArgs { tnaForgeEbbEnv :: Maybe (ForgeEbbEnv blk) , tnaFuture :: Future , tnaJoinPlan :: NodeJoinPlan - , tnaNodeInfo :: CoreNodeId -> TestNodeInitialization m blk + , tnaNodeInfo :: CoreNodeId -> m (TestNodeInitialization m blk) , tnaNumCoreNodes :: NumCoreNodes , tnaNumSlots :: NumSlots , tnaMessageDelay :: CalcMessageDelay blk @@ -378,8 +377,8 @@ runThreadNetwork forM coreNodeIds $ \nid -> do -- assume they all start with the empty chain and the same initial -- ledger - let nodeInitData = mkProtocolInfo (CoreNodeId 0) - TestNodeInitialization{tniProtocolInfo} = nodeInitData + nodeInitData <- mkProtocolInfo (CoreNodeId 0) + let TestNodeInitialization{tniProtocolInfo} = nodeInitData ProtocolInfo{pInfoInitLedger} = tniProtocolInfo ExtLedgerState{ledgerState} = pInfoInitLedger v <- @@ -392,8 +391,8 @@ runThreadNetwork let uedges = edgesNodeTopology nodeTopology edgeStatusVars <- fmap (Map.fromList . concat) $ do -- assume they all use the same CodecConfig - let nodeInitData = mkProtocolInfo (CoreNodeId 0) - TestNodeInitialization{tniProtocolInfo} = nodeInitData + nodeInitData <- mkProtocolInfo (CoreNodeId 0) + let TestNodeInitialization{tniProtocolInfo} = nodeInitData ProtocolInfo{pInfoConfig} = tniProtocolInfo codecConfig = configCodec pInfoConfig forM uedges $ \uedge -> do @@ -500,29 +499,30 @@ runThreadNetwork nodeInfo nextInstrSlotVar = void $ forkLinkedThread sharedRegistry label $ do - loop 0 tniProtocolInfo tniBlockForging NodeRestart restarts0 + TestNodeInitialization + { tniCrucialTxs + , tniProtocolInfo + , tniBlockForging + } <- + mkProtocolInfo coreNodeId + loop tniCrucialTxs 0 tniProtocolInfo tniBlockForging NodeRestart restarts0 where label = "vertex-" <> condense coreNodeId - TestNodeInitialization - { tniCrucialTxs - , tniProtocolInfo - , tniBlockForging - } = mkProtocolInfo coreNodeId - restarts0 :: Map SlotNo NodeRestart restarts0 = Map.mapMaybe (Map.lookup coreNodeId) m where NodeRestarts m = nodeRestarts loop :: + [GenTx blk] -> SlotNo -> ProtocolInfo blk -> m [MkBlockForging m blk] -> NodeRestart -> Map SlotNo NodeRestart -> m () - loop s pInfo mkBlockForging nr rs = do + loop tniCrucialTxs s pInfo mkBlockForging nr rs = do -- a registry solely for the resources of this specific node instance (again, finalChain, finalLdgr) <- withRegistry $ \nodeRegistry -> do -- change the node's key and prepare a delegation transaction if @@ -599,7 +599,7 @@ runThreadNetwork case again of Nothing -> pure () - Just (s', pInfo', blockForging', nr', rs') -> loop s' pInfo' blockForging' nr' rs' + Just (s', pInfo', blockForging', nr', rs') -> loop tniCrucialTxs s' pInfo' blockForging' nr' rs' -- \| Instrumentation: record the tip's block number at the onset of the -- slot. @@ -793,7 +793,7 @@ runThreadNetwork Origin -> error "selTracer" -- prop_general relies on this tracer - instrumentationTracer = Tracer $ \case + instrumentationTracer = mkTracer $ \case ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation (ChainDB.InvalidBlock e p)) -> traceWith invalidTracer (p, e) @@ -854,7 +854,7 @@ runThreadNetwork -- prop_general relies on these tracers let invalidTracer = nodeEventsInvalids nodeInfoEvents updatesTracer = nodeEventsUpdates nodeInfoEvents - wrapTracer tr = Tracer $ \(p, bno) -> do + wrapTracer tr = mkTracer $ \(p, bno) -> do s <- OracularClock.getCurrentSlot clock traceWith tr (s, p, bno) addTracer = wrapTracer $ nodeEventsAdds nodeInfoEvents @@ -988,7 +988,7 @@ runThreadNetwork -- prop_general relies on these tracers instrumentationTracers = nullTracers - { chainSyncClientTracer = Tracer $ \case + { chainSyncClientTracer = mkTracer $ \case TraceLabelPeer _ (CSClient.TraceDownloadedHeader hdr) -> case blockPoint hdr of GenesisPoint -> pure () @@ -999,7 +999,7 @@ runThreadNetwork headerAddTracer (RealPoint s h, blockNo hdr) _ -> pure () - , forgeTracer = Tracer $ \(TraceLabelCreds _ ev) -> do + , forgeTracer = mkTracer $ \(TraceLabelCreds _ ev) -> do traceWith (nodeEventsForges nodeInfoEvents) ev case ev of TraceNodeIsLeader s -> atomically $ blockOnCrucial s @@ -1739,8 +1739,8 @@ mkTestOutput vertexInfos = do -------------------------------------------------------------------------------} -- | Occurs throughout in positions that might be useful for debugging. -nullDebugTracer :: (Applicative m, Show a) => Tracer m a -nullDebugTracer = nullTracer `asTypeOf` showTracing debugTracer +nullDebugTracer :: (Monad m, Show a) => Tracer m a +nullDebugTracer = nullTracer `asTypeOf` (show >$< debugTracer) -- | Occurs throughout in positions that might be useful for debugging. nullDebugTracers :: @@ -1775,7 +1775,8 @@ type TracingConstraints blk = , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , Show (TxMeasure blk) + , Show (TxMeasurePhase1 blk) + , Show (TxMeasurePhase2 blk) , Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) , HasNestedContent Header blk ) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs index 7ec0253a47..14d1d29fc3 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs @@ -41,7 +41,7 @@ import qualified Control.Monad.Class.MonadTime.SI as SI import qualified Control.Monad.Class.MonadTimer.SI as SI import qualified Control.Monad.IOSim as IOSim import Control.Monad.Reader -import Control.Tracer (Tracer (Tracer)) +import Control.Tracer (mkTracer) import Data.Functor ((<&>)) import Data.List ((\\)) import qualified Data.Map.Strict as Map @@ -132,7 +132,7 @@ setupGsm :: SystemStateVars (IOSim.IOSim s) -> GSM.GsmEntryPoints (IOSim.IOSim s) setupGsm isHaaSatisfied vars = do - let tracer = Tracer $ push varEvents . EvGsm + let tracer = mkTracer $ push varEvents . EvGsm GSM.realGsmEntryPoints (id, tracer) GSM.GsmView diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 2ffcd3ff8f..6558c1eb21 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -226,9 +226,10 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = testConfigMB = TestConfigMB { nodeInfo = \a -> - plainTestNodeInitialization - (protocolInfo a) - (return blockForging) + pure $ + plainTestNodeInitialization + (protocolInfo a) + (return blockForging) , mkRekeyM = Nothing } @@ -431,7 +432,8 @@ instance HasHardForkTxOut '[BlockA, BlockB] where type TestBlock = HardForkBlock '[BlockA, BlockB] instance CanHardFork '[BlockA, BlockB] where - type HardForkTxMeasure '[BlockA, BlockB] = IgnoringOverflow ByteSize32 + type HardForkTxMeasurePhase1 '[BlockA, BlockB] = IgnoringOverflow ByteSize32 + type HardForkTxMeasurePhase2 '[BlockA, BlockB] = TrivialTxMeasurePhase2 hardForkEraTranslation = EraTranslation @@ -443,9 +445,13 @@ instance CanHardFork '[BlockA, BlockB] where hardForkChainSel = Tails.mk2 NoTiebreakerAcrossEras hardForkInjectTxs = InPairs.mk2 injectTx_AtoB - hardForkInjTxMeasure = \case - (Z (WrapTxMeasure x)) -> x - S (Z (WrapTxMeasure x)) -> x + hardForkInjTxMeasurePhase1 = \case + (Z (WrapTxMeasurePhase1 x)) -> x + S (Z (WrapTxMeasurePhase1 x)) -> x + + hardForkInjTxMeasurePhase2 = \case + (Z (WrapTxMeasurePhase2 x)) -> x + S (Z (WrapTxMeasurePhase2 x)) -> x versionN2N :: BlockNodeToNodeVersion TestBlock versionN2N = diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 2f6d1f4dea..7028bec6f3 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -402,10 +402,12 @@ instance LedgerSupportsMempool BlockA where mkMempoolApplyTxError = nothingMkMempoolApplyTxError instance TxLimits BlockA where - type TxMeasure BlockA = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 BlockA = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 BlockA = TrivialTxMeasurePhase2 txWireSize = const . fromIntegral $ (0 :: Int) - blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 $ 100 * 1024 -- arbitrary - txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow $ ByteSize32 $ 100 * 1024) TrivialTxMeasurePhase2 -- arbitrary + txMeasurePhase1 _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 newtype instance TxId (GenTx BlockA) = TxIdA Int deriving stock (Show, Eq, Ord, Generic) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 6e7401deca..3aa0908cc4 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -335,10 +335,12 @@ instance LedgerSupportsMempool BlockB where mkMempoolApplyTxError = nothingMkMempoolApplyTxError instance TxLimits BlockB where - type TxMeasure BlockB = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 BlockB = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 BlockB = TrivialTxMeasurePhase2 txWireSize = const . fromIntegral $ (0 :: Int) - blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 $ 100 * 1024 -- arbitrary - txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow $ ByteSize32 $ 100 * 1024) TrivialTxMeasurePhase2 -- arbitrary + txMeasurePhase1 _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 data instance TxId (GenTx BlockB) deriving stock (Show, Eq, Ord, Generic) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index e429d0b4cd..b810444892 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -19,8 +19,7 @@ import Control.Monad (void) import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.ResourceRegistry -import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (Tracer, nullTracer, traceWith, (>$<)) import Network.TypedProtocol.Codec ( ActiveState , AnyMessage diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index cbceade7af..491744990b 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -14,8 +14,9 @@ import Cardano.Network.NodeToNode.Version (NodeToNodeVersion) import Control.Exception (SomeException) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Tracer - ( Tracer (Tracer) + ( Tracer , contramap + , mkTracer , nullTracer , traceWith ) @@ -109,7 +110,7 @@ basicChainSyncClient chainSyncClient CSClient.ConfigEnv { CSClient.mkPipelineDecision0 = pipelineDecisionLowHighMark 10 20 - , CSClient.tracer = Tracer (traceWith tracer . TraceChainSyncClientEvent peerId) + , CSClient.tracer = mkTracer (traceWith tracer . TraceChainSyncClientEvent peerId) , CSClient.cfg , CSClient.chainDbView , CSClient.someHeaderInFutureCheck = dummyHeaderInFutureCheck @@ -194,7 +195,7 @@ runChainSyncClient res <- try $ runPipelinedPeerWithLimits - (Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Client") + (mkTracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Client") codecChainSyncId chainSyncNoSizeLimits (timeLimitsChainSync chainSyncTimeouts) @@ -270,4 +271,4 @@ runChainSyncServer tracer peerId StateViewTracers{svtPeerSimulatorResultsTracer} case fromException exn of (_ :: Maybe SomeException) -> pure () where - sendRecvTracer = Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Server" + sendRecvTracer = mkTracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Server" diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index 20b4147bb7..5eed3de7f8 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -15,7 +15,7 @@ module Test.Consensus.PeerSimulator.NodeLifecycle ) where import Control.ResourceRegistry -import Control.Tracer (Tracer (..), traceWith) +import Control.Tracer (Tracer, mkTracer, traceWith) import Data.Functor (void) import Data.Set (Set) import qualified Data.Set as Set @@ -154,7 +154,7 @@ mkChainDb resources = do chainDbArgs <- do let args = updateTracer - (Tracer (traceWith lrTracer . TraceChainDBEvent)) + (mkTracer (traceWith lrTracer . TraceChainDBEvent)) ( fromMinimalChainDbArgs MinimalChainDbArgs { mcdbTopLevelConfig = lrConfig diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 78e43cbe4f..eef1496169 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -14,7 +14,7 @@ import Control.Monad (foldM, forM, void, when) import Control.Monad.Class.MonadTime (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer, mkTracer, nullTracer, traceWith) import Data.Coerce (coerce) import Data.Foldable (for_) import Data.List (sort) @@ -524,7 +524,7 @@ startNode protocolInfo schedulerConfig genesisTest interval = do -- FIXME: This type of configuration should move to `Trace.mkTracer`. tracer = if scTrace schedulerConfig - then Tracer (\evt -> traceWith lrTracer evt >> traceWith svtTraceTracer evt) + then mkTracer (\evt -> traceWith lrTracer evt >> traceWith svtTraceTracer evt) else svtTraceTracer chainSyncTimeouts_ = @@ -643,7 +643,7 @@ runPointSchedule protocolInfoArgs schedulerConfig genesisTest tracer0 = lifecycle <- nodeLifecycle protocolInfoArgs schedulerConfig genesisTest tracer registry peerSim (chainDb, stateViewTracers) <- runScheduler - (Tracer $ traceWith tracer . TraceSchedulerEvent) + (mkTracer $ traceWith tracer . TraceSchedulerEvent) (cschcMap (psrHandles peerSim)) gtSchedule (psrPeers peerSim) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs index cb523d570f..802833d581 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs @@ -109,8 +109,8 @@ runScheduledBlockFetchServer ssPeerId ssTickStarted ssCurrentState tracer sbfsHa , ssTickStarted , ssCurrentState , ssCommonTracer = - Tracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId . TraceHandlerEventBF) + mkTracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId . TraceHandlerEventBF) } - , sbfsTracer = Tracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId) + , sbfsTracer = mkTracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId) , sbfsHandlers } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs index f52aaa5ffd..bee6ea439e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs @@ -12,7 +12,7 @@ module Test.Consensus.PeerSimulator.ScheduledChainSyncServer , runScheduledChainSyncServer ) where -import Control.Tracer (Tracer (Tracer), traceWith) +import Control.Tracer (Tracer, mkTracer, traceWith) import Ouroboros.Consensus.Block (Header) import Ouroboros.Consensus.Block.Abstract (Point (..)) import Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM)) @@ -159,8 +159,8 @@ runScheduledChainSyncServer ssPeerId ssTickStarted ssCurrentState tracer scssHan , ssTickStarted , ssCurrentState , ssCommonTracer = - Tracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId . TraceHandlerEventCS) + mkTracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId . TraceHandlerEventCS) } - , scssTracer = Tracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId) + , scssTracer = mkTracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId) , scssHandlers } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs index dbe4873066..166542d606 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs @@ -37,7 +37,7 @@ import Control.Monad.State.Strict , runState , state ) -import Control.Tracer (Tracer (Tracer), debugTracer, traceWith) +import Control.Tracer (Tracer, debugTracer, mkTracer, traceWith) import Data.Bifunctor (first) import Data.Foldable as Foldable (foldl', foldr') import Data.List (intersperse, mapAccumL, sort, transpose) @@ -963,11 +963,11 @@ peerSimStateDiagram = -- a block tree, highlighting the candidate fragments, selection, and forks in -- different colors, omitting uninteresting segments. peerSimStateDiagramTracer :: - (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => + (Monad m, AF.HasHeader blk, Eq (Header blk), GetHeader blk) => Tracer m String -> Tracer m (PeerSimState blk) peerSimStateDiagramTracer tracer = - Tracer (traceWith tracer . peerSimStateDiagram) + mkTracer (traceWith tracer . peerSimStateDiagram) -- | Construct a stateful tracer that prints the current peer simulator state in -- a block tree, highlighting the candidate fragments, selection, and forks in @@ -986,7 +986,7 @@ peerSimStateDiagramSTMTracer :: m (Tracer m ()) peerSimStateDiagramSTMTracer stringTracer pssBlockTree selectionVar candidatesVar pointsVar = do peerCache <- uncheckedNewTVarM mempty - pure $ Tracer $ const $ do + pure $ mkTracer $ const $ do (s, cachedPeers) <- atomically $ do pssSelection <- selectionVar pssCandidates <- candidatesVar diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs index 0fbb0ba758..fffc21029e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs @@ -23,8 +23,9 @@ module Test.Consensus.PeerSimulator.Trace ) where import Control.Tracer - ( Tracer (Tracer) + ( Tracer , contramap + , mkTracer , traceWith ) import Data.Bifunctor (second) @@ -219,7 +220,7 @@ tracerTestBlock tracer0 = do -- it behaves well in IO (where it prefixes all lines by the time). tickTimeVar <- uncheckedNewTVarM $ Time (-1) let setTickTime = atomically . writeTVar tickTimeVar - tracer = Tracer $ \msg -> do + tracer = mkTracer $ \msg -> do time <- getMonotonicTime tickTime <- readTVarIO tickTimeVar let timeHeader = prettyTime time ++ " " @@ -228,9 +229,10 @@ tracerTestBlock tracer0 = do then timeHeader else replicate (length timeHeader) ' ' traceWith tracer0 $ concat $ intersperse "\n" $ map (prefix ++) $ lines msg - pure $ Tracer $ traceEventTestBlockWith setTickTime tracer0 tracer + pure $ mkTracer $ traceEventTestBlockWith setTickTime tracer0 tracer mkGDDTracerTestBlock :: + Monad m => Tracer m (TraceEvent blk) -> Tracer m (TraceGDDEvent PeerId blk) mkGDDTracerTestBlock = contramap TraceGenesisDDEvent @@ -356,7 +358,7 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case ["(LookingForIntersection", terseJumpInfo goodJumpInfo, terseJumpInfo badJumpInfo, ")"] traceScheduledServerHandlerEventTestBlockWith :: - Condense (NodeState blk) => + (Monad m, Condense (NodeState blk)) => Tracer m String -> String -> TraceScheduledServerHandlerEvent (NodeState blk) blk -> @@ -376,7 +378,8 @@ traceScheduledServerHandlerEventTestBlockWith tracer unit = \case traceLines = traceUnitLinesWith tracer unit traceScheduledChainSyncServerEventTestBlockWith :: - ( Condense (NodeState blk) + ( Monad m + , Condense (NodeState blk) , Terse blk ) => Tracer m String -> @@ -420,7 +423,8 @@ traceScheduledChainSyncServerEventTestBlockWith tracer peerId = \case traceLines = traceUnitLinesWith tracer unit traceScheduledBlockFetchServerEventTestBlockWith :: - ( Condense (NodeState blk) + ( Monad m + , Condense (NodeState blk) , Terse blk ) => Tracer m String -> @@ -482,7 +486,8 @@ traceChainDBEventTestBlockWith tracer = \case traceChainSyncClientEventTestBlockWith :: forall blk m. - ( AF.HasHeader (Header blk) + ( Monad m + , AF.HasHeader (Header blk) , Terse blk , Typeable blk ) => @@ -545,6 +550,7 @@ terseJumpInfo :: terseJumpInfo ji = tersePoint @blk (castPoint $ headPoint $ jTheirFragment ji) traceChainSyncClientTerminationEventTestBlockWith :: + Monad m => PeerId -> Tracer m String -> TraceChainSyncClientTerminationEvent -> @@ -562,6 +568,7 @@ traceChainSyncClientTerminationEventTestBlockWith pid tracer = \case trace = traceUnitWith tracer ("ChainSyncClient " ++ condense pid) traceBlockFetchClientTerminationEventTestBlockWith :: + Monad m => PeerId -> Tracer m String -> TraceBlockFetchClientTerminationEvent -> @@ -576,7 +583,7 @@ traceBlockFetchClientTerminationEventTestBlockWith pid tracer = \case -- | Trace all the SendRecv events of the ChainSync mini-protocol. traceChainSyncSendRecvEventTestBlockWith :: - Applicative m => + Monad m => Terse blk => PeerId -> String -> @@ -605,6 +612,7 @@ traceChainSyncSendRecvEventTestBlockWith pid ptp tracer = \case MsgDone -> "MsgDone" traceDbjEventWith :: + Monad m => Tracer m String -> TraceEventDbf PeerId -> m () @@ -613,7 +621,7 @@ traceDbjEventWith tracer = RotatedDynamo old new -> "Rotated dynamo from " ++ condense old ++ " to " ++ condense new traceCsjEventWith :: - Terse blk => + (Monad m, Terse blk) => PeerId -> Tracer m String -> TraceEventCsj PeerId blk -> @@ -738,6 +746,7 @@ prettyTime (Time time) = in printf "%02d:%02d.%03d" minutes (seconds `rem` 60) (milliseconds `rem` 1_000) traceLinesWith :: + Monad m => Tracer m String -> [String] -> m () @@ -752,11 +761,11 @@ padUnit unit = unit ++ replicate (maxUnitLength - length unit) ' ' -- | Trace using the given tracer, printing the current time (typically the time -- of the simulation) and the unit name. -traceUnitLinesWith :: Tracer m String -> String -> [String] -> m () +traceUnitLinesWith :: Monad m => Tracer m String -> String -> [String] -> m () traceUnitLinesWith tracer unit msgs = traceLinesWith tracer $ map (printf "%s | %s" $ padUnit unit) msgs -- | Trace using the given tracer, printing the current time (typically the time -- of the simulation) and the unit name. -traceUnitWith :: Tracer m String -> String -> String -> m () +traceUnitWith :: Monad m => Tracer m String -> String -> String -> m () traceUnitWith tracer unit msg = traceUnitLinesWith tracer unit [msg] diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs index a455689110..80d2c4b662 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs @@ -109,13 +109,14 @@ prop_simple_bft_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoBft - numCoreNodes - nid - k - (HardFork.defaultEraParams k slotLength) - ) - (pure $ fmap (MkBlockForging . pure) $ blockForgingBft nid) + pure $ + plainTestNodeInitialization + ( protocolInfoBft + numCoreNodes + nid + k + (HardFork.defaultEraParams k slotLength) + ) + (pure $ fmap (MkBlockForging . pure) $ blockForgingBft nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs index 9dd2053a66..6ad45b593b 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs @@ -124,20 +124,21 @@ prop_simple_leader_schedule_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoPraosRule - numCoreNodes - nid - PraosParams - { praosSecurityParam = k - , praosSlotsPerEpoch = unEpochSize epochSize - , praosLeaderF = dummyF - } - (HardFork.defaultEraParams k slotLength) - schedule - emptyPraosEvolvingStake - ) - (pure $ fmap (MkBlockForging . pure) $ blockForgingPraosRule) + pure $ + plainTestNodeInitialization + ( protocolInfoPraosRule + numCoreNodes + nid + PraosParams + { praosSecurityParam = k + , praosSlotsPerEpoch = unEpochSize epochSize + , praosLeaderF = dummyF + } + (HardFork.defaultEraParams k slotLength) + schedule + emptyPraosEvolvingStake + ) + (pure $ fmap (MkBlockForging . pure) $ blockForgingPraosRule) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs index af003a923e..323b9a7b8d 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs @@ -123,12 +123,13 @@ prop_simple_pbft_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoMockPBFT - params - (HardFork.defaultEraParams k slotLength) - ) - (pure $ fmap (MkBlockForging . pure) $ blockForgingMockPBFT nid) + pure $ + plainTestNodeInitialization + ( protocolInfoMockPBFT + params + (HardFork.defaultEraParams k slotLength) + ) + (pure $ fmap (MkBlockForging . pure) $ blockForgingMockPBFT nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs index 4b78803da4..f3e4a00cba 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs @@ -159,19 +159,20 @@ prop_simple_praos_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoPraos - numCoreNodes - nid - params - ( HardFork.defaultEraParams - k - slotLength - ) - setupInitialNonce - evolvingStake - ) - (fmap (fmap (MkBlockForging . pure)) $ blockForgingPraos numCoreNodes nid) + pure $ + plainTestNodeInitialization + ( protocolInfoPraos + numCoreNodes + nid + params + ( HardFork.defaultEraParams + k + slotLength + ) + setupInitialNonce + evolvingStake + ) + (fmap (fmap (MkBlockForging . pure)) $ blockForgingPraos numCoreNodes nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 1089989945..dc1afd7f73 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -39,6 +39,7 @@ import qualified Cardano.Crypto.VRF as VRF import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce, (⭒)) import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Chain as SL +import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) import Cardano.Ledger.Hashes (HASH) import Cardano.Ledger.Keys ( DSIGN @@ -48,6 +49,7 @@ import Cardano.Ledger.Keys , hashKey ) import qualified Cardano.Ledger.Keys as SL +import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Slot (Duration (Duration), (+*)) import qualified Cardano.Ledger.State as SL import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) @@ -310,12 +312,12 @@ instance Serialise PraosState where [ CBOR.encodeListLen 8 , toCBOR praosStateLastSlot , toCBOR praosStateOCertCounters - , toCBOR praosStateEvolvingNonce - , toCBOR praosStateCandidateNonce - , toCBOR praosStateEpochNonce - , toCBOR praosStatePreviousEpochNonce - , toCBOR praosStateLabNonce - , toCBOR praosStateLastEpochBlockNonce + , toEraCBOR @ShelleyEra praosStateEvolvingNonce + , toEraCBOR @ShelleyEra praosStateCandidateNonce + , toEraCBOR @ShelleyEra praosStateEpochNonce + , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce + , toEraCBOR @ShelleyEra praosStateLabNonce + , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce ] decode = @@ -327,16 +329,16 @@ instance Serialise PraosState where PraosState <$> fromCBOR <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra data instance Ticked PraosState = TickedPraosState { tickedPraosStateChainDepState :: PraosState - , tickedPraosStateLedgerView :: Views.LedgerView + , tickedPraosStateLedgerView :: Views.PraosLedgerView } -- | Errors which we might encounter @@ -391,7 +393,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where type IsLeader (Praos c) = PraosIsLeader c type CanBeLeader (Praos c) = PraosCanBeLeader c type TiebreakerView (Praos c) = PraosTiebreakerView c - type LedgerView (Praos c) = Views.LedgerView + type LedgerView (Praos c) = Views.PraosLedgerView type ValidationErr (Praos c) = PraosValidationErr c type ValidateView (Praos c) = PraosValidateView c @@ -539,7 +541,7 @@ meetsLeaderThreshold :: Bool meetsLeaderThreshold PraosConfig{praosParams} - Views.LedgerView{Views.lvPoolDistr} + Views.PraosLedgerView{Views.plvPoolDistr} keyHash rho = checkLeaderNatValue @@ -547,7 +549,7 @@ meetsLeaderThreshold r (praosLeaderF praosParams) where - SL.PoolDistr poolDistr _totalActiveStake = lvPoolDistr + SL.PoolDistr poolDistr _totalActiveStake = plvPoolDistr r = maybe 0 SL.individualPoolStake $ Map.lookup keyHash poolDistr @@ -556,11 +558,11 @@ validateVRFSignature :: forall c. PraosCrypto c => Nonce -> - Views.LedgerView -> + Views.PraosLedgerView -> ActiveSlotCoeff -> Views.HeaderView c -> Except (PraosValidationErr c) () -validateVRFSignature eta0 (Views.lvPoolDistr -> SL.PoolDistr pd _) = +validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = doValidateVRFSignature eta0 pd -- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need @@ -609,9 +611,9 @@ validateKESSignature PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} _ei ) - Views.LedgerView{Views.lvPoolDistr = SL.PoolDistr lvPoolDistr _totalActiveStake} + Views.PraosLedgerView{Views.plvPoolDistr = SL.PoolDistr plvPoolDistr _totalActiveStake} ocertCounters = - doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod lvPoolDistr ocertCounters + doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod plvPoolDistr ocertCounters -- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to -- construct a 'PraosConfig' nor 'LedgerView' to test it. @@ -750,12 +752,12 @@ instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where -- - They share the same DSIGN verification keys -- - They share the same VRF verification keys instance TranslateProto (TPraos c) (Praos c) where - translateLedgerView _ SL.LedgerView{SL.lvPoolDistr, SL.lvChainChecks} = - Views.LedgerView - { Views.lvPoolDistr = lvPoolDistr - , Views.lvMaxHeaderSize = SL.ccMaxBHSize lvChainChecks - , Views.lvMaxBodySize = SL.ccMaxBBSize lvChainChecks - , Views.lvProtocolVersion = SL.ccProtocolVersion lvChainChecks + translateLedgerView _ SL.TPraosLedgerView{SL.tplvPoolDistr, SL.tplvChainChecks} = + Views.PraosLedgerView + { Views.plvPoolDistr = tplvPoolDistr + , Views.plvMaxHeaderSize = SL.ccMaxBHSize tplvChainChecks + , Views.plvMaxBodySize = SL.ccMaxBBSize tplvChainChecks + , Views.plvProtocolVersion = SL.ccProtocolVersion tplvChainChecks } translateChainDepState _ tpState = diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs index 8054799201..e35a6e6562 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -41,6 +44,8 @@ import Cardano.Ledger.Binary ( Annotator (..) , DecCBOR (decCBOR) , EncCBOR (..) + , ifDecoderVersionAtLeast + , natVersion , serialize' , unCBORGroup ) @@ -52,6 +57,8 @@ import Cardano.Ledger.Binary.Crypto , encodeVerKeyVRF ) import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Block (Block (..), EraBlockHeader (..)) +import Cardano.Ledger.Core (Era) import Cardano.Ledger.Hashes ( EraIndependentBlockBody , EraIndependentBlockHeader @@ -61,7 +68,7 @@ import Cardano.Ledger.Hashes , extractHash , originalBytesSize ) -import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) +import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey, hashKey) import Cardano.Ledger.MemoBytes ( Mem , MemoBytes @@ -78,6 +85,7 @@ import Cardano.Slotting.Block (BlockNo) import Cardano.Slotting.Slot (SlotNo) import Data.Word (Word32) import GHC.Generics (Generic) +import Lens.Micro (lens, to) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) @@ -202,18 +210,33 @@ instance Crypto crypto => EncCBOR (HeaderBody crypto) where instance Crypto crypto => DecCBOR (HeaderBody crypto) where decCBOR = - decode $ - RecD HeaderBody - decCBOR + <*> decCBOR + <*> decCBOR + <*> decCBOR + <*> decodeVerKeyVRF + <*> decCBOR + <*> decCBOR + <*> decCBOR + <*> decCBOR + <*> decCBOR encodeHeaderRaw :: Crypto crypto => @@ -237,3 +260,33 @@ deriving via Mem (HeaderRaw crypto) instance Crypto crypto => DecCBOR (Annotator (Header crypto)) + +instance (Crypto c, Era era) => EraBlockHeader (Header c) era where + blockIssuerBlockHeaderG = + to (\(Block (Header hb _) _) -> hashKey (hbVk hb)) + blockHeaderSizeBlockHeaderG = + to (\(Block hdr _) -> originalBytesSize hdr) + blockBodySizeBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbBodySize hb) + ( \(Block (Header hb sig) body) sz -> + Block (Header hb{hbBodySize = sz} sig) body + ) + blockBodyHashBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbBodyHash hb) + ( \(Block (Header hb sig) body) h -> + Block (Header hb{hbBodyHash = h} sig) body + ) + slotNoBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbSlotNo hb) + ( \(Block (Header hb sig) body) s -> + Block (Header hb{hbSlotNo = s} sig) body + ) + protVerBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbProtVer hb) + ( \(Block (Header hb sig) body) pv -> + Block (Header hb{hbProtVer = pv} sig) body + ) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 58fbb6dc65..fd9057d169 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -1,11 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Ouroboros.Consensus.Protocol.Praos.Views ( HeaderView (..) - , LedgerView (..) + , PraosLedgerView (..) + , forecastToPraosLedgerView ) where import Cardano.Crypto.KES (SignedKES) import Cardano.Crypto.VRF (CertifiedVRF, VRFAlgorithm (VerKeyVRF)) import Cardano.Ledger.BaseTypes (ProtVer) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (KES, VRF) @@ -13,6 +19,7 @@ import Cardano.Protocol.TPraos.BHeader (PrevHash) import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) import Data.Word (Word16, Word32) +import Lens.Micro ((^.)) import Ouroboros.Consensus.Protocol.Praos.Header (HeaderBody) import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) @@ -36,14 +43,30 @@ data HeaderView crypto = HeaderView -- ^ KES Signature of the header } -data LedgerView = LedgerView - { lvPoolDistr :: SL.PoolDistr +data PraosLedgerView = PraosLedgerView + { plvPoolDistr :: SL.PoolDistr -- ^ Stake distribution - , lvMaxHeaderSize :: !Word16 + , plvMaxHeaderSize :: !Word16 -- ^ Maximum header size - , lvMaxBodySize :: !Word32 + , plvMaxBodySize :: !Word32 -- ^ Maximum block body size - , lvProtocolVersion :: !ProtVer + , plvProtocolVersion :: !ProtVer -- ^ Current protocol version } deriving Show + +-- | Build a 'PraosLedgerView' from a ledger 'EraForecast' +forecastToPraosLedgerView :: + forall t era. + SL.EraForecast era => + SL.Forecast t era -> + PraosLedgerView +forecastToPraosLedgerView f = + PraosLedgerView + { plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , plvMaxHeaderSize = ccMaxBHSize cc + , plvMaxBodySize = ccMaxBBSize cc + , plvProtocolVersion = ccProtocolVersion cc + } + where + cc = SL.forecastChainChecks @t @era f diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index d86ff4279c..13543738c4 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -297,7 +297,7 @@ instance Serialise TPraosState where data instance Ticked TPraosState = TickedChainDepState { tickedTPraosStateChainDepState :: SL.ChainDepState - , tickedTPraosStateLedgerView :: SL.LedgerView + , tickedTPraosStateLedgerView :: SL.TPraosLedgerView } instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where @@ -305,7 +305,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where type IsLeader (TPraos c) = TPraosIsLeader c type CanBeLeader (TPraos c) = PraosCanBeLeader c type TiebreakerView (TPraos c) = PraosTiebreakerView c - type LedgerView (TPraos c) = SL.LedgerView + type LedgerView (TPraos c) = SL.TPraosLedgerView type ValidationErr (TPraos c) = SL.ChainTransitionError c type ValidateView (TPraos c) = TPraosValidateView c @@ -348,7 +348,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where where chainState = tickedTPraosStateChainDepState cs lv = tickedTPraosStateLedgerView cs - d = SL.lvD lv + d = SL.tplvD lv asc = tpraosLeaderF $ tpraosParams cfg firstSlot = firstSlotOfEpochOfSlot @@ -363,7 +363,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF y = VRF.evalCertified () y' praosCanBeLeaderSignKeyVRF - SL.GenDelegs dlgMap = SL.lvGenDelegs lv + SL.GenDelegs dlgMap = SL.tplvGenDelegs lv tickChainDepState cfg@TPraosConfig{..} @@ -435,7 +435,7 @@ meetsLeaderThreshold :: Bool meetsLeaderThreshold TPraosConfig{tpraosParams} - SL.LedgerView{lvPoolDistr} + SL.TPraosLedgerView{tplvPoolDistr} keyHash certNat = SL.checkLeaderValue @@ -443,7 +443,7 @@ meetsLeaderThreshold r (tpraosLeaderF tpraosParams) where - SL.PoolDistr poolDistr _totalActiveStake = lvPoolDistr + SL.PoolDistr poolDistr _totalActiveStake = tplvPoolDistr r = maybe 0 SL.individualPoolStake $ Map.lookup keyHash poolDistr diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 205c2fa3b2..1df3f4f4db 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -354,16 +354,16 @@ library binary >=0.8 && <0.11, bytestring >=0.10 && <0.13, cardano-binary, - cardano-crypto-class ^>=2.3, + cardano-crypto-class ^>=2.5, cardano-diffusion:api, - cardano-ledger-binary ^>=1.8, - cardano-ledger-core ^>=1.20, + cardano-ledger-binary ^>=1.9, + cardano-ledger-core ^>=1.21, cardano-prelude, cardano-slotting, cardano-strict-containers, cborg ^>=0.2.2, containers >=0.5 && <0.9, - contra-tracer ^>=0.1, + contra-tracer ^>=0.2.1, deepseq, FailT ^>=0.1.2, filelock, @@ -386,7 +386,7 @@ library semialign >=1.1, serialise ^>=0.2, singletons ^>=3, - small-steps ^>=1.1, + small-steps ^>=1.1 || ^>=1.2, sop-core ^>=0.5, sop-extras ^>=0.4.1, streaming, @@ -952,16 +952,17 @@ library protocol cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, - cardano-ledger-shelley ^>=1.18, - cardano-protocol-tpraos ^>=1.5, + cardano-ledger-shelley ^>=1.19, + cardano-protocol-tpraos ^>=1.6, cardano-slotting, cborg, containers, contra-tracer, io-classes, io-sim, - kes-agent ^>=1.2, - kes-agent-crypto ^>=1.1, + kes-agent ^>=1.3, + kes-agent-crypto ^>=1.2, + microlens, mtl, network ^>=3.2.7, nothunks, @@ -1343,6 +1344,7 @@ library cardano Ouroboros.Consensus.Shelley.Node.Serialisation Ouroboros.Consensus.Shelley.Node.TPraos Ouroboros.Consensus.Shelley.Protocol.Abstract + Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks Ouroboros.Consensus.Shelley.Protocol.Praos Ouroboros.Consensus.Shelley.Protocol.TPraos Ouroboros.Consensus.Shelley.ShelleyHFC @@ -1352,20 +1354,21 @@ library cardano base, base-deriving-via, bytestring, + cardano-base, cardano-binary, cardano-crypto, cardano-crypto-class:cardano-crypto-class, cardano-crypto-wrapper, - cardano-ledger-allegra ^>=1.9, - cardano-ledger-alonzo ^>=1.15, + cardano-ledger-allegra ^>=1.10, + cardano-ledger-alonzo ^>=1.16, cardano-ledger-api ^>=1.13, - cardano-ledger-babbage ^>=1.13, + cardano-ledger-babbage ^>=1.14, cardano-ledger-binary, cardano-ledger-byron ^>=1.3, - cardano-ledger-conway ^>=1.22, + cardano-ledger-conway ^>=1.23, cardano-ledger-core, - cardano-ledger-dijkstra ^>=0.2, - cardano-ledger-mary ^>=1.10, + cardano-ledger-dijkstra ^>=0.3, + cardano-ledger-mary ^>=1.11, cardano-ledger-shelley, cardano-prelude, cardano-protocol-tpraos, @@ -1377,6 +1380,7 @@ library cardano crypton, deepseq, formatting >=6.3 && <7.3, + fs-api, measures, mempack, microlens, @@ -1392,7 +1396,7 @@ library cardano strict-sop-core, text, these, - validation >=1.1.5, + validation >=1.2, library unstable-byronspec import: common-lib @@ -1523,13 +1527,11 @@ library unstable-shelley-testlib cardano-crypto-class, cardano-data, cardano-ledger-allegra:cardano-ledger-allegra, - cardano-ledger-alonzo-test, cardano-ledger-babbage:testlib, cardano-ledger-conway:testlib, cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-dijkstra:testlib, cardano-ledger-mary:cardano-ledger-mary, - cardano-ledger-shelley-ma-test, cardano-ledger-shelley-test, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, @@ -1537,6 +1539,7 @@ library unstable-shelley-testlib cardano-strict-containers, containers, contra-tracer, + fs-api, kes-agent, kes-agent-crypto, microlens, @@ -1577,6 +1580,8 @@ test-suite shelley-test containers, contra-tracer, filepath, + fs-api, + fs-sim, measures, mempack, microlens, @@ -1626,6 +1631,8 @@ library unstable-cardano-testlib cborg, containers, contra-tracer, + fs-api, + fs-sim, mempack, microlens, mtl, @@ -1685,6 +1692,8 @@ test-suite cardano-test contra-tracer, directory, filepath, + fs-api, + fs-sim, microlens, ouroboros-consensus:{cardano, ouroboros-consensus, protocol, unstable-cardano-testlib, unstable-consensus-testlib, unstable-diffusion-testlib, unstable-mempool-test-utils}, ouroboros-network:{api, protocols, protocols-tests-lib}, @@ -1708,8 +1717,6 @@ library unstable-cardano-tools visibility: public hs-source-dirs: ouroboros-consensus-cardano/src/unstable-cardano-tools exposed-modules: - Cardano.Api.Any - Cardano.Node.Types Cardano.Tools.DBAnalyser.Analysis Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.FileWriting Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.Metadata @@ -1723,7 +1730,6 @@ library unstable-cardano-tools Cardano.Tools.DBAnalyser.Types Cardano.Tools.DBImmutaliser.Run Cardano.Tools.DBSynthesizer.Forging - Cardano.Tools.DBSynthesizer.Orphans Cardano.Tools.DBSynthesizer.Run Cardano.Tools.DBSynthesizer.Types Cardano.Tools.DBTruncater.Run @@ -1733,26 +1739,11 @@ library unstable-cardano-tools Cardano.Tools.ImmDBServer.Diffusion Cardano.Tools.ImmDBServer.MiniProtocols - other-modules: - Cardano.Api.Key - Cardano.Api.KeysByron - Cardano.Api.KeysPraos - Cardano.Api.KeysShelley - Cardano.Api.OperationalCertificate - Cardano.Api.SerialiseTextEnvelope - Cardano.Api.SerialiseUsing - Cardano.Node.Protocol.Alonzo - Cardano.Node.Protocol.Byron - Cardano.Node.Protocol.Cardano - Cardano.Node.Protocol.Conway - Cardano.Node.Protocol.Shelley - build-depends: aeson, base, - base16-bytestring, bytestring, - cardano-crypto, + cardano-config, cardano-crypto-class, cardano-crypto-wrapper, cardano-diffusion:cardano-diffusion, @@ -1797,7 +1788,6 @@ library unstable-cardano-tools text, text-builder >=1, transformers, - transformers-except, executable db-analyser import: common-lib @@ -1841,20 +1831,6 @@ executable db-immutaliser ouroboros-consensus:unstable-cardano-tools, with-utf8, -executable db-synthesizer - import: common-exe - hs-source-dirs: ouroboros-consensus-cardano/app - main-is: db-synthesizer.hs - build-depends: - base, - cardano-crypto-class, - optparse-applicative, - ouroboros-consensus, - unstable-cardano-tools, - with-utf8, - - other-modules: DBSynthesizer.Parsers - executable db-truncater import: common-exe hs-source-dirs: ouroboros-consensus-cardano/app @@ -1938,7 +1914,8 @@ test-suite tools-test build-depends: aeson, base, - ouroboros-consensus:{cardano, ouroboros-consensus, unstable-cardano-tools, unstable-consensus-testlib, unstable-protocol-testlib}, + cardano-ledger-core, + ouroboros-consensus:{cardano, ouroboros-consensus, unstable-cardano-testlib, unstable-cardano-tools, unstable-consensus-testlib, unstable-protocol-testlib, unstable-shelley-testlib}, QuickCheck, tasty, tasty-hunit, diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs index c447c01390..be7e58180d 100644 --- a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs +++ b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs @@ -241,16 +241,18 @@ instance Ledger.LedgerSupportsMempool TestBlock where mkMempoolApplyTxError = Ledger.nothingMkMempoolApplyTxError instance Ledger.TxLimits TestBlock where - type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase1 TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase2 TestBlock = Ledger.TrivialTxMeasurePhase2 txWireSize = fromIntegral . Ledger.unByteSize32 . txSize -- We tweaked this in such a way that we test the case in which we exceed the -- maximum mempool capacity. The value used here depends on 'txInBlockSize'. blockCapacityTxMeasure _cfg _st = - Ledger.IgnoringOverflow $ Ledger.ByteSize32 20 + Ledger.TxMeasure (Ledger.IgnoringOverflow $ Ledger.ByteSize32 20) Ledger.TrivialTxMeasurePhase2 - txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize + txMeasurePhase1 _cfg _st = pure . Ledger.IgnoringOverflow . txSize + txMeasurePhase2 _cfg _st _tx = pure Ledger.TrivialTxMeasurePhase2 newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx deriving stock Generic diff --git a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs index 6c17a670ad..addd93cdf8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -62,7 +62,6 @@ import Data.ByteString (toStrict) import qualified Data.ByteString.Builder as BS import Data.ByteString.Char8 (readInt) import qualified Data.Foldable as Foldable -import Data.Functor.Contravariant ((>$<)) import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs index 6dadea7745..17a11caded 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs @@ -48,11 +48,13 @@ module Ouroboros.Consensus.Committee.Crypto.BLS import Cardano.Binary (FromCBOR, ToCBOR) import Cardano.Crypto.DSIGN ( BLS12381MinSigDSIGN - , BLS12381SignContext (..) + , BLS12381SignContext , DSIGNAggregatable (..) , DSIGNAlgorithm (..) , SigDSIGN (..) , VerKeyDSIGN (..) + , blsSignContextAug + , minSigPoPDST ) import Cardano.Crypto.EllipticCurve.BLS12_381 (blsIsInf, blsMSM) import qualified Cardano.Crypto.Hash as Hash @@ -171,42 +173,20 @@ newtype ProofOfPossession = ProofOfPossession deriving stock (Eq, Show) deriving newtype (FromCBOR, ToCBOR) --- TODO: get these contexts directly from @cardano-base@ after --- https://github.com/IntersectMBO/cardano-base/pull/635 --- is merged. - --- Basic over G1: --- https://www.ietf.org/archive/id/draft-irtf-cfrg-bls-signature-06.html#section-4.2.1-1 -minSigSignatureDST :: BLS12381SignContext -minSigSignatureDST = - BLS12381SignContext - { blsSignContextDst = Just "BLS_SIG_BLS12381G1_XMD:SHA-256_SSWU_RO_NUL_" - , blsSignContextAug = Nothing - } - --- PoP over G1: --- https://www.ietf.org/archive/id/draft-irtf-cfrg-bls-signature-06.html#section-4.2.3-1 -minSigPoPDST :: BLS12381SignContext -minSigPoPDST = - BLS12381SignContext - { blsSignContextDst = Just "BLS_SIG_BLS12381G1_XMD:SHA-256_SSWU_RO_POP_" - , blsSignContextAug = Nothing - } - -- | Role-separated BLS contexts for signatures class HasBLSContext (r :: KeyRole) where blsCtx :: Proxy r -> KeyScope -> BLS12381SignContext instance HasBLSContext SIGN where blsCtx _ keyScope = - minSigSignatureDST + minSigPoPDST { blsSignContextAug = Just ("VOTE:" <> keyScope <> ":V0") } instance HasBLSContext VRF where blsCtx _ keyScope = - minSigSignatureDST + minSigPoPDST { blsSignContextAug = Just ("VRF:" <> keyScope <> ":V0") } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index 7c514a81e0..7adba244bc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -32,11 +32,17 @@ class ( All SingleEraBlock xs , Typeable xs , IsNonEmpty xs - , Measure (HardForkTxMeasure xs) - , HasByteSize (HardForkTxMeasure xs) - , NoThunks (HardForkTxMeasure xs) - , Show (HardForkTxMeasure xs) - , TxMeasureMetrics (HardForkTxMeasure xs) + , -- \* Phase1 + Measure (HardForkTxMeasurePhase1 xs) + , HasByteSize (HardForkTxMeasurePhase1 xs) + , NoThunks (HardForkTxMeasurePhase1 xs) + , Show (HardForkTxMeasurePhase1 xs) + , TxMeasurePhase1Metrics (HardForkTxMeasurePhase1 xs) + , -- \* Phase2 + Measure (HardForkTxMeasurePhase2 xs) + , NoThunks (HardForkTxMeasurePhase2 xs) + , Show (HardForkTxMeasurePhase2 xs) + , TxMeasurePhase2Metrics (HardForkTxMeasurePhase2 xs) ) => CanHardFork xs where @@ -45,7 +51,9 @@ class -- Usually, this can simply be the union of the sets of components of each -- individual era's 'TxMeasure'. (Which is too awkward of a type to express -- in Haskell.) - type HardForkTxMeasure xs + type HardForkTxMeasurePhase1 xs + + type HardForkTxMeasurePhase2 xs hardForkEraTranslation :: EraTranslation xs hardForkChainSel :: Tails AcrossEraTiebreaker xs @@ -62,13 +70,17 @@ class -- If that's not possible, the result must not be too small, since this is -- relied upon to determine which prefix of the mempool's txs will fit in a -- valid block. - hardForkInjTxMeasure :: SOP.NS WrapTxMeasure xs -> HardForkTxMeasure xs + hardForkInjTxMeasurePhase1 :: SOP.NS WrapTxMeasurePhase1 xs -> HardForkTxMeasurePhase1 xs + + hardForkInjTxMeasurePhase2 :: SOP.NS WrapTxMeasurePhase2 xs -> HardForkTxMeasurePhase2 xs instance SingleEraBlock blk => CanHardFork '[blk] where - type HardForkTxMeasure '[blk] = TxMeasure blk + type HardForkTxMeasurePhase1 '[blk] = TxMeasurePhase1 blk + type HardForkTxMeasurePhase2 '[blk] = TxMeasurePhase2 blk hardForkEraTranslation = trivialEraTranslation hardForkChainSel = Tails.mk1 hardForkInjectTxs = InPairs.mk1 - hardForkInjTxMeasure (SOP.Z (WrapTxMeasure x)) = x + hardForkInjTxMeasurePhase1 (SOP.Z (WrapTxMeasurePhase1 x)) = x + hardForkInjTxMeasurePhase2 (SOP.Z (WrapTxMeasurePhase2 x)) = x diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs index 08d35dbbd8..4f8bbe648f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs @@ -320,7 +320,8 @@ instance K $ injectApplyTxErr idx <$> mkMempoolApplyTxError tlst txt instance CanHardFork xs => TxLimits (HardForkBlock xs) where - type TxMeasure (HardForkBlock xs) = HardForkTxMeasure xs + type TxMeasurePhase1 (HardForkBlock xs) = HardForkTxMeasurePhase1 xs + type TxMeasurePhase2 (HardForkBlock xs) = HardForkTxMeasurePhase2 xs txWireSize = \tx -> @@ -354,15 +355,63 @@ instance CanHardFork xs => TxLimits (HardForkBlock xs) where Index xs blk -> WrapPartialLedgerConfig blk -> FlipTickedLedgerState mk blk -> - K (HardForkTxMeasure xs) blk + K (TxMeasure (HardForkBlock xs)) blk aux idx pcfg st' = K $ - hardForkInjTxMeasure . injectNS idx . WrapTxMeasure $ - blockCapacityTxMeasure - (completeLedgerConfig' ei pcfg) - (getFlipTickedLedgerState st') + let TxMeasure p1 p2 = + blockCapacityTxMeasure + (completeLedgerConfig' ei pcfg) + (getFlipTickedLedgerState st') + in TxMeasure + (hardForkInjTxMeasurePhase1 . injectNS idx $ WrapTxMeasurePhase1 p1) + (hardForkInjTxMeasurePhase2 . injectNS idx $ WrapTxMeasurePhase2 p2) + + txMeasurePhase1 + HardForkLedgerConfig{..} + (TickedHardForkLedgerState transition hardForkState) + tx = + case matchTx injs (unwrapTx tx) hardForkState of + Left{} -> pure Measure.zero -- safe b/c the tx will be found invalid + Right pair -> hcollapse $ hcizipWith proxySingle aux cfgs pair + where + pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra + ei = + State.epochInfoPrecomputedTransitionInfo + hardForkLedgerConfigShape + transition + hardForkState + cfgs = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs + + unwrapTx = getOneEraGenTx . getHardForkGenTx + + injs :: InPairs (InjectPolyTx GenTx) xs + injs = + InPairs.hmap (\(Pair2 injTx _injValidatedTx) -> injTx) $ + InPairs.requiringBoth cfgs hardForkInjectTxs + + aux :: + forall blk. + SingleEraBlock blk => + Index xs blk -> + WrapLedgerConfig blk -> + (Product GenTx (FlipTickedLedgerState EmptyMK)) blk -> + K (Except (HardForkApplyTxErr xs) (HardForkTxMeasurePhase1 xs)) blk + aux idx cfg (Pair tx' st') = + K + $ mapExcept + ( ( HardForkApplyTxErrFromEra + . OneEraApplyTxErr + . injectNS idx + . WrapApplyTxErr + ) + +++ (hardForkInjTxMeasurePhase1 . injectNS idx . WrapTxMeasurePhase1) + ) + $ txMeasurePhase1 + (unwrapLedgerConfig cfg) + (getFlipTickedLedgerState st') + tx' - txMeasure + txMeasurePhase2 HardForkLedgerConfig{..} (TickedHardForkLedgerState transition hardForkState) tx = @@ -391,7 +440,7 @@ instance CanHardFork xs => TxLimits (HardForkBlock xs) where Index xs blk -> WrapLedgerConfig blk -> (Product GenTx (FlipTickedLedgerState ValuesMK)) blk -> - K (Except (HardForkApplyTxErr xs) (HardForkTxMeasure xs)) blk + K (Except (HardForkApplyTxErr xs) (HardForkTxMeasurePhase2 xs)) blk aux idx cfg (Pair tx' st') = K $ mapExcept @@ -400,9 +449,9 @@ instance CanHardFork xs => TxLimits (HardForkBlock xs) where . injectNS idx . WrapApplyTxErr ) - +++ (hardForkInjTxMeasure . injectNS idx . WrapTxMeasure) + +++ (hardForkInjTxMeasurePhase2 . injectNS idx . WrapTxMeasurePhase2) ) - $ txMeasure + $ txMeasurePhase2 (unwrapLedgerConfig cfg) (getFlipTickedLedgerState st') tx' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index 7755ab9662..e0991713eb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -733,18 +733,26 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where Just $ DualGenTxErr x y instance Bridge m a => TxLimits (DualBlock m a) where - type TxMeasure (DualBlock m a) = TxMeasure m + type TxMeasurePhase1 (DualBlock m a) = TxMeasurePhase1 m + type TxMeasurePhase2 (DualBlock m a) = TxMeasurePhase2 m txWireSize = txWireSize . dualGenTxMain - txMeasure DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = + txMeasurePhase1 DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = do mapExcept (inj +++ id) - $ txMeasure dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain + $ txMeasurePhase1 dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain + where + inj m = DualGenTxErr m (error "ByronSpec has no tx-too-big error") + txMeasurePhase2 DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = + do + mapExcept (inj +++ id) + $ txMeasurePhase2 dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain where inj m = DualGenTxErr m (error "ByronSpec has no tx-too-big error") blockCapacityTxMeasure DualLedgerConfig{..} TickedDualLedgerState{..} = - blockCapacityTxMeasure dualLedgerConfigMain tickedDualLedgerStateMain + let TxMeasure a b = blockCapacityTxMeasure dualLedgerConfigMain tickedDualLedgerStateMain + in TxMeasure a b -- We don't need a pair of IDs, as long as we can unique ID the transaction newtype instance TxId (GenTx (DualBlock m a)) = DualGenTxId diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs index cff4102366..2061930913 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -1,13 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Ledger.SupportsMempool ( ApplyTxErr @@ -26,7 +30,10 @@ module Ouroboros.Consensus.Ledger.SupportsMempool , ReapplyTxsResult (..) , TxId , TxLimits (..) - , TxMeasureMetrics (..) + , TxMeasure (..) + , TxMeasurePhase1Metrics (..) + , TxMeasurePhase2Metrics (..) + , TrivialTxMeasurePhase2 (..) , Validated , WhetherToIntervene (..) , nothingMkMempoolApplyTxError @@ -41,9 +48,10 @@ import Data.DerivingVia (InstantiatedAt (..)) import qualified Data.Foldable as Foldable import Data.Kind (Type) import Data.Measure (Measure) -import qualified Data.Measure +import qualified Data.Measure as M import Data.Text (Text) import Data.Word (Word32) +import GHC.Generics import GHC.Stack (HasCallStack) import NoThunks.Class import Numeric.Natural @@ -305,6 +313,48 @@ class HasTxs blk where Tx sizes -------------------------------------------------------------------------------} +data TxMeasure blk = TxMeasure + { tmPhase1 :: !(TxMeasurePhase1 blk) + , tmPhase2 :: !(TxMeasurePhase2 blk) + } + deriving Generic + +deriving instance (Eq (TxMeasurePhase1 blk), Eq (TxMeasurePhase2 blk)) => Eq (TxMeasure blk) + +deriving instance (Show (TxMeasurePhase1 blk), Show (TxMeasurePhase2 blk)) => Show (TxMeasure blk) + +deriving via + InstantiatedAt Generic (TxMeasure blk) + instance + (Measure (TxMeasurePhase1 blk), Measure (TxMeasurePhase2 blk)) => + Measure (TxMeasure blk) + +instance HasByteSize (TxMeasurePhase1 blk) => HasByteSize (TxMeasure blk) where + txMeasureByteSize = txMeasureByteSize . tmPhase1 + +instance (NoThunks (TxMeasurePhase1 blk), NoThunks (TxMeasurePhase2 blk)) => NoThunks (TxMeasure blk) + +instance TxMeasurePhase1Metrics (TxMeasurePhase1 blk) => TxMeasurePhase1Metrics (TxMeasure blk) where + txMeasureMetricTxSizeBytes (TxMeasure a _) = txMeasureMetricTxSizeBytes a + txMeasureMetricExUnitsMemory (TxMeasure a _) = txMeasureMetricExUnitsMemory a + txMeasureMetricExUnitsSteps (TxMeasure a _) = txMeasureMetricExUnitsSteps a + +instance TxMeasurePhase2Metrics (TxMeasurePhase2 blk) => TxMeasurePhase2Metrics (TxMeasure blk) where + txMeasureMetricRefScriptsSizeBytes (TxMeasure _ b) = txMeasureMetricRefScriptsSizeBytes b + +data TrivialTxMeasurePhase2 = TrivialTxMeasurePhase2 + deriving (Eq, Show, Generic) + deriving anyclass NoThunks + +instance Measure TrivialTxMeasurePhase2 where + zero = TrivialTxMeasurePhase2 + plus _ _ = TrivialTxMeasurePhase2 + max _ _ = TrivialTxMeasurePhase2 + min _ _ = TrivialTxMeasurePhase2 + +instance TxMeasurePhase2Metrics TrivialTxMeasurePhase2 where + txMeasureMetricRefScriptsSizeBytes _ = mempty + -- | Each block has its limits of how many transactions it can hold. That limit -- is compared against the sum of measurements taken of each of the -- transactions in that block. @@ -319,16 +369,24 @@ class HasTxs blk where -- execution units). For details please see the individual instances for the -- TxLimits. class - ( Measure (TxMeasure blk) - , HasByteSize (TxMeasure blk) - , NoThunks (TxMeasure blk) - , TxMeasureMetrics (TxMeasure blk) - , Show (TxMeasure blk) + ( -- \* Phase 1 + Measure (TxMeasurePhase1 blk) + , HasByteSize (TxMeasurePhase1 blk) + , NoThunks (TxMeasurePhase1 blk) + , TxMeasurePhase1Metrics (TxMeasurePhase1 blk) + , Show (TxMeasurePhase1 blk) + , -- \* Phase 2 + Measure (TxMeasurePhase2 blk) + , NoThunks (TxMeasurePhase2 blk) + , TxMeasurePhase2Metrics (TxMeasurePhase2 blk) + , Show (TxMeasurePhase2 blk) ) => TxLimits blk where -- | The (possibly multi-dimensional) size of a transaction in a block. - type TxMeasure blk + type TxMeasurePhase1 blk + + type TxMeasurePhase2 blk -- | The size of the transaction from the perspective of diffusion layer txWireSize :: GenTx blk -> Network.SizeInBytes @@ -362,14 +420,23 @@ class -- -- Returns an exception if and only if the transaction violates the per-tx -- limits. - txMeasure :: + txMeasurePhase1 :: + -- | used at least by HFC's composition logic + LedgerConfig blk -> + -- | This state needs values as a transaction measure might depend on + -- those. For example in Cardano they look at the reference scripts. + TickedLedgerState blk EmptyMK -> + GenTx blk -> + Except (ApplyTxErr blk) (TxMeasurePhase1 blk) + + txMeasurePhase2 :: -- | used at least by HFC's composition logic LedgerConfig blk -> -- | This state needs values as a transaction measure might depend on -- those. For example in Cardano they look at the reference scripts. TickedLedgerState blk ValuesMK -> GenTx blk -> - Except (ApplyTxErr blk) (TxMeasure blk) + Except (ApplyTxErr blk) (TxMeasurePhase2 blk) -- | What is the allowed capacity for the txs in an individual block? blockCapacityTxMeasure :: @@ -428,7 +495,7 @@ newtype IgnoringOverflow a = IgnoringOverflow {unIgnoringOverflow :: a} deriving newtype (Monoid, Semigroup) deriving newtype NoThunks deriving newtype HasByteSize - deriving newtype TxMeasureMetrics + deriving newtype TxMeasurePhase1Metrics instance Measure (IgnoringOverflow ByteSize32) where zero = coerce (0 :: Word32) @@ -443,17 +510,21 @@ class HasByteSize a where instance HasByteSize ByteSize32 where txMeasureByteSize = id -class TxMeasureMetrics msr where +class TxMeasurePhase1Metrics msr where txMeasureMetricTxSizeBytes :: msr -> ByteSize32 txMeasureMetricExUnitsMemory :: msr -> Natural txMeasureMetricExUnitsSteps :: msr -> Natural + +class TxMeasurePhase2Metrics msr where txMeasureMetricRefScriptsSizeBytes :: msr -> ByteSize32 -instance TxMeasureMetrics ByteSize32 where +instance TxMeasurePhase2Metrics () where + txMeasureMetricRefScriptsSizeBytes () = mempty + +instance TxMeasurePhase1Metrics ByteSize32 where txMeasureMetricTxSizeBytes = id txMeasureMetricExUnitsMemory _ = 0 txMeasureMetricExUnitsSteps _ = 0 - txMeasureMetricRefScriptsSizeBytes _ = mempty -- | A transaction that was previously valid. Used to clarify the types on the -- 'reapplyTxs' function. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs index f80457bdec..48f4ab477e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -495,10 +496,12 @@ instance Measure (TxMeasure blk) => Measure (TxMeasureWithDiffTime blk) where instance HasByteSize (TxMeasure blk) => HasByteSize (TxMeasureWithDiffTime blk) where txMeasureByteSize = txMeasureByteSize . forgetTxMeasureWithDiffTime -instance TxMeasureMetrics (TxMeasure blk) => TxMeasureMetrics (TxMeasureWithDiffTime blk) where +instance TxMeasurePhase1Metrics (TxMeasure blk) => TxMeasurePhase1Metrics (TxMeasureWithDiffTime blk) where txMeasureMetricTxSizeBytes = txMeasureMetricTxSizeBytes . forgetTxMeasureWithDiffTime txMeasureMetricExUnitsMemory = txMeasureMetricExUnitsMemory . forgetTxMeasureWithDiffTime txMeasureMetricExUnitsSteps = txMeasureMetricExUnitsSteps . forgetTxMeasureWithDiffTime + +instance TxMeasurePhase2Metrics (TxMeasure blk) => TxMeasurePhase2Metrics (TxMeasureWithDiffTime blk) where txMeasureMetricRefScriptsSizeBytes = txMeasureMetricRefScriptsSizeBytes . forgetTxMeasureWithDiffTime -- | How long it took to validate a valid tx diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index bfcec21e3f..f00da78485 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -175,7 +175,8 @@ deriving instance , NoThunks (TickedLedgerState blk DiffMK) , NoThunks (TxIn blk) , NoThunks (TxOut blk) - , NoThunks (TxMeasure blk) + , NoThunks (TxMeasurePhase1 blk) + , NoThunks (TxMeasurePhase2 blk) , StandardHash blk , Typeable blk ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs index f441e1b73d..3bfff57ad3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs @@ -17,7 +17,6 @@ import Control.Monad.Class.MonadTimer.SI (MonadTimer, timeout) import Control.Monad.Except (runExcept) import Control.Tracer import qualified Data.Foldable as Foldable -import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import qualified Data.List.NonEmpty as NE @@ -28,7 +27,7 @@ import qualified Data.Text as T import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) +import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.Capacity import Ouroboros.Consensus.Mempool.Impl.Common @@ -204,86 +203,116 @@ doAddTx mpEnv caller wti tx = do Just prevSize -> check $ isMempoolSize is /= prevSize eRes <- withTMVarAnd istate additionalCheck $ - \is () -> do - frkr <- readMVar forker - tbs <- roforkerReadTables frkr (getTransactionKeySets tx) - before <- getMonotonicTime - mbX <- do - let f m = case mbToCfg of - Nothing -> Just <$> m - Just toCfg -> timeout (mempoolTimeoutHard toCfg) m - f $ do - x <- evaluate $ pureTryAddTx mpEnv cfg wti tx is tbs - case (caller, x) of - (TestingAddTx testDiffTime, Processed{}) -> do - after <- getMonotonicTime - let sofar = after `diffTime` before - threadDelay $ testDiffTime - min testDiffTime sofar - -- Note that @sofar == 0@ always and this 'threadDelay' would - -- be perfectly precise in the @IOSim@ monad. Unfortunately, - -- the state machines tests are still only in IO. - _ -> pure () - pure x - dur <- do - -- Note that both the hard 'timeout' and the soft duration check use - -- the actual monotonic clock measurements instead of simply - -- deferring to 'TestingAddTx'. This means the test will fail if the - -- 'timeout' and the monotonic clock measurement primitives are not - -- as precise as the test expects (recall that the test suite chooses - -- intended validation times that are not "too close" to the - -- thresholds). - after <- getMonotonicTime - pure $ after `diffTime` before - let rejectBecauseOfTimeoutSoft txerr = do - let outcome = - TransactionProcessingResult + \is () -> + case runExcept $ txMeasurePhase1 cfg (forgetLedgerTables $ isLedgerState is) tx of + Left err -> + -- The transaction does not have a valid measure (eg its ExUnits is + -- greater than what this ledger state allows for a single transaction). + pure + ( Right + ( TransactionProcessingResult Nothing - (MempoolTxRejected tx txerr) - $ TraceMempoolRejectedTx - tx - txerr - (MempoolRejectedByTimeoutSoft dur) - (isMempoolSize is) - pure (Right outcome, is) - mbTimeoutSoftTxErr = - -- This @txerr@ is not available in historical Cardano eras, but - -- it is starting from Conway. So this rejection will be disabled - -- prior to Conway. Which is irrelevant, since mainnet is already - -- in Conway. - let txt = T.pack $ "MempoolTxTooSlow (" <> show dur <> ") " <> show (txId tx) - in mkMempoolApplyTxError (isLedgerState is) txt - case mbX of - Nothing -> case (wti, mbTimeoutSoftTxErr) of - (Intervene, Just txerr) -> do - rejectBecauseOfTimeoutSoft txerr - _ -> do - -- Either they're not a local client or the era doesn't allow for - -- soft rejections. - throwIO $ MkExnMempoolTimeout dur tx - Just _ - | Just toCfg <- mbToCfg - , dur > mempoolTimeoutSoft toCfg - , Just txerr <- mbTimeoutSoftTxErr -> do - rejectBecauseOfTimeoutSoft txerr - Just NotEnoughSpaceLeft -> do - pure (Left (isMempoolSize is), is) - Just (NotProcessed outcome) -> do - let TransactionProcessingResult is' _ _ = outcome - pure (Right outcome, fromMaybe is is') - Just (Processed mkResult) -> do - let outcome = mkResult $ FiniteDiffTimeMeasure $ case caller of - ProductionAddTx -> dur - TestingAddTx testDiffTime -> - -- For the sake of an accurate cumulative measure, pretend - -- the tx took exactly as long to validate as the test - -- suite intended. - -- - -- Note that @testDiffTime == dur@ always in @IOSim@. - -- Unfortunately, the state machines tests are still only - -- in IO. - testDiffTime - TransactionProcessingResult is' _ _ = outcome - pure (Right outcome, fromMaybe is is') + (MempoolTxRejected tx err) + ( TraceMempoolRejectedTx + tx + err + MempoolRejectedByLedger + (isMempoolSize is) + ) + ) + , is + ) + Right txsz1 + | let currentSize = TxSeq.toSize (isTxs is) + , not $ + currentSize + Measure.<= currentSize + `Measure.plus` MkTxMeasureWithDiffTime (TxMeasure txsz1 Measure.zero) Measure.zero -> + pure (Left (isMempoolSize is), is) + | let currentSize = TxSeq.toSize (isTxs is) + , let MkTxMeasureWithDiffTime txssz _txsdifftime = currentSize + , not $ txssz `Measure.plus` (TxMeasure txsz1 Measure.zero) Measure.<= isCapacity is -> + pure (Left (isMempoolSize is), is) + | otherwise -> do + frkr <- readMVar forker + tbs <- roforkerReadTables frkr (getTransactionKeySets tx) + before <- getMonotonicTime + mbX <- do + let f m = case mbToCfg of + Nothing -> Just <$> m + Just toCfg -> timeout (mempoolTimeoutHard toCfg) m + f $ do + x <- evaluate $ pureTryAddTx mpEnv cfg wti tx is tbs txsz1 + case (caller, x) of + (TestingAddTx testDiffTime, Processed{}) -> do + after <- getMonotonicTime + let sofar = after `diffTime` before + threadDelay $ testDiffTime - min testDiffTime sofar + -- Note that @sofar == 0@ always and this 'threadDelay' would + -- be perfectly precise in the @IOSim@ monad. Unfortunately, + -- the state machines tests are still only in IO. + _ -> pure () + pure x + dur <- do + -- Note that both the hard 'timeout' and the soft duration check use + -- the actual monotonic clock measurements instead of simply + -- deferring to 'TestingAddTx'. This means the test will fail if the + -- 'timeout' and the monotonic clock measurement primitives are not + -- as precise as the test expects (recall that the test suite chooses + -- intended validation times that are not "too close" to the + -- thresholds). + after <- getMonotonicTime + pure $ after `diffTime` before + let rejectBecauseOfTimeoutSoft txerr = do + let outcome = + TransactionProcessingResult + Nothing + (MempoolTxRejected tx txerr) + $ TraceMempoolRejectedTx + tx + txerr + (MempoolRejectedByTimeoutSoft dur) + (isMempoolSize is) + pure (Right outcome, is) + mbTimeoutSoftTxErr = + -- This @txerr@ is not available in historical Cardano eras, but + -- it is starting from Conway. So this rejection will be disabled + -- prior to Conway. Which is irrelevant, since mainnet is already + -- in Conway. + let txt = T.pack $ "MempoolTxTooSlow (" <> show dur <> ") " <> show (txId tx) + in mkMempoolApplyTxError (isLedgerState is) txt + case mbX of + Nothing -> case (wti, mbTimeoutSoftTxErr) of + (Intervene, Just txerr) -> do + rejectBecauseOfTimeoutSoft txerr + _ -> do + -- Either they're not a local client or the era doesn't allow for + -- soft rejections. + throwIO $ MkExnMempoolTimeout dur tx + Just _ + | Just toCfg <- mbToCfg + , dur > mempoolTimeoutSoft toCfg + , Just txerr <- mbTimeoutSoftTxErr -> do + rejectBecauseOfTimeoutSoft txerr + Just NotEnoughSpaceLeft -> do + pure (Left (isMempoolSize is), is) + Just (NotProcessed outcome) -> do + let TransactionProcessingResult is' _ _ = outcome + pure (Right outcome, fromMaybe is is') + Just (Processed mkResult) -> do + let outcome = mkResult $ FiniteDiffTimeMeasure $ case caller of + ProductionAddTx -> dur + TestingAddTx testDiffTime -> + -- For the sake of an accurate cumulative measure, pretend + -- the tx took exactly as long to validate as the test + -- suite intended. + -- + -- Note that @testDiffTime == dur@ always in @IOSim@. + -- Unfortunately, the state machines tests are still only + -- in IO. + testDiffTime + TransactionProcessingResult is' _ _ = outcome + pure (Right outcome, fromMaybe is is') case (caller, eRes) of (ProductionAddTx, _) -> either (doAddTx' . Just) (pure . Identity) eRes (TestingAddTx _, Left _) -> pure Nothing @@ -302,8 +331,9 @@ pureTryAddTx :: -- | The current internal state of the mempool. InternalState blk -> LedgerTables blk ValuesMK -> + TxMeasurePhase1 blk -> TriedToAddTx blk -pureTryAddTx mpEnv cfg wti tx is values = +pureTryAddTx mpEnv cfg wti tx is values p1TxMeasure = let MempoolEnv { mpEnvTimeoutConfig = mbToCfg } = mpEnv @@ -313,7 +343,7 @@ pureTryAddTx mpEnv cfg wti tx is values = values (getTransactionKeySets tx) (isLedgerState is) - in case runExcept $ txMeasure cfg st tx of + in case runExcept $ txMeasurePhase2 cfg st tx of Left err -> -- The transaction does not have a valid measure (eg its ExUnits is -- greater than what this ledger state allows for a single transaction). @@ -348,7 +378,10 @@ pureTryAddTx mpEnv cfg wti tx is values = -- 'isCapacity' are much smaller than the modulus, and so this should -- never happen. Despite that, blocking until adding the transaction -- doesn't overflow seems like a reasonable way to handle this case. - | not $ currentSize Measure.<= currentSize `Measure.plus` MkTxMeasureWithDiffTime txsz Measure.zero -> + | not $ + currentSize + Measure.<= currentSize + `Measure.plus` MkTxMeasureWithDiffTime (TxMeasure p1TxMeasure txsz) Measure.zero -> NotEnoughSpaceLeft -- We add the transaction if and only if it wouldn't overrun any component -- of the mempool capacity. @@ -385,14 +418,14 @@ pureTryAddTx mpEnv cfg wti tx is values = -- tx that wouldn't even fit in an empty mempool would be rejected by -- 'txMeasure'. | let MkTxMeasureWithDiffTime txssz _txsdifftime = currentSize - , not $ txssz `Measure.plus` txsz Measure.<= isCapacity is -> + , not $ txssz `Measure.plus` (TxMeasure p1TxMeasure txsz) Measure.<= isCapacity is -> NotEnoughSpaceLeft | Just toCfg <- mbToCfg , let MkTxMeasureWithDiffTime _txssz txsdifftime = currentSize , not $ txsdifftime Measure.<= FiniteDiffTimeMeasure (mempoolTimeoutCapacity toCfg) -> NotEnoughSpaceLeft | otherwise -> - case validateNewTransaction cfg wti tx txsz values st is of + case validateNewTransaction cfg wti tx (TxMeasure p1TxMeasure txsz) values st is of (Left err, _) -> Processed $ \_dur -> TransactionProcessingResult diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs index 48dbbffd75..ce008f0d7d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs @@ -106,7 +106,7 @@ localTxMonitorServer mempool = tno (_a, b, _c) = b :: TicketNo mkMeasuresMap :: - TxMeasureMetrics (TxMeasure blk) => + (TxMeasurePhase1Metrics (TxMeasurePhase1 blk), TxMeasurePhase2Metrics (TxMeasurePhase2 blk)) => Proxy blk -> TxMeasure blk -> TxMeasure blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index f7ef29105f..a78974d6a9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -48,7 +48,6 @@ import Control.ResourceRegistry ) import Control.Tracer import Data.Functor ((<&>)) -import Data.Functor.Contravariant ((>$<)) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) import GHC.Stack (HasCallStack) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 3828af1bf8..af2c216c17 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -16,9 +16,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ) where import Control.ResourceRegistry (ResourceRegistry) -import Control.Tracer (Tracer, nullTracer) +import Control.Tracer (Tracer, nullTracer, (>$<)) import Data.Function ((&)) -import Data.Functor.Contravariant ((>$<)) import Data.Kind import Data.Time.Clock (secondsToDiffTime) import Ouroboros.Consensus.Block @@ -241,6 +240,7 @@ completeChainDbArgs } updateTracer :: + Monad m => Tracer m (TraceEvent blk) -> ChainDbArgs f m blk -> ChainDbArgs f m blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index c81520ac0e..b63f86a1a6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -621,4 +621,4 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) where - starvationTracer = Tracer $ traceWith cdbTracer . TraceChainSelStarvationEvent + starvationTracer = mkTracer $ traceWith cdbTracer . TraceChainSelStarvationEvent diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index e77b1d68ac..30499356d1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -35,10 +35,9 @@ import Control.Monad.Except () import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Control.Monad.Trans.State.Strict -import Control.Tracer (Tracer, nullTracer, traceWith) +import Control.Tracer (Tracer, nullTracer, traceWith, (>$<)) import Data.Bifunctor (first) import Data.Function (on) -import Data.Functor.Contravariant ((>$<)) import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs index 6ce87b0cb6..ebaad5463d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs @@ -225,7 +225,7 @@ data IteratorEnv m blk = IteratorEnv } -- | Obtain an 'IteratorEnv' from a 'ChainDbEnv'. -fromChainDbEnv :: ChainDbEnv m blk -> IteratorEnv m blk +fromChainDbEnv :: Monad m => ChainDbEnv m blk -> IteratorEnv m blk fromChainDbEnv CDB{..} = IteratorEnv { itImmutableDB = cdbImmutableDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index c96f284bed..3d5b271e7f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -165,7 +165,7 @@ data ImmutableDbArgs f m blk = ImmutableDbArgs -- only the most recent chunk? -- | Default arguments -defaultArgs :: Applicative m => Incomplete ImmutableDbArgs m blk +defaultArgs :: Monad m => Incomplete ImmutableDbArgs m blk defaultArgs = ImmutableDbArgs { immCacheConfig = cacheConfig diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index a43b34d77a..c88b01f9d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -17,7 +17,7 @@ module Ouroboros.Consensus.Storage.LedgerDB import Control.Monad.Trans.Class import Control.ResourceRegistry -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer ((>$<)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index 89f9430636..070dc632a8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -226,7 +226,6 @@ import Codec.Serialise import Control.Monad.Except import Control.Tracer import Data.ByteString (ByteString) -import Data.Functor.Contravariant ((>$<)) import Data.Kind import Data.List.NonEmpty (NonEmpty) import Data.MemPack @@ -708,6 +707,7 @@ data TraceReplayEvent blk -- | Add the tip of the Immutable DB to the trace event decorateReplayTracerWithGoal :: + Monad m => -- | Tip of the ImmutableDB Point blk -> Tracer m (TraceReplayProgressEvent blk) -> @@ -716,6 +716,7 @@ decorateReplayTracerWithGoal immTip = (($ ReplayGoal immTip) >$<) -- | Add the block at which a replay started. decorateReplayTracerWithStart :: + Monad m => -- | Starting point of the replay Point blk -> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk) -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs index 3536bc5681..2a99cea7f6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs @@ -62,7 +62,7 @@ data LedgerDbArgs f m blk = LedgerDbArgs -- | Default arguments defaultArgs :: - Applicative m => + Monad m => V2.SomeBackendArgs m blk -> Incomplete LedgerDbArgs m blk defaultArgs backendArgs = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index 20aca78c5c..938ccb925c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -23,7 +23,6 @@ import Data.Bifunctor (first) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (for_) import qualified Data.Foldable as Foldable -import Data.Functor.Contravariant ((>$<)) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs index e21cb1e623..6ed1f8fa04 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs @@ -22,7 +22,6 @@ import Control.Exception import Control.Monad (when) import Control.RAWLock (RAWLock, withWriteAccess) import Control.Tracer -import Data.Functor.Contravariant ((>$<)) import Data.Maybe (fromMaybe) import GHC.Generics import Ouroboros.Consensus.Block diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index cab8fc5997..aa5b2d6b6f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -38,7 +38,6 @@ import Control.Tracer import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) -import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity import qualified Data.List as List import qualified Data.Map.Strict as Map diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 2a859ffd57..7bf1426f66 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -123,7 +123,7 @@ data PerasCertDbArgs f m blk = PerasCertDbArgs { pcdbaTracer :: Tracer m (TraceEvent blk) } -defaultArgs :: Applicative m => Incomplete PerasCertDbArgs m blk +defaultArgs :: Monad m => Incomplete PerasCertDbArgs m blk defaultArgs = PerasCertDbArgs { pcdbaTracer = nullTracer diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 7f5fce1611..0dec8d0703 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -127,7 +127,7 @@ data PerasVoteDbArgs f m blk = PerasVoteDbArgs , pvdbaPerasCfg :: HKD f (PerasCfg blk) } -defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk +defaultArgs :: Monad m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index 25453618e9..99838dbcbb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -177,7 +177,7 @@ data VolatileDbArgs f m blk = VolatileDbArgs -- corrupt/invalid block? -- | Default arguments -defaultArgs :: Applicative m => Incomplete VolatileDbArgs m blk +defaultArgs :: Monad m => Incomplete VolatileDbArgs m blk defaultArgs = VolatileDbArgs { volCheckIntegrity = noDefault diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs index dc958e806c..2266b26ed8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs @@ -23,7 +23,8 @@ module Ouroboros.Consensus.TypeFamilyWrappers , WrapTentativeHeaderView (..) , WrapTipInfo (..) , WrapTxIn (..) - , WrapTxMeasure (..) + , WrapTxMeasurePhase1 (..) + , WrapTxMeasurePhase2 (..) , WrapTxOut (..) , WrapValidatedGenTx (..) @@ -88,7 +89,8 @@ newtype WrapTipInfo blk = WrapTipInfo {unwrapTipInfo :: TipInfo blk} -- wrappers in this module. newtype WrapValidatedGenTx blk = WrapValidatedGenTx {unwrapValidatedGenTx :: Validated (GenTx blk)} -newtype WrapTxMeasure blk = WrapTxMeasure {unwrapTxMeasure :: TxMeasure blk} +newtype WrapTxMeasurePhase1 blk = WrapTxMeasurePhase1 {unwrapTxMeasurePhase1 :: TxMeasurePhase1 blk} +newtype WrapTxMeasurePhase2 blk = WrapTxMeasurePhase2 {unwrapTxMeasurePhase2 :: TxMeasurePhase2 blk} newtype WrapTxIn blk = WrapTxIn {unwrapTxIn :: TxIn blk} newtype WrapTxOut blk = WrapTxOut {unwrapTxOut :: TxOut blk} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs index fa12f77a1d..0ef5f86522 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs @@ -85,7 +85,7 @@ pattern FallingEdge = FallingEdgeWith () -- pure (input + 5) -- :} encloseWith :: - Applicative m => + Monad m => Tracer m Enclosing -> m a -> m a diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 6dcef59082..8d7d0832ea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -24,8 +24,7 @@ import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors import Data.Typeable (Typeable) import NoThunks.Class - ( InspectHeap (..) - , InspectHeapNamed (..) + ( InspectHeapNamed (..) , NoThunks (..) , OnlyCheckWhnf (..) , OnlyCheckWhnfNamed (..) @@ -33,7 +32,7 @@ import NoThunks.Class ) import Ouroboros.Network.Util.ShowProxy import System.FS.API (SomeHasFS) -import System.FS.API.Types (FsPath, Handle) +import System.FS.API.Types (Handle) import System.FS.CRC (CRC (CRC)) import System.Random (StdGen) import qualified System.Random.Internal as Random @@ -97,7 +96,6 @@ instance NoThunks StdGen where fs-api -------------------------------------------------------------------------------} -deriving via InspectHeap FsPath instance NoThunks FsPath deriving newtype instance NoThunks CRC deriving via InspectHeapNamed "Handle" (Handle h) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs index 88b5695a3d..895fe3072b 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs @@ -8,6 +8,7 @@ module Test.Util.Orphans.NoThunks () where +import Cardano.Ledger.Orphans () import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict @@ -19,7 +20,6 @@ import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util.MonadSTM.StrictSVar import qualified Ouroboros.Consensus.Util.NormalForm.StrictMVar as NormalForm import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as NormalForm -import System.FS.API.Types import System.FS.Sim.FsTree import System.FS.Sim.MockFS @@ -53,7 +53,6 @@ instance NoThunks a => NoThunks (NormalForm.StrictTVar (IOSim s) a) where fs-sim -------------------------------------------------------------------------------} -deriving instance NoThunks FsPath deriving instance NoThunks MockFS deriving instance NoThunks a => NoThunks (FsTree a) deriving instance NoThunks HandleMock diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs index b68055e190..c873c409f4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs @@ -55,7 +55,6 @@ import Ouroboros.Consensus.Ledger.Query , blockQueryIsSupportedOnVersion , nodeToClientVersionToQueryVersion ) -import Ouroboros.Consensus.Ledger.Tables (valuesMKEncoder) import Ouroboros.Consensus.Node.NetworkProtocolVersion ( HasNetworkProtocolVersion (..) , SupportedNetworkProtocolVersion (..) @@ -223,34 +222,6 @@ goldenTests testName examples enc goldenFolder mCDDL labels :: [Maybe String] labels = map fst examples -goldenTests' :: - HasCallStack => - TestName -> - Labelled (a, a -> Encoding) -> - -- | Folder containing the golden files - FilePath -> - Maybe (FilePath, T.Text) -> - TestTree -goldenTests' testName examples goldenFolder mCDDL - | nub labels /= labels = - error $ "Examples with the same label for " <> testName - | [(Nothing, (example, exampleEncoder))] <- examples = - -- If there's just a single unlabelled example, no need for grouping, - -- which makes the output more verbose. - goldenTestCBOR testName example exampleEncoder (goldenFolder testName) mCDDL - | otherwise = - testGroup - testName - [ goldenTestCBOR testName' example exampleEncoder (goldenFolder testName') mCDDL - | (mbLabel, (example, exampleEncoder)) <- examples - , let testName' = case mbLabel of - Nothing -> testName - Just label -> testName <> "_" <> label - ] - where - labels :: [Maybe String] - labels = map fst examples - {------------------------------------------------------------------------------- Skeletons -------------------------------------------------------------------------------} @@ -322,7 +293,6 @@ goldenTest_SerialiseDisk codecConfig goldenDir Examples{..} = , test "AnnTip" exampleAnnTip (encodeDisk codecConfig) , test "ChainDepState" exampleChainDepState (encodeDisk codecConfig) , test "ExtLedgerState" exampleExtLedgerState encodeExt - , testLedgerTables ] where test :: TestName -> Labelled a -> (a -> Encoding) -> TestTree @@ -334,18 +304,6 @@ goldenTest_SerialiseDisk codecConfig goldenDir Examples{..} = (goldenDir "disk") Nothing - testLedgerTables :: TestTree - testLedgerTables = - goldenTests' - "LedgerTables" - ( zipWith - (\(lbl, tbs) (_, st) -> (lbl, (tbs, valuesMKEncoder st))) - exampleLedgerTables - exampleLedgerState - ) - (goldenDir "disk") - Nothing - encodeExt = encodeDiskExtLedgerState codecConfig -- TODO how can we ensure that we have a test for each constraint listed in diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs index 3dbbf33c2d..9929522715 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs @@ -18,7 +18,7 @@ recordingTracerIORef :: IO (Tracer IO ev, IO [ev]) recordingTracerIORef = newIORef [] >>= \ref -> return - ( Tracer $ \ev -> atomicModifyIORef' ref $ \evs -> (ev : evs, ()) + ( mkTracer $ \ev -> atomicModifyIORef' ref $ \evs -> (ev : evs, ()) , reverse <$> readIORef ref ) @@ -29,7 +29,7 @@ recordingTracerTVar :: MonadSTM m => m (Tracer m ev, m [ev]) recordingTracerTVar = uncheckedNewTVarM [] >>= \ref -> return - ( Tracer $ \ev -> atomically $ modifyTVar ref (ev :) + ( mkTracer $ \ev -> atomically $ modifyTVar ref (ev :) , atomically $ reverse <$> readTVar ref ) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index 288c72bb32..09ac25cf0e 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -625,7 +625,8 @@ instance mkMempoolApplyTxError _tls txt = Just $ MockMempoolError txt instance TxLimits (SimpleBlock c ext) where - type TxMeasure (SimpleBlock c ext) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (SimpleBlock c ext) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (SimpleBlock c ext) = TrivialTxMeasurePhase2 txWireSize = fromIntegral . unByteSize32 . genTxSize @@ -633,13 +634,15 @@ instance TxLimits (SimpleBlock c ext) where -- don't override it. -- -- But not 'maxbound'!, since the mempool sometimes holds multiple blocks worth. - blockCapacityTxMeasure _cfg _st = IgnoringOverflow simpleBlockCapacity + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow simpleBlockCapacity) TrivialTxMeasurePhase2 - txMeasure cfg _st = + txMeasurePhase1 cfg _st = fmap IgnoringOverflow . checkTxSize (simpleLedgerMockConfig cfg) . simpleGenTx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + simpleBlockCapacity :: ByteSize32 simpleBlockCapacity = ByteSize32 512 diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index f28edd2f18..ae651cff8a 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -35,7 +35,7 @@ import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.Except (runExcept) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.State (State, evalState, get, modify) -import Control.Tracer (Tracer (..)) +import Control.Tracer (mkTracer) import Data.Bifunctor (first, second) import Data.Either (isRight) import Data.Functor ((<&>)) @@ -234,7 +234,8 @@ prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempoolToRemove testSetup tx prop_Mempool_getCapacity :: MempoolCapTestSetup -> Property prop_Mempool_getCapacity mcts = withTestMempool testSetup $ \TestMempool{mempool} -> do - IgnoringOverflow actualCapacity <- atomically $ getCapacity mempool + TxMeasure (IgnoringOverflow actualCapacity) TrivialTxMeasurePhase2 <- + atomically $ getCapacity mempool pure $ actualCapacity === expectedCapacity where MempoolCapacityBytesOverride testCapacity = testMempoolCapOverride testSetup @@ -544,10 +545,11 @@ instance Arbitrary TestSetupWithTxs where } let mempoolCap :: TheMeasure mempoolCap = - computeMempoolCapacity - testLedgerConfigNoSizeLimits - (TickedSimpleLedgerState ledger) - (testMempoolCapOverride testSetup') + tmPhase1 $ + computeMempoolCapacity + testLedgerConfigNoSizeLimits + (TickedSimpleLedgerState ledger) + (testMempoolCapOverride testSetup') largeInvalidTx <- genLargeInvalidTx mempoolCap let txs' = (largeInvalidTx, False) : txs @@ -754,7 +756,7 @@ withTestMempoolWithTimeoutConfig timeoutConfig setup@TestSetup{..} prop = -- Set up the Tracer varEvents <- uncheckedNewTVarM [] -- TODO use IOSim's dynamicTracer - let tracer = Tracer $ \ev -> atomically $ modifyTVar varEvents (ev :) + let tracer = mkTracer $ \ev -> atomically $ modifyTVar varEvents (ev :) -- Open the mempool and add the initial transactions mempool <- diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs index d4764439c1..442d25daf3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs @@ -120,15 +120,17 @@ instance Ledger.LedgerSupportsMempool TestBlock where mkMempoolApplyTxError = Ledger.nothingMkMempoolApplyTxError instance Ledger.TxLimits TestBlock where - type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase1 TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase2 TestBlock = Ledger.TrivialTxMeasurePhase2 txWireSize = fromIntegral . Ledger.unByteSize32 . txSize . unGenTx blockCapacityTxMeasure _cfg _st = -- The tests will override this value. By using 1, @computeMempoolCapacity@ -- can be exactly what each test requests. - Ledger.IgnoringOverflow $ Ledger.ByteSize32 1 + Ledger.TxMeasure (Ledger.IgnoringOverflow $ Ledger.ByteSize32 1) Ledger.TrivialTxMeasurePhase2 - txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize . unGenTx + txMeasurePhase1 _cfg _st = pure . Ledger.IgnoringOverflow . txSize . unGenTx + txMeasurePhase2 _cfg _st _tx = pure Ledger.TrivialTxMeasurePhase2 {------------------------------------------------------------------------------- Ledger support (empty tables) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 42cfbd37b2..d097dc43c8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -28,8 +28,8 @@ import Cardano.Slotting.Slot import Control.Arrow (second) import Control.Concurrent.Class.MonadSTM.Strict.TChan import Control.Monad.Class.MonadTimer.SI (MonadTimer) -import Control.Monad.Except (runExcept) -import qualified Control.Tracer as CT (Tracer (..), traceWith) +import Control.Monad.Except (Except, runExcept) +import qualified Control.Tracer as CT (Tracer, mkTracer, traceWith) import qualified Data.Foldable as Foldable import Data.Function (on) import qualified Data.Map.Strict as Map @@ -442,7 +442,7 @@ foldTxs cfg nextTk capacity initialFilled initialState = let slot = case getTipSlot st of Origin -> minimumPossibleSlotNo (Proxy @blk) At v -> v + 1 - in case runExcept $ (,) <$> txMeasure cfg st tx <*> applyTx cfg DoNotIntervene slot tx st of + in case runExcept $ (,) <$> txMeasureFull cfg st tx <*> applyTx cfg DoNotIntervene slot tx st of Left{} -> go ( acc @@ -474,6 +474,17 @@ foldTxs cfg nextTk capacity initialFilled initialState = ) next +txMeasureFull :: + LedgerSupportsMempool blk => + LedgerConfig blk -> + TickedLedgerState blk ValuesMK -> + GenTx blk -> + Except (ApplyTxErr blk) (TxMeasure blk) +txMeasureFull cfg st tx = + TxMeasure + <$> txMeasurePhase1 cfg (forgetLedgerTables st) tx + <*> txMeasurePhase2 cfg st tx + tick :: ( ValidateEnvelope blk , LedgerSupportsMempool blk @@ -570,16 +581,16 @@ mkSUT cfg initialLedger = do (lif, t) <- newLedgerInterface initialLedger trcrChan <- atomically newTChan :: m (StrictTChan m (Either String (TraceEventMempool blk))) let trcr = - CT.Tracer $ -- Dbg.traceShowM @(Either String (TraceEventMempool blk)) + CT.mkTracer $ -- Dbg.traceShowM @(Either String (TraceEventMempool blk)) atomically . writeTChan trcrChan mempool <- openMempoolWithoutSyncThread lif cfg - (MempoolCapacityBytesOverride $ unIgnoringOverflow txMaxBytes') + (MempoolCapacityBytesOverride $ unIgnoringOverflow $ tmPhase1 txMaxBytes') (Nothing :: Maybe MempoolTimeoutConfig) - (CT.Tracer $ CT.traceWith trcr . Right) - pure (SUT mempool t, CT.Tracer $ atomically . writeTChan trcrChan . Left) + (CT.mkTracer $ CT.traceWith trcr . Right) + pure (SUT mempool t, CT.mkTracer $ atomically . writeTChan trcrChan . Left) semantics :: ( LedgerSupportsMempool blk @@ -822,8 +833,8 @@ tests = -- | The 'TestBlock' txMaxBytes is fixed to a very high number. We use this -- local declaration to have a mempool that sometimes fill but still don't make -- it configurable. -txMaxBytes' :: IgnoringOverflow ByteSize32 -txMaxBytes' = IgnoringOverflow $ ByteSize32 maxBound +txMaxBytes' :: TxMeasure TestBlock +txMaxBytes' = TxMeasure (IgnoringOverflow $ ByteSize32 maxBound) TrivialTxMeasurePhase2 instance (StandardHash blk, GetTip (LedgerState blk)) => diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index 2a84ff4ea4..0b7494efbc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -30,7 +30,7 @@ import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.IOSim (runSimOrThrow) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer, mkTracer, nullTracer, traceWith) import Data.Bifunctor (first) import Data.Hashable (Hashable) import Data.Map.Strict (Map) @@ -197,7 +197,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do blockFetchTracer :: Tracer m (PeerRole, Driver.TraceSendRecv (BlockFetch TestBlock (Point TestBlock))) - blockFetchTracer = Tracer \case + blockFetchTracer = mkTracer \case (AsClient, ev) -> do atomically case ev of Driver.TraceRecvMsg (AnyMessage (MsgBlock _)) -> @@ -311,7 +311,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB pure BlockFetchClientInterface.ChainDbView{..} where - cdbTracer = Tracer \case + cdbTracer = mkTracer \case ChainDBImpl.TraceAddBlockEvent ev -> traceWith tracer $ "ChainDB: " <> show ev _ -> pure () diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index a5cbbdbffb..d00da3af23 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -23,7 +23,7 @@ import Cardano.Ledger.BaseTypes (nonZero) import Control.Monad (forever) import Control.Monad.IOSim (runSimOrThrow) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), contramapM, traceWith) +import Control.Tracer (Tracer, contramapM, mkTracer, traceWith) import Data.Foldable (for_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -128,7 +128,7 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist (withTime -> tracer, getTrace) <- recordingTracerTVar - let chainDBTracer = Tracer \case + let chainDBTracer = mkTracer \case ChainDBImpl.TraceAddBlockEvent ev -> do traceWith tracer $ "ChainDB: " <> show ev case ev of diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs index badc675dd7..009ce7474d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs @@ -185,7 +185,7 @@ runAddBlocks lgrDbBackendArgs testSetup = withRegistry \registry -> do pure (chainDB, LedgerDB.lgrHasFS $ ChainDB.cdbLgrDbArgs chainDbArgs) isSnapshottingTracer :: StrictTMVar m () -> Tracer m (ChainDB.TraceEvent TestBlock) - isSnapshottingTracer tmvar = Tracer \case + isSnapshottingTracer tmvar = mkTracer \case ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent (SnapshotRequestDelayed _ _ _)) -> atomically $ putTMVar tmvar () ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent SnapshotRequestCompleted) -> @@ -411,7 +411,7 @@ runTest lgrDbBackendArgs testSetup = withRegistry \registry -> do withTime = contramapM \ev -> (,ev) <$> getMonotonicTime isSnapshottingTracer :: StrictTMVar m () -> Tracer m (ChainDB.TraceEvent TestBlock) - isSnapshottingTracer tmvar = Tracer \case + isSnapshottingTracer tmvar = mkTracer \case ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent (SnapshotRequestDelayed _ _ _)) -> atomically $ putTMVar tmvar () ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent SnapshotRequestCompleted) -> diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs index cf078ad55c..7bd923092d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs @@ -35,8 +35,7 @@ import qualified Control.Monad as Monad import Control.Monad.Except import Control.Monad.State hiding (state) import Control.ResourceRegistry -import Control.Tracer (Tracer (..)) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (Tracer, mkTracer, (>$<)) import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) @@ -705,7 +704,7 @@ newtype NumOpenHandles = NumOpenHandles Word64 mkTrackOpenHandles :: IO (Tracer IO (TraceEvent TestBlock), IO NumOpenHandles) mkTrackOpenHandles = do varOpen <- uncheckedNewTVarM (NumOpenHandles 0) - let tracer = Tracer $ \case + let tracer = mkTracer $ \case LedgerDBFlavorImplEvent (FlavorImplSpecificTraceV2 ev) -> atomically $ modifyTVar varOpen $ case ev of V2.TraceLedgerTablesHandleCreate FallingEdgeWith{} -> succ