From 976be12bdf74326738e6d7382cf1ef8bbbbe14c9 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Sun, 3 Apr 2022 04:13:41 +0300 Subject: [PATCH 01/11] Update dependencies --- .github/bin/check-git-dependencies | 6 +- .github/master-check-exceptions.list | 2 + .github/workflows/haskell.yml | 57 +++++ cabal.project | 58 +++-- cardano-chain-gen/cardano-chain-gen.cabal | 7 +- .../src/Cardano/Mock/Forging/Crypto.hs | 38 ++++ .../src/Cardano/Mock/Forging/Interpreter.hs | 1 + .../src/Cardano/Mock/Forging/Tx/Alonzo.hs | 15 +- .../Mock/Forging/Tx/Alonzo/ScriptsExamples.hs | 12 +- .../src/Cardano/Mock/Forging/Tx/Generic.hs | 20 +- .../src/Cardano/Mock/Forging/Tx/Shelley.hs | 7 + .../test/Test/Cardano/Db/Mock/Unit.hs | 11 +- .../testfiles/config/test-db-sync-config.json | 4 +- cardano-db-sync/src/Cardano/DbSync/Default.hs | 6 +- .../DbSync/Era/Shelley/Generic/EpochUpdate.hs | 2 +- .../DbSync/Era/Shelley/Generic/Metadata.hs | 3 +- .../Era/Shelley/Generic/ParamProposal.hs | 2 +- .../DbSync/Era/Shelley/Generic/ProtoParams.hs | 2 +- .../DbSync/Era/Shelley/Generic/Rewards.hs | 2 +- .../DbSync/Era/Shelley/Generic/StakeDist.hs | 2 +- .../Cardano/DbSync/Era/Shelley/Generic/Tx.hs | 8 +- .../DbSync/Era/Shelley/Generic/Util.hs | 12 - .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 7 +- .../src/Cardano/DbSync/Era/Shelley/Query.hs | 7 +- .../src/Cardano/DbSync/LedgerEvent.hs | 42 +++- .../src/Cardano/DbSync/LedgerState.hs | 2 +- .../Cardano/DbSync/Tracing/ToObjectOrphans.hs | 6 +- cardano-db-tool/cardano-db-tool.cabal | 1 + .../src/Cardano/DbTool/Validate/Balance.hs | 9 +- .../src/Cardano/SMASH/Server/Types.hs | 2 +- flake.lock | 205 +++++++++++++++--- flake.nix | 12 +- nix/haskell.nix | 1 - schema/migration-2-0011-20220322.sql | 21 -- 34 files changed, 439 insertions(+), 153 deletions(-) create mode 100644 .github/master-check-exceptions.list create mode 100644 cardano-chain-gen/src/Cardano/Mock/Forging/Crypto.hs delete mode 100644 schema/migration-2-0011-20220322.sql diff --git a/.github/bin/check-git-dependencies b/.github/bin/check-git-dependencies index 0a2299525..9c0190245 100755 --- a/.github/bin/check-git-dependencies +++ b/.github/bin/check-git-dependencies @@ -23,8 +23,7 @@ commits () { done } -cat cabal.project | \ - grep '\(^source-repository-package\|^ *location:\|^ *tag:\)' | sed 's|^source-repository-package|-|g' | \ +grep '\(^source-repository-package\|^ *location:\|^ *tag:\)' cabal.project | sed 's|^source-repository-package|-|g' | \ yq eval -P -j \ > tmp/repositories.json @@ -33,6 +32,9 @@ for row in $(cat tmp/repositories.json | jq -r '.[] | @base64'); do location="$(echo "$json" | jq -r .location)" tag="$(echo "$json" | jq -r .tag)" + if fgrep <<<$location -f .github/master-check-exceptions.list > /dev/null + then echo "${YELLOW}check-git-dependencies: skipping location from master check: ${RED}$location${NC}"; continue; fi + rm -f tmp/tmp-dep-repo-result rm -rf tmp/dep-repo echo "$location" diff --git a/.github/master-check-exceptions.list b/.github/master-check-exceptions.list new file mode 100644 index 000000000..c4d4174d4 --- /dev/null +++ b/.github/master-check-exceptions.list @@ -0,0 +1,2 @@ +vshabanov/ekg-json +input-output-hk/iohk-monitoring-framework diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index e5f95c5ed..5c33a9af8 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -102,6 +102,63 @@ jobs: sudo apt-get -y remove --purge software-properties-common sudo apt-get -y autoremove + - name: Install secp256k1 (Linux) + if: matrix.os == 'ubuntu-latest' + run: | + sudo apt-get -y install autoconf automake libtool + mkdir secp256k1-sources + cd secp256k1-sources + git clone https://github.com/bitcoin-core/secp256k1.git + cd secp256k1 + git reset --hard $SECP256K1_REF + ./autogen.sh + ./configure --prefix=/usr --enable-module-schnorrsig --enable-experimental + make + make check + sudo make install + cd ../.. + + - name: Install secp256k1 (MacOS) + if: matrix.os == 'macos-latest' || matrix.os == 'macos-11' + run: | + brew install autoconf automake libtool + mkdir secp256k1-sources + cd secp256k1-sources + git clone https://github.com/bitcoin-core/secp256k1.git + cd secp256k1 + git reset --hard $SECP256K1_REF + ./autogen.sh + ./configure --enable-module-schnorrsig --enable-experimental + make + make check + make install + + - name: Install secp256k1 (Windows) + if: matrix.os == 'windows-latest' + env: + RUNNER_TEMP: ${{ runner.temp }} + run: | + echo "RUNNER_TEMP=$RUNNER_TEMP" + cd "$RUNNER_TEMP" + RUNNER_TEMP_FWD="$(echo "$RUNNER_TEMP" | sed 's|\\|/|g')" + curl -Ls \ + --connect-timeout 5 \ + --max-time 10 \ + --retry 5 \ + --retry-delay 0 \ + --retry-max-time 40 \ + https://hydra.iohk.io/job/Cardano/haskell-nix/windows-secp256k1/latest/download/1 -o secp256k1.zip + mkdir secp256k1 + cd secp256k1 + unzip ../secp256k1.zip + cd .. + export PKG_CONFIG_PATH="$PKG_CONFIG_PATH;$(readlink -f secp256k1/lib/pkgconfig | sed 's|^/d|D:|g' | tr / '\\')" + echo "PKG_CONFIG_PATH=$PKG_CONFIG_PATH" + echo "PKG_CONFIG_PATH=$PKG_CONFIG_PATH" >> $GITHUB_ENV + export SECP256K1_PATH="$(readlink -f secp256k1/bin | sed 's|^/d|D:|g' | tr / '\\')" + echo "SECP256K1_PATH=$SECP256K1_PATH" + echo "$SECP256K1_PATH" >> $GITHUB_PATH + - name: Cabal update run: cabal update diff --git a/cabal.project b/cabal.project index 8a5adf0ba..c045c3da8 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -index-state: 2021-12-13T00:00:00Z +index-state: 2022-02-18T00:00:00Z packages: cardano-db @@ -10,6 +10,7 @@ packages: constraints: libsystemd-journal >= 1.4.4 + , bimap >= 0.4.0 , systemd >= 2.3.0 -- systemd-2.3.0 requires at least network 3.1.1.0 but it doesn't declare -- that dependency @@ -31,6 +32,11 @@ package cardano-smash-server package postgresql-libpq flags: +use-pkg-config +package cryptonite + -- Using RDRAND instead of /dev/urandom as an entropy source for key + -- generation is dubious. Set the flag so we use /dev/urandom by default. + flags: -support_rdrand + -- --------------------------------------------------------- -- Disable all tests by default @@ -66,6 +72,7 @@ package io-classes tests: False allow-newer: + *:aeson, monoidal-containers:aeson, size-based:template-haskell @@ -83,23 +90,30 @@ source-repository-package tag: 7497a29cb998721a9068d5725d49461f2bba0e7a --sha256: 1gvsrg925vynwgqwplgjmp53vj953qyh3wbdf34pw21c8r47w35r +source-repository-package + type: git + location: https://github.com/vshabanov/ekg-json + tag: 00ebe7211c981686e65730b7144fbf5350462608 + --sha256: 1zvjm3pb38w0ijig5wk5mdkzcszpmlp5d4zxvks2jk1rkypi8gsm + source-repository-package type: git location: https://github.com/input-output-hk/hedgehog-extras - tag: edf6945007177a638fbeb8802397f3a6f4e47c14 - --sha256: 0wc7qzkc7j4ns2rz562h6qrx2f8xyq7yjcb7zidnj7f6j0pcd0i9 + tag: 967d79533c21e33387d0227a5f6cc185203fe658 + --sha256: 0rbqb7a64aya1qizlr3im06hdydg9zr6sl3i8bvqqlf7kpa647sd source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: 41545ba3ac6b3095966316a99883d678b5ab8da8 - --sha256: 0icq9y3nnl42fz536da84414av36g37894qnyw4rk3qkalksqwir + tag: 394c4637c24d82325bd04ceb99c8e8df5617e663 + --sha256: 02q8y69za5b0vsnj9qga1364vkmfc1kh35d0yshw1lf7nw9bls8m subdir: base-deriving-via binary binary/test cardano-crypto-class cardano-crypto-praos + cardano-crypto-tests measures orphans-deriving-via slotting @@ -114,11 +128,12 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger - tag: 1a9ec4ae9e0b09d54e49b2a40c4ead37edadcce5 - --sha256: 0avzyiqq0m8njd41ck9kpn992yq676b1az9xs77977h7cf85y4wm + tag: 1db68a3ec0a2dcb5751004beb22b906162474f23 + --sha256: 03pv2jvskbi65dwaddp6a8bxbbcw674csjxhg8xbqd6q1kfpc41a subdir: eras/alonzo/impl -- eras/alonzo/test-suite + eras/babbage/impl eras/byron/chain/executable-spec eras/byron/crypto eras/byron/crypto/test @@ -126,7 +141,6 @@ source-repository-package eras/byron/ledger/impl eras/byron/ledger/impl/test eras/shelley/impl - eras/shelley/test-suite eras/shelley-ma/impl -- eras/shelley-ma/test-suite libs/cardano-ledger-core @@ -143,14 +157,13 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-node - tag: 5d8d9513f22beb0addc32634fdc8f4c9eeff3662 - --sha256: 112m8mxcpb7jl16cqdv2dw0vn1jfqj7swva8wlgw7q08gmcic0zq + tag: e757b88926dfc958303c5a6edfac83a0a49490f3 + --sha256: 1bwaz909f3lpgd40yy296jrcpfm0irk2j7nqcswgc1xkr77fy6iy subdir: cardano-api cardano-cli cardano-git-rev cardano-node - plutus-example trace-dispatcher trace-forward trace-resources @@ -173,8 +186,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/iohk-monitoring-framework - tag: 808724ff8a19a33d0ed06f9ef59fbd900b08553c - --sha256: 0298dpl29gxzs9as9ha6y0w18hqwc00ipa3hzkxv7nlfrjjz8hmz + tag: eb7854d1337637b8672af1227b276aa33a658f47 + --sha256: 1ll81hlhkhj96f5v6lswjkq2h8f7zcmdrj2azqhi4ylzafn026r3 subdir: contra-tracer iohk-monitoring @@ -194,14 +207,15 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: 4fac197b6f0d2ff60dc3486c593b68dc00969fbf - --sha256: 1b43vbdsr9m3ry1kgag2p2ixpv54gw7a4vvmndxl6knqg8qbsb8b + tag: ad47441e9e399495579d7dd05ccaf96b46a487b2 + --sha256: 1a54yfc4m9n5j699cn8ln524h28043dyrlzn34wmnhsgqnxhavr4 subdir: cardano-client io-sim io-classes monoidal-synchronisation network-mux + ntp-client ouroboros-consensus ouroboros-consensus-byron ouroboros-consensus-cardano @@ -218,12 +232,10 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/plutus - tag: 1efbb276ef1a10ca6961d0fd32e6141e9798bd11 - --sha256: 1jicyk4hr8p0xksj4048gdxndrb42jz4wsnkhc3ymxbm5v6snalf + tag: ccf5bcb99ffe054dc8cd5626723f64e02708dbae + --sha256: 18569bgywilibz7r5jyxj9bid8g4fwr80cc0hd9rcm3jhasbgq8i subdir: - freer-extras plutus-core - plutus-ledger plutus-ledger-api plutus-tx plutus-tx-plugin @@ -231,6 +243,14 @@ source-repository-package stubs/plutus-ghc-stub word-array +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-addresses + tag: 71006f9eb956b0004022e80aadd4ad50d837b621 + subdir: + command-line + core + -- Something in plutus-core requries this. source-repository-package diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index 443c6d172..da756c2bf 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -44,6 +44,7 @@ library Cardano.Mock.ChainDB Cardano.Mock.ChainSync.Server Cardano.Mock.ChainSync.State + Cardano.Mock.Forging.Crypto Cardano.Mock.Forging.Interpreter Cardano.Mock.Forging.Tx.Alonzo Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples @@ -63,17 +64,18 @@ library , cardano-crypto-class , cardano-crypto-praos , cardano-crypto-wrapper + , cardano-data , cardano-ledger-alonzo , cardano-ledger-byron , cardano-ledger-core , cardano-ledger-shelley , cardano-ledger-shelley-ma - , cardano-ledger-shelley-test , cardano-node , cardano-prelude , cardano-protocol-tpraos , cardano-slotting , cborg + , compact-map , containers , contra-tracer , directory @@ -101,7 +103,7 @@ library , persistent , persistent-postgresql , plutus-core - , plutus-example + , plutus-ledger-api , pretty-show , prometheus , random-shuffle @@ -199,5 +201,4 @@ test-suite cardano-chain-gen , ouroboros-network-framework , persistent , persistent-postgresql - , plutus-example , postgresql-simple diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Crypto.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Crypto.hs new file mode 100644 index 000000000..a9bea8d90 --- /dev/null +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Crypto.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeApplications #-} + +module Cardano.Mock.Forging.Crypto where + +import Data.Typeable (Proxy (Proxy)) +import Data.Word (Word64) + +import Cardano.Binary (ToCBOR (..)) +import Cardano.Crypto.Hash +import Cardano.Crypto.Seed (Seed, mkSeedFromBytes) +import Cardano.Crypto.VRF + + +instance ToCBOR RawSeed where + toCBOR (RawSeed w1 w2 w3 w4 w5) = toCBOR (w1, w2, w3, w4, w5) + encodedSizeExpr size _ = 1 + size (Proxy :: Proxy Word64) * 5 + +data RawSeed = RawSeed !Word64 !Word64 !Word64 !Word64 !Word64 + deriving (Eq, Show) + +-- | For testing purposes, generate a deterministic VRF key pair given a seed. +mkVRFKeyPair :: + VRFAlgorithm v => + RawSeed -> + (SignKeyVRF v, VerKeyVRF v) +mkVRFKeyPair seed = + let sk = genKeyVRF $ mkSeedFromWords seed + in (sk, deriveVerKeyVRF sk) + +-- | Construct a seed from a bunch of Word64s +-- +-- We multiply these words by some extra stuff to make sure they contain +-- enough bits for our seed. +mkSeedFromWords :: + RawSeed -> + Seed +mkSeedFromWords stuff = + mkSeedFromBytes . hashToBytes $ hashWithSerialiser @Blake2b_256 toCBOR stuff diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs index 0b405c2af..90351f305 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs @@ -65,6 +65,7 @@ import Ouroboros.Consensus.Block (BlockForging, BlockNo (..), BlockPro import qualified Ouroboros.Consensus.Block as Block import Ouroboros.Consensus.Cardano.Block (AlonzoEra, LedgerState (..), ShelleyEra, StandardCrypto) +import Ouroboros.Consensus.Cardano.CanHardFork () import Ouroboros.Consensus.Config (TopLevelConfig, configConsensus, configLedger, topLevelConfigLedger) import Ouroboros.Consensus.Forecast (Forecast (..)) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs index 55d7e4afb..634175ee3 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs @@ -6,6 +6,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Cardano.Mock.Forging.Tx.Alonzo where import Cardano.Prelude hiding ((.)) @@ -19,6 +21,9 @@ import qualified Data.Set as Set import Cardano.Slotting.Slot +import Cardano.Crypto.VRF + +import Cardano.Ledger.Address import Cardano.Ledger.Alonzo.Data import Cardano.Ledger.Alonzo.Scripts import Cardano.Ledger.Alonzo.Tx @@ -34,7 +39,7 @@ import Cardano.Ledger.Keys import Cardano.Ledger.Mary.Value import Cardano.Ledger.Shelley.Metadata import Cardano.Ledger.Shelley.TxBody (DCert (..), PoolCert (..), PoolMetadata (..), - PoolParams (..), RewardAcnt (..), StakePoolRelay (..), Wdrl (..)) + PoolParams (..), StakePoolRelay (..), Wdrl (..)) import Cardano.Ledger.ShelleyMA.Timelocks import Cardano.Ledger.TxIn (TxIn (..), txid) @@ -42,15 +47,17 @@ import Ouroboros.Consensus.Cardano.Block (LedgerState) import Ouroboros.Consensus.Shelley.Eras (AlonzoEra, StandardCrypto) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) +import Cardano.Mock.Forging.Crypto import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples import Cardano.Mock.Forging.Tx.Generic import Cardano.Mock.Forging.Types -import Test.Cardano.Ledger.Shelley.Utils - type AlonzoUTxOIndex = UTxOIndex (AlonzoEra StandardCrypto) type AlonzoLedgerState = LedgerState (ShelleyBlock (AlonzoEra StandardCrypto)) +instance HasField "address" (TxOut (AlonzoEra StandardCrypto)) (Addr StandardCrypto) where + getField (TxOut addr _ _) = addr + consTxBody :: Set (TxIn (Crypto (AlonzoEra StandardCrypto))) -> Set (TxIn (Crypto (AlonzoEra StandardCrypto))) -> StrictSeq (TxOut (AlonzoEra StandardCrypto)) @@ -311,7 +318,7 @@ addMetadata tx n = tx { auxiliaryData = Strict.SJust $ AuxiliaryData mp mempty} mkUTxOAlonzo :: ValidatedTx (AlonzoEra StandardCrypto) -> [(TxIn StandardCrypto, TxOut (AlonzoEra StandardCrypto))] mkUTxOAlonzo tx = [ (TxIn transId idx, out) - | (out, idx) <- zip (toList $ getField @"outputs" (getField @"body" tx)) [0 ..] + | (out, idx) <- zip (toList $ getField @"outputs" (getField @"body" tx)) (TxIx <$> [0 ..]) ] where transId = txid $ getField @"body" tx diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo/ScriptsExamples.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo/ScriptsExamples.hs index 83db3d6b2..24ca3ae3b 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo/ScriptsExamples.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo/ScriptsExamples.hs @@ -16,19 +16,15 @@ import Cardano.Ledger.Era import Cardano.Ledger.Hashes import Cardano.Ledger.Mary.Value -import Cardano.PlutusExample.AlwaysFails (alwaysFailsScriptShortBs) -import Cardano.PlutusExample.AlwaysSucceeds (alwaysSucceedsScriptShortBs) -import Cardano.PlutusExample.MintingScript - +import qualified Plutus.V1.Ledger.Examples as Plutus import qualified PlutusCore.Data as Plutus alwaysSucceedsScript :: Script (AlonzoEra StandardCrypto) -alwaysSucceedsScript = PlutusScript PlutusV1 alwaysSucceedsScriptShortBs +alwaysSucceedsScript = PlutusScript PlutusV1 (Plutus.alwaysSucceedingNAryFunction 0) alwaysSucceedsScriptHash :: ScriptHash StandardCrypto alwaysSucceedsScriptHash = hashScript @(AlonzoEra StandardCrypto) alwaysSucceedsScript --- addr_test1wpnlxv2xv9a9ucvnvzqakwepzl9ltx7jzgm53av2e9ncv4sysemm8 alwaysSucceedsScriptAddr :: Addr StandardCrypto alwaysSucceedsScriptAddr = Addr Testnet (ScriptHashObj alwaysSucceedsScriptHash) StakeRefNull @@ -37,7 +33,7 @@ alwaysSucceedsScriptStake = ScriptHashObj alwaysSucceedsScriptHash alwaysFailsScript :: Script (AlonzoEra StandardCrypto) -alwaysFailsScript = PlutusScript PlutusV1 alwaysFailsScriptShortBs +alwaysFailsScript = PlutusScript PlutusV1 (Plutus.alwaysFailingNAryFunction 0) alwaysFailsScriptHash :: ScriptHash StandardCrypto alwaysFailsScriptHash = hashScript @(AlonzoEra StandardCrypto) alwaysFailsScript @@ -55,7 +51,7 @@ plutusDataList = Data $ Plutus.List [] alwaysMintScript :: Script (AlonzoEra StandardCrypto) -alwaysMintScript = PlutusScript PlutusV1 mintingScriptShortBs +alwaysMintScript = PlutusScript PlutusV1 (Plutus.alwaysFailingNAryFunction 1) alwaysMintScriptHash :: ScriptHash StandardCrypto alwaysMintScriptHash = hashScript @(AlonzoEra StandardCrypto) alwaysMintScript diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs index fcc1d5148..950ac7a5d 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs @@ -15,10 +15,12 @@ module Cardano.Mock.Forging.Tx.Generic import Cardano.Prelude hiding (length, (.)) +import qualified Data.Compact.SplitMap as SplitMap import Data.List (nub) import Data.List.Extra ((!?)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Data.UMap as UMap import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes @@ -71,7 +73,7 @@ resolveUTxOIndex index st = toLeft $ case index of find (hasAddr addr) utxoPairs where utxoPairs :: [(TxIn (Crypto era), Core.TxOut era)] - utxoPairs = Map.toList $ unUTxO $ _utxo $ _utxoState $ esLState $ + utxoPairs = SplitMap.toList $ unUTxO $ _utxo $ lsUTxOState $ esLState $ nesEs $ Consensus.shelleyLedgerState st hasAddr addr (_, txOut) = addr == getField @"address" txOut @@ -85,27 +87,27 @@ resolveStakeCreds :: (Crypto era ~ StandardCrypto) => StakeIndex -> LedgerState (ShelleyBlock era) -> Either ForgingError (StakeCredential StandardCrypto) resolveStakeCreds indx st = case indx of - StakeIndex n -> toEither $ rewardAccs !? n + StakeIndex n -> toEither $ fst <$> (rewardAccs !? n) StakeAddress addr -> Right addr StakeIndexNew n -> toEither $ unregisteredStakeCredentials !? n StakeIndexScript bl -> Right $ if bl then alwaysSucceedsScriptStake else alwaysFailsScriptStake StakeIndexPoolLeader poolIndex -> Right $ getRwdCred $ _poolRAcnt $ findPoolParams poolIndex StakeIndexPoolMember n poolIndex -> Right $ resolvePoolMember n poolIndex where - rewardAccs = Map.keys $ _rewards $ _dstate $ _delegationState $ esLState $ + rewardAccs = Map.toList $ UMap.rewView $ _unified $ dpsDState $ lsDPState $ esLState $ nesEs $ Consensus.shelleyLedgerState st - poolParams = _pParams $ _pstate $ _delegationState $ esLState $ + poolParams = _pParams $ dpsPState $ lsDPState $ esLState $ nesEs $ Consensus.shelleyLedgerState st - delegations = _delegations dstate + delegs = UMap.delView $ _unified dstate - dstate = _dstate $ _delegationState $ esLState $ + dstate = dpsDState $ lsDPState $ esLState $ nesEs $ Consensus.shelleyLedgerState st resolvePoolMember n poolIndex = let poolId = _poolId (findPoolParams poolIndex) - poolMembers = Map.keys $ Map.filter (== poolId) delegations + poolMembers = Map.keys $ Map.filter (== poolId) delegs in poolMembers !! n findPoolParams :: PoolIndex -> PoolParams StandardCrypto @@ -125,14 +127,14 @@ resolvePool pix st = case pix of PoolIndex n -> _poolId $ poolParams !! n PoolIndexNew n -> unregisteredPools !! n where - poolParams = Map.elems $ _pParams $ _pstate $ _delegationState $ esLState $ + poolParams = Map.elems $ _pParams $ dpsPState $ lsDPState $ esLState $ nesEs $ Consensus.shelleyLedgerState st allPoolStakeCert :: LedgerState (ShelleyBlock era) -> [DCert (Crypto era)] allPoolStakeCert st = DCertDeleg . RegKey <$> nub creds where - poolParms = Map.elems $ _pParams $ _pstate $ _delegationState $ + poolParms = Map.elems $ _pParams $ dpsPState $ lsDPState $ esLState $ nesEs $ Consensus.shelleyLedgerState st creds = concatMap getPoolStakeCreds poolParms diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs index 0b8e7c2a4..72845c54a 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Cardano.Mock.Forging.Tx.Shelley where @@ -12,6 +15,7 @@ import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set +import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin import Cardano.Ledger.Credential @@ -32,6 +36,9 @@ type ShelleyUTxOIndex = UTxOIndex (ShelleyEra StandardCrypto) type ShelleyLedgerState = LedgerState (ShelleyBlock (ShelleyEra StandardCrypto)) type ShelleyTx = Tx (ShelleyEra StandardCrypto) +instance HasField "address" (TxOut (ShelleyEra StandardCrypto)) (Addr StandardCrypto) where + getField (TxOut addr _) = addr + mkPaymentTx :: ShelleyUTxOIndex -> ShelleyUTxOIndex -> Integer -> Integer -> ShelleyLedgerState -> Either ForgingError ShelleyTx diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs index 7b25ab8ac..db5588b6b 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs @@ -21,6 +21,7 @@ import qualified Cardano.Db as DB import qualified Cardano.Crypto.Hash as Crypto import Cardano.Ledger.Alonzo.Data +import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin import Cardano.Ledger.Credential import Cardano.Ledger.Keys @@ -414,7 +415,7 @@ stakeAddressPtr = blk <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [ (StakeIndexNew 1, DCertDeleg . RegKey)] - let ptr = Ptr (blockSlot blk) 0 0 + let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 @@ -432,7 +433,7 @@ stakeAddressPtrDereg = blk <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [ (StakeIndexNew 0, DCertDeleg . RegKey)] - let ptr0 = Ptr (blockSlot blk) 0 0 + let ptr0 = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) blk' <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st @@ -441,7 +442,7 @@ stakeAddressPtrDereg = st pure [tx0, tx1] - let ptr1 = Ptr (blockSlot blk') 1 1 + let ptr1 = Ptr (blockSlot blk') (TxIx 1) (CertIx 1) _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithPtr 0 ptr1) 20000 20000 st @@ -471,7 +472,7 @@ stakeAddressPtrUseBefore = blk <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [ (StakeIndexNew 1, DCertDeleg . RegKey)] - let ptr = Ptr (blockSlot blk) 0 0 + let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 @@ -858,7 +859,7 @@ simpleScript = where testLabel = "simpleScript" getOutFields txOut = (DB.txOutAddress txOut, DB.txOutAddressHasScript txOut, DB.txOutValue txOut, DB.txOutDataHash txOut) - expectedFields = ( "addr_test1wpnlxv2xv9a9ucvnvzqakwepzl9ltx7jzgm53av2e9ncv4sysemm8" :: Text + expectedFields = ( renderAddress alwaysSucceedsScriptAddr , True, DB.DbLovelace 20000 , Just $ Crypto.hashToBytes (extractHash $ hashData plutusDataList)) diff --git a/cardano-chain-gen/test/testfiles/config/test-db-sync-config.json b/cardano-chain-gen/test/testfiles/config/test-db-sync-config.json index a99805bd3..02914ca3c 100644 --- a/cardano-chain-gen/test/testfiles/config/test-db-sync-config.json +++ b/cardano-chain-gen/test/testfiles/config/test-db-sync-config.json @@ -14,14 +14,14 @@ "stdout" ] ], - "minSeverity": "Warning", + "minSeverity": "Info", "options": { "cfokey": { "value": "Release-1.0.0" }, "mapBackends": {}, "mapSeverity": { - "db-sync-node": "Error", + "db-sync-node": "Info", "db-sync-node.Mux": "Error", "db-sync-node.Subscription": "Error" }, diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 6405d8308..a76c8b0e5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -153,13 +153,17 @@ handleLedgerEvents tracer lenv point = , show (unEpochNo $ Generic.rwdEpoch rwds), " ", renderPoint point ] postEpochRewards lenv rwds point + + LedgerDeltaRewards _ -> pure () + LedgerIncrementalRewards _rew -> pure () + LedgerStakeDist sdist -> do liftIO . logInfo tracer $ mconcat [ "Handling ", show (Map.size (Generic.sdistStakeMap sdist)), " stakes for epoch " , show (unEpochNo $ Generic.sdistEpochNo sdist), " ", renderPoint point ] postEpochStake lenv sdist point - LedgerRewardDist rwd -> + LedgerTotalRewards rwd -> lift $ stashPoolRewards tracer lenv rwd LedgerMirDist md -> lift $ stashMirRewards tracer lenv md diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs index 043bfac55..340671add 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs @@ -10,8 +10,8 @@ import Cardano.Prelude hiding (Maybe (..), fromMaybe) import Cardano.Slotting.Slot (EpochNo (..)) import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Cardano.Ledger.Shelley.API.Protocol as Shelley import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley +import qualified Cardano.Protocol.TPraos.API as Shelley import qualified Cardano.Protocol.TPraos.Rules.Tickn as Shelley import Cardano.DbSync.Era.Shelley.Generic.ProtoParams diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Metadata.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Metadata.hs index 944536f08..dfc2b8b46 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Metadata.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Metadata.hs @@ -24,6 +24,7 @@ import qualified Cardano.Ledger.Shelley.Metadata as Shelley import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as ShelleyMa import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.Text as Aeson.Text import qualified Data.ByteString.Base16 as Base16 import qualified Data.Map.Strict as Map @@ -67,7 +68,7 @@ metadataValueToJsonNoSchema = conv conv (TxMetaText txt) = Aeson.String txt conv (TxMetaList vs) = Aeson.Array (Vector.fromList (map conv vs)) conv (TxMetaMap kvs) = Aeson.object - [ (convKey k, conv v) + [ (Aeson.fromText $ convKey k, conv v) | (k, v) <- kvs ] -- Metadata allows any value as a key, not just string as JSON does. diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ParamProposal.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ParamProposal.hs index 17feb5f5a..64cf2b6d2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ParamProposal.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ParamProposal.hs @@ -113,7 +113,7 @@ convertAlonzoParamProposal epochNo (key, pmap) = -- New for Alonzo. , pppCoinsPerUtxoWord = strictMaybeToMaybe (Alonzo._coinsPerUTxOWord pmap) - , pppCostmdls = strictMaybeToMaybe (Alonzo._costmdls pmap) + , pppCostmdls = strictMaybeToMaybe (Alonzo.unCostModels <$> Alonzo._costmdls pmap) , pppPriceMem = Ledger.unboundRational . Alonzo.prMem <$> strictMaybeToMaybe (Alonzo._prices pmap) , pppPriceStep = Ledger.unboundRational . Alonzo.prSteps <$> strictMaybeToMaybe (Alonzo._prices pmap) , pppMaxTxExMem = fromIntegral . Alonzo.exUnitsMem <$> strictMaybeToMaybe (Alonzo._maxTxExUnits pmap) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs index ef0ab6cd0..1dfb0e359 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs @@ -109,7 +109,7 @@ fromAlonzoParams params = , ppMinUTxOValue = Alonzo._coinsPerUTxOWord params , ppMinPoolCost = Alonzo._minPoolCost params , ppCoinsPerUtxoWord = Just $ Alonzo._coinsPerUTxOWord params - , ppCostmdls = Just $ Alonzo._costmdls params + , ppCostmdls = Just $ Alonzo.unCostModels $ Alonzo._costmdls params , ppPriceMem = Just . Ledger.unboundRational $ Alonzo.prMem (Alonzo._prices params) , ppPriceStep = Just . Ledger.unboundRational $ Alonzo.prSteps (Alonzo._prices params) , ppMaxTxExMem = Just . fromIntegral $ Alonzo.exUnitsMem (Alonzo._maxTxExUnits params) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs index 86d03b008..5501ab8a2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs @@ -182,7 +182,7 @@ getInstantaneousRewards network lstate = instRwds :: Shelley.InstantaneousRewards (Crypto era) instRwds = - Shelley._irwd . Shelley._dstate . Shelley._delegationState + Shelley._irwd . Shelley.dpsDState . Shelley.lsDPState . Shelley.esLState . Shelley.nesEs $ Consensus.shelleyLedgerState lstate -- ------------------------------------------------------------------------------------------------- diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index a2e30bff8..e6af96217 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -19,7 +19,7 @@ import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import qualified Cardano.Ledger.Shelley.EpochBoundary as Shelley -import qualified Cardano.Ledger.Shelley.LedgerState as Shelley hiding (_delegations) +import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import Cardano.Slotting.Slot (EpochNo (..)) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs index e60c35992..c6cade57b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs @@ -47,14 +47,15 @@ import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..)) import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo import qualified Cardano.Ledger.Alonzo.TxWitness as Ledger +import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin (Coin (..)) +import qualified Cardano.Ledger.CompactAddress as Ledger import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Mary as Mary import Cardano.Ledger.Mary.Value (AssetName, PolicyID, Value (..)) import qualified Cardano.Ledger.SafeHash as Ledger -import qualified Cardano.Ledger.Shelley.CompactAddr as Ledger import Cardano.Ledger.Shelley.Scripts (ScriptHash) import qualified Cardano.Ledger.Shelley.Scripts as Shelley import qualified Cardano.Ledger.Shelley.Tx as ShelleyTx @@ -68,7 +69,6 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.ByteString.Short as SBS import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (strictMaybeToMaybe) import Data.MemoBytes (MemoBytes (..)) import Data.Sequence.Strict (StrictSeq) import qualified Data.Set as Set @@ -588,10 +588,10 @@ fromAlonzoTx pp (blkIndex, tx) = -- ------------------------------------------------------------------------------------------------- fromTxIn :: Maybe Word64 -> ShelleyTx.TxIn StandardCrypto -> TxIn -fromTxIn setIndex (ShelleyTx.TxIn (ShelleyTx.TxId txid) index) = +fromTxIn setIndex (ShelleyTx.TxIn (ShelleyTx.TxId txid) (TxIx w16)) = TxIn { txInHash = Crypto.hashToBytes $ Ledger.extractHash txid - , txInIndex = fromIntegral index + , txInIndex = fromIntegral w16 , txInRedeemerIndex = setIndex } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Util.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Util.hs index a9c88261b..0490296e2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Util.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Util.hs @@ -20,7 +20,6 @@ module Cardano.DbSync.Era.Shelley.Generic.Util , nonceToBytes , partitionMIRTargets , renderAddress - , renderLanguageCostModel , renderRewardAcnt , stakingCredHash , unitIntervalToDouble @@ -40,8 +39,6 @@ import Cardano.Db (DbLovelace (..)) import qualified Cardano.Db as Db import qualified Cardano.Ledger.Address as Ledger -import Cardano.Ledger.Alonzo.Language (Language) -import Cardano.Ledger.Alonzo.Scripts (CostModel (..)) import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Keys as Ledger @@ -52,14 +49,11 @@ import qualified Cardano.Ledger.Shelley.TxBody as Shelley import Cardano.Ledger.Coin (Coin (..), DeltaCoin) import qualified Cardano.Ledger.SafeHash as Ledger -import Cardano.DbSync.Util - import qualified Data.Binary.Put as Binary import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.List as List -import qualified Data.Map.Strict as Map import qualified Data.Text.Encoding as Text import Ouroboros.Consensus.Cardano.Block (StandardCrypto) @@ -129,12 +123,6 @@ partitionMIRTargets = renderAddress :: Ledger.Addr StandardCrypto -> Text renderAddress = Api.serialiseAddress . Api.fromShelleyAddrToAny -renderCostModel :: CostModel -> Text -renderCostModel (CostModel x) = textShow x - -renderLanguageCostModel :: Map Language CostModel -> Text -renderLanguageCostModel mlc = textShow $ Map.map renderCostModel mlc - renderRewardAcnt :: Ledger.RewardAcnt StandardCrypto -> Text renderRewardAcnt = Api.serialiseAddress . Api.fromShelleyStakeAddr diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs index e04cf1a73..c40419398 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -37,6 +37,7 @@ import qualified Cardano.Ledger.Shelley.TxBody as Shelley import qualified Cardano.Ledger.Shelley.UTxO as Shelley import qualified Data.ByteString.Char8 as BS +import qualified Data.Compact.SplitMap as SplitMap import qualified Data.Map.Strict as Map import qualified Data.Text as Text import Data.Time.Clock (UTCTime (..)) @@ -292,11 +293,7 @@ genesisTxoAssocList = genesisUtxOs :: ShelleyGenesis StandardShelley -> [(ShelleyTx.TxIn (Crypto StandardShelley), Shelley.TxOut StandardShelley)] genesisUtxOs = - Map.toList . unUTxO . Shelley.genesisUTxO - where - -- Sigh! - unUTxO :: Shelley.UTxO StandardShelley -> Map (ShelleyTx.TxIn (Crypto StandardShelley)) (Shelley.TxOut StandardShelley) - unUTxO (Shelley.UTxO m) = m + SplitMap.toList . Shelley.unUTxO . Shelley.genesisUTxO configStartTime :: ShelleyGenesis StandardShelley -> UTCTime configStartTime = roundToMillseconds . Shelley.sgSystemStart diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs index 28086b561..3b8ffea64 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs @@ -23,6 +23,7 @@ import Cardano.Prelude hiding (Ptr, from, maybeToEither, on) import Cardano.Db import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.Address as Ledger import Cardano.Ledger.Credential (Ptr (..), StakeReference (..)) @@ -98,7 +99,7 @@ queryStakeAddressRef addr = :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddressId) - queryStakeDelegation (Ptr (SlotNo slot) txIx certIx) = do + queryStakeDelegation (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do res <- select $ do (dlg :& tx :& blk) <- from $ table @Delegation @@ -109,7 +110,7 @@ queryStakeAddressRef addr = where_ (blk ^. BlockSlotNo ==. just (val slot)) where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx)) - where_ (dlg ^. DelegationCertIndex ==. val (fromIntegral certIx)) + where_ (dlg ^. DelegationCertIndex ==. val certIx) -- Need to order by BlockSlotNo descending for correct behavior when there are two -- or more delegation certificates in a single epoch. orderBy [desc (blk ^. BlockSlotNo)] @@ -138,7 +139,7 @@ queryStakeAddressIdPair cred@(Generic.StakeCred bs) = do convert (Value said) = (cred, said) queryStakeRefPtr :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddressId) -queryStakeRefPtr (Ptr (SlotNo slot) txIx certIx) = do +queryStakeRefPtr (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do res <- select $ do (blk :& tx :& sr) <- from $ table @Block diff --git a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs index 9a1ea817a..1ff2b9416 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs @@ -27,7 +27,9 @@ import Cardano.Ledger.Shelley.Rules.Epoch (EpochEvent (PoolReapEvent)) import Cardano.Ledger.Shelley.Rules.Mir (MirEvent (..)) import Cardano.Ledger.Shelley.Rules.NewEpoch (NewEpochEvent (..)) import Cardano.Ledger.Shelley.Rules.PoolReap (PoolreapEvent (..)) -import Cardano.Ledger.Shelley.Rules.Tick (TickEvent (..)) +import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent(RupdEvent)) +import Cardano.Ledger.Shelley.Rules.Tick (TickEvent (NewEpochEvent)) +import qualified Cardano.Ledger.Shelley.Rules.Tick as Tick import Cardano.Prelude hiding (All) @@ -56,7 +58,9 @@ data LedgerEvent | LedgerRewards !SlotDetails !Generic.Rewards | LedgerStakeDist !Generic.StakeDist - | LedgerRewardDist !Generic.Rewards + | LedgerTotalRewards !Generic.Rewards + | LedgerDeltaRewards !Generic.Rewards + | LedgerIncrementalRewards !Generic.Rewards | LedgerMirDist !Generic.Rewards | LedgerPoolReap !EpochNo !(Map (Ledger.StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin)) deriving Eq @@ -83,12 +87,15 @@ instance , Event (Ledger.EraRule "MIR" ledgerera) ~ MirEvent ledgerera , Event (Ledger.EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera , Event (Ledger.EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera + , Event (Ledger.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) ) => ConvertLedgerEvent (ShelleyBlock ledgerera) where toLedgerEvent nw evt = case unwrapLedgerEvent evt of - LERewards e m -> Just $ LedgerRewardDist (convertPoolRewards nw e m) + LETotalRewards e m -> Just $ LedgerTotalRewards (convertPoolRewards nw e m) + LEDeltaReward e m -> Just $ LedgerDeltaRewards (convertPoolRewards nw e m) + LEIncrementalReward e m -> Just $ LedgerIncrementalRewards (convertPoolRewards nw e m) LEMirTransfer rp tp _rtt _ttr -> Just $ LedgerMirDist (convertMirRewards nw rp tp) LERetiredPools r _u en -> Just $ LedgerPoolReap en r ShelleyLedgerEventBBODY {} -> Nothing @@ -150,16 +157,39 @@ mapBimap fk fa = Map.fromAscList . map (bimap fk fa) . Map.toAscList -------------------------------------------------------------------------------- -- Patterns for event access. Why aren't these in ledger-specs? -pattern LERewards +pattern LETotalRewards :: ( Crypto ledgerera ~ StandardCrypto , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera , Event (Ledger.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera ) => EpochNo -> Map (Ledger.StakeCredential StandardCrypto) (Set (Ledger.Reward StandardCrypto)) -> AuxLedgerEvent (LedgerState (ShelleyBlock ledgerera)) -pattern LERewards e m <- +pattern LETotalRewards e m <- ShelleyLedgerEventTICK - (NewEpochEvent (RewardEvent e m)) + (NewEpochEvent (TotalRewardEvent e m)) + +pattern LEDeltaReward + :: ( Crypto ledgerera ~ StandardCrypto + , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera + , Event (Ledger.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera + , Event (Ledger.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + ) + => EpochNo -> Map (Ledger.StakeCredential StandardCrypto) (Set (Ledger.Reward StandardCrypto)) + -> AuxLedgerEvent (LedgerState (ShelleyBlock ledgerera)) +pattern LEDeltaReward e m <- + ShelleyLedgerEventTICK + (NewEpochEvent (DeltaRewardEvent (RupdEvent e m))) + +pattern LEIncrementalReward + :: ( Crypto ledgerera ~ StandardCrypto + , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera + , Event (Ledger.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + ) + => EpochNo -> Map (Ledger.StakeCredential StandardCrypto) (Set (Ledger.Reward StandardCrypto)) + -> AuxLedgerEvent (LedgerState (ShelleyBlock ledgerera)) +pattern LEIncrementalReward e m <- + ShelleyLedgerEventTICK + (Tick.RupdEvent (RupdEvent e m)) pattern LEMirTransfer :: ( Crypto ledgerera ~ StandardCrypto diff --git a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs index e57bc3583..30cb08529 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs @@ -697,7 +697,7 @@ getPoolParamsShelley => LedgerState (ShelleyBlock era) -> Set.Set (KeyHash 'StakePool StandardCrypto) getPoolParamsShelley lState = - Map.keysSet $ Shelley._pParams $ Shelley._pstate $ Shelley._delegationState + Map.keysSet $ Shelley._pParams $ Shelley.dpsPState $ Shelley.lsDPState $ Shelley.esLState $ Shelley.nesEs $ Consensus.shelleyLedgerState lState -- We only compute 'AdaPots' for later eras. This is a time consuming diff --git a/cardano-db-sync/src/Cardano/DbSync/Tracing/ToObjectOrphans.hs b/cardano-db-sync/src/Cardano/DbSync/Tracing/ToObjectOrphans.hs index fda919cb8..7b6a765ec 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Tracing/ToObjectOrphans.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Tracing/ToObjectOrphans.hs @@ -24,9 +24,9 @@ instance HasTextFormatter (TraceSendRecv (ChainSync blk (Point blk) (Tip blk))) instance ToObject ByronBlock where toObject _verb msg = - mkObject [ "kind" .= ("ByronBlock" :: String) - , "event" .= show msg - ] + mconcat [ "kind" .= ("ByronBlock" :: String) + , "event" .= show msg + ] instance Transformable Text IO (TraceSendRecv (ChainSync blk (Point blk) (Tip blk))) where trTransformer = trStructuredText diff --git a/cardano-db-tool/cardano-db-tool.cabal b/cardano-db-tool/cardano-db-tool.cabal index 555840e65..7e5dba6d6 100644 --- a/cardano-db-tool/cardano-db-tool.cabal +++ b/cardano-db-tool/cardano-db-tool.cabal @@ -69,6 +69,7 @@ library , cardano-ledger-shelley , cardano-prelude , cardano-slotting + , compact-map , containers , esqueleto , extra diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs index c99ef88cc..3efe3c446 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs @@ -18,10 +18,10 @@ import qualified Cardano.Chain.UTxO as Byron import Cardano.Ledger.Address (BootstrapAddress (..)) import Cardano.Ledger.Alonzo (AlonzoEra) import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo +import Cardano.Ledger.CompactAddress (CompactAddr, compactAddr) import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Shelley.API (Addr (..), Coin (..)) -import Cardano.Ledger.Shelley.CompactAddr (CompactAddr, compactAddr) import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import qualified Cardano.Ledger.Shelley.TxBody as Shelley import qualified Cardano.Ledger.Shelley.UTxO as Shelley @@ -30,6 +30,7 @@ import Cardano.Ledger.Compactible import Cardano.Ledger.Val import Cardano.Prelude +import qualified Data.Compact.SplitMap as SplitMap import qualified Data.Map.Strict as Map import qualified Data.Text as Text @@ -50,7 +51,7 @@ ledgerAddrBalance addr lsc = LedgerStateAlonzo st -> getAlonzoBalance addr $ getUTxO st where getUTxO :: LedgerState (ShelleyBlock era) -> Shelley.UTxO era - getUTxO = Shelley._utxo . Shelley._utxoState . Shelley.esLState . Shelley.nesEs . shelleyLedgerState + getUTxO = Shelley._utxo . Shelley.lsUTxOState . Shelley.esLState . Shelley.nesEs . shelleyLedgerState getByronBalance :: Text -> Byron.UTxO -> Either Text Word64 getByronBalance addrText utxo = do @@ -70,7 +71,7 @@ getShelleyBalance => Text -> Shelley.UTxO era -> Either Text Word64 getShelleyBalance addrText utxo = do caddr <- covertToCompactAddress addrText - Right . fromIntegral . sum $ unCoin <$> mapMaybe (compactTxOutValue caddr) (Map.elems $ Shelley.unUTxO utxo) + Right . fromIntegral . sum $ unCoin <$> mapMaybe (compactTxOutValue caddr) (SplitMap.elems $ Shelley.unUTxO utxo) where compactTxOutValue :: CompactAddr (Crypto era) -> Ledger.TxOut era -> Maybe Coin compactTxOutValue caddr (Shelley.TxOutCompact scaddr v) = @@ -81,7 +82,7 @@ getShelleyBalance addrText utxo = do getAlonzoBalance :: Text -> Shelley.UTxO (AlonzoEra StandardCrypto) -> Either Text Word64 getAlonzoBalance addrText utxo = do caddr <- covertToCompactAddress addrText - Right . fromIntegral . sum $ unCoin <$> mapMaybe (compactTxOutValue caddr) (Map.elems $ Shelley.unUTxO utxo) + Right . fromIntegral . sum $ unCoin <$> mapMaybe (compactTxOutValue caddr) (SplitMap.elems $ Shelley.unUTxO utxo) where compactTxOutValue :: CompactAddr (Crypto (AlonzoEra StandardCrypto)) -> Alonzo.TxOut (AlonzoEra StandardCrypto) -> Maybe Coin diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs index aac25290f..898fe8d9b 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs @@ -334,7 +334,7 @@ instance MimeUnrender OctetStream PoolMetadataRaw where -- Here we are usingg the unsafe encoding since we already have the JSON format -- from the database. instance ToJSON PoolMetadataRaw where - toJSON (PoolMetadataRaw metadata) = toJSON metadata + toJSON (PoolMetadataRaw metadata) = Aeson.String $ decodeUtf8 metadata toEncoding (PoolMetadataRaw metadata) = unsafeToEncoding $ BSB.byteString metadata instance ToSchema PoolMetadataRaw where diff --git a/flake.lock b/flake.lock index b7f576095..e23edb154 100644 --- a/flake.lock +++ b/flake.lock @@ -20,10 +20,10 @@ "flake": false, "locked": { "lastModified": 1603716527, - "narHash": "sha256-sDbrmur9Zfp4mPKohCD8IDZfXJ0Tjxpmr2R+kg5PpSY=", + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", "owner": "haskell", "repo": "cabal", - "rev": "94aaa8e4720081f9c75497e2735b90f6a819b08e", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", "type": "github" }, "original": { @@ -36,11 +36,11 @@ "cabal-34": { "flake": false, "locked": { - "lastModified": 1622475795, - "narHash": "sha256-chwTL304Cav+7p38d9mcb+egABWmxo2Aq+xgVBgEb/U=", + "lastModified": 1640353650, + "narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=", "owner": "haskell", "repo": "cabal", - "rev": "b086c1995cdd616fc8d91f46a21e905cc50a1049", + "rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd", "type": "github" }, "original": { @@ -50,6 +50,23 @@ "type": "github" } }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1641652457, + "narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=", + "owner": "haskell", + "repo": "cabal", + "rev": "f27667f8ec360c475027dcaee0138c937477b070", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, "cardano-shell": { "flake": false, "locked": { @@ -79,11 +96,11 @@ }, "flake-utils": { "locked": { - "lastModified": 1623875721, - "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", "owner": "numtide", "repo": "flake-utils", - "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", "type": "github" }, "original": { @@ -112,11 +129,27 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1639357972, - "narHash": "sha256-NvVn00YOYZMqDUSiBbghJk/rm/nJItBEUJulWRGTgvk=", + "lastModified": 1650935983, + "narHash": "sha256-wZTCKzA4f7nk5sIdP2BhGz5qkt6ex5VTC/53U2Y4i9Y=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "b65addc81b03406b3ee8b139549980591ed15be5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackageNix": { + "flake": false, + "locked": { + "lastModified": 1650935983, + "narHash": "sha256-wZTCKzA4f7nk5sIdP2BhGz5qkt6ex5VTC/53U2Y4i9Y=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "54adf6e47e20831d9c49a2b62e12f7f218fd7752", + "rev": "b65addc81b03406b3ee8b139549980591ed15be5", "type": "github" }, "original": { @@ -130,15 +163,17 @@ "HTTP": "HTTP", "cabal-32": "cabal-32", "cabal-34": "cabal-34", + "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", "flake-utils": "flake-utils", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": "hackage", "hpc-coveralls": "hpc-coveralls", + "hydra": "hydra", "nix-tools": "nix-tools", "nixpkgs": [ "haskellNix", - "nixpkgs-2111" + "nixpkgs-unstable" ], "nixpkgs-2003": "nixpkgs-2003", "nixpkgs-2105": "nixpkgs-2105", @@ -148,11 +183,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1639371915, - "narHash": "sha256-i5kW3hPptzXwzkpI2FAkfdDA/9QEDl/9mrwwoeBxDJg=", + "lastModified": 1650936156, + "narHash": "sha256-B58b4OCSc6ohRjGEdbQ78r+TK/OZYsBXION90kfQDC4=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "e95a1f0dacbc64603c31d11e36e4ba1af8f0eb43", + "rev": "9a502b8c8aac4d7b8033bc9affb87fd03d4740fc", "type": "github" }, "original": { @@ -177,6 +212,29 @@ "type": "github" } }, + "hydra": { + "inputs": { + "nix": "nix", + "nixpkgs": [ + "haskellNix", + "hydra", + "nix", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1646878427, + "narHash": "sha256-KtbrofMtN8GlM7D+n90kixr7QpSlVmdN+vK5CA/aRzc=", + "owner": "NixOS", + "repo": "hydra", + "rev": "28b682b85b7efc5cf7974065792a1f22203a5927", + "type": "github" + }, + "original": { + "id": "hydra", + "type": "indirect" + } + }, "iohkNix": { "inputs": { "nixpkgs": [ @@ -197,14 +255,67 @@ "type": "github" } }, + "lowdown-src": { + "flake": false, + "locked": { + "lastModified": 1633514407, + "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", + "owner": "kristapsdz", + "repo": "lowdown", + "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", + "type": "github" + }, + "original": { + "owner": "kristapsdz", + "repo": "lowdown", + "type": "github" + } + }, + "nix": { + "inputs": { + "lowdown-src": "lowdown-src", + "nixpkgs": "nixpkgs", + "nixpkgs-regression": "nixpkgs-regression" + }, + "locked": { + "lastModified": 1643066034, + "narHash": "sha256-xEPeMcNJVOeZtoN+d+aRwolpW8mFSEQx76HTRdlhPhg=", + "owner": "NixOS", + "repo": "nix", + "rev": "a1cd7e58606a41fcf62bf8637804cf8306f17f62", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "2.6.0", + "repo": "nix", + "type": "github" + } + }, "nix-tools": { "flake": false, "locked": { - "lastModified": 1636018067, - "narHash": "sha256-ng306fkuwr6V/malWtt3979iAC4yMVDDH2ViwYB6sQE=", + "lastModified": 1649424170, + "narHash": "sha256-XgKXWispvv5RCvZzPb+p7e6Hy3LMuRjafKMl7kXzxGw=", + "owner": "input-output-hk", + "repo": "nix-tools", + "rev": "e109c94016e3b6e0db7ed413c793e2d4bdb24aa7", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "nix-tools", + "type": "github" + } + }, + "nixTools": { + "flake": false, + "locked": { + "lastModified": 1649424170, + "narHash": "sha256-XgKXWispvv5RCvZzPb+p7e6Hy3LMuRjafKMl7kXzxGw=", "owner": "input-output-hk", "repo": "nix-tools", - "rev": "ed5bd7215292deba55d6ab7a4e8c21f8b1564dda", + "rev": "e109c94016e3b6e0db7ed413c793e2d4bdb24aa7", "type": "github" }, "original": { @@ -213,6 +324,21 @@ "type": "github" } }, + "nixpkgs": { + "locked": { + "lastModified": 1632864508, + "narHash": "sha256-d127FIvGR41XbVRDPVvozUPQ/uRHbHwvfyKHwEt5xFM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "82891b5e2c2359d7e58d08849e4c89511ab94234", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "ref": "nixos-21.05-small", + "type": "indirect" + } + }, "nixpkgs-2003": { "locked": { "lastModified": 1620055814, @@ -231,11 +357,11 @@ }, "nixpkgs-2105": { "locked": { - "lastModified": 1639202042, - "narHash": "sha256-xEMgCsIcDUQ0kw9xvqU0wObns580kpdcr1ACz83+gHs=", + "lastModified": 1645296114, + "narHash": "sha256-y53N7TyIkXsjMpOG7RhvqJFGDacLs9HlyHeSTBioqYU=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "499ca2a9f6463ce119e40361f4329afa921a1d13", + "rev": "530a53dcbc9437363471167a5e4762c5fcfa34a1", "type": "github" }, "original": { @@ -247,11 +373,11 @@ }, "nixpkgs-2111": { "locked": { - "lastModified": 1639213685, - "narHash": "sha256-Evuobw7o9uVjAZuwz06Al0fOWZ5JMKOktgXR0XgWBtg=", + "lastModified": 1648744337, + "narHash": "sha256-bYe1dFJAXovjqiaPKrmAbSBEK5KUkgwVaZcTbSoJ7hg=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "453bcb8380fd1777348245b3c44ce2a2b93b2e2d", + "rev": "0a58eebd8ec65ffdef2ce9562784123a73922052", "type": "github" }, "original": { @@ -261,13 +387,28 @@ "type": "github" } }, + "nixpkgs-regression": { + "locked": { + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "type": "indirect" + } + }, "nixpkgs-unstable": { "locked": { - "lastModified": 1639239143, - "narHash": "sha256-9fFMUs6m3/4ZMflSqRgO4iEkBtFBnDyLWa3AB2tOvfs=", + "lastModified": 1648219316, + "narHash": "sha256-Ctij+dOi0ZZIfX5eMhgwugfvB+WZSrvVNAyAuANOsnQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e6df26a654b7fdd59a068c57001eab5736b1363c", + "rev": "30d3d79b7d3607d56546dd2a6b49e156ba0ec634", "type": "github" }, "original": { @@ -297,11 +438,13 @@ "root": { "inputs": { "customConfig": "customConfig", + "hackageNix": "hackageNix", "haskellNix": "haskellNix", "iohkNix": "iohkNix", + "nixTools": "nixTools", "nixpkgs": [ "haskellNix", - "nixpkgs-2111" + "nixpkgs-unstable" ], "utils": "utils" } @@ -309,11 +452,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1639185224, - "narHash": "sha256-ZBL0Lvqq8/Iwl8F5sT2N9J8+HTh0OY+09LkkUVtuUtY=", + "lastModified": 1650936094, + "narHash": "sha256-9ibS+iszPXe3HQd8rexVfrQeO4JkXSPokhbPiJ/Lags=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "14819f5c85a92e5fb6e322cc809c803fa6419bd4", + "rev": "85f94546f85fb9b92080f958bec655a364b2f0e5", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index a5d5ce178..607250a65 100644 --- a/flake.nix +++ b/flake.nix @@ -2,13 +2,21 @@ description = "cardano-db-sync"; inputs = { + nixpkgs.follows = "haskellNix/nixpkgs-unstable"; + hackageNix = { + url = "github:input-output-hk/hackage.nix"; + flake = false; + }; + nixTools = { + url = "github:input-output-hk/nix-tools"; + flake = false; + }; haskellNix.url = "github:input-output-hk/haskell.nix"; + utils.url = "github:numtide/flake-utils"; iohkNix = { url = "github:input-output-hk/iohk-nix"; inputs.nixpkgs.follows = "nixpkgs"; }; - nixpkgs.follows = "haskellNix/nixpkgs-2111"; - utils.url = "github:numtide/flake-utils"; customConfig = { url = "path:./custom-config"; }; }; diff --git a/nix/haskell.nix b/nix/haskell.nix index 80f4c922f..9a4024bd7 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -80,7 +80,6 @@ let enableLibraryProfiling = profiling; packages.plutus-ledger.doHaddock = false; - packages.plutus-example.doHaddock = false; } { packages = lib.genAttrs projectPackages (name: { diff --git a/schema/migration-2-0011-20220322.sql b/schema/migration-2-0011-20220322.sql deleted file mode 100644 index fd5791fab..000000000 --- a/schema/migration-2-0011-20220322.sql +++ /dev/null @@ -1,21 +0,0 @@ --- Persistent generated migration. - -CREATE FUNCTION migrate() RETURNS void AS $$ -DECLARE - next_version int ; -BEGIN - SELECT stage_two + 1 INTO next_version FROM schema_version ; - IF next_version = 11 THEN - EXECUTE 'ALTER TABLE "block" ALTER COLUMN "slot_no" TYPE word63type' ; - EXECUTE 'ALTER TABLE "ada_pots" ALTER COLUMN "slot_no" TYPE word63type' ; - EXECUTE 'ALTER TABLE "delegation" ALTER COLUMN "slot_no" TYPE word63type' ; - -- Hand written SQL statements can be added here. - UPDATE schema_version SET stage_two = next_version ; - RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ; - END IF ; -END ; -$$ LANGUAGE plpgsql ; - -SELECT migrate() ; - -DROP FUNCTION migrate() ; From b43b8dcac146e56b5ca5f484fe0b7842ef5f270a Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Wed, 23 Mar 2022 01:29:13 +0200 Subject: [PATCH 02/11] Cleanup Byron hash utilities --- .../src/Cardano/DbSync/Era/Byron/Insert.hs | 7 ++----- .../src/Cardano/DbSync/Era/Byron/Util.hs | 20 ++++++++++++++++--- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs index 972d847ef..bd659a89c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -78,10 +78,7 @@ insertABOBBoundary -> ExceptT SyncNodeError (ReaderT SqlBackend m) () insertABOBBoundary tracer blk details = do -- Will not get called in the OBFT part of the Byron era. - let prevHash = case Byron.boundaryPrevHash (Byron.boundaryHeader blk) of - Left gh -> Byron.genesisToHeaderHash gh - Right hh -> Byron.unHeaderHash hh - pbid <- liftLookupFail "insertABOBBoundary" $ DB.queryBlockId prevHash + pbid <- liftLookupFail "insertABOBBoundary" $ DB.queryBlockId (Byron.ebbPrevHash blk) slid <- lift . DB.insertSlotLeader $ DB.SlotLeader { DB.slotLeaderHash = BS.replicate 28 '\0' @@ -123,7 +120,7 @@ insertABlock => Trace IO Text -> Bool -> Byron.ABlock ByteString -> SlotDetails -> ExceptT SyncNodeError (ReaderT SqlBackend m) () insertABlock tracer firstBlockOfEpoch blk details = do - pbid <- liftLookupFail "insertABlock" $ DB.queryBlockId (Byron.unHeaderHash $ Byron.blockPreviousHash blk) + pbid <- liftLookupFail "insertABlock" $ DB.queryBlockId (Byron.blockPreviousHash blk) slid <- lift . DB.insertSlotLeader $ Byron.mkSlotLeader blk blkId <- lift . DB.insertBlock $ DB.Block diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Util.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Util.hs index 40919702f..34ce7ac59 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Util.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Util.hs @@ -15,6 +15,8 @@ module Cardano.DbSync.Era.Byron.Util , blockNumber , blockPayload , blockPreviousHash + , ebbPrevHash + , prevHash , epochNumber , genesisToHeaderHash , protocolVersion @@ -37,9 +39,10 @@ import qualified Cardano.Chain.Block as Byron import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.Genesis as Byron import qualified Cardano.Chain.Slotting as Byron -import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Chain.Update as Byron +import qualified Cardano.Chain.UTxO as Byron +import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron import qualified Cardano.Db as DB @@ -91,8 +94,19 @@ blockPayload :: Byron.ABlock a -> [Byron.TxAux] blockPayload = Byron.unTxPayload . Byron.bodyTxPayload . Byron.blockBody -blockPreviousHash :: Byron.ABlock a -> Byron.HeaderHash -blockPreviousHash = Byron.headerPrevHash . Byron.blockHeader +blockPreviousHash :: Byron.ABlock a -> ByteString +blockPreviousHash = unHeaderHash . Byron.headerPrevHash . Byron.blockHeader + +ebbPrevHash :: Byron.ABoundaryBlock a -> ByteString +ebbPrevHash bblock = + case Byron.boundaryPrevHash (Byron.boundaryHeader bblock) of + Left gh -> genesisToHeaderHash gh + Right hh -> unHeaderHash hh + +prevHash :: Byron.ByronBlock -> ByteString +prevHash blk = case Byron.byronBlockRaw blk of + Byron.ABOBBlock ablk -> blockPreviousHash ablk + Byron.ABOBBoundary abblk -> ebbPrevHash abblk epochNumber :: Byron.ABlock ByteString -> Word64 -> Word64 epochNumber blk slotsPerEpoch = From b247ceedab40683096d6e25db04ae47ecd927109 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Wed, 23 Mar 2022 01:33:09 +0200 Subject: [PATCH 03/11] Replace StakeDist volatile data by StakeSlices --- cardano-db-sync/src/Cardano/DbSync/Default.hs | 8 +- .../DbSync/Era/Shelley/Generic/Block.hs | 1 + .../DbSync/Era/Shelley/Generic/StakeDist.hs | 168 ++++++++++++------ .../src/Cardano/DbSync/Era/Shelley/Insert.hs | 3 +- .../DbSync/Era/Shelley/Insert/Epoch.hs | 73 ++++---- .../src/Cardano/DbSync/LedgerEvent.hs | 1 - .../src/Cardano/DbSync/LedgerState.hs | 152 ++++++++++------ cardano-db/src/Cardano/Db/Query.hs | 8 + schema/migration-2-0011-20220318.sql | 21 +++ 9 files changed, 278 insertions(+), 157 deletions(-) create mode 100644 schema/migration-2-0011-20220318.sql diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index a76c8b0e5..6004e0d22 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -23,7 +23,7 @@ import Cardano.DbSync.Era.Shelley.Adjust (adjustEpochRewards) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Insert (insertShelleyBlock) import Cardano.DbSync.Era.Shelley.Insert.Epoch (finalizeEpochBulkOps, forceInsertRewards, - insertPoolDepositRefunds, isEmptyEpochBulkOps, postEpochRewards, postEpochStake) + insertPoolDepositRefunds, isEmptyEpochBulkOps, postEpochRewards) import Cardano.DbSync.Era.Shelley.Validate (validateEpochRewards) import Cardano.DbSync.Error import Cardano.DbSync.LedgerState (LedgerEvent (..), LedgerStateSnapshot (..), applyBlock, @@ -157,12 +157,6 @@ handleLedgerEvents tracer lenv point = LedgerDeltaRewards _ -> pure () LedgerIncrementalRewards _rew -> pure () - LedgerStakeDist sdist -> do - liftIO . logInfo tracer $ mconcat - [ "Handling ", show (Map.size (Generic.sdistStakeMap sdist)), " stakes for epoch " - , show (unEpochNo $ Generic.sdistEpochNo sdist), " ", renderPoint point - ] - postEpochStake lenv sdist point LedgerTotalRewards rwd -> lift $ stashPoolRewards tracer lenv rwd LedgerMirDist md -> diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs index d1ecd7517..5dc31454a 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs @@ -14,6 +14,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Block , blockHash , slotLeaderHash + , blockPrevHash ) where import qualified Cardano.Api.Shelley as Api diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index e6af96217..694c52439 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -1,14 +1,21 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + module Cardano.DbSync.Era.Shelley.Generic.StakeDist - ( StakeDist (..) - , epochStakeDist + ( StakeSliceRes (..) + , StakeSlice (..) , stakeDistPoolHashKeys , stakeDistStakeCreds + , getSecurityParameter + , getStakeSlice ) where import Cardano.Prelude +import Prelude (id) import Cardano.Crypto.Hash (hashToBytes) @@ -21,82 +28,135 @@ import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import qualified Cardano.Ledger.Shelley.EpochBoundary as Shelley import qualified Cardano.Ledger.Shelley.LedgerState as Shelley -import Cardano.Slotting.Slot (EpochNo (..)) - import Cardano.DbSync.Era.Shelley.Generic.StakeCred import Cardano.DbSync.Era.Shelley.Generic.StakePoolKeyHash import Cardano.DbSync.Types +import Data.Compact.VMap (VB, VMap (..), VP) import qualified Data.Compact.VMap as VMap import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import qualified Data.Vector.Generic as VG +import Ouroboros.Consensus.Block import Ouroboros.Consensus.Cardano.Block (LedgerState (..)) - +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) -import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Shelley.Ledger import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus +data StakeSliceRes = + Slice StakeSlice Bool -- True if this is the final slice for this epoch. Can be used for logging. + | NoSlices -data StakeDist = StakeDist - { sdistEpochNo :: !EpochNo - , sdistStakeMap :: !(Map StakeCred (Coin, StakePoolKeyHash)) +data StakeSlice = StakeSlice + { sliceEpochNo :: !EpochNo + , sliceDistr :: !(Map StakeCred (Coin, StakePoolKeyHash)) } deriving Eq -epochStakeDist :: Ledger.Network -> EpochNo -> ExtLedgerState CardanoBlock -> Maybe StakeDist -epochStakeDist network epoch els = +emptySlice :: EpochNo -> StakeSlice +emptySlice epoch = StakeSlice epoch Map.empty + +getSecurityParameter :: ConsensusProtocol (BlockProtocol blk) + => ProtocolInfo IO blk -> Word64 +getSecurityParameter = maxRollbacks . configSecurityParam . pInfoConfig + +-- 'sliceIndex' can match the epochBlockNo for every block. +-- +-- 'minSliceSize' has to be constant or it could cause missing data. +-- If this value is too small it will be adjusted to a 'defaultEpochSliceSize' +-- which is big enough to cover all delegations. +-- On mainnet, for a value minSliceSize = 2000, it will be used as the actual size of slices +-- until the size of delegations grows up to 8.6M, in which case, the size of slices +-- will be adjusted. +getStakeSlice :: ConsensusProtocol (BlockProtocol blk) + => ProtocolInfo IO blk -> Ledger.Network + -> EpochNo -> Word64 -> Word64 -> ExtLedgerState CardanoBlock -> StakeSliceRes +getStakeSlice pInfo network epoch sliceIndex minSliceSize els = case ledgerState els of - LedgerStateByron _ -> Nothing - LedgerStateShelley sls -> Just $ genericStakeDist network epoch sls - LedgerStateAllegra als -> Just $ genericStakeDist network epoch als - LedgerStateMary mls -> Just $ genericStakeDist network epoch mls - LedgerStateAlonzo als -> Just $ genericStakeDist network epoch als - --- Use Set because they guarantee unique elements. -stakeDistPoolHashKeys :: StakeDist -> Set StakePoolKeyHash -stakeDistPoolHashKeys = Set.fromList . map snd . Map.elems . sdistStakeMap - -stakeDistStakeCreds :: StakeDist -> Set StakeCred -stakeDistStakeCreds = Map.keysSet . sdistStakeMap - --- ------------------------------------------------------------------------------------------------- - -genericStakeDist :: forall era. Ledger.Network -> EpochNo -> LedgerState (ShelleyBlock era) -> StakeDist -genericStakeDist network epoch lstate = - StakeDist - { sdistEpochNo = epoch - , sdistStakeMap = stakeMap - } + LedgerStateByron _ -> NoSlices + LedgerStateShelley sls -> genericStakeSlice pInfo network epoch sliceIndex minSliceSize sls + LedgerStateAllegra als -> genericStakeSlice pInfo network epoch sliceIndex minSliceSize als + LedgerStateMary mls -> genericStakeSlice pInfo network epoch sliceIndex minSliceSize mls + LedgerStateAlonzo als -> genericStakeSlice pInfo network epoch sliceIndex minSliceSize als + +genericStakeSlice :: forall era c blk. (c ~ Crypto era, ConsensusProtocol (BlockProtocol blk)) + => ProtocolInfo IO blk -> Ledger.Network -> EpochNo -> Word64 -> Word64 + -> LedgerState (ShelleyBlock era) -> StakeSliceRes +genericStakeSlice pInfo network epoch sliceIndex minSliceSize lstate + | index > delegationsLen = NoSlices + | index == delegationsLen = Slice (emptySlice epoch) True + | index + epochSliceSize > delegationsLen = Slice (mkSlice (delegationsLen - index)) True + | otherwise = Slice (mkSlice epochSliceSize) False where - stakeMap :: Map StakeCred (Coin, StakePoolKeyHash) - stakeMap = Map.intersectionWith (,) stakeCoinMap stakePoolMap - - stakeCoinMap :: Map StakeCred Coin - stakeCoinMap = mapBimap (toStakeCred network) Ledger.fromCompact stMap - - stMap :: Map (Credential 'Staking (Crypto era)) (Ledger.CompactForm Coin) - stMap = VMap.toMap . Shelley.unStake $ Shelley._stake stakeSet - - stakePoolMap :: Map StakeCred StakePoolKeyHash - stakePoolMap = mapBimap (toStakeCred network) convertStakePoolkeyHash delMap - - delMap :: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era)) - delMap = VMap.toMap $ Shelley._delegations stakeSet - -- We use '_pstakeSet' here instead of '_pstateMark' because the stake addresses for the -- later may not have been added to the database yet. That means that when these values -- are added to the database, the epoch number where they become active is the current -- epoch plus one. - stakeSet :: Shelley.SnapShot (Crypto era) - stakeSet = Shelley._pstakeSet . Shelley.esSnapshots . Shelley.nesEs + stakeSnapshot :: Shelley.SnapShot c + stakeSnapshot = Shelley._pstakeSet . Shelley.esSnapshots . Shelley.nesEs $ Consensus.shelleyLedgerState lstate - convertStakePoolkeyHash :: KeyHash 'StakePool (Crypto era) -> StakePoolKeyHash + delegations :: VMap.KVVector VB VB (Credential 'Staking c, KeyHash 'StakePool c) + delegations = VMap.unVMap $ Shelley._delegations stakeSnapshot + + delegationsLen :: Word64 + delegationsLen = fromIntegral $ VG.length delegations + + stakes :: VMap VB VP (Credential 'Staking c) (Ledger.CompactForm Coin) + stakes = Shelley.unStake $ Shelley._stake stakeSnapshot + + lookupStake :: Credential 'Staking c -> Maybe Coin + lookupStake cred = Ledger.fromCompact <$> VMap.lookup cred stakes + + -- This is deterministic for the whole epoch and is the constant size of slices + -- until the data are over. This means the last slice could be of smaller size and slices + -- after that will be empty. + epochSliceSize :: Word64 + epochSliceSize = + max minSliceSize defaultEpochSliceSize + where + -- On mainnet this is 2160 + k :: Word64 + k = getSecurityParameter pInfo + + -- On mainnet this is 21600 + expectedBlocks :: Word64 + expectedBlocks = 10 * k + + -- This size of slices is enough to cover the whole list, even if only + -- the 20% of the expected blocks appear in an epoch. + defaultEpochSliceSize :: Word64 + defaultEpochSliceSize = 1 + div (delegationsLen * 5) expectedBlocks + + -- The starting index of the data in the delegation vector. + index :: Word64 + index = sliceIndex * epochSliceSize + + mkSlice :: Word64 -> StakeSlice + mkSlice size = + StakeSlice + { sliceEpochNo = epoch + , sliceDistr = distribution + } + where + delegationsSliced :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c) + delegationsSliced = VMap $ VG.slice (fromIntegral index) (fromIntegral size) delegations + + distribution :: Map StakeCred (Coin, StakePoolKeyHash) + distribution = Map.mapKeys (toStakeCred network) $ VMap.toMap $ + VMap.mapMaybe id $ VMap.mapWithKey (\k p -> (, convertStakePoolkeyHash p) <$> lookupStake k) delegationsSliced + + convertStakePoolkeyHash :: KeyHash 'StakePool c -> StakePoolKeyHash convertStakePoolkeyHash (KeyHash h) = StakePoolKeyHash $ hashToBytes h --- Is there a better way to do this? -mapBimap :: Ord k2 => (k1 -> k2) -> (a1 -> a2) -> Map k1 a1 -> Map k2 a2 -mapBimap fk fa = Map.fromAscList . map (bimap fk fa) . Map.toAscList - +-- Use Set because they guarantee unique elements. +stakeDistPoolHashKeys :: StakeSlice -> Set StakePoolKeyHash +stakeDistPoolHashKeys = Set.fromList . map snd . Map.elems . sliceDistr +stakeDistStakeCreds :: StakeSlice -> Set StakeCred +stakeDistStakeCreds = Map.keysSet . sliceDistr diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs index 009d499be..8c143263d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs @@ -10,7 +10,6 @@ module Cardano.DbSync.Era.Shelley.Insert ( insertShelleyBlock , postEpochRewards - , postEpochStake -- These are exported for data in Shelley Genesis , insertPoolRegister @@ -137,6 +136,8 @@ insertShelleyBlock tracer lenv firstBlockOfEpoch blk lStateSnap details = do whenJust (lssNewEpoch lStateSnap) $ \ newEpoch -> do insertOnNewEpoch tracer blkId (Generic.blkSlotNo blk) (sdEpochNo details) newEpoch + insertStakeSlice tracer (leIndexCache lenv) (lssStakeSlice lStateSnap) + mbop <- liftIO . atomically $ tryReadTBQueue (leBulkOpQueue lenv) whenJust (maybeToStrict mbop) $ \ bop -> insertEpochInterleaved tracer bop diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs index 347e70ec5..dd76c0c8a 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs @@ -15,7 +15,7 @@ module Cardano.DbSync.Era.Shelley.Insert.Epoch , insertEpochInterleaved , insertPoolDepositRefunds , postEpochRewards - , postEpochStake + , insertStakeSlice ) where import Cardano.Prelude @@ -36,8 +36,8 @@ import Cardano.DbSync.Util import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad.Class.MonadSTM.Strict (flushTBQueue, isEmptyTBQueue, readTVar, - writeTBQueue, writeTVar) +import Control.Monad.Class.MonadSTM.Strict (StrictTVar, flushTBQueue, isEmptyTBQueue, + readTVar, readTVarIO, writeTBQueue, writeTVar) import Control.Monad.Extra (mapMaybeM) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except.Extra (hoistEither) @@ -93,19 +93,7 @@ insertEpochInterleaved tracer bop = BulkRewardReport epochNo _ rewardCount total -> do liftIO $ reportRewards epochNo rewardCount lift $ insertEpochRewardTotalReceived epochNo total - BulkStakeDistChunk epochNo _ icache sDistChunk -> - insertEpochStake tracer icache epochNo sDistChunk - BulkStakeDistReport epochNo _ count -> - liftIO $ reportStakeDist epochNo count where - reportStakeDist :: EpochNo -> Int -> IO () - reportStakeDist epochNo count = - logInfo tracer $ - mconcat - [ "insertEpochInterleaved: Epoch ", textShow (unEpochNo epochNo) - , ", ", textShow count, " stake addresses" - ] - reportRewards :: EpochNo -> Int -> IO () reportRewards epochNo rewardCount = logInfo tracer $ @@ -127,18 +115,6 @@ postEpochRewards lenv rwds point = do writeTBQueue (leBulkOpQueue lenv) $ BulkRewardReport epochNo point (length $ Generic.rwdRewards rwds) (sumRewardTotal $ Generic.rwdRewards rwds) -postEpochStake - :: (MonadBaseControl IO m, MonadIO m) - => LedgerEnv -> Generic.StakeDist -> CardanoPoint - -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -postEpochStake lenv smap point = do - icache <- lift $ updateIndexCache lenv (Generic.stakeDistStakeCreds smap) (Generic.stakeDistPoolHashKeys smap) - liftIO . atomically $ do - let epochNo = Generic.sdistEpochNo smap - forM_ (chunksOf 1000 $ Map.toList (Generic.sdistStakeMap smap)) $ \stakeChunk -> - writeTBQueue (leBulkOpQueue lenv) $ BulkStakeDistChunk epochNo point icache stakeChunk - writeTBQueue (leBulkOpQueue lenv) $ BulkStakeDistReport epochNo point (length $ Generic.sdistStakeMap smap) - isEmptyEpochBulkOps :: MonadIO m => LedgerEnv @@ -159,12 +135,26 @@ insertEpochRewardTotalReceived epochNo total = , DB.epochRewardTotalReceivedAmount = Generic.coinToDbLovelace total } +insertStakeSlice + :: (MonadBaseControl IO m, MonadIO m) + => Trace IO Text -> StrictTVar IO IndexCache -> Generic.StakeSliceRes + -> ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertStakeSlice _ _ Generic.NoSlices = pure () +insertStakeSlice tracer cacheVar (Generic.Slice slice finalSlice) = do + cache <- liftIO $ readTVarIO cacheVar + -- cache TVar is not updated. We just use a slice here. + cacheSlice <- lift $ modifyCache (Generic.stakeDistStakeCreds slice) (Generic.stakeDistPoolHashKeys slice) cache + insertEpochStake cacheSlice (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice) + when finalSlice $ do + size <- lift $ DB.queryEpochStakeCount (unEpochNo $ Generic.sliceEpochNo slice) + liftIO . logInfo tracer $ mconcat ["Inserted ", show size, " EpochStake for ", show (Generic.sliceEpochNo slice)] + insertEpochStake :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> IndexCache -> EpochNo + => IndexCache -> EpochNo -> [(Generic.StakeCred, (Shelley.Coin, Generic.StakePoolKeyHash))] -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertEpochStake _tracer icache epochNo stakeChunk = do +insertEpochStake icache epochNo stakeChunk = do dbStakes <- mapM mkStake stakeChunk lift $ DB.insertManyEpochStakes dbStakes where @@ -292,21 +282,22 @@ updateIndexCache -> ReaderT SqlBackend m IndexCache updateIndexCache lenv screds pkhs = do oldCache <- liftIO . atomically $ readTVar (leIndexCache lenv) - newIndexCache <- createNewCache oldCache + newIndexCache <- modifyCache screds pkhs oldCache liftIO . atomically $ writeTVar (leIndexCache lenv) newIndexCache pure newIndexCache - where - createNewCache - :: (MonadBaseControl IO m, MonadIO m) - => IndexCache -> ReaderT SqlBackend m IndexCache - createNewCache oldCache = do - newAddresses <- newAddressCache (icAddressCache oldCache) - newPools <- newPoolCache (icPoolCache oldCache) - pure $ IndexCache - { icAddressCache = newAddresses - , icPoolCache = newPools - } +modifyCache + :: (MonadBaseControl IO m, MonadIO m) + => Set Generic.StakeCred -> Set Generic.StakePoolKeyHash + -> IndexCache -> ReaderT SqlBackend m IndexCache +modifyCache screds pkhs oldCache = do + newAddresses <- newAddressCache (icAddressCache oldCache) + newPools <- newPoolCache (icPoolCache oldCache) + pure $ IndexCache + { icAddressCache = newAddresses + , icPoolCache = newPools + } + where newAddressCache :: (MonadBaseControl IO m, MonadIO m) => Map Generic.StakeCred DB.StakeAddressId diff --git a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs index 1ff2b9416..09fdc83fa 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs @@ -56,7 +56,6 @@ data LedgerEvent = LedgerNewEpoch !EpochNo !SyncState | LedgerStartAtEpoch !EpochNo | LedgerRewards !SlotDetails !Generic.Rewards - | LedgerStakeDist !Generic.StakeDist | LedgerTotalRewards !Generic.Rewards | LedgerDeltaRewards !Generic.Rewards diff --git a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs index 30cb08529..c25afd5fc 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -32,11 +33,11 @@ module Cardano.DbSync.LedgerState , getAlonzoPParams ) where -import Prelude (String, id) +import Prelude (String, fail, id) import Cardano.BM.Trace (Trace, logInfo, logWarning) -import Cardano.Binary (DecoderError) +import Cardano.Binary (Decoder, DecoderError, Encoding, FromCBOR (..), ToCBOR (..)) import qualified Cardano.Binary as Serialize import qualified Cardano.Db as DB @@ -130,8 +131,6 @@ import System.Mem (performMajorGC) data BulkOperation = BulkRewardChunk !EpochNo !CardanoPoint !IndexCache ![(StakeCred, Set Generic.Reward)] | BulkRewardReport !EpochNo !CardanoPoint !Int !Coin - | BulkStakeDistChunk !EpochNo !CardanoPoint !IndexCache ![(StakeCred, (Coin, StakePoolKeyHash))] - | BulkStakeDistReport !EpochNo !CardanoPoint !Int data IndexCache = IndexCache { icAddressCache :: !(Map StakeCred DB.StakeAddressId) @@ -161,21 +160,54 @@ data LedgerEnv = LedgerEnv , leStableEpochSlot :: !EpochSlot } +-- TODO this is unstable in terms of restarts and we should try to remove it. data LedgerEventState = LedgerEventState { lesInitialized :: !Bool , lesEpochNo :: !(Maybe EpochNo) , lesLastRewardsEpoch :: !(Maybe EpochNo) - , lesLastStateDistEpoch :: !(Maybe EpochNo) , lesLastAdded :: !CardanoPoint } topLevelConfig :: LedgerEnv -> TopLevelConfig CardanoBlock topLevelConfig = Consensus.pInfoConfig . leProtocolInfo -newtype CardanoLedgerState = CardanoLedgerState +data CardanoLedgerState = CardanoLedgerState { clsState :: ExtLedgerState CardanoBlock + , clsEpochBlockNo :: EpochBlockNo } +-- The height of the block in the current Epoch. We maintain this +-- data next to the ledger state and store it in the same blob file. +data EpochBlockNo = GenesisEpochBlockNo | EBBEpochBlockNo | EpochBlockNo Word64 + +instance ToCBOR EpochBlockNo where + toCBOR GenesisEpochBlockNo = toCBOR (0 :: Word8) + toCBOR EBBEpochBlockNo = toCBOR (1 :: Word8) + toCBOR (EpochBlockNo n) = + toCBOR (2 :: Word8) <> toCBOR n + +instance FromCBOR EpochBlockNo where + fromCBOR = do + tag :: Word8 <- fromCBOR + case tag of + 0 -> pure GenesisEpochBlockNo + 1 -> pure EBBEpochBlockNo + 2 -> EpochBlockNo <$> fromCBOR + n -> fail $ "unexpected EpochBlockNo value " <> show n + +encodeCardanoLedgerState :: (ExtLedgerState CardanoBlock -> Encoding) + -> CardanoLedgerState -> Encoding +encodeCardanoLedgerState encodeExt cls = mconcat + [ encodeExt (clsState cls) + , toCBOR (clsEpochBlockNo cls) + ] + +decodeCardanoLedgerState :: (forall s. Decoder s (ExtLedgerState CardanoBlock)) + -> (forall s. Decoder s CardanoLedgerState) +decodeCardanoLedgerState decodeExt = do + ldgrState <- decodeExt + CardanoLedgerState ldgrState <$> fromCBOR + data LedgerStateFile = LedgerStateFile { lsfSlotNo :: !SlotNo , lsfHash :: !ByteString @@ -189,6 +221,7 @@ data LedgerStateSnapshot = LedgerStateSnapshot , lssNewEpoch :: !(Strict.Maybe Generic.NewEpoch) -- Only Just for a single block at the epoch boundary , lssSlotDetails :: !SlotDetails , lssPoint :: !CardanoPoint + , lssStakeSlice :: !Generic.StakeSliceRes , lssEvents :: ![LedgerEvent] } @@ -259,7 +292,6 @@ mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do { lesInitialized = False , lesEpochNo = Nothing , lesLastRewardsEpoch = Nothing - , lesLastStateDistEpoch = Nothing , lesLastAdded = GenesisPoint } @@ -267,6 +299,7 @@ mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do initCardanoLedgerState :: Consensus.ProtocolInfo IO CardanoBlock -> CardanoLedgerState initCardanoLedgerState pInfo = CardanoLedgerState { clsState = Consensus.pInfoInitLedger pInfo + , clsEpochBlockNo = GenesisEpochBlockNo } -- TODO make this type safe. We make the assumption here that the first message of @@ -291,18 +324,22 @@ applyBlock env blk = do ledgerDB <- readStateUnsafe env let oldState = ledgerDbCurrent ledgerDB let !result = applyBlk (ExtLedgerCfg (topLevelConfig env)) blk (clsState oldState) - let !newState = oldState { clsState = lrResult result } - details <- getSlotDetails env (ledgerState $ clsState newState) time (cardanoBlockSlotNo blk) + let !newLedgerState = lrResult result + details <- getSlotDetails env (ledgerState newLedgerState) time (cardanoBlockSlotNo blk) + let !newEpoch = mkNewEpoch (clsState oldState) newLedgerState + let !newEpochBlockNo = applyToEpochBlockNo (isJust $ blockIsEBB blk) (isJust newEpoch) (clsEpochBlockNo oldState) + let !newState = CardanoLedgerState newLedgerState newEpochBlockNo let !ledgerDB' = pushLedgerDB ledgerDB newState writeTVar (leStateVar env) (Just ledgerDB') oldEventState <- readTVar (leEventState env) - events <- generateEvents env oldEventState details newState (blockPoint blk) + events <- generateEvents env oldEventState details newState (blockPoint blk) pure $ LedgerStateSnapshot { lssState = newState , lssOldState = oldState - , lssNewEpoch = maybeToStrict $ mkNewEpoch oldState newState + , lssNewEpoch = maybeToStrict newEpoch , lssSlotDetails = details , lssPoint = blockPoint blk + , lssStakeSlice = stakeSlice newState details , lssEvents = events ++ mapMaybe (convertAuxLedgerEvent (leNetwork env)) (lrEvents result) } where @@ -315,7 +352,7 @@ applyBlock env blk = do Left err -> panic err Right result -> result - mkNewEpoch :: CardanoLedgerState -> CardanoLedgerState -> Maybe Generic.NewEpoch + mkNewEpoch :: ExtLedgerState CardanoBlock -> ExtLedgerState CardanoBlock -> Maybe Generic.NewEpoch mkNewEpoch oldState newState = if ledgerEpochNo env newState /= ledgerEpochNo env oldState + 1 then Nothing @@ -325,16 +362,36 @@ applyBlock env blk = do { Generic.neEpoch = ledgerEpochNo env newState , Generic.neIsEBB = isJust $ blockIsEBB blk , Generic.neAdaPots = maybeToStrict $ getAdaPots newState - , Generic.neEpochUpdate = Generic.epochUpdate (clsState newState) + , Generic.neEpochUpdate = Generic.epochUpdate newState } + applyToEpochBlockNo :: Bool -> Bool -> EpochBlockNo -> EpochBlockNo + applyToEpochBlockNo True _ _ = EBBEpochBlockNo + applyToEpochBlockNo _ True _ = EpochBlockNo 0 + applyToEpochBlockNo _ _ (EpochBlockNo n) = EpochBlockNo (n + 1) + applyToEpochBlockNo _ _ GenesisEpochBlockNo = EpochBlockNo 0 + applyToEpochBlockNo _ _ EBBEpochBlockNo = EpochBlockNo 0 + + stakeSliceMinSize :: Word64 + stakeSliceMinSize = 2000 + + stakeSlice :: CardanoLedgerState -> SlotDetails -> Generic.StakeSliceRes + stakeSlice cls details = case clsEpochBlockNo cls of + EpochBlockNo n -> Generic.getStakeSlice + (leProtocolInfo env) + (leNetwork env) + (sdEpochNo details) + n + stakeSliceMinSize + (clsState cls) + _ -> Generic.NoSlices + generateEvents :: LedgerEnv -> LedgerEventState -> SlotDetails -> CardanoLedgerState -> CardanoPoint -> STM [LedgerEvent] generateEvents env oldEventState details cls pnt = do writeTVar (leEventState env) newEventState pure $ catMaybes [ newEpochEvent , LedgerRewards details <$> rewards - , LedgerStakeDist <$> stakeDist ] where currentEpochNo :: EpochNo @@ -359,22 +416,9 @@ generateEvents env oldEventState details cls pnt = do then mkRewards else Nothing - mkRewards :: Maybe Generic.Rewards mkRewards = Generic.epochRewards (leNetwork env) (sdEpochNo details) (clsState cls) - stakeDist :: Maybe Generic.StakeDist - stakeDist = - case lesLastStateDistEpoch oldEventState of - Nothing -> mkStakeDist - Just oldStakeEpoch -> - if oldStakeEpoch < currentEpochNo - then mkStakeDist - else Nothing - - mkStakeDist :: Maybe Generic.StakeDist - mkStakeDist = Generic.epochStakeDist (leNetwork env) (sdEpochNo details) (clsState cls) - newEventState :: LedgerEventState newEventState = LedgerEventState @@ -384,19 +428,15 @@ generateEvents env oldEventState details cls pnt = do if isJust rewards then Just currentEpochNo else lesLastRewardsEpoch oldEventState - , lesLastStateDistEpoch = - if isJust stakeDist - then Just currentEpochNo - else lesLastStateDistEpoch oldEventState , lesLastAdded = - if isNothing rewards && isNothing stakeDist + if isNothing rewards then lesLastAdded oldEventState else pnt } -saveCurrentLedgerState :: LedgerEnv -> ExtLedgerState CardanoBlock -> Maybe EpochNo -> IO () +saveCurrentLedgerState :: LedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () saveCurrentLedgerState env ledger mEpochNo = do - case mkLedgerStateFilename (leDir env) ledger mEpochNo of + case mkLedgerStateFilename (leDir env) (clsState ledger) mEpochNo of Origin -> pure () -- we don't store genesis At file -> do exists <- doesFileExist file @@ -406,11 +446,12 @@ saveCurrentLedgerState env ledger mEpochNo = do else do LBS.writeFile file $ Serialize.serializeEncoding $ - Consensus.encodeExtLedgerState - (encodeDisk codecConfig) - (encodeDisk codecConfig) - (encodeDisk codecConfig) - ledger + encodeCardanoLedgerState + (Consensus.encodeExtLedgerState + (encodeDisk codecConfig) + (encodeDisk codecConfig) + (encodeDisk codecConfig)) + ledger logInfo (leTrace env) $ mconcat ["Took a ledger snapshot at ", Text.pack file] where codecConfig :: CodecConfig CardanoBlock @@ -423,7 +464,7 @@ mkLedgerStateFilename dir ledger mEpochNo = lsfFilePath . dbPointToFileName dir saveCleanupState :: LedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () saveCleanupState env ledger mEpochNo = do let st = clsState ledger - saveCurrentLedgerState env st mEpochNo + saveCurrentLedgerState env ledger mEpochNo cleanupLedgerStateFiles env $ fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState st) @@ -639,9 +680,9 @@ loadLedgerStateFromFile config delete lsf = do mst <- safeReadFile (lsfFilePath lsf) case mst of Left err -> when delete (safeRemoveFile $ lsfFilePath lsf) >> pure (Left err) - Right st -> pure . Right $ CardanoLedgerState { clsState = st } + Right st -> pure $ Right st where - safeReadFile :: FilePath -> IO (Either Text (ExtLedgerState CardanoBlock)) + safeReadFile :: FilePath -> IO (Either Text CardanoLedgerState) safeReadFile fp = do mbs <- Exception.try $ BS.readFile fp case mbs of @@ -654,16 +695,21 @@ loadLedgerStateFromFile config delete lsf = do codecConfig :: CodecConfig CardanoBlock codecConfig = configCodec config - decode :: ByteString -> Either DecoderError (ExtLedgerState CardanoBlock) - decode = + decode :: ByteString -> Either DecoderError CardanoLedgerState + decode = do Serialize.decodeFullDecoder "Ledger state file" - (Consensus.decodeExtLedgerState - (decodeDisk codecConfig) - (decodeDisk codecConfig) - (decodeDisk codecConfig)) + decodeState . LBS.fromStrict + decodeState :: (forall s. Decoder s CardanoLedgerState) + decodeState = + decodeCardanoLedgerState $ + Consensus.decodeExtLedgerState + (decodeDisk codecConfig) + (decodeDisk codecConfig) + (decodeDisk codecConfig) + -- Get a list of the ledger state files order most recent listLedgerStateFilesOrdered :: LedgerStateDir -> IO [LedgerStateFile] listLedgerStateFilesOrdered dir = do @@ -702,18 +748,18 @@ getPoolParamsShelley lState = -- We only compute 'AdaPots' for later eras. This is a time consuming -- function and we only want to run it on epoch boundaries. -getAdaPots :: CardanoLedgerState -> Maybe Shelley.AdaPots +getAdaPots :: ExtLedgerState CardanoBlock -> Maybe Shelley.AdaPots getAdaPots st = - case ledgerState $ clsState st of + case ledgerState st of LedgerStateByron _ -> Nothing LedgerStateShelley sts -> Just $ totalAdaPots sts LedgerStateAllegra sta -> Just $ totalAdaPots sta LedgerStateMary stm -> Just $ totalAdaPots stm LedgerStateAlonzo sta -> Just $ totalAdaPots sta -ledgerEpochNo :: LedgerEnv -> CardanoLedgerState -> EpochNo +ledgerEpochNo :: LedgerEnv -> ExtLedgerState CardanoBlock -> EpochNo ledgerEpochNo env cls = - case ledgerTipSlot (ledgerState (clsState cls)) of + case ledgerTipSlot (ledgerState cls) of Origin -> 0 -- An empty chain is in epoch 0 NotOrigin slot -> case runExcept $ epochInfoEpoch epochInfo slot of @@ -721,7 +767,7 @@ ledgerEpochNo env cls = Right en -> en where epochInfo :: EpochInfo (Except Consensus.PastHorizonException) - epochInfo = epochInfoLedger (configLedger $ topLevelConfig env) (hardForkLedgerStatePerEra . ledgerState $ clsState cls) + epochInfo = epochInfoLedger (configLedger $ topLevelConfig env) (hardForkLedgerStatePerEra $ ledgerState cls) -- Like 'Consensus.tickThenReapply' but also checks that the previous hash from the block matches -- the head hash of the ledger state. diff --git a/cardano-db/src/Cardano/Db/Query.hs b/cardano-db/src/Cardano/Db/Query.hs index 32044ae25..146f84424 100644 --- a/cardano-db/src/Cardano/Db/Query.hs +++ b/cardano-db/src/Cardano/Db/Query.hs @@ -57,6 +57,7 @@ module Cardano.Db.Query , queryTxOutCount , queryTxOutValue , queryTxOutCredentials + , queryEpochStakeCount , queryUtxoAtBlockNo , queryUtxoAtSlotNo , queryWithdrawalsUpToBlockNo @@ -742,6 +743,13 @@ queryUtxoAtBlockId blkid = do (out, Value (Just hash')) -> Just (entityVal out, hash') (_, Value Nothing) -> Nothing +queryEpochStakeCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 +queryEpochStakeCount epoch = do + res <- select $ do + epochStake <- from $ table @ EpochStake + where_ (epochStake ^. EpochStakeEpochNo ==. val epoch) + pure countRows + pure $ maybe 0 unValue (listToMaybe res) queryUtxoAtBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(TxOut, ByteString)] queryUtxoAtBlockNo blkNo = do diff --git a/schema/migration-2-0011-20220318.sql b/schema/migration-2-0011-20220318.sql new file mode 100644 index 000000000..fd5791fab --- /dev/null +++ b/schema/migration-2-0011-20220318.sql @@ -0,0 +1,21 @@ +-- Persistent generated migration. + +CREATE FUNCTION migrate() RETURNS void AS $$ +DECLARE + next_version int ; +BEGIN + SELECT stage_two + 1 INTO next_version FROM schema_version ; + IF next_version = 11 THEN + EXECUTE 'ALTER TABLE "block" ALTER COLUMN "slot_no" TYPE word63type' ; + EXECUTE 'ALTER TABLE "ada_pots" ALTER COLUMN "slot_no" TYPE word63type' ; + EXECUTE 'ALTER TABLE "delegation" ALTER COLUMN "slot_no" TYPE word63type' ; + -- Hand written SQL statements can be added here. + UPDATE schema_version SET stage_two = next_version ; + RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ; + END IF ; +END ; +$$ LANGUAGE plpgsql ; + +SELECT migrate() ; + +DROP FUNCTION migrate() ; From 5e9c93c3f9800ba1b6ea23181875f88cdd9819da Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Fri, 25 Mar 2022 15:56:56 +0200 Subject: [PATCH 04/11] Tests for Stake Slices --- cardano-chain-gen/cardano-chain-gen.cabal | 1 + .../src/Cardano/Mock/Forging/Examples.hs | 42 ++++++ .../src/Cardano/Mock/Forging/Tx/Alonzo.hs | 20 ++- .../src/Cardano/Mock/Forging/Tx/Generic.hs | 24 ++++ .../test/Test/Cardano/Db/Mock/UnifiedApi.hs | 8 ++ .../test/Test/Cardano/Db/Mock/Unit.hs | 132 ++++++++++++++++++ .../test/Test/Cardano/Db/Mock/Validate.hs | 27 +++- .../test/testfiles/config/genesis.byron.json | 2 +- .../test/testfiles/config/test-config.json | 2 +- .../testfiles/fingerprint/delegations2000 | 1 + .../testfiles/fingerprint/delegations2001 | 1 + .../testfiles/fingerprint/delegations8000 | 1 + .../testfiles/fingerprint/delegationsMany | 1 + .../fingerprint/delegationsManyNotDense | 1 + .../testfiles/fingerprint/stakeDistGenesis | 1 + 15 files changed, 258 insertions(+), 6 deletions(-) create mode 100644 cardano-chain-gen/src/Cardano/Mock/Forging/Examples.hs create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/delegations2000 create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/delegations2001 create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/delegations8000 create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/delegationsMany create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/delegationsManyNotDense create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/stakeDistGenesis diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index da756c2bf..fc0fb4d44 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -45,6 +45,7 @@ library Cardano.Mock.ChainSync.Server Cardano.Mock.ChainSync.State Cardano.Mock.Forging.Crypto + Cardano.Mock.Forging.Examples Cardano.Mock.Forging.Interpreter Cardano.Mock.Forging.Tx.Alonzo Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Examples.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Examples.hs new file mode 100644 index 000000000..f20a6e11e --- /dev/null +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Examples.hs @@ -0,0 +1,42 @@ +module Cardano.Mock.Forging.Examples where + +import Cardano.Prelude hiding (length, (.)) + +import Data.List.Extra + +import Cardano.Ledger.Mary.Value +import Cardano.Ledger.Shelley.API +import Cardano.Mock.Forging.Interpreter +import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo +import Cardano.Mock.Forging.Tx.Generic +import Cardano.Mock.Forging.Types + +delegateAndSendBlocks :: Int -> Interpreter -> IO [CardanoBlock] +delegateAndSendBlocks n interpreter = do + addrFrom <- withAlonzoLedgerState interpreter $ resolveAddress (UTxOIndex 0) + registerBlocks <- forM (chunksOf 500 creds) $ \blockCreds -> do + blockTxs <- withAlonzoLedgerState interpreter $ \_st -> + forM (chunksOf 10 blockCreds) $ \txCreds -> -- 10 per tx + Alonzo.mkDCertTx (fmap (DCertDeleg . RegKey) txCreds) (Wdrl mempty) + forgeNextFindLeader interpreter (TxAlonzo <$> blockTxs) + + delegateBlocks <- forM (chunksOf 500 creds) $ \blockCreds -> do + blockTxs <- withAlonzoLedgerState interpreter $ \st -> + forM (chunksOf 10 blockCreds) $ \txCreds -> --do -- 10 per tx + Alonzo.mkDCertTx + (fmap (\ (poolIx, cred) -> DCertDeleg $ Delegate $ Delegation cred (resolvePool (PoolIndex poolIx) st)) + (zip (cycle [0,1,2]) txCreds)) + (Wdrl mempty) + forgeNextFindLeader interpreter (TxAlonzo <$> blockTxs) + + let utxoIndex = UTxOAddress addrFrom + sendBlocks <- forM (chunksOf 500 addresses) $ \blockAddresses -> do + blockTxs <- withAlonzoLedgerState interpreter $ \st -> + forM (chunksOf 10 blockAddresses) $ \txAddresses -> + Alonzo.mkPaymentTx' utxoIndex (fmap (\addr -> (UTxOAddress addr, Value 1 mempty)) txAddresses) st + forgeNextFindLeader interpreter (TxAlonzo <$> blockTxs) + pure $ registerBlocks <> delegateBlocks <> sendBlocks + where + creds = createStakeCredentials n + pcreds = createPaymentCredentials n + addresses = fmap (\(pcred, cred) -> Addr Testnet pcred (StakeRefBase cred)) (zip pcreds creds) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs index 634175ee3..5d254f97a 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs @@ -10,7 +10,7 @@ module Cardano.Mock.Forging.Tx.Alonzo where -import Cardano.Prelude hiding ((.)) +import Cardano.Prelude hiding (sum, (.)) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) @@ -116,6 +116,24 @@ mkPaymentTx inputIndex outputIndex amount fees sta = do change = TxOut addr' (valueFromList (fromIntegral $ fromIntegral inputValue - amount - fees) []) Strict.SNothing Right $ mkSimpleTx True $ consPaymentTxBody input mempty (StrictSeq.fromList [output, change]) (Coin fees) mempty +mkPaymentTx' :: AlonzoUTxOIndex + -> [(AlonzoUTxOIndex, Value StandardCrypto)] + -> AlonzoLedgerState + -> Either ForgingError (ValidatedTx (AlonzoEra StandardCrypto)) +mkPaymentTx' inputIndex outputIndex sta = do + inputPair <- fst <$> resolveUTxOIndex inputIndex sta + outps <- mapM mkOuts outputIndex + + let inps = Set.singleton $ fst inputPair + TxOut addr' (Value inputValue _) _ = snd inputPair + outValue = sum ((\ (Value vl _) -> vl) . snd <$> outputIndex) + change = TxOut addr' (valueFromList (fromIntegral $ fromIntegral inputValue - outValue) []) Strict.SNothing + Right $ mkSimpleTx True $ consPaymentTxBody inps mempty (StrictSeq.fromList $ outps ++ [change]) (Coin 0) mempty + where + mkOuts (outIx, vl) = do + addr <- resolveAddress outIx sta + Right $ TxOut addr vl Strict.SNothing + mkLockByScriptTx :: AlonzoUTxOIndex -> [Bool] -> Integer -> Integer -> AlonzoLedgerState -> Either ForgingError (ValidatedTx (AlonzoEra StandardCrypto)) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs index 950ac7a5d..c42d7631a 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs @@ -11,10 +11,14 @@ module Cardano.Mock.Forging.Tx.Generic , resolveUTxOIndex , resolveStakeCreds , resolvePool + , createStakeCredentials + , createPaymentCredentials + , mkDummyScriptHash ) where import Cardano.Prelude hiding (length, (.)) +import Data.Coerce (coerce) import qualified Data.Compact.SplitMap as SplitMap import Data.List (nub) import Data.List.Extra ((!?)) @@ -26,7 +30,9 @@ import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential +import Cardano.Ledger.Crypto (ADDRHASH) import Cardano.Ledger.Era (Crypto) +import Cardano.Ledger.Hashes (ScriptHash (ScriptHash)) import Cardano.Ledger.Keys import Cardano.Ledger.Shelley.LedgerState hiding (LedgerState) import Cardano.Ledger.Shelley.TxBody @@ -38,6 +44,10 @@ import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus +import Cardano.Binary (ToCBOR (..)) +import Cardano.Crypto.Hash (HashAlgorithm) +import qualified Cardano.Crypto.Hash as Hash + import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples import Cardano.Mock.Forging.Types @@ -163,3 +173,17 @@ unregisteredPools = , KeyHash "222462543264795t3298745680239746523897456238974563298348" , KeyHash "33323876542397465497834256329487563428975634827956348975" ] + +createStakeCredentials :: Int -> [StakeCredential StandardCrypto] +createStakeCredentials n = + fmap (KeyHashObj . KeyHash . mkDummyHash (Proxy @(ADDRHASH StandardCrypto))) [1..n] + +createPaymentCredentials :: Int -> [PaymentCredential StandardCrypto] +createPaymentCredentials n = + fmap (KeyHashObj . KeyHash . mkDummyHash (Proxy @(ADDRHASH StandardCrypto))) [1..n] + +mkDummyScriptHash :: Int -> ScriptHash StandardCrypto +mkDummyScriptHash n = ScriptHash $ mkDummyHash (Proxy @(ADDRHASH StandardCrypto)) n + +mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash.Hash h a +mkDummyHash _ = coerce . hashWithSerialiser @h toCBOR diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs index b99a85e4d..e9256348f 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs @@ -1,6 +1,7 @@ module Test.Cardano.Db.Mock.UnifiedApi ( forgeNextAndSubmit , forgeNextFindLeaderAndSubmit + , forgeNextSkipSlotsFindLeaderAndSubmit , forgeAndSubmitBlocks , withAlonzoFindLeaderAndSubmit , withAlonzoFindLeaderAndSubmitTx @@ -14,6 +15,7 @@ module Test.Cardano.Db.Mock.UnifiedApi , registerAllStakeCreds ) where +import Data.Word (Word64) import Cardano.Slotting.Slot (SlotNo (..)) @@ -43,6 +45,12 @@ forgeNextFindLeaderAndSubmit interpreter mockServer txs' = do atomically $ addBlock mockServer blk pure blk +forgeNextSkipSlotsFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> Word64 -> [TxEra] -> IO CardanoBlock +forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer skipSlots txs' = do + blk <- forgeNextAfter interpreter skipSlots txs' + atomically $ addBlock mockServer blk + pure blk + forgeAndSubmitBlocks :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock] forgeAndSubmitBlocks interpreter mockServer blocksToCreate = do forM [1..blocksToCreate] $ \_ -> forgeNextFindLeaderAndSubmit interpreter mockServer [] diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs index db5588b6b..b9bd910e5 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs @@ -37,6 +37,7 @@ import Cardano.SMASH.Server.PoolDataLayer import Cardano.SMASH.Server.Types import Cardano.Mock.ChainSync.Server +import Cardano.Mock.Forging.Examples import Cardano.Mock.Forging.Interpreter import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples @@ -96,6 +97,14 @@ unitTests iom knownMigrations = , test "rollback on epoch boundary" rollbackBoundary , test "single MIR Cert multiple outputs" singleMIRCertMultiOut ] + , testGroup "stake distribution" + [ test "stake distribution from genesis" stakeDistGenesis + , test "2000 delegations" delegations2000 + , test "2001 delegations" delegations2001 + , test "8000 delegations" delegations8000 + , test "many delegations" delegationsMany + , test "many delegations, not dense chain" delegationsManyNotDense + ] , testGroup "plutus spend scripts" [ test "simple script lock" simpleScript , test "unlock script in same block" unlockScriptSameBlock @@ -843,6 +852,129 @@ singleMIRCertMultiOut = where testLabel = "singleMIRCertMultiOut" +stakeDistGenesis :: IOManager -> [(Text, Text)] -> Assertion +stakeDistGenesis = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + a <- fillUntilNextEpoch interpreter mockServer + assertBlockNoBackoff dbSync (fromIntegral $ length a) + -- There are 5 delegations in genesis + assertEpochStake dbSync 5 + where + testLabel = "stakeDistGenesis" + +delegations2000 :: IOManager -> [(Text, Text)] -> Assertion +delegations2000 = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + a <- delegateAndSendBlocks 1995 interpreter + forM_ a $ atomically . addBlock mockServer + b <- fillUntilNextEpoch interpreter mockServer + c <- fillUntilNextEpoch interpreter mockServer + + assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) + -- There are exactly 2000 entries on the second epoch, 5 from genesis and 1995 manually added + assertEpochStakeEpoch dbSync 2 2000 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) + assertEpochStakeEpoch dbSync 2 2000 + where + testLabel = "delegations2000" + +delegations2001 :: IOManager -> [(Text, Text)] -> Assertion +delegations2001 = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + a <- delegateAndSendBlocks 1996 interpreter + forM_ a $ atomically . addBlock mockServer + b <- fillUntilNextEpoch interpreter mockServer + c <- fillUntilNextEpoch interpreter mockServer + + assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) + -- The first block of epoch inserts 2000 out of 2001 epoch distribution. + assertEpochStakeEpoch dbSync 2 2000 + -- The remaining entry is inserted on the next block. + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) + assertEpochStakeEpoch dbSync 2 2001 + where + testLabel = "delegations2001" + +delegations8000 :: IOManager -> [(Text, Text)] -> Assertion +delegations8000 = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + a <- delegateAndSendBlocks 7995 interpreter + forM_ a $ atomically . addBlock mockServer + b <- fillEpochs interpreter mockServer 3 + + assertBlockNoBackoff dbSync (fromIntegral $ length a + length b) + assertEpochStakeEpoch dbSync 3 2000 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertEpochStakeEpoch dbSync 3 4000 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertEpochStakeEpoch dbSync 3 6000 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertEpochStakeEpoch dbSync 3 8000 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertEpochStakeEpoch dbSync 3 8000 + where + testLabel = "delegations8000" + +delegationsMany :: IOManager -> [(Text, Text)] -> Assertion +delegationsMany = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + a <- delegateAndSendBlocks 40000 interpreter + forM_ a $ atomically . addBlock mockServer + b <- fillEpochs interpreter mockServer 5 + + -- too long. We cannot use default delays + assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b) + -- The slice size here is + -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 + -- instead of 2000, because there are many delegations + assertEpochStakeEpoch dbSync 7 2001 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertEpochStakeEpoch dbSync 7 4002 + + _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + assertEpochStakeEpoch dbSync 7 6003 + where + testLabel = "delegationsMany" + +delegationsManyNotDense :: IOManager -> [(Text, Text)] -> Assertion +delegationsManyNotDense = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + a <- delegateAndSendBlocks 40000 interpreter + forM_ a $ atomically . addBlock mockServer + b <- fillEpochs interpreter mockServer 5 + + -- too long. We cannot use default delays + assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b) + -- The slice size here is + -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 + -- instead of 2000, because there are many delegations + assertEpochStakeEpoch dbSync 7 2001 + + -- Blocks come on average every 5 slots. If we skip 15 slots before each block, + -- we are expected to get only 1/4 of the expected blocks. The adjusted slices + -- should still be long enough to cover everything. + replicateM_ 40 $ + forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] + + -- Even if the chain is not dense, all distributions are inserted. + assertEpochStakeEpoch dbSync 7 40005 + where + testLabel = "delegationsManyNotDense" + simpleScript :: IOManager -> [(Text, Text)] -> Assertion simpleScript = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs index c3e4b7acd..43a52b743 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -25,7 +25,7 @@ import Data.Word (Word64) import GHC.Records (HasField (..)) import Database.Esqueleto.Legacy (InnerJoin (..), SqlExpr, countRows, from, on, select, - unValue, (==.), (^.)) + unValue, val, where_, (==.), (^.)) import Database.Persist.Sql (Entity, SqlBackend, entityVal) import Database.PostgreSQL.Simple (SqlError (..)) @@ -66,8 +66,11 @@ assertRewardCount env n = assertEqBackoff env queryRewardCount n defaultDelays "Unexpected rewards count" assertBlockNoBackoff :: DBSyncEnv -> Int -> IO () -assertBlockNoBackoff env blockNo = - assertEqBackoff env queryBlockHeight (Just $ fromIntegral blockNo) defaultDelays "Unexpected BlockNo" +assertBlockNoBackoff = assertBlockNoBackoffTimes defaultDelays + +assertBlockNoBackoffTimes :: [Int] -> DBSyncEnv -> Int -> IO () +assertBlockNoBackoffTimes times env blockNo = + assertEqBackoff env queryBlockHeight (Just $ fromIntegral blockNo) times "Unexpected BlockNo" defaultDelays :: [Int] defaultDelays = [1,2,4,8,16,32,64,128] @@ -201,6 +204,24 @@ assertRewardCounts env st filterAddr expected = do pure (reward, stake_addr ^. StakeAddressHashRaw) pure $ fmap (bimap entityVal unValue) res +assertEpochStake :: DBSyncEnv -> Word64 -> IO () +assertEpochStake env expected = + assertEqBackoff env q expected defaultDelays "Unexpected epoch stake counts" + where + q = + maybe 0 unValue . listToMaybe <$> + (select . from $ \(_a :: SqlExpr (Entity EpochStake)) -> pure countRows) + +assertEpochStakeEpoch :: DBSyncEnv -> Word64 -> Word64 -> IO () +assertEpochStakeEpoch env e expected = + assertEqBackoff env q expected defaultDelays "Unexpected epoch stake counts" + where + q = + maybe 0 unValue . listToMaybe <$> + (select . from $ \(a :: SqlExpr (Entity EpochStake)) -> do + where_ (a ^. EpochStakeEpochNo ==. val e) + pure countRows + ) assertAlonzoCounts :: DBSyncEnv -> (Word64, Word64, Word64, Word64, Word64, Word64, Word64, Word64) -> IO () assertAlonzoCounts env expected = diff --git a/cardano-chain-gen/test/testfiles/config/genesis.byron.json b/cardano-chain-gen/test/testfiles/config/genesis.byron.json index cf088f937..25ced6be5 100644 --- a/cardano-chain-gen/test/testfiles/config/genesis.byron.json +++ b/cardano-chain-gen/test/testfiles/config/genesis.byron.json @@ -26,6 +26,6 @@ { "summand": "155381000000000" , "multiplier": "43946000000" } , "unlockStakeEpoch": "18446744073709551615" } -, "protocolConsts": { "k": 216 , "protocolMagic": 42 } +, "protocolConsts": { "k": 10 , "protocolMagic": 42 } , "avvmDistr": {} } diff --git a/cardano-chain-gen/test/testfiles/config/test-config.json b/cardano-chain-gen/test/testfiles/config/test-config.json index 60a3306d4..64e59bf85 100644 --- a/cardano-chain-gen/test/testfiles/config/test-config.json +++ b/cardano-chain-gen/test/testfiles/config/test-config.json @@ -4,7 +4,7 @@ "ApplicationName": "cardano-sl", "ApplicationVersion": 0, "ByronGenesisFile": "genesis.byron.json", - "ByronGenesisHash": "462bb9869a5a6e4325cc294ca659d68607e8a6f37b5be96ea663fdedfe2b5949", + "ByronGenesisHash": "865a9da19944fc00cefe5a0cdcb6dc9d3964a74681d9488ab79967f13a6400b3", "LastKnownBlockVersion-Alt": 0, "LastKnownBlockVersion-Major": 5, "LastKnownBlockVersion-Minor": 1, diff --git a/cardano-chain-gen/test/testfiles/fingerprint/delegations2000 b/cardano-chain-gen/test/testfiles/fingerprint/delegations2000 new file mode 100644 index 000000000..4d2459b37 --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/delegations2000 @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1001,1002] \ No newline at end of file diff --git a/cardano-chain-gen/test/testfiles/fingerprint/delegations2001 b/cardano-chain-gen/test/testfiles/fingerprint/delegations2001 new file mode 100644 index 000000000..ba65fd934 --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/delegations2001 @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1002,1005] \ No newline at end of file diff --git a/cardano-chain-gen/test/testfiles/fingerprint/delegations8000 b/cardano-chain-gen/test/testfiles/fingerprint/delegations8000 new file mode 100644 index 000000000..82b8fd9f2 --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/delegations8000 @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1007,1014,1016,1021,1031,1038,1052,1056,1063,1066,1068,1069,1071,1086,1111,1114,1132,1133,1135,1140,1141,1143,1147,1157,1164,1166,1184,1192,1194,1201,1208,1210,1217,1224,1227,1249,1250,1251,1258,1259,1271,1275,1277,1280,1287,1291,1292,1295,1298,1301,1302,1305,1312,1317,1320,1331,1335,1340,1342,1345,1350,1356,1358,1364,1368,1383,1384,1388,1389,1396,1410,1423,1429,1434,1438,1442,1444,1445,1446,1448,1450,1456,1462,1470,1471,1476,1478,1480,1482,1484,1491,1492,1493,1503,1505,1508,1517,1518] \ No newline at end of file diff --git a/cardano-chain-gen/test/testfiles/fingerprint/delegationsMany b/cardano-chain-gen/test/testfiles/fingerprint/delegationsMany new file mode 100644 index 000000000..15ca95847 --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/delegationsMany @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1001,1003,1005,1008,1013,1015,1017,1023,1035,1039,1046,1049,1053,1064,1065,1077,1078,1082,1085,1092,1098,1104,1118,1120,1131,1138,1140,1152,1153,1158,1163,1166,1173,1175,1176,1194,1197,1213,1214,1220,1221,1222,1223,1225,1229,1230,1231,1232,1236,1243,1244,1245,1247,1248,1251,1273,1293,1307,1309,1312,1324,1325,1330,1335,1340,1341,1349,1351,1356,1361,1370,1373,1377,1391,1399,1406,1408,1410,1417,1418,1420,1429,1431,1458,1462,1470,1476,1478,1480,1485,1489,1494,1495,1506,1507,1514,1518,1522,1523,1524,1526,1528,1529,1530,1536,1539,1554,1556,1560,1561,1570,1589,1598,1608,1615,1618,1619,1632,1633,1636,1639,1641,1645,1648,1654,1661,1667,1680,1681,1684,1690,1695,1696,1697,1700,1701,1702,1711,1721,1725,1728,1731,1733,1735,1739,1742,1745,1747,1749,1750,1756,1760,1788,1790,1796,1798,1804,1809,1812,1822,1824,1829,1837,1840,1843,1844,1845,1862,1878,1881,1885,1888,1889,1890,1892,1903,1905,1915,1920,1921,1926,1929,1937,1941,1955,1957,1966,1971,1979,1991,1994,1995,1997,2008,2009,2011,2014,2025,2029,2032,2035,2037,2041,2051,2054,2063,2069,2071,2073,2079,2083,2088,2090,2092,2095,2100,2106,2123,2127,2135,2137,2141,2142,2144,2153,2165,2166,2171,2173,2184,2192,2198,2203,2206,2211,2212,2216,2218,2224,2226,2234,2236,2245,2252,2256,2257,2260,2262,2263,2268,2269,2271,2274,2282,2283,2285,2291,2308,2310,2313,2319,2329,2333,2338,2356,2359,2361,2369,2374,2375,2376,2378,2381,2384,2396,2403,2413,2431,2441,2448,2450,2452,2453,2456,2471,2484,2485,2487,2488,2495,2503,2505,2506,2515,2516,2517,2518,2522,2523,2526,2530,2541,2545,2546,2549,2551,2554,2555,2558,2560,2561,2563,2566,2573,2581,2588,2589,2591,2595,2596,2597,2619,2625,2630,2643,2644,2645,2646,2647,2653,2655,2660,2662,2673,2675,2677,2678,2683,2684,2690,2692,2697,2700,2705,2706,2710,2712,2713,2714,2727,2731,2741,2743,2759,2763,2765,2778,2779,2802,2809,2819,2820,2834,2837,2838,2856,2865,2878,2883,2889,2899,2901,2904,2907,2911,2913,2919,2924,2927,2933,2942,2951,2957,2963,2967,2977,2978,2980,2984,2991,2992,2993,2999,3007,3008,3021,3031,3032,3050,3053,3062,3074,3080,3086,3087,3090,3100,3102,3103,3104,3105,3109,3110,3113,3114,3118,3123,3124,3126,3132,3137,3139,3142,3145,3159,3165,3175,3188,3193,3199,3204,3206,3210,3213,3217,3219,3221,3223,3225,3227,3235,3236,3244,3246,3251,3262,3264,3270,3273,3280,3284,3287,3288,3291,3300,3301,3303,3304,3305,3330,3335,3338,3343,3344,3351,3364,3365,3366,3378,3385,3386,3398,3400,3411,3415,3429,3430,3432,3435,3436,3439,3444,3446,3447,3453,3460,3462,3463,3475,3478,3480,3481,3487,3494,3497,3501,3502,3510] \ No newline at end of file diff --git a/cardano-chain-gen/test/testfiles/fingerprint/delegationsManyNotDense b/cardano-chain-gen/test/testfiles/fingerprint/delegationsManyNotDense new file mode 100644 index 000000000..a8e7643d8 --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/delegationsManyNotDense @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1001,1003,1005,1008,1013,1015,1017,1023,1035,1039,1046,1049,1053,1064,1065,1077,1078,1082,1085,1092,1098,1104,1118,1120,1131,1138,1140,1152,1153,1158,1163,1166,1173,1175,1176,1194,1197,1213,1214,1220,1221,1222,1223,1225,1229,1230,1231,1232,1236,1243,1244,1245,1247,1248,1251,1273,1293,1307,1309,1312,1324,1325,1330,1335,1340,1341,1349,1351,1356,1361,1370,1373,1377,1391,1399,1406,1408,1410,1417,1418,1420,1429,1431,1458,1462,1470,1476,1478,1480,1485,1489,1494,1495,1506,1507,1514,1518,1522,1523,1524,1526,1528,1529,1530,1536,1539,1554,1556,1560,1561,1570,1589,1598,1608,1615,1618,1619,1632,1633,1636,1639,1641,1645,1648,1654,1661,1667,1680,1681,1684,1690,1695,1696,1697,1700,1701,1702,1711,1721,1725,1728,1731,1733,1735,1739,1742,1745,1747,1749,1750,1756,1760,1788,1790,1796,1798,1804,1809,1812,1822,1824,1829,1837,1840,1843,1844,1845,1862,1878,1881,1885,1888,1889,1890,1892,1903,1905,1915,1920,1921,1926,1929,1937,1941,1955,1957,1966,1971,1979,1991,1994,1995,1997,2008,2009,2011,2014,2025,2029,2032,2035,2037,2041,2051,2054,2063,2069,2071,2073,2079,2083,2088,2090,2092,2095,2100,2106,2123,2127,2135,2137,2141,2142,2144,2153,2165,2166,2171,2173,2184,2192,2198,2203,2206,2211,2212,2216,2218,2224,2226,2234,2236,2245,2252,2256,2257,2260,2262,2263,2268,2269,2271,2274,2282,2283,2285,2291,2308,2310,2313,2319,2329,2333,2338,2356,2359,2361,2369,2374,2375,2376,2378,2381,2384,2396,2403,2413,2431,2441,2448,2450,2452,2453,2456,2471,2484,2485,2487,2488,2495,2503,2505,2506,2515,2516,2517,2518,2522,2523,2526,2530,2541,2545,2546,2549,2551,2554,2555,2558,2560,2561,2563,2566,2573,2581,2588,2589,2591,2595,2596,2597,2619,2625,2630,2643,2644,2645,2646,2647,2653,2655,2660,2662,2673,2675,2677,2678,2683,2684,2690,2692,2697,2700,2705,2706,2710,2712,2713,2714,2727,2731,2741,2743,2759,2763,2765,2778,2779,2802,2809,2819,2820,2834,2837,2838,2856,2865,2878,2883,2889,2899,2901,2904,2907,2911,2913,2919,2924,2927,2933,2942,2951,2957,2963,2967,2977,2978,2980,2984,2991,2992,2993,2999,3007,3008,3021,3031,3032,3050,3053,3062,3074,3080,3086,3087,3090,3100,3102,3103,3104,3105,3109,3110,3113,3114,3118,3123,3124,3126,3132,3137,3139,3142,3145,3159,3165,3175,3188,3193,3199,3204,3206,3210,3213,3217,3219,3221,3223,3225,3227,3235,3236,3244,3246,3251,3262,3264,3270,3273,3280,3284,3287,3288,3291,3300,3301,3303,3304,3305,3330,3335,3338,3343,3344,3351,3364,3365,3366,3378,3385,3386,3398,3400,3411,3415,3429,3430,3432,3435,3436,3439,3444,3446,3447,3453,3460,3462,3463,3475,3478,3480,3481,3487,3494,3497,3501,3520,3539,3555,3574,3590,3616,3632,3651,3668,3689,3707,3734,3750,3776,3809,3830,3847,3872,3893,3916,3933,3950,3972,3993,4022,4039,4063,4081,4101,4128,4147,4170,4187,4206,4222,4240,4274,4300,4318,4336] \ No newline at end of file diff --git a/cardano-chain-gen/test/testfiles/fingerprint/stakeDistGenesis b/cardano-chain-gen/test/testfiles/fingerprint/stakeDistGenesis new file mode 100644 index 000000000..42445c6bb --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/stakeDistGenesis @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503] \ No newline at end of file From 67a622ceb1212dd3dad92684bb30cdcd71aea74b Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Fri, 25 Feb 2022 20:42:03 +0200 Subject: [PATCH 05/11] Introduce LRU Cache --- cardano-db-sync/cardano-db-sync.cabal | 2 + .../src/Cardano/DbSync/Cache/LRU.hs | 63 +++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index 400fb6213..5dc1fed7b 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -98,6 +98,7 @@ library Cardano.DbSync.Metrics + Cardano.DbSync.Cache.LRU Cardano.DbSync.Default Cardano.DbSync.Epoch @@ -164,6 +165,7 @@ library , persistent-postgresql , pretty-show , prometheus + , psqueues , random-shuffle , small-steps , split diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs b/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs new file mode 100644 index 000000000..d59734389 --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BangPatterns #-} + +module Cardano.DbSync.Cache.LRU where + +import Data.OrdPSQ (OrdPSQ) +import qualified Data.OrdPSQ as OrdPSQ +import Data.Word (Word64) + +-- Inspired by https://jaspervdj.be/posts/2015-02-24-lru-cache.html +-- We use Maps based on Ord instead of Hash, to avoid hash collision attacks. + +data LRUCache k v = LRUCache + { cCapacity :: !Word64 + , cTick :: !Word64 + , cQueue :: !(OrdPSQ k Word64 v) + } + +empty :: Word64 -> LRUCache k v +empty capacity = LRUCache + { cCapacity = capacity + , cTick = 0 + , cQueue = OrdPSQ.empty + } + +cleanup :: LRUCache k v -> LRUCache k v +cleanup cache = cache + { cTick = 0 + , cQueue = OrdPSQ.empty + } + +trim :: Ord k => LRUCache k v -> LRUCache k v +trim cache + | cTick cache == maxBound = empty (cCapacity cache) + | fromIntegral (OrdPSQ.size $ cQueue cache) > cCapacity cache = + cache { cQueue = OrdPSQ.deleteMin (cQueue cache) } + | otherwise = cache + +insert :: Ord k => k -> v -> LRUCache k v -> LRUCache k v +insert k v cache = + trim $! + cache + { cTick = cTick cache + 1 + , cQueue = queue + } + where + (_mbOldVal, queue) = OrdPSQ.insertView k (cTick cache) v (cQueue cache) + +lookup :: Ord k => k -> LRUCache k v -> Maybe (v, LRUCache k v) +lookup k c = + case OrdPSQ.alter lookupAndBump k (cQueue c) of + (Nothing, _) -> Nothing + (Just x, q) -> + let !c' = trim $ c {cTick = cTick c + 1, cQueue = q} + in Just (x, c') + where + lookupAndBump Nothing = (Nothing, Nothing) + lookupAndBump (Just (_, x)) = (Just x, Just (cTick c, x)) + +getSize :: LRUCache k v -> Int +getSize = OrdPSQ.size . cQueue + +getCapacity :: LRUCache k v -> Word64 +getCapacity = cCapacity From 6b7de5d4b7896df1b7d99589e2e49626dea21923 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Fri, 25 Feb 2022 20:42:29 +0200 Subject: [PATCH 06/11] Introduce Cache --- cardano-db-sync/cardano-db-sync.cabal | 1 + cardano-db-sync/src/Cardano/DbSync/Cache.hs | 374 ++++++++++++++++++++ cardano-db/src/Cardano/Db/Query.hs | 25 ++ 3 files changed, 400 insertions(+) create mode 100644 cardano-db-sync/src/Cardano/DbSync/Cache.hs diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index 5dc1fed7b..826c3f09f 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -98,6 +98,7 @@ library Cardano.DbSync.Metrics + Cardano.DbSync.Cache Cardano.DbSync.Cache.LRU Cardano.DbSync.Default Cardano.DbSync.Epoch diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache.hs b/cardano-db-sync/src/Cardano/DbSync/Cache.hs new file mode 100644 index 000000000..ad70058b4 --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Cache.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.DbSync.Cache + ( Cache + , CacheNew (..) + , newEmptyCache + , uninitiatedCache + , rollbackCache + , queryPoolKeyWithCache + , insertPoolKeyWithCache + , queryStakeAddrWithCache + , queryMAWithCache + , queryPrevBlockWithCache + , insertBlockAndCache + + -- * CacheStatistics + , CacheStatistics + , getCacheStatistics + , textShowStats + ) where + +import Cardano.Prelude + +import Control.Monad.Class.MonadSTM.Strict (StrictTVar, modifyTVar, newTVarIO, readTVarIO, + writeTVar) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) +import Cardano.Ledger.Mary.Value + +import qualified Cardano.Db as DB + +import Cardano.DbSync.Cache.LRU (LRUCache) +import qualified Cardano.DbSync.Cache.LRU as LRU +import Cardano.DbSync.Era.Shelley.Generic +import qualified Cardano.DbSync.Era.Shelley.Generic.StakePoolKeyHash as Generic +import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic +import Cardano.DbSync.Era.Shelley.Query +import Cardano.DbSync.Era.Util +import Cardano.DbSync.Error + +import Ouroboros.Consensus.Cardano.Block (StandardCrypto) + +import Database.Persist.Postgresql (SqlBackend) + +type StakeAddrCache = Map StakeCred DB.StakeAddressId +type StakePoolCache = Map StakePoolKeyHash DB.PoolHashId + +-- The 'UninitiatedCache' makes it possible to call functions in this module +-- without having actually initiated the cache yet. It is used by genesis +-- insertions, where the cache has not been initiated yet. +data Cache + = UninitiatedCache + | Cache CacheInternal + +data CacheNew + = CacheNew + | DontCacheNew + | EvictAndReturn + deriving Eq + +data CacheInternal = CacheInternal + { cStakeCreds :: !(StrictTVar IO StakeAddrCache) + , cPools :: !(StrictTVar IO StakePoolCache) + , cMultiAssets :: !(StrictTVar IO (LRUCache (ByteString, AssetName) DB.MultiAssetId)) + , cPrevBlock :: !(StrictTVar IO (Maybe (DB.BlockId, ByteString))) + , cStats :: !(StrictTVar IO CacheStatistics) + } + +data CacheStatistics = CacheStatistics + { credsHits :: !Word64 + , credsQueries :: !Word64 + , poolsHits :: !Word64 + , poolsQueries :: !Word64 + , multiAssetsHits :: !Word64 + , multiAssetsQueries :: !Word64 + , prevBlockHits :: !Word64 + , prevBlockQueries :: !Word64 + } + +hitCreds :: StrictTVar IO CacheStatistics -> IO () +hitCreds ref = + atomically $ modifyTVar ref (\cs -> cs {credsHits = 1 + credsHits cs, credsQueries = 1 + credsQueries cs}) + +missCreds :: StrictTVar IO CacheStatistics -> IO () +missCreds ref = + atomically $ modifyTVar ref (\cs -> cs {credsQueries = 1 + credsQueries cs}) + +hitPools :: StrictTVar IO CacheStatistics -> IO () +hitPools ref = + atomically $ modifyTVar ref (\cs -> cs {poolsHits = 1 + poolsHits cs, poolsQueries = 1 + poolsQueries cs}) + +missPools :: StrictTVar IO CacheStatistics -> IO () +missPools ref = + atomically $ modifyTVar ref (\cs -> cs {poolsQueries = 1 + poolsQueries cs}) + +hitMAssets :: StrictTVar IO CacheStatistics -> IO () +hitMAssets ref = + atomically $ modifyTVar ref (\cs -> cs {multiAssetsHits = 1 + multiAssetsHits cs, multiAssetsQueries = 1 + multiAssetsQueries cs}) + +missMAssets :: StrictTVar IO CacheStatistics -> IO () +missMAssets ref = + atomically $ modifyTVar ref (\cs -> cs {multiAssetsQueries = 1 + multiAssetsQueries cs}) + +hitPBlock :: StrictTVar IO CacheStatistics -> IO () +hitPBlock ref = + atomically $ modifyTVar ref (\cs -> cs {prevBlockHits = 1 + prevBlockHits cs, prevBlockQueries = 1 + prevBlockQueries cs}) + +missPrevBlock :: StrictTVar IO CacheStatistics -> IO () +missPrevBlock ref = + atomically $ modifyTVar ref (\cs -> cs {prevBlockQueries = 1 + prevBlockQueries cs}) + +initCacheStatistics :: CacheStatistics +initCacheStatistics = CacheStatistics 0 0 0 0 0 0 0 0 + +getCacheStatistics :: Cache -> IO CacheStatistics +getCacheStatistics cs = + case cs of + UninitiatedCache -> pure initCacheStatistics + Cache ci -> readTVarIO (cStats ci) + +textShowStats :: Cache -> IO Text +textShowStats UninitiatedCache = pure "UninitiatedCache" +textShowStats (Cache ic) = do + stats <- readTVarIO $ cStats ic + creds <- readTVarIO (cStakeCreds ic) + pools <- readTVarIO (cPools ic) + mAssets <- readTVarIO (cMultiAssets ic) + pure $ mconcat + [ "\nCache Statistics:" + , "\n Stake Addresses: ", "cache size: ", DB.textShow (Map.size creds) + , if credsQueries stats == 0 + then "" + else ", hit rate: " <> DB.textShow (100 * credsHits stats `div` credsQueries stats) <> "%" + , ", hits: ", DB.textShow (credsHits stats) + , ", misses: ", DB.textShow (credsQueries stats - credsHits stats) + , "\n Pools: ", "cache size: ", DB.textShow (Map.size pools) + , if poolsQueries stats == 0 + then "" + else ", hit rate: " <> DB.textShow (100 * poolsHits stats `div` poolsQueries stats) <> "%" + , ", hits: ", DB.textShow (poolsHits stats) + , ", misses: ", DB.textShow (poolsQueries stats - poolsHits stats) + , "\n Multi Assets: ", "cache capacity: ", DB.textShow (LRU.getCapacity mAssets) + , ", cache size: ", DB.textShow (LRU.getSize mAssets) + , if multiAssetsQueries stats == 0 + then "" + else ", hit rate: " <> DB.textShow (100 * multiAssetsHits stats `div` multiAssetsQueries stats) <> "%" + , ", hits: ", DB.textShow (multiAssetsHits stats) + , ", misses: ", DB.textShow (multiAssetsQueries stats - multiAssetsHits stats) + , "\n Previous Block: " + , if prevBlockQueries stats == 0 + then "" + else "hit rate: " <> DB.textShow (100 * prevBlockHits stats `div` prevBlockQueries stats) <> "%" + , ", hits: ", DB.textShow (prevBlockHits stats) + , ", misses: ", DB.textShow (prevBlockQueries stats - prevBlockHits stats) + ] + +uninitiatedCache :: Cache +uninitiatedCache = UninitiatedCache + +newEmptyCache :: MonadIO m => Word64 -> m Cache +newEmptyCache maCapacity = + liftIO . fmap Cache $ + CacheInternal + <$> newTVarIO Map.empty + <*> newTVarIO Map.empty + <*> newTVarIO (LRU.empty maCapacity) + <*> newTVarIO Nothing + <*> newTVarIO initCacheStatistics + +-- Rollbacks make everything harder and the same applies to caching. +-- After a rollback db entries are deleted, so we need to clean the same +-- cached entries. Cleaning more cached entries is not an issue. Cleaning less +-- can cause all sorts of issues, since it would give false info about the existance +-- of an entry or even a wrong entry id, if the entry is reinserted on a different +-- id after the rollback. +-- +-- IMPORTANT NOTE: we rely here on the fact that 'MultiAsset' and 'PoolHash' +-- tables don't have an ON DELETE reference and as a result are not cleaned up in +-- case of a rollback. If this changes in the future, it is necessary that their +-- cached values are also cleaned up. +-- +-- NOTE: BlockId is cleaned up on rollbacks, since it may get reinserted on +-- a different id. +-- NOTE: For 'StakeAddresses' we use a mixed approach. If the rollback is long we just drop +-- everything, since it is very rare. If not, we query all the StakeAddressesId of blocks +-- that wil be deleted. +rollbackCache :: MonadIO m => Cache -> Maybe Word64 -> Word64 -> ReaderT SqlBackend m () +rollbackCache UninitiatedCache _ _ = pure () +rollbackCache (Cache cache) mBlockNo nBlocks = do + liftIO $ do + atomically $ writeTVar (cPools cache) Map.empty + atomically $ modifyTVar (cMultiAssets cache) LRU.cleanup + atomically $ writeTVar (cPrevBlock cache) Nothing + rollbackStakeAddr cache mBlockNo nBlocks + +rollbackStakeAddr :: MonadIO m => CacheInternal -> Maybe Word64 -> Word64 -> ReaderT SqlBackend m () +rollbackStakeAddr ci mBlockNo nBlocks = do + case mBlockNo of + Nothing -> liftIO $ atomically $ writeTVar (cStakeCreds ci) Map.empty + Just blockNo -> + if nBlocks > 600 + then liftIO $ atomically $ writeTVar (cStakeCreds ci) Map.empty + else do + initMp <- liftIO $ readTVarIO (cStakeCreds ci) + stakeAddrIds <- DB.queryStakeAddressIdsAfter blockNo + let stakeAddrIdsSet = Set.fromList stakeAddrIds + let !mp = Map.filter (`Set.member` stakeAddrIdsSet) initMp + liftIO $ atomically $ writeTVar (cStakeCreds ci) mp + +queryStakeAddrWithCache + :: forall m. MonadIO m => Cache -> CacheNew -> StakeCred + -> ReaderT SqlBackend m (Either DB.LookupFail DB.StakeAddressId) +queryStakeAddrWithCache cache cacheNew cred = do + case cache of + UninitiatedCache -> queryStakeAddress (unStakeCred cred) + Cache ci -> do + mp <- liftIO $ readTVarIO (cStakeCreds ci) + (mAddrId, mp') <- queryStakeAddrAux cacheNew mp (cStats ci) cred + liftIO $ atomically $ writeTVar (cStakeCreds ci) mp' + pure mAddrId + +queryStakeAddrAux + :: MonadIO m + => CacheNew -> StakeAddrCache -> StrictTVar IO CacheStatistics -> StakeCred + -> ReaderT SqlBackend m (Either DB.LookupFail DB.StakeAddressId, StakeAddrCache) +queryStakeAddrAux cacheNew mp sts hsh = + case Map.lookup hsh mp of + Just addrId -> do + liftIO $ hitCreds sts + case cacheNew of + EvictAndReturn -> pure (Right addrId, Map.delete hsh mp) + _ -> pure (Right addrId, mp) + Nothing -> do + liftIO $ missCreds sts + mAddrId <- queryStakeAddress (unStakeCred hsh) + case (mAddrId, cacheNew) of + (Right addrId, CacheNew) -> pure (Right addrId, Map.insert hsh addrId mp) + (Right addrId, _) -> pure (Right addrId, mp) + (err, _) -> pure (err, mp) + +queryPoolKeyWithCache + :: MonadIO m + => Cache -> CacheNew -> StakePoolKeyHash + -> ReaderT SqlBackend m (Either DB.LookupFail DB.PoolHashId) +queryPoolKeyWithCache cache cacheNew hsh = + case cache of + UninitiatedCache -> do + mPhId <- queryPoolHashId (unStakePoolKeyHash hsh) + case mPhId of + Nothing -> pure $ Left (DB.DbLookupMessage "StakePoolKeyHash") + Just phId -> pure $ Right phId + Cache ci -> do + mp <- liftIO $ readTVarIO (cPools ci) + case Map.lookup hsh mp of + Just phId -> do + liftIO $ hitPools (cStats ci) + -- hit so we can't cache even with 'CacheNew' + when (cacheNew == EvictAndReturn) $ + liftIO $ atomically $ modifyTVar (cPools ci) $ Map.delete hsh + pure $ Right phId + Nothing -> do + liftIO $ missPools (cStats ci) + mPhId <- queryPoolHashId (unStakePoolKeyHash hsh) + case mPhId of + Nothing -> pure $ Left (DB.DbLookupMessage "StakePoolKeyHash") + Just phId -> do + -- missed so we can't evict even with 'EvictAndReturn' + when (cacheNew == CacheNew) $ + liftIO $ atomically $ modifyTVar (cPools ci) $ Map.insert hsh phId + pure $ Right phId + +insertPoolKeyWithCache + :: (MonadBaseControl IO m, MonadIO m) => Cache -> CacheNew -> KeyHash 'StakePool StandardCrypto + -> ReaderT SqlBackend m DB.PoolHashId +insertPoolKeyWithCache cache cacheNew pHash = + case cache of + UninitiatedCache -> + DB.insertPoolHash $ + DB.PoolHash + { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash + , DB.poolHashView = Generic.unKeyHashView pHash + } + Cache ci -> do + mp <- liftIO $ readTVarIO (cPools ci) + let !keyHash = Generic.toStakePoolKeyHash pHash + case Map.lookup keyHash mp of + Just phId -> do + liftIO $ hitPools (cStats ci) + when (cacheNew == EvictAndReturn) $ + liftIO $ atomically $ modifyTVar (cPools ci) $ Map.delete keyHash + pure phId + Nothing -> do + liftIO $ missPools (cStats ci) + phId <- DB.insertPoolHash $ + DB.PoolHash + { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash + , DB.poolHashView = Generic.unKeyHashView pHash + } + when (cacheNew == CacheNew) $ + liftIO $ atomically $ modifyTVar (cPools ci) $ Map.insert keyHash phId + pure phId + +queryMAWithCache :: MonadIO m => Cache -> ByteString -> AssetName + -> ReaderT SqlBackend m (Maybe DB.MultiAssetId) +queryMAWithCache cache policyId asset = + case cache of + UninitiatedCache -> DB.queryMultiAssetId policyId (unAssetName asset) + Cache ci -> do + mp <- liftIO $ readTVarIO (cMultiAssets ci) + case LRU.lookup (policyId, asset) mp of + Just (maId, mp') -> do + liftIO $ hitMAssets (cStats ci) + liftIO $ atomically $ writeTVar (cMultiAssets ci) mp' + pure $ Just maId + Nothing -> do + liftIO $ missMAssets (cStats ci) + -- miss. The lookup doesn't change the cache on a miss. + maId <- DB.queryMultiAssetId policyId (unAssetName asset) + case maId of + Nothing -> do + pure Nothing + Just mId -> do + liftIO $ atomically $ modifyTVar (cMultiAssets ci) $ LRU.insert (policyId, asset) mId + pure maId + +queryPrevBlockWithCache :: MonadIO m => Text -> Cache -> ByteString + -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.BlockId +queryPrevBlockWithCache msg cache hsh = + case cache of + UninitiatedCache -> liftLookupFail msg $ DB.queryBlockId hsh + Cache ci -> do + mCachedPrev <- liftIO $ readTVarIO (cPrevBlock ci) + case mCachedPrev of + -- if the cached block matches the requested hash, we return its db id. + Just (cachedBlockId, cachedHash) -> + if cachedHash == hsh + then do + liftIO $ hitPBlock (cStats ci) + pure cachedBlockId + else queryFromDb ci + _ -> queryFromDb ci + where + queryFromDb + :: MonadIO m + => CacheInternal -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.BlockId + queryFromDb ci = do + liftIO $ missPrevBlock (cStats ci) + liftLookupFail msg $ DB.queryBlockId hsh + +insertBlockAndCache + :: (MonadIO m, MonadBaseControl IO m) + => Cache -> DB.Block -> ReaderT SqlBackend m DB.BlockId +insertBlockAndCache cache block = + case cache of + UninitiatedCache -> DB.insertBlock block + Cache ci -> do + bid <- DB.insertBlock block + liftIO $ do + missPrevBlock (cStats ci) + atomically $ writeTVar (cPrevBlock ci) $ Just (bid, DB.blockHash block) + pure bid + +-- It is completely ***INSANE*** that we even need to do something like this. +unAssetName :: AssetName -> ByteString +unAssetName (AssetName a) = a diff --git a/cardano-db/src/Cardano/Db/Query.hs b/cardano-db/src/Cardano/Db/Query.hs index 146f84424..4c214308b 100644 --- a/cardano-db/src/Cardano/Db/Query.hs +++ b/cardano-db/src/Cardano/Db/Query.hs @@ -14,6 +14,7 @@ module Cardano.Db.Query , queryBlockCount , queryBlockHeight , queryBlockId + , queryBlockNoId , queryBlockSlotNo , queryBlockNo , queryMainBlock @@ -79,6 +80,7 @@ module Cardano.Db.Query , queryDelegationScript , queryWithdrawalScript , queryStakeAddressScript + , queryStakeAddressIdsAfter , existsDelistedPool , existsPoolHash , existsPoolHashId @@ -214,6 +216,15 @@ queryBlockId hash = do pure $ blk ^. BlockId pure $ maybeToEither (DbLookupBlockHash hash) unValue (listToMaybe res) +-- | Get the 'BlockId' associated with the given hash. +queryBlockNoId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail (BlockId, Maybe Word64)) +queryBlockNoId hash = do + res <- select $ do + blk <- from $ table @Block + where_ (blk ^. BlockHash ==. val hash) + pure (blk ^. BlockId, blk ^. BlockBlockNo) + pure $ maybeToEither (DbLookupBlockHash hash) unValue2 (listToMaybe res) + -- | Get the 'SlotNo' associated with the given hash. queryBlockSlotNo :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail (Maybe Word64)) queryBlockSlotNo hash = do @@ -992,6 +1003,20 @@ queryStakeAddressScript = do pure st_addr pure $ entityVal <$> res +queryStakeAddressIdsAfter :: MonadIO m => Word64 -> ReaderT SqlBackend m [StakeAddressId] +queryStakeAddressIdsAfter blockNo = do + res <- select $ do + (_tx :& blk :& st_addr) <- + from $ table @Tx + `innerJoin` table @Block + `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `innerJoin` table @StakeAddress + `on` (\(tx :& _blk :& st_addr) -> tx ^. TxId ==. st_addr ^. StakeAddressTxId) + where_ (isJust $ blk ^. BlockBlockNo) + where_ (blk ^. BlockBlockNo >. val (Just blockNo)) + pure (st_addr ^. StakeAddressId) + pure $ unValue <$> res + existsDelistedPool :: MonadIO m => ByteString -> ReaderT SqlBackend m Bool existsDelistedPool ph = do res <- select $ do From 070594c10972d2abd21f268d3026cf70cad85e5c Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Sat, 26 Feb 2022 00:36:09 +0200 Subject: [PATCH 07/11] Use Cache --- cardano-db-sync/src/Cardano/DbSync/Api.hs | 71 +++--- .../src/Cardano/DbSync/Database.hs | 2 +- cardano-db-sync/src/Cardano/DbSync/Default.hs | 11 +- .../src/Cardano/DbSync/Era/Byron/Insert.hs | 49 ++-- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 10 +- .../src/Cardano/DbSync/Era/Shelley/Insert.hs | 226 ++++++++++-------- .../src/Cardano/DbSync/Era/Shelley/Query.hs | 81 ++----- .../src/Cardano/DbSync/Rollback.hs | 30 ++- cardano-db/src/Cardano/Db/Types.hs | 12 +- .../test/Test/Property/Cardano/Db/Types.hs | 6 +- 10 files changed, 258 insertions(+), 240 deletions(-) diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index c0fc816a0..cf78c6468 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -16,12 +17,12 @@ module Cardano.DbSync.Api , logDbState ) where -import Cardano.Prelude hiding ((.)) +import Cardano.Prelude import Cardano.BM.Trace (Trace, logInfo) import qualified Cardano.Chain.Genesis as Byron -import Cardano.Crypto.ProtocolMagic +import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..)) import qualified Cardano.Db as DB @@ -30,6 +31,7 @@ import qualified Cardano.Ledger.Shelley.Genesis as Shelley import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..)) +import Cardano.DbSync.Cache import Cardano.DbSync.Config.Cardano import Cardano.DbSync.Config.Shelley import Cardano.DbSync.Config.Types @@ -55,21 +57,22 @@ data SyncEnv = SyncEnv , envSystemStart :: !SystemStart , envBackend :: !SqlBackend , envOptions :: !SyncOptions + , envCache :: !Cache , envLedger :: !LedgerEnv } data SyncOptions = SyncOptions - { soptExtended :: Bool - , soptAbortOnInvalid :: Bool - , snapshotEveryFollowing :: Word64 - , snapshotEveryLagging :: Word64 + { soptExtended :: !Bool + , soptAbortOnInvalid :: !Bool + , snapshotEveryFollowing :: !Word64 + , snapshotEveryLagging :: !Word64 } getTrace :: SyncEnv -> Trace IO Text -getTrace env = leTrace (envLedger env) +getTrace = leTrace . envLedger getSlotHash :: SqlBackend -> SlotNo -> IO [(SlotNo, ByteString)] -getSlotHash backend slotNo = DB.runDbIohkNoLogging backend $ DB.querySlotHash slotNo +getSlotHash backend = DB.runDbIohkNoLogging backend . DB.querySlotHash getDbLatestBlockInfo :: SqlBackend -> IO (Maybe TipInfo) getDbLatestBlockInfo backend = do @@ -107,10 +110,10 @@ logDbState env = do getCurrentTipBlockNo :: SyncEnv -> IO (WithOrigin BlockNo) getCurrentTipBlockNo env = do - maybeTip <- getDbLatestBlockInfo (envBackend env) - case maybeTip of - Just tip -> pure $ At (bBlockNo tip) - Nothing -> pure Origin + maybeTip <- getDbLatestBlockInfo (envBackend env) + case maybeTip of + Just tip -> pure $ At (bBlockNo tip) + Nothing -> pure Origin mkSyncEnv :: Trace IO Text -> SqlBackend -> SyncOptions -> ProtocolInfo IO CardanoBlock -> Ledger.Network @@ -118,42 +121,44 @@ mkSyncEnv -> IO SyncEnv mkSyncEnv trce backend syncOptions protoInfo nw nwMagic systemStart dir stableEpochSlot = do ledgerEnv <- mkLedgerEnv trce protoInfo dir nw stableEpochSlot systemStart (soptAbortOnInvalid syncOptions) + cache <- newEmptyCache 200000 pure $ SyncEnv { envProtocol = SyncProtocolCardano , envNetworkMagic = nwMagic , envSystemStart = systemStart , envBackend = backend , envOptions = syncOptions + , envCache = cache , envLedger = ledgerEnv } mkSyncEnvFromConfig :: Trace IO Text -> SqlBackend -> SyncOptions -> LedgerStateDir -> GenesisConfig -> IO (Either SyncNodeError SyncEnv) mkSyncEnvFromConfig trce backend syncOptions dir genCfg = - case genCfg of - GenesisCardano _ bCfg sCfg _ - | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) -> - pure . Left . NECardanoConfig $ - mconcat - [ "ProtocolMagicId ", DB.textShow (unProtocolMagicId $ Byron.configProtocolMagicId bCfg) - , " /= ", DB.textShow (Shelley.sgNetworkMagic $ scConfig sCfg) - ] - | Byron.gdStartTime (Byron.configGenesisData bCfg) /= Shelley.sgSystemStart (scConfig sCfg) -> - pure . Left . NECardanoConfig $ - mconcat - [ "SystemStart ", DB.textShow (Byron.gdStartTime $ Byron.configGenesisData bCfg) - , " /= ", DB.textShow (Shelley.sgSystemStart $ scConfig sCfg) - ] - | otherwise -> - Right <$> mkSyncEnv trce backend syncOptions (mkProtocolInfoCardano genCfg []) (Shelley.sgNetworkId $ scConfig sCfg) - (NetworkMagic . unProtocolMagicId $ Byron.configProtocolMagicId bCfg) - (SystemStart .Byron.gdStartTime $ Byron.configGenesisData bCfg) - dir (calculateStableEpochSlot $ scConfig sCfg) + case genCfg of + GenesisCardano _ bCfg sCfg _ + | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) -> + pure . Left . NECardanoConfig $ + mconcat + [ "ProtocolMagicId ", DB.textShow (unProtocolMagicId $ Byron.configProtocolMagicId bCfg) + , " /= ", DB.textShow (Shelley.sgNetworkMagic $ scConfig sCfg) + ] + | Byron.gdStartTime (Byron.configGenesisData bCfg) /= Shelley.sgSystemStart (scConfig sCfg) -> + pure . Left . NECardanoConfig $ + mconcat + [ "SystemStart ", DB.textShow (Byron.gdStartTime $ Byron.configGenesisData bCfg) + , " /= ", DB.textShow (Shelley.sgSystemStart $ scConfig sCfg) + ] + | otherwise -> + Right <$> mkSyncEnv trce backend syncOptions (mkProtocolInfoCardano genCfg []) (Shelley.sgNetworkId $ scConfig sCfg) + (NetworkMagic . unProtocolMagicId $ Byron.configProtocolMagicId bCfg) + (SystemStart .Byron.gdStartTime $ Byron.configGenesisData bCfg) + dir (calculateStableEpochSlot $ scConfig sCfg) getLatestPoints :: SyncEnv -> IO [CardanoPoint] getLatestPoints env = do - files <- listLedgerStateFilesOrdered $ leDir (envLedger env) - verifyFilePoints env files + files <- listLedgerStateFilesOrdered $ leDir (envLedger env) + verifyFilePoints env files verifyFilePoints :: SyncEnv -> [LedgerStateFile] -> IO [CardanoPoint] verifyFilePoints env files = diff --git a/cardano-db-sync/src/Cardano/DbSync/Database.hs b/cardano-db-sync/src/Cardano/DbSync/Database.hs index b3e910fe9..456007a0b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Database.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Database.hs @@ -138,7 +138,7 @@ runRollbacksDB :: SyncEnv -> CardanoPoint -> ExceptT SyncNodeError IO () runRollbacksDB env point = - newExceptT $ rollbackToPoint (envBackend env) (getTrace env) point + newExceptT $ rollbackToPoint env point insertBlockList :: SyncEnv -> [CardanoBlock] diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 6004e0d22..094d1702b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -72,7 +72,6 @@ insertDefaultBlock env blocks = insertDetails cblk = do -- Calculate the new ledger state to pass to the DB insert functions but do not yet -- update ledgerStateVar. - let lenv = envLedger env lStateSnap <- liftIO $ applyBlock (envLedger env) cblk let !details = lssSlotDetails lStateSnap mkSnapshotMaybe env lStateSnap (blockNo cblk) (isSyncedWithinSeconds details 600) @@ -80,16 +79,16 @@ insertDefaultBlock env blocks = let firstBlockOfEpoch = hasEpochStartEvent (lssEvents lStateSnap) case cblk of BlockByron blk -> - newExceptT $ insertByronBlock tracer firstBlockOfEpoch blk details + newExceptT $ insertByronBlock env firstBlockOfEpoch blk details BlockShelley blk -> - newExceptT $ insertShelleyBlock tracer lenv firstBlockOfEpoch (Generic.fromShelleyBlock blk) lStateSnap details + newExceptT $ insertShelleyBlock env firstBlockOfEpoch (Generic.fromShelleyBlock blk) lStateSnap details BlockAllegra blk -> - newExceptT $ insertShelleyBlock tracer lenv firstBlockOfEpoch (Generic.fromAllegraBlock blk) lStateSnap details + newExceptT $ insertShelleyBlock env firstBlockOfEpoch (Generic.fromAllegraBlock blk) lStateSnap details BlockMary blk -> - newExceptT $ insertShelleyBlock tracer lenv firstBlockOfEpoch (Generic.fromMaryBlock blk) lStateSnap details + newExceptT $ insertShelleyBlock env firstBlockOfEpoch (Generic.fromMaryBlock blk) lStateSnap details BlockAlonzo blk -> do let pp = getAlonzoPParams $ lssState lStateSnap - newExceptT $ insertShelleyBlock tracer lenv firstBlockOfEpoch (Generic.fromAlonzoBlock pp blk) lStateSnap details + newExceptT $ insertShelleyBlock env firstBlockOfEpoch (Generic.fromAlonzoBlock pp blk) lStateSnap details when (soptExtended $ envOptions env) . newExceptT $ epochInsert tracer (BlockDetails cblk details) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs index bd659a89c..470d08641 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -12,8 +12,8 @@ module Cardano.DbSync.Era.Byron.Insert import Cardano.Prelude -import Cardano.BM.Trace (Trace, logDebug, logInfo) import Cardano.Binary (serialize') +import Cardano.BM.Trace (Trace, logDebug, logInfo) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except.Extra (firstExceptT) @@ -25,8 +25,8 @@ import qualified Cardano.Binary as Binary -- qualified. import qualified Cardano.Chain.Block as Byron hiding (blockHash) import qualified Cardano.Chain.Common as Byron -import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Chain.Update as Byron hiding (protocolVersion) +import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto as Crypto (serializeCborHash) @@ -44,6 +44,8 @@ import qualified Data.Text.Encoding as Text import Database.Persist.Sql (SqlBackend) import qualified Cardano.Db as DB +import Cardano.DbSync.Api +import Cardano.DbSync.Cache import qualified Cardano.DbSync.Era.Byron.Util as Byron import Cardano.DbSync.Error import Cardano.DbSync.Util @@ -58,34 +60,39 @@ data ValueFee = ValueFee insertByronBlock :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Bool -> ByronBlock -> SlotDetails + => SyncEnv -> Bool -> ByronBlock -> SlotDetails -> ReaderT SqlBackend m (Either SyncNodeError ()) -insertByronBlock tracer firstBlockOfEpoch blk details = do - res <- runExceptT $ - case byronBlockRaw blk of - Byron.ABOBBlock ablk -> insertABlock tracer firstBlockOfEpoch ablk details - Byron.ABOBBoundary abblk -> insertABOBBoundary tracer abblk details - -- Serializiing things during syncing can drastically slow down full sync - -- times (ie 10x or more). - when (getSyncStatus details == SyncFollowing) - DB.transactionCommit - pure res +insertByronBlock env firstBlockOfEpoch blk details = do + res <- runExceptT $ + case byronBlockRaw blk of + Byron.ABOBBlock ablk -> insertABlock tracer cache firstBlockOfEpoch ablk details + Byron.ABOBBoundary abblk -> insertABOBBoundary tracer cache abblk details + -- Serializing things during syncing can drastically slow down full sync + -- times (ie 10x or more). + when (getSyncStatus details == SyncFollowing) + DB.transactionCommit + pure res + where + tracer :: Trace IO Text + tracer = getTrace env + cache :: Cache + cache = envCache env insertABOBBoundary :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Byron.ABoundaryBlock ByteString -> SlotDetails + => Trace IO Text -> Cache -> Byron.ABoundaryBlock ByteString -> SlotDetails -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertABOBBoundary tracer blk details = do +insertABOBBoundary tracer cache blk details = do -- Will not get called in the OBFT part of the Byron era. - pbid <- liftLookupFail "insertABOBBoundary" $ DB.queryBlockId (Byron.ebbPrevHash blk) + pbid <- queryPrevBlockWithCache "insertABOBBoundary" cache (Byron.ebbPrevHash blk) slid <- lift . DB.insertSlotLeader $ DB.SlotLeader { DB.slotLeaderHash = BS.replicate 28 '\0' , DB.slotLeaderPoolHashId = Nothing , DB.slotLeaderDescription = "Epoch boundary slot leader" } - void . lift . DB.insertBlock $ + void . lift . insertBlockAndCache cache $ DB.Block { DB.blockHash = Byron.unHeaderHash $ Byron.boundaryHashAnnotated blk , DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details) @@ -117,12 +124,12 @@ insertABOBBoundary tracer blk details = do insertABlock :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Bool -> Byron.ABlock ByteString -> SlotDetails + => Trace IO Text -> Cache -> Bool -> Byron.ABlock ByteString -> SlotDetails -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertABlock tracer firstBlockOfEpoch blk details = do - pbid <- liftLookupFail "insertABlock" $ DB.queryBlockId (Byron.blockPreviousHash blk) +insertABlock tracer cache firstBlockOfEpoch blk details = do + pbid <- queryPrevBlockWithCache "insertABlock" cache (Byron.blockPreviousHash blk) slid <- lift . DB.insertSlotLeader $ Byron.mkSlotLeader blk - blkId <- lift . DB.insertBlock $ + blkId <- lift . insertBlockAndCache cache $ DB.Block { DB.blockHash = Byron.blockHash blk , DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs index c40419398..4d1744010 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -20,6 +20,7 @@ import Control.Monad.Trans.Except.Extra (newExceptT) import qualified Cardano.Db as DB +import Cardano.DbSync.Cache import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic import Cardano.DbSync.Era.Shelley.Insert import Cardano.DbSync.Era.Util (liftLookupFail) @@ -142,7 +143,7 @@ insertValidateGenesisDist backend tracer networkName cfg shelleyInitiation = do liftIO . logInfo tracer $ "Initial genesis distribution populated. Hash " <> renderByteArray (configGenesisHash cfg) when hasStakes $ - insertStaking tracer bid cfg + insertStaking tracer uninitiatedCache bid cfg supply <- lift DB.queryTotalSupply liftIO $ logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply) @@ -215,7 +216,7 @@ insertTxOuts trce blkId (ShelleyTx.TxIn txInId _, txOut) = do , DB.txValidContract = True , DB.txScriptSize = 0 } - _ <- insertStakeAddressRefIfMissing trce txId (txOutAddress txOut) + _ <- insertStakeAddressRefIfMissing trce uninitiatedCache txId (txOutAddress txOut) void . DB.insertTxOut $ DB.TxOut { DB.txOutTxId = txId @@ -241,10 +242,11 @@ insertTxOuts trce blkId (ShelleyTx.TxIn txInId _, txOut) = do insertStaking :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text + -> Cache -> DB.BlockId -> ShelleyGenesis StandardShelley -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertStaking tracer blkId genesis = do +insertStaking tracer cache blkId genesis = do -- All Genesis staking comes from an artifical transaction -- with a hash generated by hashing the address. txId <- lift $ DB.insertTx $ @@ -264,7 +266,7 @@ insertStaking tracer blkId genesis = do let params = zip [0..] $ Map.elems (sgsPools $ sgStaking genesis) forM_ params $ uncurry (insertPoolRegister tracer (Left 2) (sgNetworkId genesis) 0 blkId txId) let stakes = zip [0..] $ Map.toList (sgsStake $ sgStaking genesis) - forM_ stakes $ \(n, (keyStaking, keyPool)) -> insertDelegation tracer (sgNetworkId genesis) 0 0 txId n Nothing (KeyHashObj keyStaking) [] keyPool + forM_ stakes $ \(n, (keyStaking, keyPool)) -> insertDelegation cache (sgNetworkId genesis) 0 0 txId n Nothing (KeyHashObj keyStaking) [] keyPool -- ----------------------------------------------------------------------------- diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs index 8c143263d..e0f164420 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs @@ -46,22 +46,23 @@ import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Keys as Ledger +import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..), Value (..)) import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley +import qualified Cardano.Ledger.Shelley.TxBody as Shelley +import Cardano.DbSync.Api +import Cardano.DbSync.Cache +import Cardano.DbSync.Era.Shelley.Generic.StakePoolKeyHash import Cardano.DbSync.Error import Cardano.DbSync.LedgerState import Cardano.DbSync.Types import Cardano.DbSync.Util -import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..), Value (..)) -import qualified Cardano.Ledger.Shelley.TxBody as Shelley - import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..)) import Control.Monad.Class.MonadSTM.Strict (tryReadTBQueue) import Control.Monad.Trans.Control (MonadBaseControl) - import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Group (invert) @@ -77,17 +78,17 @@ import Ouroboros.Consensus.Cardano.Block (StandardCrypto) insertShelleyBlock :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerEnv -> Bool -> Generic.Block -> LedgerStateSnapshot -> SlotDetails + => SyncEnv -> Bool -> Generic.Block -> LedgerStateSnapshot -> SlotDetails -> ReaderT SqlBackend m (Either SyncNodeError ()) -insertShelleyBlock tracer lenv firstBlockOfEpoch blk lStateSnap details = do +insertShelleyBlock env firstBlockOfEpoch blk lStateSnap details = do runExceptT $ do pbid <- case Generic.blkPreviousHash blk of Nothing -> liftLookupFail (renderInsertName (Generic.blkEra blk)) DB.queryGenesis -- this is for networks that fork from Byron on epoch 0. - Just pHash -> liftLookupFail (renderInsertName (Generic.blkEra blk)) $ DB.queryBlockId pHash - mPhid <- lift $ queryPoolHashId (Generic.blkCreatorPoolHash blk) + Just pHash -> queryPrevBlockWithCache (renderInsertName (Generic.blkEra blk)) cache pHash + mPhid <- lift $ queryPoolKeyWithCache cache CacheNew (Generic.StakePoolKeyHash $ Generic.blkCreatorPoolHash blk) - slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (Generic.blkSlotLeader blk) mPhid - blkId <- lift . DB.insertBlock $ + slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (Generic.blkSlotLeader blk) (rightToJust mPhid) + blkId <- lift . insertBlockAndCache cache $ DB.Block { DB.blockHash = Generic.blkHash blk , DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details) @@ -109,7 +110,7 @@ insertShelleyBlock tracer lenv firstBlockOfEpoch blk lStateSnap details = do } let zippedTx = zip [0 .. ] (Generic.blkTxs blk) - let txInserter = insertTx tracer (leNetwork lenv) lStateSnap blkId (sdEpochNo details) (Generic.blkSlotNo blk) + let txInserter = insertTx tracer cache (leNetwork lenv) lStateSnap blkId (sdEpochNo details) (Generic.blkSlotNo blk) grouped <- foldM (\grouped (idx, tx) -> txInserter idx tx grouped) mempty zippedTx insertBlockGroupedData tracer grouped @@ -171,6 +172,13 @@ insertShelleyBlock tracer lenv firstBlockOfEpoch blk lStateSnap details = do SyncFollowing -> 10 SyncLagging -> 2000 + rightToJust (Right a) = Just a + rightToJust _ = Nothing + + lenv = envLedger env + tracer = getTrace env + cache = envCache env + -- ----------------------------------------------------------------------------- insertOnNewEpoch @@ -190,10 +198,10 @@ insertOnNewEpoch tracer blkId slotNo epochNo newEpoch = do insertTx :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Ledger.Network -> LedgerStateSnapshot -> DB.BlockId -> EpochNo + => Trace IO Text -> Cache -> Ledger.Network -> LedgerStateSnapshot -> DB.BlockId -> EpochNo -> SlotNo -> Word64 -> Generic.Tx -> BlockGroupedData -> ExceptT SyncNodeError (ReaderT SqlBackend m) BlockGroupedData -insertTx tracer network lStateSnap blkId epochNo slotNo blockIndex tx grouped = do +insertTx tracer cache network lStateSnap blkId epochNo slotNo blockIndex tx grouped = do let fees = unCoin $ Generic.txFees tx outSum = unCoin $ Generic.txOutSum tx withdrawalSum = unCoin $ Generic.txWithdrawalSum tx @@ -229,7 +237,7 @@ insertTx tracer network lStateSnap blkId epochNo slotNo blockIndex tx grouped = else do -- The following operations only happen if the script passes stage 2 validation (or the tx has -- no script). - txOutsGrouped <- mapM (prepareTxOut tracer (txId, txHash)) (Generic.txOutputs tx) + txOutsGrouped <- mapM (prepareTxOut tracer cache (txId, txHash)) (Generic.txOutputs tx) redeemers <- mapM (insertRedeemer tracer (fst <$> groupedTxOut grouped) txId) (Generic.txRedeemer tx) @@ -241,12 +249,12 @@ insertTx tracer network lStateSnap blkId epochNo slotNo blockIndex tx grouped = whenJust (maybeToStrict $ Generic.txMetadata tx) $ \ md -> insertTxMetadata tracer txId md - mapM_ (insertCertificate tracer lStateSnap network blkId txId epochNo slotNo redeemers) $ Generic.txCertificates tx + mapM_ (insertCertificate tracer cache lStateSnap network blkId txId epochNo slotNo redeemers) $ Generic.txCertificates tx mapM_ (insertWithdrawals tracer txId redeemers) $ Generic.txWithdrawals tx mapM_ (insertParamProposal tracer blkId txId) $ Generic.txParamProposal tx - insertMaTxMint tracer txId $ Generic.txMint tx + insertMaTxMint tracer cache txId $ Generic.txMint tx mapM_ (insertScript tracer txId) $ Generic.txScripts tx @@ -256,10 +264,10 @@ insertTx tracer network lStateSnap blkId epochNo slotNo blockIndex tx grouped = prepareTxOut :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> (DB.TxId, ByteString) -> Generic.TxOut + => Trace IO Text -> Cache -> (DB.TxId, ByteString) -> Generic.TxOut -> ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut]) -prepareTxOut tracer (txId, txHash) (Generic.TxOut index addr addrRaw value maMap dataHash) = do - mSaId <- lift $ insertStakeAddressRefIfMissing tracer txId addr +prepareTxOut tracer cache (txId, txHash) (Generic.TxOut index addr addrRaw value maMap dataHash) = do + mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache txId addr let txOut = DB.TxOut { DB.txOutTxId = txId , DB.txOutIndex = index @@ -272,7 +280,7 @@ prepareTxOut tracer (txId, txHash) (Generic.TxOut index addr addrRaw value maMap , DB.txOutDataHash = dataHash } let eutxo = ExtendedTxOut txHash txOut - maTxOuts <- prepareMaTxOuts tracer maMap + maTxOuts <- prepareMaTxOuts tracer cache maMap pure (eutxo, maTxOuts) where hasScript :: Bool @@ -310,15 +318,15 @@ insertCollateralTxIn _tracer txInId (Generic.TxIn txId index _) = do insertCertificate :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerStateSnapshot -> Ledger.Network -> DB.BlockId -> DB.TxId -> EpochNo -> SlotNo + => Trace IO Text -> Cache -> LedgerStateSnapshot -> Ledger.Network -> DB.BlockId -> DB.TxId -> EpochNo -> SlotNo -> [(DB.RedeemerId, Generic.TxRedeemer)] -> Generic.TxCertificate -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertCertificate tracer lStateSnap network blkId txId epochNo slotNo redeemers (Generic.TxCertificate ridx idx cert) = +insertCertificate tracer cache lStateSnap network blkId txId epochNo slotNo redeemers (Generic.TxCertificate ridx idx cert) = case cert of - Shelley.DCertDeleg deleg -> insertDelegCert tracer network txId idx ridx epochNo slotNo redeemers deleg - Shelley.DCertPool pool -> insertPoolCert tracer lStateSnap network epochNo blkId txId idx pool - Shelley.DCertMir mir -> insertMirCert tracer network txId idx mir + Shelley.DCertDeleg deleg -> insertDelegCert tracer cache network txId idx ridx epochNo slotNo redeemers deleg + Shelley.DCertPool pool -> insertPoolCert tracer cache lStateSnap network epochNo blkId txId idx pool + Shelley.DCertMir mir -> insertMirCert tracer cache network txId idx mir Shelley.DCertGenesis _gen -> do -- TODO : Low priority liftIO $ logWarning tracer "insertCertificate: Unhandled DCertGenesis certificate" @@ -327,39 +335,38 @@ insertCertificate tracer lStateSnap network blkId txId epochNo slotNo redeemers insertPoolCert :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerStateSnapshot -> Ledger.Network -> EpochNo -> DB.BlockId -> DB.TxId -> Word16 -> Shelley.PoolCert StandardCrypto + => Trace IO Text -> Cache -> LedgerStateSnapshot -> Ledger.Network -> EpochNo -> DB.BlockId -> DB.TxId -> Word16 -> Shelley.PoolCert StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertPoolCert tracer lStateSnap network epoch blkId txId idx pCert = +insertPoolCert tracer cache lStateSnap network epoch blkId txId idx pCert = case pCert of - Shelley.RegPool pParams -> insertPoolRegister tracer (Right lStateSnap) network epoch blkId txId idx pParams - Shelley.RetirePool keyHash epochNum -> insertPoolRetire txId epochNum idx keyHash + Shelley.RegPool pParams -> insertPoolRegister tracer cache (Right lStateSnap) network epoch blkId txId idx pParams + Shelley.RetirePool keyHash epochNum -> insertPoolRetire txId cache epochNum idx keyHash insertDelegCert :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Ledger.Network -> DB.TxId -> Word16 -> Maybe Word64 -> EpochNo -> SlotNo + => Trace IO Text -> Cache -> Ledger.Network -> DB.TxId -> Word16 -> Maybe Word64 -> EpochNo -> SlotNo -> [(DB.RedeemerId, Generic.TxRedeemer)] -> Shelley.DelegCert StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertDelegCert tracer network txId idx ridx epochNo slotNo redeemers dCert = +insertDelegCert _tracer cache network txId idx ridx epochNo slotNo redeemers dCert = case dCert of - Shelley.RegKey cred -> insertStakeRegistration tracer epochNo txId idx $ Generic.annotateStakingCred network cred - Shelley.DeRegKey cred -> insertStakeDeregistration tracer network epochNo txId idx ridx redeemers cred - Shelley.Delegate (Shelley.Delegation cred poolkh) -> insertDelegation tracer network epochNo slotNo txId idx ridx cred redeemers poolkh + Shelley.RegKey cred -> insertStakeRegistration epochNo txId idx $ Generic.annotateStakingCred network cred + Shelley.DeRegKey cred -> insertStakeDeregistration cache network epochNo txId idx ridx redeemers cred + Shelley.Delegate (Shelley.Delegation cred poolkh) -> insertDelegation cache network epochNo slotNo txId idx ridx cred redeemers poolkh insertPoolRegister :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Either Word64 LedgerStateSnapshot -> Ledger.Network -> EpochNo -> DB.BlockId -> DB.TxId -> Word16 -> Shelley.PoolParams StandardCrypto + => Trace IO Text -> Cache -> Either Word64 LedgerStateSnapshot -> Ledger.Network -> EpochNo -> DB.BlockId -> DB.TxId -> Word16 -> Shelley.PoolParams StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertPoolRegister _tracer mlStateSnap network (EpochNo epoch) blkId txId idx params = do - poolHashId <- insertPoolHash (Shelley._poolId params) - +insertPoolRegister _tracer cache mlStateSnap network (EpochNo epoch) blkId txId idx params = do + poolHashId <- lift $ insertPoolKeyWithCache cache CacheNew (Shelley._poolId params) mdId <- case strictMaybeToMaybe $ Shelley._poolMD params of Just md -> Just <$> insertMetaDataRef poolHashId txId md Nothing -> pure Nothing epochActivationDelay <- mkEpochActivationDelay poolHashId - saId <- lift $ insertStakeAddress txId (adjustNetworkTag $ Shelley._poolRAcnt params) + saId <- lift $ insertStakeAddressWithCache cache CacheNew txId (adjustNetworkTag $ Shelley._poolRAcnt params) poolUpdateId <- lift . DB.insertPoolUpdate $ DB.PoolUpdate { DB.poolUpdateHashId = poolHashId @@ -374,7 +381,7 @@ insertPoolRegister _tracer mlStateSnap network (EpochNo epoch) blkId txId idx pa , DB.poolUpdateRegisteredTxId = txId } - mapM_ (insertPoolOwner network poolUpdateId txId) $ toList (Shelley._poolOwners params) + mapM_ (insertPoolOwner cache network poolUpdateId txId) $ toList (Shelley._poolOwners params) mapM_ (insertPoolRelay poolUpdateId) $ toList (Shelley._poolRelays params) where @@ -396,24 +403,12 @@ insertPoolRegister _tracer mlStateSnap network (EpochNo epoch) blkId txId idx pa adjustNetworkTag :: Ledger.RewardAcnt StandardCrypto -> Ledger.RewardAcnt StandardCrypto adjustNetworkTag (Shelley.RewardAcnt _ cred) = Shelley.RewardAcnt network cred -insertPoolHash - :: forall m . (MonadBaseControl IO m, MonadIO m) - => Ledger.KeyHash 'Ledger.StakePool StandardCrypto - -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.PoolHashId -insertPoolHash kh = - lift . DB.insertPoolHash $ - DB.PoolHash - { DB.poolHashHashRaw = Generic.unKeyHashRaw kh - , DB.poolHashView = Generic.unKeyHashView kh - } - - insertPoolRetire :: (MonadBaseControl IO m, MonadIO m) - => DB.TxId -> EpochNo -> Word16 -> Ledger.KeyHash 'Ledger.StakePool StandardCrypto + => DB.TxId -> Cache -> EpochNo -> Word16 -> Ledger.KeyHash 'Ledger.StakePool StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertPoolRetire txId epochNum idx keyHash = do - poolId <- liftLookupFail "insertPoolRetire" $ queryStakePoolKeyHash keyHash +insertPoolRetire txId cache epochNum idx keyHash = do + poolId <- liftLookupFail "insertPoolRetire" $ queryPoolKeyWithCache cache CacheNew (toStakePoolKeyHash keyHash) void . lift . DB.insertPoolRetire $ DB.PoolRetire { DB.poolRetireHashId = poolId @@ -436,29 +431,50 @@ insertMetaDataRef poolId txId md = , DB.poolMetadataRefRegisteredTxId = txId } -insertStakeAddress +insertStakeAddressAux :: (MonadBaseControl IO m, MonadIO m) - => DB.TxId -> Shelley.RewardAcnt StandardCrypto + => Maybe (Cache, CacheNew) -> DB.TxId -> Shelley.RewardAcnt StandardCrypto -> ReaderT SqlBackend m DB.StakeAddressId -insertStakeAddress txId rewardAddr = +insertStakeAddressAux mcache txId rewardAddr = do + case mcache of + Just (cache, cacheNew) -> do + eiAddrId <- queryStakeAddrWithCache cache cacheNew (Generic.StakeCred stakeCred) + case eiAddrId of + Left _ -> doInsert + Right addrId -> pure addrId + Nothing -> doInsert + where + stakeCred = Ledger.serialiseRewardAcnt rewardAddr -- If the address already esists in the table, it will not be inserted again (due to -- the uniqueness constraint) but the function will return the 'StakeAddressId'. - DB.insertStakeAddress $ - DB.StakeAddress - { DB.stakeAddressHashRaw = Ledger.serialiseRewardAcnt rewardAddr - , DB.stakeAddressView = Generic.renderRewardAcnt rewardAddr - , DB.stakeAddressScriptHash = Generic.getCredentialScriptHash $ Ledger.getRwdCred rewardAddr - , DB.stakeAddressTxId = txId - } + doInsert = DB.insertStakeAddress $ + DB.StakeAddress + { DB.stakeAddressHashRaw = stakeCred + , DB.stakeAddressView = Generic.renderRewardAcnt rewardAddr + , DB.stakeAddressScriptHash = Generic.getCredentialScriptHash $ Ledger.getRwdCred rewardAddr + , DB.stakeAddressTxId = txId + } + +insertStakeAddress + :: (MonadBaseControl IO m, MonadIO m) + => DB.TxId -> Shelley.RewardAcnt StandardCrypto + -> ReaderT SqlBackend m DB.StakeAddressId +insertStakeAddress = insertStakeAddressAux Nothing + +insertStakeAddressWithCache + :: (MonadBaseControl IO m, MonadIO m) + => Cache -> CacheNew -> DB.TxId -> Shelley.RewardAcnt StandardCrypto + -> ReaderT SqlBackend m DB.StakeAddressId +insertStakeAddressWithCache cache cacheNew = insertStakeAddressAux (Just (cache, cacheNew)) -- | Insert a stake address if it is not already in the `stake_address` table. Regardless of -- whether it is newly inserted or it is already there, we retrun the `StakeAddressId`. insertStakeAddressRefIfMissing :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> DB.TxId -> Ledger.Addr StandardCrypto + => Trace IO Text -> Cache -> DB.TxId -> Ledger.Addr StandardCrypto -> ReaderT SqlBackend m (Maybe DB.StakeAddressId) -insertStakeAddressRefIfMissing trce txId addr = - maybe insertSAR (pure . Just) =<< queryStakeAddressRef addr +insertStakeAddressRefIfMissing trce cache txId addr = + maybe insertSAR (pure . Just) =<< queryStakeAddressRef where insertSAR :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m (Maybe DB.StakeAddressId) insertSAR = @@ -475,12 +491,26 @@ insertStakeAddressRefIfMissing trce txId addr = pure mid Ledger.StakeRefNull -> pure Nothing + queryStakeAddressRef + :: MonadIO m + => ReaderT SqlBackend m (Maybe DB.StakeAddressId) + queryStakeAddressRef = + case addr of + Ledger.AddrBootstrap {} -> pure Nothing + Ledger.Addr nw _pcred sref -> + case sref of + Ledger.StakeRefBase cred -> do + eres <- queryStakeAddrWithCache cache DontCacheNew $ Generic.StakeCred $ Ledger.serialiseRewardAcnt (Ledger.RewardAcnt nw cred) + pure $ either (const Nothing) Just eres + Ledger.StakeRefPtr ptr -> queryStakeDelegation ptr + Ledger.StakeRefNull -> pure Nothing + insertPoolOwner :: (MonadBaseControl IO m, MonadIO m) - => Ledger.Network -> DB.PoolUpdateId -> DB.TxId -> Ledger.KeyHash 'Ledger.Staking StandardCrypto + => Cache -> Ledger.Network -> DB.PoolUpdateId -> DB.TxId -> Ledger.KeyHash 'Ledger.Staking StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertPoolOwner network poolUpdateId txId skh = do - saId <- lift $ insertStakeAddress txId (Shelley.RewardAcnt network (Ledger.KeyHashObj skh)) +insertPoolOwner cache network poolUpdateId txId skh = do + saId <- lift $ insertStakeAddressWithCache cache CacheNew txId (Shelley.RewardAcnt network (Ledger.KeyHashObj skh)) void . lift . DB.insertPoolOwner $ DB.PoolOwner { DB.poolOwnerAddrId = saId @@ -489,9 +519,12 @@ insertPoolOwner network poolUpdateId txId skh = do insertStakeRegistration :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> EpochNo -> DB.TxId -> Word16 -> Shelley.RewardAcnt StandardCrypto + => EpochNo -> DB.TxId -> Word16 -> Shelley.RewardAcnt StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertStakeRegistration _tracer epochNo txId idx rewardAccount = do +insertStakeRegistration epochNo txId idx rewardAccount = do + -- We by-pass the cache here It's likely it won't hit. + -- We don't store to the cache yet, since there are many addrresses + -- which are registered and never used. saId <- lift $ insertStakeAddress txId rewardAccount void . lift . DB.insertStakeRegistration $ DB.StakeRegistration @@ -503,11 +536,11 @@ insertStakeRegistration _tracer epochNo txId idx rewardAccount = do insertStakeDeregistration :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Ledger.Network -> EpochNo -> DB.TxId -> Word16 -> Maybe Word64 + => Cache -> Ledger.Network -> EpochNo -> DB.TxId -> Word16 -> Maybe Word64 -> [(DB.RedeemerId, Generic.TxRedeemer)] -> Ledger.StakeCredential StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertStakeDeregistration _tracer network epochNo txId idx ridx redeemers cred = do - scId <- liftLookupFail "insertStakeDeregistration" $ queryStakeAddress (Generic.stakingCredHash network cred) +insertStakeDeregistration cache network epochNo txId idx ridx redeemers cred = do + scId <- liftLookupFail "insertStakeDeregistration" $ queryStakeAddrWithCache cache EvictAndReturn (Generic.toStakeCred network cred) void . lift . DB.insertStakeDeregistration $ DB.StakeDeregistration { DB.stakeDeregistrationAddrId = scId @@ -524,14 +557,14 @@ insertStakeDeregistration _tracer network epochNo txId idx ridx redeemers cred = insertDelegation :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Ledger.Network -> EpochNo -> SlotNo -> DB.TxId -> Word16 -> Maybe Word64 + => Cache -> Ledger.Network -> EpochNo -> SlotNo -> DB.TxId -> Word16 -> Maybe Word64 -> Ledger.StakeCredential StandardCrypto -> [(DB.RedeemerId, Generic.TxRedeemer)] -> Ledger.KeyHash 'Ledger.StakePool StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertDelegation _tracer network (EpochNo epoch) slotNo txId idx ridx cred redeemers poolkh = do - addrId <- liftLookupFail "insertDelegation" $ queryStakeAddress (Generic.stakingCredHash network cred) - poolHashId <-liftLookupFail "insertDelegation" $ queryStakePoolKeyHash poolkh +insertDelegation cache network (EpochNo epoch) slotNo txId idx ridx cred redeemers poolkh = do + addrId <- liftLookupFail "insertDelegation" $ queryStakeAddrWithCache cache CacheNew (Generic.toStakeCred network cred) + poolHashId <-liftLookupFail "insertDelegation" $ queryPoolKeyWithCache cache CacheNew (toStakePoolKeyHash poolkh) void . lift . DB.insertDelegation $ DB.Delegation { DB.delegationAddrId = addrId @@ -550,9 +583,9 @@ insertDelegation _tracer network (EpochNo epoch) slotNo txId idx ridx cred redee insertMirCert :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Ledger.Network -> DB.TxId -> Word16 -> Shelley.MIRCert StandardCrypto + => Trace IO Text -> Cache -> Ledger.Network -> DB.TxId -> Word16 -> Shelley.MIRCert StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertMirCert _tracer network txId idx mcert = do +insertMirCert _tracer cache network txId idx mcert = do case Shelley.mirPot mcert of Shelley.ReservesMIR -> case Shelley.mirRewards mcert of @@ -570,7 +603,7 @@ insertMirCert _tracer network txId idx mcert = do => (Ledger.StakeCredential StandardCrypto, Ledger.DeltaCoin) -> ExceptT SyncNodeError (ReaderT SqlBackend m) () insertMirReserves (cred, dcoin) = do - addrId <- lift . insertStakeAddress txId $ Generic.annotateStakingCred network cred + addrId <- lift . insertStakeAddressWithCache cache CacheNew txId $ Generic.annotateStakingCred network cred void . lift . DB.insertReserve $ DB.Reserve { DB.reserveAddrId = addrId @@ -584,7 +617,7 @@ insertMirCert _tracer network txId idx mcert = do => (Ledger.StakeCredential StandardCrypto, Ledger.DeltaCoin) -> ExceptT SyncNodeError (ReaderT SqlBackend m) () insertMirTreasury (cred, dcoin) = do - addrId <- lift . insertStakeAddress txId $ Generic.annotateStakingCred network cred + addrId <- lift . insertStakeAddressWithCache cache CacheNew txId $ Generic.annotateStakingCred network cred void . lift . DB.insertTreasury $ DB.Treasury { DB.treasuryAddrId = addrId @@ -835,9 +868,9 @@ insertEpochParam tracer blkId (EpochNo epoch) params nonce = do insertMaTxMint :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> DB.TxId -> Value StandardCrypto + => Trace IO Text -> Cache -> DB.TxId -> Value StandardCrypto -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertMaTxMint _tracer txId (Value _adaShouldAlwaysBeZeroButWeDoNotCheck mintMap) = +insertMaTxMint _tracer cache txId (Value _adaShouldAlwaysBeZeroButWeDoNotCheck mintMap) = mapM_ (lift . insertOuter) $ Map.toList mintMap where insertOuter @@ -852,7 +885,7 @@ insertMaTxMint _tracer txId (Value _adaShouldAlwaysBeZeroButWeDoNotCheck mintMap => PolicyID StandardCrypto -> (AssetName, Integer) -> ReaderT SqlBackend m () insertInner policy (aname, amount) = do - maId <- insertMultiAsset policy aname + maId <- insertMultiAsset cache policy aname void . DB.insertMaTxMint $ DB.MaTxMint { DB.maTxMintIdent = maId @@ -862,9 +895,9 @@ insertMaTxMint _tracer txId (Value _adaShouldAlwaysBeZeroButWeDoNotCheck mintMap prepareMaTxOuts :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Map (PolicyID StandardCrypto) (Map AssetName Integer) + => Trace IO Text -> Cache -> Map (PolicyID StandardCrypto) (Map AssetName Integer) -> ExceptT SyncNodeError (ReaderT SqlBackend m) [MissingMaTxOut] -prepareMaTxOuts _tracer maMap = +prepareMaTxOuts _tracer cache maMap = concatMapM (lift . prepareOuter) $ Map.toList maMap where prepareOuter @@ -879,7 +912,7 @@ prepareMaTxOuts _tracer maMap = => PolicyID StandardCrypto -> (AssetName, Integer) -> ReaderT SqlBackend m MissingMaTxOut prepareInner policy (aname, amount) = do - maId <- insertMultiAsset policy aname + maId <- insertMultiAsset cache policy aname pure $ MissingMaTxOut { mmtoIdent = maId @@ -888,19 +921,20 @@ prepareMaTxOuts _tracer maMap = insertMultiAsset :: (MonadBaseControl IO m, MonadIO m) - => PolicyID StandardCrypto -> AssetName + => Cache -> PolicyID StandardCrypto -> AssetName -> ReaderT SqlBackend m DB.MultiAssetId -insertMultiAsset p@(PolicyID pol) a@(AssetName aName) = do - mId <- DB.queryMultiAssetId (Generic.unScriptHash pol) aName +insertMultiAsset cache (PolicyID pol) a@(AssetName aName) = do + mId <- queryMAWithCache cache policy a case mId of Just maId -> pure maId Nothing -> DB.insertMultiAssetUnchecked $ DB.MultiAsset - { DB.multiAssetPolicy = Generic.unScriptHash pol + { DB.multiAssetPolicy = policy , DB.multiAssetName = aName - , DB.multiAssetFingerprint = DB.unAssetFingerprint (DB.mkAssetFingerprint p a) + , DB.multiAssetFingerprint = DB.unAssetFingerprint (DB.mkAssetFingerprint policy a) } - + where + policy = Generic.unScriptHash pol insertScript :: (MonadBaseControl IO m, MonadIO m) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs index 3b8ffea64..9ffe8a7ea 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs @@ -8,9 +8,8 @@ module Cardano.DbSync.Era.Shelley.Query ( queryPoolHashId , queryStakeAddress - , queryStakePoolKeyHash , queryStakeRefPtr - , queryStakeAddressRef + , queryStakeDelegation , queryResolveInput , queryResolveInputCredentials @@ -25,9 +24,7 @@ import Cardano.Db import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.Ledger.BaseTypes -import qualified Cardano.Ledger.Address as Ledger -import Cardano.Ledger.Credential (Ptr (..), StakeReference (..)) -import qualified Cardano.Ledger.Keys as Ledger +import Cardano.Ledger.Credential (Ptr (..)) import Cardano.DbSync.Util @@ -36,8 +33,6 @@ import Cardano.Slotting.Slot (SlotNo (..)) import Database.Esqueleto.Experimental (SqlBackend, Value (..), desc, from, innerJoin, just, limit, on, orderBy, select, table, val, where_, (:&) ((:&)), (==.), (^.)) -import Ouroboros.Consensus.Cardano.Block (StandardCrypto) - {- HLINT ignore "Fuse on/on" -} queryPoolHashId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe PoolHashId) @@ -59,65 +54,27 @@ queryStakeAddress addr = do pure (saddr ^. StakeAddressId) pure $ maybeToEither (DbLookupMessage $ "StakeAddress " <> renderByteArray addr) unValue (listToMaybe res) -queryStakePoolKeyHash - :: forall era m. MonadIO m - => Ledger.KeyHash 'Ledger.StakePool era - -> ReaderT SqlBackend m (Either LookupFail PoolHashId) -queryStakePoolKeyHash kh = do +queryStakeDelegation + :: MonadIO m + => Ptr + -> ReaderT SqlBackend m (Maybe StakeAddressId) +queryStakeDelegation (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do res <- select $ do - (blk :& _ :& _ :& poolHash) <- - from $ table @Block + (dlg :& tx :& blk) <- + from $ table @Delegation `innerJoin` table @Tx - `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) - `innerJoin` table @PoolUpdate - `on` (\(_ :& tx :& poolUpdate) -> tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId) - `innerJoin` table @PoolHash - `on` (\(_ :& _ :& poolUpdate :& poolHash) -> poolUpdate ^. PoolUpdateHashId ==. poolHash ^. PoolHashId) - where_ (poolHash ^. PoolHashHashRaw ==. val (Generic.unKeyHashRaw kh)) + `on` (\(dlg :& tx) -> tx ^. TxId ==. dlg ^. DelegationTxId) + `innerJoin` table @Block + `on` (\(_dlg :& tx :& blk) -> blk ^. BlockId ==. tx ^. TxBlockId) + where_ (blk ^. BlockSlotNo ==. just (val slot)) + where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx)) + where_ (dlg ^. DelegationCertIndex ==. val (fromIntegral certIx)) + -- Need to order by BlockSlotNo descending for correct behavior when there are two + -- or more delegation certificates in a single epoch. orderBy [desc (blk ^. BlockSlotNo)] limit 1 - pure (poolHash ^. PoolHashId) - - pure $ maybeToEither (DbLookupMessage "StakePoolKeyHash") unValue (listToMaybe res) - -queryStakeAddressRef - :: MonadIO m - => Ledger.Addr StandardCrypto - -> ReaderT SqlBackend m (Maybe StakeAddressId) -queryStakeAddressRef addr = - case addr of - Ledger.AddrBootstrap {} -> pure Nothing - Ledger.Addr nw _pcred sref -> - case sref of - StakeRefBase cred -> do - eres <- queryStakeAddress $ Ledger.serialiseRewardAcnt (Ledger.RewardAcnt nw cred) - pure $ either (const Nothing) Just eres - StakeRefPtr ptr -> queryStakeDelegation ptr - StakeRefNull -> pure Nothing - where - queryStakeDelegation - :: MonadIO m - => Ptr - -> ReaderT SqlBackend m (Maybe StakeAddressId) - queryStakeDelegation (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do - res <- select $ do - (dlg :& tx :& blk) <- - from $ table @Delegation - `innerJoin` table @Tx - `on` (\(dlg :& tx) -> tx ^. TxId ==. dlg ^. DelegationTxId) - `innerJoin` table @Block - `on` (\(_dlg :& tx :& blk) -> blk ^. BlockId ==. tx ^. TxBlockId) - - where_ (blk ^. BlockSlotNo ==. just (val slot)) - where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx)) - where_ (dlg ^. DelegationCertIndex ==. val certIx) - -- Need to order by BlockSlotNo descending for correct behavior when there are two - -- or more delegation certificates in a single epoch. - orderBy [desc (blk ^. BlockSlotNo)] - limit 1 - pure (dlg ^. DelegationAddrId) - - pure $ unValue <$> listToMaybe res + pure (dlg ^. DelegationAddrId) + pure $ unValue <$> listToMaybe res queryResolveInput :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) queryResolveInput txIn = diff --git a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs index bd04f8540..ebcf8d859 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + module Cardano.DbSync.Rollback ( rollbackToPoint , unsafeRollback @@ -13,8 +15,9 @@ import Cardano.BM.Trace (Trace, logInfo) import qualified Cardano.Db as DB +import Cardano.DbSync.Api +import Cardano.DbSync.Cache import Cardano.DbSync.Era.Util - import Cardano.DbSync.Error import Cardano.DbSync.Types import Cardano.DbSync.Util @@ -29,10 +32,14 @@ import Ouroboros.Network.Point -- Rollbacks are done in an Era generic way based on the 'Point' we are -- rolling back to. -rollbackToPoint :: SqlBackend -> Trace IO Text -> CardanoPoint -> IO (Either SyncNodeError ()) -rollbackToPoint backend trce point = +rollbackToPoint :: SyncEnv -> CardanoPoint -> IO (Either SyncNodeError ()) +rollbackToPoint env point = DB.runDbIohkNoLogging backend $ runExceptT action where + backend = envBackend env + trce = getTrace env + cache = envCache env + action :: MonadIO m => ExceptT SyncNodeError (ReaderT SqlBackend m) () action = do liftIO . logInfo trce $ "Rolling back to " <> renderPoint point @@ -47,7 +54,11 @@ rollbackToPoint backend trce point = ] -- We delete the block right after the point we rollback to. This delete -- should cascade to the rest of the chain. - prevId <- liftLookupFail "Rollback.rollbackToPoint" $ queryBlockId point + (prevId, mBlockNo) <- liftLookupFail "Rollback.rollbackToPoint" $ queryBlock point + -- 'length xs' here gives an approximation of the blocks deleted. An approximation + -- is good enough, since it is only used to decide on the best policy and is not + -- important for correctness. + lift $ rollbackCache cache mBlockNo (fromIntegral $ length xs) deleted <- lift $ DB.deleteCascadeAfter prevId liftIO . logInfo trce $ if deleted @@ -60,11 +71,14 @@ rollbackToPoint backend trce point = Origin -> DB.querySlotNos At sl -> DB.querySlotNosGreaterThan (unSlotNo sl) - queryBlockId :: MonadIO m => Point CardanoBlock -> ReaderT SqlBackend m (Either DB.LookupFail DB.BlockId) - queryBlockId pnt = + queryBlock :: MonadIO m => Point CardanoBlock + -> ReaderT SqlBackend m (Either DB.LookupFail (DB.BlockId, Maybe Word64)) + queryBlock pnt = do case getPoint pnt of - Origin -> DB.queryGenesis - At blk -> DB.queryBlockId (SBS.fromShort . getOneEraHash $ blockPointHash blk) + Origin -> + fmap (, Nothing) <$> DB.queryGenesis + At blkPoint -> + DB.queryBlockNoId (SBS.fromShort . getOneEraHash $ blockPointHash blkPoint) -- For testing and debugging. unsafeRollback :: Trace IO Text -> DB.PGConfig -> SlotNo -> IO (Either SyncNodeError ()) diff --git a/cardano-db/src/Cardano/Db/Types.hs b/cardano-db/src/Cardano/Db/Types.hs index a8cc6c26a..f7855ed2f 100644 --- a/cardano-db/src/Cardano/Db/Types.hs +++ b/cardano-db/src/Cardano/Db/Types.hs @@ -39,13 +39,9 @@ module Cardano.Db.Types , word64ToAda ) where -import qualified Cardano.Crypto.Hash as Crypto - import Cardano.Ledger.Coin (DeltaCoin (..)) -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..)) +import Cardano.Ledger.Mary.Value (AssetName (..)) import Cardano.Ledger.Shelley.Rewards as Shelley -import qualified Cardano.Ledger.Shelley.Scripts as Shelley import qualified Codec.Binary.Bech32 as Bech32 @@ -95,10 +91,10 @@ newtype AssetFingerprint = AssetFingerprint { unAssetFingerprint :: Text } deriving (Eq, Show) -mkAssetFingerprint :: PolicyID StandardCrypto -> AssetName -> AssetFingerprint -mkAssetFingerprint (PolicyID (Shelley.ScriptHash h)) (AssetName name) = +mkAssetFingerprint :: ByteString -> AssetName -> AssetFingerprint +mkAssetFingerprint policyId (AssetName name) = AssetFingerprint . Bech32.encodeLenient hrp . Bech32.dataPartFromBytes . ByteArray.convert - $ Crypto.Hash.hash @_ @Blake2b_160 (Crypto.hashToBytes h <> name) + $ Crypto.Hash.hash @_ @Blake2b_160 (policyId <> name) where hrp :: Bech32.HumanReadablePart hrp = diff --git a/cardano-db/test/Test/Property/Cardano/Db/Types.hs b/cardano-db/test/Test/Property/Cardano/Db/Types.hs index 44f8d020c..e4312d1f5 100644 --- a/cardano-db/test/Test/Property/Cardano/Db/Types.hs +++ b/cardano-db/test/Test/Property/Cardano/Db/Types.hs @@ -48,8 +48,12 @@ prop_roundtrip_Ada_via_JSON = prop_AssetFingerprint :: Property prop_AssetFingerprint = H.withTests 1 . H.property $ - mapM_ (\(p, a, f) -> mkAssetFingerprint p a === f) testVectors + mapM_ (\(p, a, f) -> mkAssetFingerprint (unScriptHash $ policyID p) a === f) testVectors where + + unScriptHash :: Ledger.ScriptHash StandardCrypto -> ByteString + unScriptHash (Ledger.ScriptHash h) = Crypto.hashToBytes h + testVectors :: [(PolicyID StandardCrypto, AssetName, AssetFingerprint)] testVectors = [ ( mkPolicyId "7eae28af2208be856f7a119668ae52a49b73725e326dc16579dcc373" From a727dd78296beee0487153f1805e29d6012b5d64 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Thu, 7 Apr 2022 00:19:54 +0300 Subject: [PATCH 08/11] New events --- cabal.project | 8 - .../src/Cardano/Mock/Forging/Tx/Generic.hs | 1 + .../test/Test/Cardano/Db/Mock/Unit.hs | 2 +- .../test/Test/Cardano/Db/Mock/Validate.hs | 4 +- .../config-shelley/test-db-sync-config.json | 4 +- cardano-db-sync/cardano-db-sync.cabal | 1 - cardano-db-sync/src/Cardano/DbSync/Default.hs | 99 +++---- .../src/Cardano/DbSync/Era/Shelley/Adjust.hs | 87 +++--- .../DbSync/Era/Shelley/Generic/Rewards.hs | 157 +---------- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 14 +- .../src/Cardano/DbSync/Era/Shelley/Insert.hs | 20 +- .../DbSync/Era/Shelley/Insert/Epoch.hs | 249 +++--------------- .../Cardano/DbSync/Era/Shelley/Validate.hs | 21 +- .../src/Cardano/DbSync/LedgerEvent.hs | 61 +++-- .../src/Cardano/DbSync/LedgerState.hs | 54 +--- config/testnet-config.yaml | 2 +- 16 files changed, 203 insertions(+), 581 deletions(-) diff --git a/cabal.project b/cabal.project index c045c3da8..9dc1c2c61 100644 --- a/cabal.project +++ b/cabal.project @@ -243,14 +243,6 @@ source-repository-package stubs/plutus-ghc-stub word-array -source-repository-package - type: git - location: https://github.com/input-output-hk/cardano-addresses - tag: 71006f9eb956b0004022e80aadd4ad50d837b621 - subdir: - command-line - core - -- Something in plutus-core requries this. source-repository-package diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs index c42d7631a..fcfa9d2c8 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs @@ -185,5 +185,6 @@ createPaymentCredentials n = mkDummyScriptHash :: Int -> ScriptHash StandardCrypto mkDummyScriptHash n = ScriptHash $ mkDummyHash (Proxy @(ADDRHASH StandardCrypto)) n +{-# ANN module ("HLint: ignore Avoid restricted function" :: Text) #-} mkDummyHash :: forall h a. HashAlgorithm h => Proxy h -> Int -> Hash.Hash h a mkDummyHash _ = coerce . hashWithSerialiser @h toCBOR diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs index b9bd910e5..c54c58286 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs @@ -86,7 +86,7 @@ unitTests iom knownMigrations = , test "stake address pointers. Use before registering." stakeAddressPtrUseBefore ] , testGroup "rewards" - [ test "rewards" simpleRewards + [ test "rewards simple" simpleRewards , test "shelley rewards from multiple sources" rewardsShelley , test "rewards with deregistration" rewardsDeregistration , test "Mir Cert" mirReward diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs index 43a52b743..d8b6a73a7 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -154,8 +154,8 @@ assertCertCounts env expected = (select . from $ \(_a :: SqlExpr (Entity Delegation)) -> pure countRows) withdrawal <- maybe 0 unValue . listToMaybe <$> (select . from $ \(_a :: SqlExpr (Entity Withdrawal)) -> pure countRows) - -- We deduct the initial delegation in the genesis - pure (registr, deregistr, deleg - 5, withdrawal) + -- We deduct the initial registration and delegation in the genesis + pure (registr - 5, deregistr, deleg - 5, withdrawal) assertRewardCounts :: (Crypto era ~ StandardCrypto) => DBSyncEnv -> LedgerState (ShelleyBlock era) -> Bool diff --git a/cardano-chain-gen/test/testfiles/config-shelley/test-db-sync-config.json b/cardano-chain-gen/test/testfiles/config-shelley/test-db-sync-config.json index 678d34067..02914ca3c 100644 --- a/cardano-chain-gen/test/testfiles/config-shelley/test-db-sync-config.json +++ b/cardano-chain-gen/test/testfiles/config-shelley/test-db-sync-config.json @@ -14,14 +14,14 @@ "stdout" ] ], - "minSeverity": "Error", + "minSeverity": "Info", "options": { "cfokey": { "value": "Release-1.0.0" }, "mapBackends": {}, "mapSeverity": { - "db-sync-node": "Error", + "db-sync-node": "Info", "db-sync-node.Mux": "Error", "db-sync-node.Subscription": "Error" }, diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index 826c3f09f..03d36e57f 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -169,7 +169,6 @@ library , psqueues , random-shuffle , small-steps - , split , stm , strict , strict-containers diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 094d1702b..8547c94e9 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -11,19 +11,19 @@ module Cardano.DbSync.Default import Cardano.Prelude -import Cardano.BM.Trace (Trace, logDebug, logInfo) +import Cardano.BM.Trace (logDebug, logInfo) import qualified Cardano.Db as DB import Cardano.DbSync.Api +import Cardano.DbSync.Cache import Cardano.DbSync.Epoch import Cardano.DbSync.Era.Byron.Insert (insertByronBlock) import Cardano.DbSync.Era.Cardano.Insert (insertEpochSyncTime) import Cardano.DbSync.Era.Shelley.Adjust (adjustEpochRewards) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Insert (insertShelleyBlock) -import Cardano.DbSync.Era.Shelley.Insert.Epoch (finalizeEpochBulkOps, forceInsertRewards, - insertPoolDepositRefunds, isEmptyEpochBulkOps, postEpochRewards) +import Cardano.DbSync.Era.Shelley.Insert.Epoch (insertPoolDepositRefunds, insertRewards) import Cardano.DbSync.Era.Shelley.Validate (validateEpochRewards) import Cardano.DbSync.Error import Cardano.DbSync.LedgerState (LedgerEvent (..), LedgerStateSnapshot (..), applyBlock, @@ -42,7 +42,6 @@ import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad.Class.MonadSTM.Strict (putTMVar, tryTakeTMVar) import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except.Extra (newExceptT) @@ -75,7 +74,7 @@ insertDefaultBlock env blocks = lStateSnap <- liftIO $ applyBlock (envLedger env) cblk let !details = lssSlotDetails lStateSnap mkSnapshotMaybe env lStateSnap (blockNo cblk) (isSyncedWithinSeconds details 600) - handleLedgerEvents tracer (envLedger env) (lssPoint lStateSnap) (lssEvents lStateSnap) + handleLedgerEvents env (sdEpochNo details) (lssEvents lStateSnap) let firstBlockOfEpoch = hasEpochStartEvent (lssEvents lStateSnap) case cblk of BlockByron blk -> @@ -101,16 +100,13 @@ mkSnapshotMaybe env snapshot blkNo syncState = Just newEpoch -> do liftIO $ logDebug (leTrace $ envLedger env) "Preparing for a snapshot" let newEpochNo = Generic.neEpoch newEpoch - -- flush all volatile data - finalizeEpochBulkOps (envLedger env) liftIO $ logDebug (leTrace $ envLedger env) "Taking a ledger a snapshot" -- finally take a ledger snapshot -- TODO: Instead of newEpochNo - 1, is there any way to get the epochNo from 'lssOldState'? liftIO $ saveCleanupState (envLedger env) (lssOldState snapshot) (Just $ newEpochNo - 1) Nothing -> - when (timeToSnapshot syncState blkNo) . - whenM (isEmptyEpochBulkOps $ envLedger env) . - liftIO $ saveCleanupState (envLedger env) (lssOldState snapshot) Nothing + when (timeToSnapshot syncState blkNo) $ + liftIO $ saveCleanupState (envLedger env) (lssOldState snapshot) Nothing where timeToSnapshot :: DB.SyncState -> BlockNo -> Bool @@ -123,11 +119,20 @@ mkSnapshotMaybe env snapshot blkNo syncState = handleLedgerEvents :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerEnv -> CardanoPoint -> [LedgerEvent] + => SyncEnv -> EpochNo -> [LedgerEvent] -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -handleLedgerEvents tracer lenv point = +handleLedgerEvents env currentEpochNo@(EpochNo curEpoch) = mapM_ handler where + tracer = getTrace env + lenv = envLedger env + cache = envCache env + + subFromCurrentEpoch :: Word64 -> EpochNo + subFromCurrentEpoch m = + if unEpochNo currentEpochNo >= m then EpochNo $ unEpochNo currentEpochNo - m + else EpochNo 0 + handler :: (MonadBaseControl IO m, MonadIO m) => LedgerEvent -> ExceptT SyncNodeError (ReaderT SqlBackend m) () @@ -136,32 +141,32 @@ handleLedgerEvents tracer lenv point = LedgerNewEpoch en ss -> do lift $ do insertEpochSyncTime en ss (leEpochSyncTime lenv) - adjustEpochRewards tracer en - finalizeEpochBulkOps lenv - -- Commit everything in the db *AFTER* the epoch rewards have been inserted, the orphaned - -- rewards removed and the bulk operations finalized. - lift DB.transactionCommit + stats <- liftIO $ textShowStats cache + liftIO . logInfo tracer $ stats liftIO . logInfo tracer $ "Starting epoch " <> textShow (unEpochNo en) LedgerStartAtEpoch en -> -- This is different from the previous case in that the db-sync started -- in this epoch, for example after a restart, instead of after an epoch boundary. liftIO . logInfo tracer $ "Starting at epoch " <> textShow (unEpochNo en) - LedgerRewards _details rwds -> do - liftIO . logInfo tracer $ mconcat - [ "Handling ", show (Map.size (Generic.rwdRewards rwds)), " rewards for epoch " - , show (unEpochNo $ Generic.rwdEpoch rwds), " ", renderPoint point - ] - postEpochRewards lenv rwds point - - LedgerDeltaRewards _ -> pure () - LedgerIncrementalRewards _rew -> pure () - - LedgerTotalRewards rwd -> - lift $ stashPoolRewards tracer lenv rwd - LedgerMirDist md -> - lift $ stashMirRewards tracer lenv md + LedgerDeltaRewards rwd -> do + let rewards = Map.toList $ Generic.rwdRewards rwd + insertRewards (subFromCurrentEpoch 2) currentEpochNo cache (Map.toList $ Generic.rwdRewards rwd) + -- This event is only created when it's not empty, so we don't need to check for null here. + liftIO . logInfo tracer $ "Inserted " <> show (length rewards) <> " Delta rewards" + LedgerIncrementalRewards rwd -> do + let rewards = Map.toList $ Generic.rwdRewards rwd + insertRewards (subFromCurrentEpoch 1) (EpochNo $ curEpoch + 1) cache rewards + LedgerRestrainedRewards e rwd creds -> do + lift $ adjustEpochRewards tracer cache e rwd creds + LedgerTotalRewards rwd -> do + lift $ validateEpochRewards tracer (subFromCurrentEpoch 2) rwd + LedgerMirDist rwd -> do + let rewards = Map.toList rwd + insertRewards (subFromCurrentEpoch 1) currentEpochNo cache rewards + unless (null rewards) $ + liftIO . logInfo tracer $ "Inserted " <> show (length rewards) <> " Mir rewards" LedgerPoolReap en drs -> - insertPoolDepositRefunds lenv (Generic.Rewards en $ convertPoolDepositReunds (leNetwork lenv) drs) + insertPoolDepositRefunds env (Generic.Rewards en $ convertPoolDepositReunds (leNetwork lenv) drs) convertPoolDepositReunds :: Network -> Map (StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin) @@ -190,33 +195,3 @@ hasEpochStartEvent = any isNewEpoch LedgerNewEpoch {} -> True LedgerStartAtEpoch {} -> True _otherwise -> False - --- ------------------------------------------------------------------------------------------------- --- These two functions must handle being called in either order. -stashPoolRewards - :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerEnv -> Generic.Rewards - -> ReaderT SqlBackend m () -stashPoolRewards tracer lenv rmap = do - mMirRwd <- liftIO . atomically $ tryTakeTMVar (leMirRewards lenv) - case mMirRwd of - Nothing -> - liftIO . atomically $ putTMVar (lePoolRewards lenv) rmap - Just mirMap -> do - let totalRwds = Generic.mergeRewards rmap mirMap - forceInsertRewards tracer lenv totalRwds - validateEpochRewards tracer (Generic.mergeRewards rmap mirMap) - -stashMirRewards - :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerEnv -> Generic.Rewards - -> ReaderT SqlBackend m () -stashMirRewards tracer lenv mirMap = do - mRwds <- liftIO . atomically $ tryTakeTMVar (lePoolRewards lenv) - case mRwds of - Nothing -> - liftIO . atomically $ putTMVar (leMirRewards lenv) mirMap - Just rmap -> do - let totalRwds = Generic.mergeRewards rmap mirMap - forceInsertRewards tracer lenv totalRwds - validateEpochRewards tracer totalRwds diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs index 765e0b2f8..1aef9d32a 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs @@ -13,17 +13,19 @@ import Cardano.BM.Trace (Trace, logInfo) import qualified Cardano.Db as Db -import Cardano.DbSync.Util +import Cardano.DbSync.Cache +import qualified Cardano.DbSync.Era.Shelley.Generic.Rewards as Generic +import Cardano.DbSync.Era.Shelley.Generic.StakeCred import Cardano.Slotting.Slot (EpochNo (..)) import Control.Monad.Trans.Control (MonadBaseControl) -import qualified Data.List.Extra as List +import qualified Data.Map as Map +import qualified Data.Set as Set -import Database.Esqueleto.Experimental (SqlBackend, delete, from, in_, innerJoin, - notExists, on, select, table, val, valList, where_, (&&.), (:&) ((:&)), (==.), - (>.), (^.)) +import Database.Esqueleto.Experimental (SqlBackend, delete, from, in_, table, val, + valList, where_, (==.), (^.)) -- Hlint warns about another version of this operator. {- HLINT ignore "Redundant ^." -} @@ -38,53 +40,42 @@ import Database.Esqueleto.Experimental (SqlBackend, delete, from, in_, adjustEpochRewards :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> EpochNo + => Trace IO Text -> Cache -> EpochNo -> Generic.Rewards + -> Set StakeCred -> ReaderT SqlBackend m () -adjustEpochRewards tracer epochNo = do - when (epochNo >= 2) $ do - (addrs, ada) <- queryOrphanedRewards epochNo - unless (null addrs) $ do - liftIO . logInfo tracer $ mconcat - [ "adjustEpochRewards: starting epoch ", textShow (unEpochNo epochNo), ", " - , textShow (length addrs), " orphaned rewards removed (" - , textShow ada, " ADA)" - ] - deleteOrphanedRewards epochNo addrs - --- ------------------------------------------------------------------------------------------------ +adjustEpochRewards tracer cache epochNo rwds creds = do + let eraIgnored = Map.toList $ Generic.rwdRewards rwds + liftIO . logInfo tracer $ mconcat + [ "Removing ", if null eraIgnored then "" else Db.textShow (length eraIgnored) <> " rewards and " + , show (length creds), " orphaned rewards"] + forM_ eraIgnored $ \(cred, rewards)-> + forM_ (Set.toList rewards) $ \rwd -> + deleteReward cache epochNo (cred, rwd) + crds <- rights <$> forM (Set.toList creds) (queryStakeAddrWithCache cache DontCacheNew) + deleteOrphanedRewards epochNo crds + +deleteReward + :: (MonadBaseControl IO m, MonadIO m) + => Cache -> EpochNo -> (StakeCred, Generic.Reward) + -> ReaderT SqlBackend m () +deleteReward cache epochNo (cred, rwd) = do + mAddrId <- queryStakeAddrWithCache cache DontCacheNew cred + eiPoolId <- case Generic.rewardPool rwd of + Nothing -> pure $ Left $ Db.DbLookupMessage "deleteReward.queryPoolKeyWithCache" + Just poolHash -> queryPoolKeyWithCache cache DontCacheNew poolHash + case (mAddrId, eiPoolId) of + (Right addrId, Right poolId) -> do + delete $ do + rwdDb <- from $ table @Db.Reward + where_ (rwdDb ^. Db.RewardAddrId ==. val addrId) + where_ (rwdDb ^. Db.RewardType ==. val (Generic.rewardSource rwd)) + where_ (rwdDb ^. Db.RewardSpendableEpoch ==. val (unEpochNo epochNo)) + where_ (rwdDb ^. Db.RewardPoolId ==. val (Just poolId)) + _ -> pure () deleteOrphanedRewards :: MonadIO m => EpochNo -> [Db.StakeAddressId] -> ReaderT SqlBackend m () deleteOrphanedRewards (EpochNo epochNo) xs = - delete $ do + delete $ do rwd <- from $ table @Db.Reward where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) where_ (rwd ^. Db.RewardAddrId `in_` valList xs) - --- Uses TxId as a proxy for BlockNo. -queryOrphanedRewards :: MonadIO m => EpochNo -> ReaderT SqlBackend m ([Db.StakeAddressId], Db.Ada) -queryOrphanedRewards (EpochNo epochNo) = do - -- Get payments to addresses that have never been registered. - res1 <- select $ do - rwd <- from $ table @Db.Reward - where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) - where_ (notExists $ do - reg <- from $ table @Db.StakeRegistration - where_ (reg ^. Db.StakeRegistrationAddrId ==. rwd ^. Db.RewardAddrId)) - pure (rwd ^. Db.RewardAddrId, rwd ^. Db.RewardAmount) - -- Get payments to addresses that have been registered but are now deregistered. - res2 <- select $ do - - (dereg :& rwd) <- - from $ table @Db.StakeDeregistration - `innerJoin` table @Db.Reward - `on` (\(dereg :& rwd) -> dereg ^. Db.StakeDeregistrationAddrId ==. rwd ^. Db.RewardAddrId) - where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) - where_ (notExists $ do - reg <- from $ table @Db.StakeRegistration - where_ (reg ^. Db.StakeRegistrationAddrId ==. dereg ^. Db.StakeDeregistrationAddrId - &&. reg ^. Db.StakeRegistrationTxId >. dereg ^. Db.StakeDeregistrationTxId)) - pure (dereg ^. Db.StakeDeregistrationAddrId, rwd ^. Db.RewardAmount) - pure $ convert (map Db.unValue2 $ res1 ++ res2) - where - convert :: [(Db.StakeAddressId, Db.DbLovelace)] -> ([Db.StakeAddressId], Db.Ada) - convert xs = (List.nubOrd (map fst xs), Db.word64ToAda . sum $ map (Db.unDbLovelace . snd) xs) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs index 5501ab8a2..8b7b45eac 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs @@ -1,14 +1,11 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Cardano.DbSync.Era.Shelley.Generic.Rewards ( Reward (..) , Rewards (..) , elemCount - , epochRewards - , mergeRewards , rewardsPoolHashKeys , rewardsStakeCreds , totalAda @@ -16,36 +13,20 @@ module Cardano.DbSync.Era.Shelley.Generic.Rewards import Cardano.Prelude -import Cardano.Db (Ada, RewardSource (..), rewardTypeToSource, textShow, word64ToAda) +import Cardano.Db (Ada, RewardSource (..), word64ToAda) -import qualified Cardano.Ledger.Alonzo.PParams as Alonzo -import qualified Cardano.Ledger.BaseTypes as Ledger import Cardano.Ledger.Coin (Coin (..)) -import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Credential as Ledger -import Cardano.Ledger.Era (Crypto) -import qualified Cardano.Ledger.Keys as Ledger -import qualified Cardano.Ledger.Shelley.LedgerState as Shelley -import qualified Cardano.Ledger.Shelley.PParams as Shelley -import qualified Cardano.Ledger.Shelley.Rewards as Shelley import Cardano.Slotting.Slot (EpochNo (..)) import Cardano.DbSync.Era.Shelley.Generic.StakeCred import Cardano.DbSync.Era.Shelley.Generic.StakePoolKeyHash -import Cardano.DbSync.Types import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto) import Ouroboros.Consensus.Cardano.CanHardFork () -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) -import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) -import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus --- The fields of this struct *must* remain in this ordering in order for the `Ord` instance --- to work correctly for `takeFirstReward` to operate correctly. data Reward = Reward { rewardSource :: !RewardSource , rewardPool :: !(Maybe StakePoolKeyHash) @@ -63,25 +44,6 @@ data Rewards = Rewards elemCount :: Rewards -> Int elemCount = sum . map Set.size . Map.elems . rwdRewards -epochRewards :: Ledger.Network -> EpochNo -> ExtLedgerState CardanoBlock -> Maybe Rewards -epochRewards nw epoch lstate = - case ledgerState lstate of - LedgerStateByron _ -> Nothing - LedgerStateShelley sls -> genericRewards nw era epoch sls - LedgerStateAllegra als -> genericRewards nw era epoch als - LedgerStateMary mls -> genericRewards nw era epoch mls - LedgerStateAlonzo als -> genericRewards nw era epoch als - where - era :: BlockEra - era = rewardBlockEra $ rewardProtoVer lstate - -mergeRewards :: Rewards -> Rewards -> Rewards -mergeRewards amap bmap = - Rewards - { rwdEpoch = max (rwdEpoch amap) (rwdEpoch bmap) - , rwdRewards = Map.unionWith mappend (rwdRewards amap) (rwdRewards bmap) - } - rewardsPoolHashKeys :: Rewards -> Set StakePoolKeyHash rewardsPoolHashKeys rwds = Set.fromList . mapMaybe rewardPool @@ -90,125 +52,8 @@ rewardsPoolHashKeys rwds = rewardsStakeCreds :: Rewards -> Set StakeCred rewardsStakeCreds = Map.keysSet . rwdRewards -rewardBlockEra :: Ledger.ProtVer -> BlockEra -rewardBlockEra pv = - case pv of - Ledger.ProtVer 2 _ -> Shelley - Ledger.ProtVer 3 _ -> Allegra - Ledger.ProtVer 4 _ -> Mary - Ledger.ProtVer 5 _ -> Alonzo - Ledger.ProtVer 6 _ -> Alonzo - x -> panic $ "rewardBlockEra: " <> textShow x - -rewardProtoVer :: ExtLedgerState CardanoBlock -> Ledger.ProtVer -rewardProtoVer lstate = - case ledgerState lstate of - LedgerStateByron _ -> Ledger.ProtVer 1 0 -- Should never happen. - LedgerStateShelley sls -> Shelley._protocolVersion $ previousPParams sls - LedgerStateAllegra als -> Shelley._protocolVersion $ previousPParams als - LedgerStateMary mls -> Shelley._protocolVersion $ previousPParams mls - LedgerStateAlonzo als -> Alonzo._protocolVersion $ previousPParams als - where - -- Get the *previous* block's PParams by using `esPrevPp` `esPp`. - previousPParams :: LedgerState (ShelleyBlock era) -> Ledger.PParams era - previousPParams = Shelley.esPrevPp . Shelley.nesEs . Consensus.shelleyLedgerState - totalAda :: Rewards -> Ada totalAda rwds = word64ToAda . fromIntegral . sum . concatMap (map (unCoin . rewardAmount) . Set.toList) $ Map.elems (rwdRewards rwds) - --- ------------------------------------------------------------------------------------------------- - -genericRewards - :: forall era. Crypto era ~ StandardCrypto - => Ledger.Network -> BlockEra -> EpochNo -> LedgerState (ShelleyBlock era) - -> Maybe Rewards -genericRewards network era epoch lstate = - fmap cleanup rewardUpdate - where - cleanup :: Map StakeCred (Set Reward) -> Rewards - cleanup rmap = - Rewards - { rwdEpoch = if epoch < 1 then 0 else epoch - 1 -- Epoch in which rewards were earned. - -- The check exists for networks that start at Shelley. - , rwdRewards = filterByEra era rmap - } - - rewardUpdate :: Maybe (Map StakeCred (Set Reward)) - rewardUpdate = - completeRewardUpdate =<< Ledger.strictMaybeToMaybe (Shelley.nesRu $ Consensus.shelleyLedgerState lstate) - - completeRewardUpdate :: Shelley.PulsingRewUpdate StandardCrypto -> Maybe (Map StakeCred (Set Reward)) - completeRewardUpdate x = - case x of - Shelley.Pulsing {} -> Nothing -- Should never happen. - Shelley.Complete ru -> Just $ Map.unionWith mappend - (convertRewardMap $ Shelley.rs ru) - (getInstantaneousRewards network lstate) - - convertRewardMap - :: Map (Ledger.Credential 'Ledger.Staking StandardCrypto) (Set (Shelley.Reward StandardCrypto)) - -> Map StakeCred (Set Reward) - convertRewardMap = mapBimap (toStakeCred network) (Set.map convertReward) - - convertReward :: Shelley.Reward StandardCrypto -> Reward - convertReward sr = - Reward - { rewardSource = rewardTypeToSource $ Shelley.rewardType sr - , rewardAmount = Shelley.rewardAmount sr - , rewardPool = Just $ toStakePoolKeyHash (Shelley.rewardPool sr) - } - -mapBimap :: Ord k2 => (k1 -> k2) -> (a1 -> a2) -> Map k1 a1 -> Map k2 a2 -mapBimap fk fa = Map.fromAscList . map (bimap fk fa) . Map.toAscList - - -getInstantaneousRewards :: forall era. Ledger.Network -> LedgerState (ShelleyBlock era) -> Map StakeCred (Set Reward) -getInstantaneousRewards network lstate = - Map.unionWith mappend - (mapBimap (toStakeCred network) (convert RwdReserves) $ Shelley.iRReserves instRwds) - (mapBimap (toStakeCred network) (convert RwdTreasury) $ Shelley.iRTreasury instRwds) - where - convert :: RewardSource -> Coin -> Set Reward - convert rs coin = - Set.singleton - Reward - { rewardSource = rs - , rewardAmount = coin - , rewardPool = Nothing - } - - instRwds :: Shelley.InstantaneousRewards (Crypto era) - instRwds = - Shelley._irwd . Shelley.dpsDState . Shelley.lsDPState - . Shelley.esLState . Shelley.nesEs $ Consensus.shelleyLedgerState lstate - --- ------------------------------------------------------------------------------------------------- --- `db-sync` needs to match the implementation of the logic in `ledger-specs` even when that logic --- is not actually correct (ie it needs to be bug compatible). Eg it was intended that a single --- stake address can receive rewards from more than one place (eg for being a pool owner and a --- pool member or rewards from two separate pools going to the name stake address). However, due --- to a bug in `ledger-specs` all rewards other than the first are accidentally dropped (caused by --- the use of `Map.union` instead of `Map.unionWith mapppend`). These missing rewards have since --- been paid back with payments from the reserves. - -filterByEra :: BlockEra -> Map StakeCred (Set Reward) -> Map StakeCred (Set Reward) -filterByEra be rmap = - case be of - Byron -> rmap -- Should never happen (Byron does not have rewards) - Shelley -> Map.map takeFirstReward rmap - Allegra -> rmap - Mary -> rmap - Alonzo -> rmap - --- This emulates the `ledger-specs` bug by taking the first element of the reward Set. --- The `Ord` instance on `Reward`, orders by `rewardSource` first, then `rewardPool` and then --- `rewardAmount`. -takeFirstReward :: Set Reward -> Set Reward -takeFirstReward rs = - -- The `toList` operation returns an ordered list. - case Set.toList rs of - [] -> mempty -- Should never happen. - x:_ -> Set.singleton x diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs index 4d1744010..6783bf5ca 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -18,6 +18,8 @@ import Cardano.BM.Trace (Trace, logError, logInfo) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except.Extra (newExceptT) +import Cardano.Slotting.Slot (EpochNo (..)) + import qualified Cardano.Db as DB import Cardano.DbSync.Cache @@ -241,10 +243,7 @@ insertTxOuts trce blkId (ShelleyTx.TxIn txInId _, txOut) = do -- Insert pools and delegations coming from Genesis. insertStaking :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text - -> Cache - -> DB.BlockId - -> ShelleyGenesis StandardShelley + => Trace IO Text -> Cache -> DB.BlockId -> ShelleyGenesis StandardShelley -> ExceptT SyncNodeError (ReaderT SqlBackend m) () insertStaking tracer cache blkId genesis = do -- All Genesis staking comes from an artifical transaction @@ -264,9 +263,12 @@ insertStaking tracer cache blkId genesis = do , DB.txScriptSize = 0 } let params = zip [0..] $ Map.elems (sgsPools $ sgStaking genesis) - forM_ params $ uncurry (insertPoolRegister tracer (Left 2) (sgNetworkId genesis) 0 blkId txId) + let network = sgNetworkId genesis + forM_ params $ uncurry (insertPoolRegister tracer uninitiatedCache (Left 2) network 0 blkId txId) let stakes = zip [0..] $ Map.toList (sgsStake $ sgStaking genesis) - forM_ stakes $ \(n, (keyStaking, keyPool)) -> insertDelegation cache (sgNetworkId genesis) 0 0 txId n Nothing (KeyHashObj keyStaking) [] keyPool + forM_ stakes $ \(n, (keyStaking, keyPool)) -> do + insertStakeRegistration (EpochNo 0) txId (2 * n) (Generic.annotateStakingCred network (KeyHashObj keyStaking)) + insertDelegation cache network 0 0 txId (2 * n + 1) Nothing (KeyHashObj keyStaking) [] keyPool -- ----------------------------------------------------------------------------- diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs index e0f164420..6ba647a55 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs @@ -9,10 +9,10 @@ module Cardano.DbSync.Era.Shelley.Insert ( insertShelleyBlock - , postEpochRewards -- These are exported for data in Shelley Genesis , insertPoolRegister + , insertStakeRegistration , insertDelegation , insertStakeAddressRefIfMissing ) where @@ -61,10 +61,10 @@ import Cardano.DbSync.Util import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..)) -import Control.Monad.Class.MonadSTM.Strict (tryReadTBQueue) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Either.Extra (eitherToMaybe) import Data.Group (invert) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (strictMaybeToMaybe) @@ -87,7 +87,7 @@ insertShelleyBlock env firstBlockOfEpoch blk lStateSnap details = do Just pHash -> queryPrevBlockWithCache (renderInsertName (Generic.blkEra blk)) cache pHash mPhid <- lift $ queryPoolKeyWithCache cache CacheNew (Generic.StakePoolKeyHash $ Generic.blkCreatorPoolHash blk) - slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (Generic.blkSlotLeader blk) (rightToJust mPhid) + slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (Generic.blkSlotLeader blk) (eitherToMaybe mPhid) blkId <- lift . insertBlockAndCache cache $ DB.Block { DB.blockHash = Generic.blkHash blk @@ -137,11 +137,7 @@ insertShelleyBlock env firstBlockOfEpoch blk lStateSnap details = do whenJust (lssNewEpoch lStateSnap) $ \ newEpoch -> do insertOnNewEpoch tracer blkId (Generic.blkSlotNo blk) (sdEpochNo details) newEpoch - insertStakeSlice tracer (leIndexCache lenv) (lssStakeSlice lStateSnap) - - mbop <- liftIO . atomically $ tryReadTBQueue (leBulkOpQueue lenv) - whenJust (maybeToStrict mbop) $ \ bop -> - insertEpochInterleaved tracer bop + insertStakeSlice env (lssStakeSlice lStateSnap) when (unBlockNo (Generic.blkBlockNo blk) `mod` offlineModBase == 0) . lift $ do @@ -172,11 +168,13 @@ insertShelleyBlock env firstBlockOfEpoch blk lStateSnap details = do SyncFollowing -> 10 SyncLagging -> 2000 - rightToJust (Right a) = Just a - rightToJust _ = Nothing - + lenv :: LedgerEnv lenv = envLedger env + + tracer :: Trace IO Text tracer = getTrace env + + cache :: Cache cache = envCache env -- ----------------------------------------------------------------------------- diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs index dd76c0c8a..196ac3d3c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs @@ -9,40 +9,32 @@ {-# LANGUAGE TypeFamilies #-} module Cardano.DbSync.Era.Shelley.Insert.Epoch - ( finalizeEpochBulkOps - , forceInsertRewards - , isEmptyEpochBulkOps - , insertEpochInterleaved + ( insertRewards , insertPoolDepositRefunds - , postEpochRewards , insertStakeSlice + , insertEpochRewardTotalReceived + , sumRewardTotal ) where import Cardano.Prelude -import Cardano.BM.Trace (Trace, logInfo, logWarning) +import Cardano.BM.Trace (Trace, logInfo) import qualified Cardano.Db as DB -import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Query - import qualified Cardano.Ledger.Coin as Shelley +import Cardano.DbSync.Api +import Cardano.DbSync.Cache +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Era.Util (liftLookupFail) import Cardano.DbSync.Error -import Cardano.DbSync.LedgerState -import Cardano.DbSync.Types -import Cardano.DbSync.Util import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad.Class.MonadSTM.Strict (StrictTVar, flushTBQueue, isEmptyTBQueue, - readTVar, readTVarIO, writeTBQueue, writeTVar) import Control.Monad.Extra (mapMaybeM) import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Except.Extra (hoistEither) -import Data.List.Split.Internals (chunksOf) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -50,121 +42,47 @@ import Database.Persist.Sql (SqlBackend) {- HLINT ignore "Use readTVarIO" -} -finalizeEpochBulkOps - :: (MonadBaseControl IO m, MonadIO m) - => LedgerEnv - -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -finalizeEpochBulkOps lenv = do - bops <- liftIO $ atomically $ flushTBQueue (leBulkOpQueue lenv) - unless (null bops) $ - liftIO $ logInfo (leTrace lenv) $ mconcat - ["Flushing remaining ", show (length bops), " BulkOperations"] - mapM_ (insertEpochInterleaved (leTrace lenv)) bops - --- | This gets called with the full set of rewards. If there are no blocks produced in the last 20% --- of the slots within an epoch, the rewards will not be updated in the normal way so they will be --- inserted here. -forceInsertRewards - :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> LedgerEnv -> Generic.Rewards -> ReaderT SqlBackend m () -forceInsertRewards tracer lenv rwds = do - let mapSize = Generic.elemCount rwds - count <- fromIntegral <$> DB.queryEpochRewardCount (unEpochNo $ Generic.rwdEpoch rwds) - when (mapSize > count) $ do - liftIO . logWarning tracer $ mconcat - [ "forceInsertRewards: ", textShow mapSize, " rewards for epoch " - , textShow (unEpochNo $ Generic.rwdEpoch rwds), " is " - , textShow (Generic.totalAda rwds), " ADA" - ] - icache <- updateIndexCache lenv (Generic.rewardsStakeCreds rwds) (Generic.rewardsPoolHashKeys rwds) - res <- runExceptT $ insertRewards (Generic.rwdEpoch rwds - 2) icache (Map.toList $ Generic.rwdRewards rwds) - case res of - Left err -> liftIO . logWarning tracer $ mconcat [ "forceInsertRewards: ", renderSyncNodeError err ] - Right () -> DB.transactionCommit - -insertEpochInterleaved - :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> BulkOperation - -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertEpochInterleaved tracer bop = - case bop of - BulkRewardChunk epochNo _ icache rwds -> - insertRewards epochNo icache rwds - BulkRewardReport epochNo _ rewardCount total -> do - liftIO $ reportRewards epochNo rewardCount - lift $ insertEpochRewardTotalReceived epochNo total - where - reportRewards :: EpochNo -> Int -> IO () - reportRewards epochNo rewardCount = - logInfo tracer $ - mconcat - [ "insertEpochInterleaved: Epoch ", textShow (unEpochNo epochNo) - , ", ", textShow rewardCount, " rewards" - ] - -postEpochRewards - :: (MonadBaseControl IO m, MonadIO m) - => LedgerEnv -> Generic.Rewards -> CardanoPoint - -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -postEpochRewards lenv rwds point = do - icache <- lift $ updateIndexCache lenv (Generic.rewardsStakeCreds rwds) (Generic.rewardsPoolHashKeys rwds) - liftIO . atomically $ do - let epochNo = Generic.rwdEpoch rwds - forM_ (chunksOf 1000 $ Map.toList (Generic.rwdRewards rwds)) $ \rewardChunk -> - writeTBQueue (leBulkOpQueue lenv) $ BulkRewardChunk epochNo point icache rewardChunk - writeTBQueue (leBulkOpQueue lenv) $ - BulkRewardReport epochNo point (length $ Generic.rwdRewards rwds) (sumRewardTotal $ Generic.rwdRewards rwds) - -isEmptyEpochBulkOps - :: MonadIO m - => LedgerEnv - -> ExceptT SyncNodeError (ReaderT SqlBackend m) Bool -isEmptyEpochBulkOps lenv = - liftIO . atomically $ isEmptyTBQueue (leBulkOpQueue lenv) - --- ------------------------------------------------------------------------------------------------- - insertEpochRewardTotalReceived :: (MonadBaseControl IO m, MonadIO m) - => EpochNo -> Shelley.Coin + => EpochNo -> DB.DbLovelace -> ReaderT SqlBackend m () insertEpochRewardTotalReceived epochNo total = void . DB.insertEpochRewardTotalReceived $ DB.EpochRewardTotalReceived { DB.epochRewardTotalReceivedEarnedEpoch = unEpochNo epochNo - , DB.epochRewardTotalReceivedAmount = Generic.coinToDbLovelace total + , DB.epochRewardTotalReceivedAmount = total } insertStakeSlice :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> StrictTVar IO IndexCache -> Generic.StakeSliceRes + => SyncEnv -> Generic.StakeSliceRes -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertStakeSlice _ _ Generic.NoSlices = pure () -insertStakeSlice tracer cacheVar (Generic.Slice slice finalSlice) = do - cache <- liftIO $ readTVarIO cacheVar - -- cache TVar is not updated. We just use a slice here. - cacheSlice <- lift $ modifyCache (Generic.stakeDistStakeCreds slice) (Generic.stakeDistPoolHashKeys slice) cache - insertEpochStake cacheSlice (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice) +insertStakeSlice _ Generic.NoSlices = pure () +insertStakeSlice env (Generic.Slice slice finalSlice) = do + insertEpochStake (envCache env) (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice) when finalSlice $ do size <- lift $ DB.queryEpochStakeCount (unEpochNo $ Generic.sliceEpochNo slice) liftIO . logInfo tracer $ mconcat ["Inserted ", show size, " EpochStake for ", show (Generic.sliceEpochNo slice)] + where + tracer :: Trace IO Text + tracer = getTrace env insertEpochStake :: (MonadBaseControl IO m, MonadIO m) - => IndexCache -> EpochNo + => Cache -> EpochNo -> [(Generic.StakeCred, (Shelley.Coin, Generic.StakePoolKeyHash))] -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertEpochStake icache epochNo stakeChunk = do +insertEpochStake cache epochNo stakeChunk = do dbStakes <- mapM mkStake stakeChunk lift $ DB.insertManyEpochStakes dbStakes where mkStake - :: MonadBaseControl IO m + :: (MonadBaseControl IO m, MonadIO m) => (Generic.StakeCred, (Shelley.Coin, Generic.StakePoolKeyHash)) -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.EpochStake mkStake (saddr, (coin, pool)) = do - saId <- hoistEither $ lookupStakeAddrIdPair "insertEpochStake StakeCred" saddr icache - poolId <- hoistEither $ lookupPoolIdPair "insertEpochStake PoolKeyHash" pool icache + saId <- liftLookupFail "insertEpochStake.queryStakeAddrWithCache" $ queryStakeAddrWithCache cache CacheNew saddr + poolId <- liftLookupFail "insertEpochStake.queryPoolKeyWithCache" $ queryPoolKeyWithCache cache CacheNew pool pure $ DB.EpochStake { DB.epochStakeAddrId = saId @@ -175,9 +93,9 @@ insertEpochStake icache epochNo stakeChunk = do insertRewards :: (MonadBaseControl IO m, MonadIO m) - => EpochNo -> IndexCache -> [(Generic.StakeCred, Set Generic.Reward)] + => EpochNo -> EpochNo -> Cache -> [(Generic.StakeCred, Set Generic.Reward)] -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertRewards epoch icache rewardsChunk = do +insertRewards earnedEpoch spendableEpoch cache rewardsChunk = do dbRewards <- concatMapM mkRewards rewardsChunk lift $ DB.insertManyRewards dbRewards where @@ -186,7 +104,7 @@ insertRewards epoch icache rewardsChunk = do => (Generic.StakeCred, Set Generic.Reward) -> ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.Reward] mkRewards (saddr, rset) = do - saId <- hoistEither $ lookupStakeAddrIdPair "insertRewards StakePool" saddr icache + saId <- liftLookupFail "insertRewards.queryStakeAddrWithCache" $ queryStakeAddrWithCache cache CacheNew saddr mapMaybeM (prepareReward saId) (Set.toList rset) -- For rewards with a null pool, the reward unique key doesn't work. @@ -197,13 +115,14 @@ insertRewards epoch icache rewardsChunk = do => DB.StakeAddressId -> Generic.Reward -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe DB.Reward) prepareReward saId rwd = do + mPool <- queryPool (Generic.rewardPool rwd) let rwdDb = DB.Reward { DB.rewardAddrId = saId , DB.rewardType = Generic.rewardSource rwd , DB.rewardAmount = Generic.coinToDbLovelace (Generic.rewardAmount rwd) - , DB.rewardEarnedEpoch = earnedEpoch (Generic.rewardSource rwd) - , DB.rewardSpendableEpoch = spendableEpoch (Generic.rewardSource rwd) - , DB.rewardPoolId = lookupPoolIdPairMaybe (Generic.rewardPool rwd) icache + , DB.rewardEarnedEpoch = unEpochNo earnedEpoch + , DB.rewardSpendableEpoch = unEpochNo spendableEpoch + , DB.rewardPoolId = mPool } case DB.rewardPoolId rwdDb of Just _ -> pure $ Just rwdDb @@ -211,112 +130,18 @@ insertRewards epoch icache rewardsChunk = do exists <- lift $ DB.queryNullPoolRewardExists rwdDb if exists then pure Nothing else pure (Just rwdDb) - -- The earnedEpoch and spendableEpoch functions have been tweaked to match the logic of the ledger. - earnedEpoch :: DB.RewardSource -> Word64 - earnedEpoch src = - unEpochNo epoch + - case src of - DB.RwdMember -> 0 - DB.RwdLeader -> 0 - DB.RwdReserves -> 1 - DB.RwdTreasury -> 1 - DB.RwdDepositRefund -> 0 - - spendableEpoch :: DB.RewardSource -> Word64 - spendableEpoch src = - unEpochNo epoch + - case src of - DB.RwdMember -> 2 - DB.RwdLeader -> 2 - DB.RwdReserves -> 2 - DB.RwdTreasury -> 2 - DB.RwdDepositRefund -> 0 + queryPool :: (MonadBaseControl IO m, MonadIO m) + => Maybe Generic.StakePoolKeyHash -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe DB.PoolHashId) + queryPool Nothing = pure Nothing + queryPool (Just poolHash) = + Just <$> liftLookupFail "insertRewards.queryPoolKeyWithCache" (queryPoolKeyWithCache cache CacheNew poolHash) insertPoolDepositRefunds :: (MonadBaseControl IO m, MonadIO m) - => LedgerEnv -> Generic.Rewards + => SyncEnv -> Generic.Rewards -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertPoolDepositRefunds lenv refunds = do - icache <- lift $ updateIndexCache lenv (Generic.rewardsStakeCreds refunds) (Generic.rewardsPoolHashKeys refunds) - insertRewards (Generic.rwdEpoch refunds) icache (Map.toList $ Generic.rwdRewards refunds) - --- ------------------------------------------------------------------------------------------------- - -lookupStakeAddrIdPair - :: Text -> Generic.StakeCred -> IndexCache - -> Either SyncNodeError DB.StakeAddressId -lookupStakeAddrIdPair msg scred lcache = - maybe errMsg Right $ Map.lookup scred (icAddressCache lcache) - where - errMsg :: Either SyncNodeError a - errMsg = - Left . NEError $ - mconcat [ "lookupStakeAddrIdPair: ", msg, renderByteArray (Generic.unStakeCred scred) ] - - -lookupPoolIdPairMaybe - :: Maybe Generic.StakePoolKeyHash -> IndexCache - -> Maybe DB.PoolHashId -lookupPoolIdPairMaybe mpkh lcache = - lookup =<< mpkh - where - lookup :: Generic.StakePoolKeyHash -> Maybe DB.PoolHashId - lookup pkh = Map.lookup pkh $ icPoolCache lcache - -lookupPoolIdPair - :: Text -> Generic.StakePoolKeyHash -> IndexCache - -> Either SyncNodeError DB.PoolHashId -lookupPoolIdPair msg pkh lcache = - maybe errMsg Right $ Map.lookup pkh (icPoolCache lcache) - where - errMsg :: Either SyncNodeError a - errMsg = - Left . NEError $ - mconcat [ "lookupPoolIdPair: ", msg, renderByteArray (Generic.unStakePoolKeyHash pkh) ] - --- ------------------------------------------------------------------------------------------------- - -updateIndexCache - :: (MonadBaseControl IO m, MonadIO m) - => LedgerEnv -> Set Generic.StakeCred -> Set Generic.StakePoolKeyHash - -> ReaderT SqlBackend m IndexCache -updateIndexCache lenv screds pkhs = do - oldCache <- liftIO . atomically $ readTVar (leIndexCache lenv) - newIndexCache <- modifyCache screds pkhs oldCache - liftIO . atomically $ writeTVar (leIndexCache lenv) newIndexCache - pure newIndexCache - -modifyCache - :: (MonadBaseControl IO m, MonadIO m) - => Set Generic.StakeCred -> Set Generic.StakePoolKeyHash - -> IndexCache -> ReaderT SqlBackend m IndexCache -modifyCache screds pkhs oldCache = do - newAddresses <- newAddressCache (icAddressCache oldCache) - newPools <- newPoolCache (icPoolCache oldCache) - pure $ IndexCache - { icAddressCache = newAddresses - , icPoolCache = newPools - } - where - newAddressCache - :: (MonadBaseControl IO m, MonadIO m) - => Map Generic.StakeCred DB.StakeAddressId - -> ReaderT SqlBackend m (Map Generic.StakeCred DB.StakeAddressId) - newAddressCache oldMap = do - let reduced = Map.restrictKeys oldMap screds - newCreds = Set.filter (`Map.notMember` reduced) screds - newPairs <- catMaybes <$> mapM queryStakeAddressIdPair (Set.toList newCreds) - pure $ Map.union reduced (Map.fromList newPairs) - - newPoolCache - :: (MonadBaseControl IO m, MonadIO m) - => Map Generic.StakePoolKeyHash DB.PoolHashId - -> ReaderT SqlBackend m (Map Generic.StakePoolKeyHash DB.PoolHashId) - newPoolCache oldMap = do - let reduced = Map.restrictKeys oldMap pkhs - newPkhs = Set.filter (`Map.notMember` reduced) pkhs - newPairs <- catMaybes <$> mapM queryPoolHashIdPair (Set.toList newPkhs) - pure $ Map.union reduced (Map.fromList newPairs) +insertPoolDepositRefunds env refunds = do + insertRewards (Generic.rwdEpoch refunds) (Generic.rwdEpoch refunds) (envCache env) (Map.toList $ Generic.rwdRewards refunds) sumRewardTotal :: Map Generic.StakeCred (Set Generic.Reward) -> Shelley.Coin sumRewardTotal = diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs index a8b688004..bc6463f1b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs @@ -15,6 +15,7 @@ import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) import Cardano.Db (DbLovelace, RewardSource) import qualified Cardano.Db as Db import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Era.Shelley.Insert.Epoch import Cardano.DbSync.Era.Shelley.ValidateWithdrawal (validateRewardWithdrawals) import Cardano.DbSync.Util (panicAbort, plusCoin, textShow) @@ -29,7 +30,6 @@ import qualified Data.List.Extra as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set - import Database.Esqueleto.Experimental (InnerJoin (InnerJoin), SqlBackend, Value (Value), desc, from, not_, on, orderBy, select, sum_, table, val, where_, (:&) ((:&)), (==.), (^.)) @@ -38,9 +38,9 @@ import Database.Esqueleto.Experimental (InnerJoin (InnerJoin), SqlBack validateEpochRewards :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> Generic.Rewards + => Trace IO Text -> EpochNo -> Generic.Rewards -> ReaderT SqlBackend m () -validateEpochRewards tracer rmap = do +validateEpochRewards tracer earnedEpochNo rmap = do actual <- queryEpochRewardTotal (Generic.rwdEpoch rmap) if actual /= expected then do @@ -50,7 +50,8 @@ validateEpochRewards tracer rmap = do , textShow expected , " ADA but got " , textShow actual, " ADA" ] logFullRewardMap tracer rmap - else + else do + insertEpochRewardTotalReceived earnedEpochNo (Db.DbLovelace expectedw64) liftIO . logInfo tracer $ mconcat [ "validateEpochRewards: total rewards that become spendable in epoch " , textShow (unEpochNo $ Generic.rwdEpoch rmap), " is ", textShow actual @@ -58,10 +59,13 @@ validateEpochRewards tracer rmap = do ] validateRewardWithdrawals tracer (Generic.rwdEpoch rmap) where + expectedw64 :: Word64 + expectedw64 = fromIntegral . sum + $ map (unCoin . Set.foldl' foldfunc (Coin 0)) (Map.elems $ Generic.rwdRewards rmap) + expected :: Db.Ada expected = - Db.word64ToAda . fromIntegral . sum - $ map (unCoin . Set.foldl' foldfunc (Coin 0)) (Map.elems $ Generic.rwdRewards rmap) + Db.word64ToAda expectedw64 foldfunc :: Coin -> Generic.Reward -> Coin foldfunc coin rwd = plusCoin coin (Generic.rewardAmount rwd) @@ -78,6 +82,8 @@ queryEpochRewardTotal (EpochNo epochNo) = do -- For ... reasons ... pool deposit refunds are put into the rewards account -- but are not considered part of the total rewards for an epoch. where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdDepositRefund) + where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdTreasury) + where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdReserves) pure (sum_ $ rwd ^. Db.RewardAmount) pure $ Db.unValueSumAda (listToMaybe res) @@ -105,6 +111,9 @@ queryRewardMap (EpochNo epochNo) = do `on` (\(rwd :& saddr) -> rwd ^. Db.RewardAddrId ==. saddr ^. Db.StakeAddressId) where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) + where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdDepositRefund) + where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdTreasury) + where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdReserves) orderBy [desc (saddr ^. Db.StakeAddressHashRaw)] pure (saddr ^. Db.StakeAddressHashRaw, rwd ^. Db.RewardType, rwd ^. Db.RewardAmount) diff --git a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs index 09fdc83fa..9a2ee8a9e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs @@ -27,21 +27,20 @@ import Cardano.Ledger.Shelley.Rules.Epoch (EpochEvent (PoolReapEvent)) import Cardano.Ledger.Shelley.Rules.Mir (MirEvent (..)) import Cardano.Ledger.Shelley.Rules.NewEpoch (NewEpochEvent (..)) import Cardano.Ledger.Shelley.Rules.PoolReap (PoolreapEvent (..)) -import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent(RupdEvent)) +import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (RupdEvent)) import Cardano.Ledger.Shelley.Rules.Tick (TickEvent (NewEpochEvent)) import qualified Cardano.Ledger.Shelley.Rules.Tick as Tick import Cardano.Prelude hiding (All) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Types import Cardano.Slotting.Slot (EpochNo (..)) import Control.State.Transition (Event) import qualified Data.Map.Strict as Map -import Data.SOP.Strict (All, K (..), hcmap, hcollapse) import qualified Data.Set as Set +import Data.SOP.Strict (All, K (..), hcmap, hcollapse) import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) import Ouroboros.Consensus.Cardano.Block (CardanoEras, HardForkBlock) @@ -53,17 +52,30 @@ import Ouroboros.Consensus.TypeFamilyWrappers data LedgerEvent - = LedgerNewEpoch !EpochNo !SyncState - | LedgerStartAtEpoch !EpochNo - | LedgerRewards !SlotDetails !Generic.Rewards - - | LedgerTotalRewards !Generic.Rewards - | LedgerDeltaRewards !Generic.Rewards - | LedgerIncrementalRewards !Generic.Rewards - | LedgerMirDist !Generic.Rewards + = LedgerMirDist !(Map Generic.StakeCred (Set Generic.Reward)) | LedgerPoolReap !EpochNo !(Map (Ledger.StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin)) + | LedgerIncrementalRewards !Generic.Rewards + | LedgerDeltaRewards !Generic.Rewards + | LedgerRestrainedRewards !EpochNo !Generic.Rewards !(Set Generic.StakeCred) + | LedgerTotalRewards !Generic.Rewards + | LedgerStartAtEpoch !EpochNo + | LedgerNewEpoch !EpochNo !SyncState deriving Eq +instance Ord LedgerEvent where + a <= b = toOrdering a <= toOrdering b + +toOrdering :: LedgerEvent -> Int +toOrdering ev = case ev of + LedgerMirDist {} -> 0 + LedgerPoolReap {} -> 1 + LedgerIncrementalRewards {} -> 2 + LedgerDeltaRewards {} -> 3 + LedgerRestrainedRewards {} -> 4 + LedgerTotalRewards {} -> 5 + LedgerStartAtEpoch {} -> 6 + LedgerNewEpoch {} -> 7 + convertAuxLedgerEvent :: Network -> OneEraLedgerEvent (CardanoEras StandardCrypto) -> Maybe LedgerEvent convertAuxLedgerEvent nw = toLedgerEvent nw . wrappedAuxLedgerEvent @@ -93,8 +105,12 @@ instance toLedgerEvent nw evt = case unwrapLedgerEvent evt of LETotalRewards e m -> Just $ LedgerTotalRewards (convertPoolRewards nw e m) - LEDeltaReward e m -> Just $ LedgerDeltaRewards (convertPoolRewards nw e m) - LEIncrementalReward e m -> Just $ LedgerIncrementalRewards (convertPoolRewards nw e m) + LERestraintRewards e m creds -> + Just $ LedgerRestrainedRewards e (convertPoolRewards nw e m) (Set.map (Generic.toStakeCred nw) creds) + LEDeltaReward e m -> + Just $ LedgerDeltaRewards (convertPoolRewards nw e m) + LEIncrementalReward e m -> + Just $ LedgerIncrementalRewards (convertPoolRewards nw e m) LEMirTransfer rp tp _rtt _ttr -> Just $ LedgerMirDist (convertMirRewards nw rp tp) LERetiredPools r _u en -> Just $ LedgerPoolReap en r ShelleyLedgerEventBBODY {} -> Nothing @@ -111,12 +127,9 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher convertMirRewards :: Network -> Map (Ledger.StakeCredential StandardCrypto) Coin -> Map (Ledger.StakeCredential StandardCrypto) Coin - -> Generic.Rewards + -> Map Generic.StakeCred (Set Generic.Reward) convertMirRewards nw resPay trePay = - Generic.Rewards - { Generic.rwdEpoch = EpochNo 0 -- Will be fixed later - , Generic.rwdRewards = Map.unionWith Set.union (convertResPay resPay) (convertTrePay trePay) - } + Map.unionWith Set.union (convertResPay resPay) (convertTrePay trePay) where convertResPay :: Map (Ledger.StakeCredential StandardCrypto) Coin -> Map Generic.StakeCred (Set Generic.Reward) convertResPay = mapBimap (Generic.toStakeCred nw) (mkPayment RwdReserves) @@ -156,6 +169,18 @@ mapBimap fk fa = Map.fromAscList . map (bimap fk fa) . Map.toAscList -------------------------------------------------------------------------------- -- Patterns for event access. Why aren't these in ledger-specs? +pattern LERestraintRewards + :: ( Crypto ledgerera ~ StandardCrypto + , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera + , Event (Ledger.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera + ) + => EpochNo -> Map (Ledger.StakeCredential StandardCrypto) (Set (Ledger.Reward StandardCrypto)) + -> Set (Ledger.StakeCredential StandardCrypto) + -> AuxLedgerEvent (LedgerState (ShelleyBlock ledgerera)) +pattern LERestraintRewards e m creds <- + ShelleyLedgerEventTICK + (NewEpochEvent (RestrainedRewards e m creds)) + pattern LETotalRewards :: ( Crypto ledgerera ~ StandardCrypto , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera diff --git a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs index c25afd5fc..a1e576bc6 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs @@ -10,8 +10,7 @@ {-# LANGUAGE TypeFamilies #-} module Cardano.DbSync.LedgerState - ( BulkOperation (..) - , CardanoLedgerState (..) + ( CardanoLedgerState (..) , IndexCache (..) , LedgerEnv (..) , LedgerEvent (..) @@ -43,7 +42,6 @@ import qualified Cardano.Binary as Serialize import qualified Cardano.Db as DB import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Core (PParams) import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) @@ -83,8 +81,8 @@ import qualified Data.Strict.Maybe as Strict import qualified Data.Text as Text import Data.Time.Clock (UTCTime, getCurrentTime) -import Ouroboros.Consensus.Block (CodecConfig, Point (..), WithOrigin (..), blockHash, - blockIsEBB, blockPoint, blockPrevHash, pointSlot) +import Ouroboros.Consensus.Block (CodecConfig, WithOrigin (..), blockHash, blockIsEBB, + blockPoint, blockPrevHash, pointSlot) import Ouroboros.Consensus.Block.Abstract (ConvertRawHash (..)) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..)) import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardAlonzo, @@ -126,12 +124,6 @@ import System.Mem (performMajorGC) {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Use readTVarIO" -} --- 'CardanoPoint' indicates at which point the 'BulkOperation' became available. --- It is only used in case of a rollback. -data BulkOperation - = BulkRewardChunk !EpochNo !CardanoPoint !IndexCache ![(StakeCred, Set Generic.Reward)] - | BulkRewardReport !EpochNo !CardanoPoint !Int !Coin - data IndexCache = IndexCache { icAddressCache :: !(Map StakeCred DB.StakeAddressId) , icPoolCache :: !(Map StakePoolKeyHash DB.PoolHashId) @@ -152,8 +144,6 @@ data LedgerEnv = LedgerEnv -- The following do not really have anything to do with maintaining ledger -- state. They are here due to the ongoing headaches around the split between -- `cardano-sync` and `cardano-db-sync`. - , leIndexCache :: !(StrictTVar IO IndexCache) - , leBulkOpQueue :: !(TBQueue IO BulkOperation) , leOfflineWorkQueue :: !(TBQueue IO PoolFetchRetry) , leOfflineResultQueue :: !(TBQueue IO FetchResult) , leEpochSyncTime :: !(StrictTVar IO UTCTime) @@ -164,8 +154,6 @@ data LedgerEnv = LedgerEnv data LedgerEventState = LedgerEventState { lesInitialized :: !Bool , lesEpochNo :: !(Maybe EpochNo) - , lesLastRewardsEpoch :: !(Maybe EpochNo) - , lesLastAdded :: !CardanoPoint } topLevelConfig :: LedgerEnv -> TopLevelConfig CardanoBlock @@ -256,11 +244,9 @@ mkLedgerEnv mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do svar <- newTVarIO Nothing evar <- newTVarIO initLedgerEventState - ivar <- newTVarIO $ IndexCache mempty mempty intervar <- newTVarIO Nothing -- 2.5 days worth of slots. If we try to stick more than this number of -- items in the queue, bad things are likely to happen. - boq <- newTBQueueIO 10800 owq <- newTBQueueIO 100 orq <- newTBQueueIO 100 est <- newTVarIO =<< getCurrentTime @@ -278,8 +264,6 @@ mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do , leEventState = evar , lePoolRewards = prvar , leMirRewards = mrvar - , leIndexCache = ivar - , leBulkOpQueue = boq , leOfflineWorkQueue = owq , leOfflineResultQueue = orq , leEpochSyncTime = est @@ -291,8 +275,6 @@ mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do LedgerEventState { lesInitialized = False , lesEpochNo = Nothing - , lesLastRewardsEpoch = Nothing - , lesLastAdded = GenesisPoint } @@ -332,7 +314,7 @@ applyBlock env blk = do let !ledgerDB' = pushLedgerDB ledgerDB newState writeTVar (leStateVar env) (Just ledgerDB') oldEventState <- readTVar (leEventState env) - events <- generateEvents env oldEventState details newState (blockPoint blk) + events <- generateEvents env oldEventState details pure $ LedgerStateSnapshot { lssState = newState , lssOldState = oldState @@ -340,7 +322,7 @@ applyBlock env blk = do , lssSlotDetails = details , lssPoint = blockPoint blk , lssStakeSlice = stakeSlice newState details - , lssEvents = events ++ mapMaybe (convertAuxLedgerEvent (leNetwork env)) (lrEvents result) + , lssEvents = sort $ events ++ mapMaybe (convertAuxLedgerEvent (leNetwork env)) (lrEvents result) } where applyBlk @@ -386,12 +368,11 @@ applyBlock env blk = do (clsState cls) _ -> Generic.NoSlices -generateEvents :: LedgerEnv -> LedgerEventState -> SlotDetails -> CardanoLedgerState -> CardanoPoint -> STM [LedgerEvent] -generateEvents env oldEventState details cls pnt = do +generateEvents :: LedgerEnv -> LedgerEventState -> SlotDetails -> STM [LedgerEvent] +generateEvents env oldEventState details = do writeTVar (leEventState env) newEventState pure $ catMaybes [ newEpochEvent - , LedgerRewards details <$> rewards ] where currentEpochNo :: EpochNo @@ -406,32 +387,11 @@ generateEvents env oldEventState details cls pnt = do then Just $ LedgerNewEpoch currentEpochNo (getSyncStatus details) else Nothing - -- Want the rewards event to be delivered once only, on a single slot. - rewards :: Maybe Generic.Rewards - rewards = - case lesLastRewardsEpoch oldEventState of - Nothing -> mkRewards - Just oldRewardEpoch -> - if sdEpochSlot details >= leStableEpochSlot env && oldRewardEpoch < currentEpochNo - then mkRewards - else Nothing - - mkRewards :: Maybe Generic.Rewards - mkRewards = Generic.epochRewards (leNetwork env) (sdEpochNo details) (clsState cls) - newEventState :: LedgerEventState newEventState = LedgerEventState { lesInitialized = True , lesEpochNo = Just currentEpochNo - , lesLastRewardsEpoch = - if isJust rewards - then Just currentEpochNo - else lesLastRewardsEpoch oldEventState - , lesLastAdded = - if isNothing rewards - then lesLastAdded oldEventState - else pnt } saveCurrentLedgerState :: LedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () diff --git a/config/testnet-config.yaml b/config/testnet-config.yaml index ac37d2580..09042a57c 100644 --- a/config/testnet-config.yaml +++ b/config/testnet-config.yaml @@ -12,7 +12,7 @@ EnableLogging: True # config, it will likely lead to db-sync throwing up weird error messages from # the consensus layer. # The path to the node config file is relative to this config file. -NodeConfigFile: ../../cardano-node/configuration/cardano/testnet-config.json +NodeConfigFile: /nix/store/5b6pry15w93fv0r0x9rc3r1ii5871lvr-config-0-0.json # ------------------------------------------------------------------------------ # Logging configuration follows. From 1f0791a13e7215e238971dcd19c0bd3d8bcafe86 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Tue, 19 Apr 2022 23:25:38 +0300 Subject: [PATCH 09/11] Improve rewards tests --- .../test/Test/Cardano/Db/Mock/Unit.hs | 378 ++++++++++-------- .../test/Test/Cardano/Db/Mock/Validate.hs | 9 +- .../test/testfiles/fingerprint/rewardsDelta | 1 + .../fingerprint/rewardsEmptyChainLast | 2 +- 4 files changed, 216 insertions(+), 174 deletions(-) create mode 100644 cardano-chain-gen/test/testfiles/fingerprint/rewardsDelta diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs index c54c58286..dddd1fdca 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit.hs @@ -94,6 +94,7 @@ unitTests iom knownMigrations = , test "Mir Cert Shelley" mirRewardShelley , test "Mir Cert deregistration" mirRewardDereg , test "test rewards empty last part of epoch" rewardsEmptyChainLast + , test "test delta rewards" rewardsDelta , test "rollback on epoch boundary" rollbackBoundary , test "single MIR Cert multiple outputs" singleMIRCertMultiOut ] @@ -103,7 +104,7 @@ unitTests iom knownMigrations = , test "2001 delegations" delegations2001 , test "8000 delegations" delegations8000 , test "many delegations" delegationsMany - , test "many delegations, not dense chain" delegationsManyNotDense + , test "many delegations, sparse chain" delegationsManyNotDense ] , testGroup "plutus spend scripts" [ test "simple script lock" simpleScript @@ -160,7 +161,7 @@ addSimple = withFullConfig defaultConfigDir testLabel $ \interpreter mockServer dbSync -> do -- Given a mock block, translate it into a real block and submit it to the -- chainsync server - _ <- forgeNextAndSubmit interpreter mockServer mockBlock0 + void $ forgeNextAndSubmit interpreter mockServer mockBlock0 -- start db-sync and let it sync startDBSync dbSync assertBlockNoBackoff dbSync 1 @@ -187,7 +188,7 @@ addSimpleChain = restartDBSync :: IOManager -> [(Text, Text)] -> Assertion restartDBSync = withFullConfig defaultConfigDir testLabel $ \interpreter mockServer dbSync -> do - _ <- forgeNextAndSubmit interpreter mockServer mockBlock0 + void $ forgeNextAndSubmit interpreter mockServer mockBlock0 -- start db-sync and let it sync startDBSync dbSync assertBlockNoBackoff dbSync 1 @@ -337,7 +338,7 @@ addSimpleTx :: IOManager -> [(Text, Text)] -> Assertion addSimpleTx = withFullConfig defaultConfigDir testLabel $ \interpreter mockServer dbSync -> do -- translate the block to a real Cardano block. - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 startDBSync dbSync @@ -349,7 +350,7 @@ addSimpleTxShelley :: IOManager -> [(Text, Text)] -> Assertion addSimpleTxShelley = withFullConfig "config-shelley" testLabel $ \interpreter mockServer dbSync -> do -- translate the block to a real Cardano block. - _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ + void $ withShelleyFindLeaderAndSubmitTx interpreter mockServer $ Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 -- start db-sync and let it sync @@ -363,18 +364,18 @@ registrationTx = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . RegKey)] - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . DeRegKey)] -- We add interval or else the txs would have the same id - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer (fmap (Alonzo.addValidityInterval 1000) . Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . RegKey)]) - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer (fmap (Alonzo.addValidityInterval 2000) . Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . DeRegKey)]) @@ -388,7 +389,7 @@ registrationsSameBlock = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . RegKey)] st tx1 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . DeRegKey)] st tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . RegKey)] st @@ -405,7 +406,7 @@ registrationsSameTx = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [ (StakeIndexNew 1, DCertDeleg . RegKey) , (StakeIndexNew 1, DCertDeleg . DeRegKey) , (StakeIndexNew 1, DCertDeleg . RegKey) @@ -426,7 +427,7 @@ stakeAddressPtr = let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 assertBlockNoBackoff dbSync 2 @@ -453,7 +454,7 @@ stakeAddressPtrDereg = let ptr1 = Ptr (blockSlot blk') (TxIx 1) (CertIx 1) - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithPtr 0 ptr1) 20000 20000 st tx1 <- Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st pure [tx0, tx1] @@ -474,7 +475,7 @@ stakeAddressPtrUseBefore = startDBSync dbSync -- first use this stake credential - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 10000 500 -- and then register it @@ -483,7 +484,7 @@ stakeAddressPtrUseBefore = let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 assertBlockNoBackoff dbSync 3 @@ -496,7 +497,7 @@ consumeSameBlock = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 20000 20000 st let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) tx1 <- Alonzo.mkPaymentTx (UTxOPair utxo0) (UTxOIndex 2) 10000 500 st @@ -509,11 +510,11 @@ simpleRewards :: IOManager -> [(Text, Text)] -> Assertion simpleRewards = withFullConfig defaultConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer -- Pools are not registered yet, this takes 2 epochs. So fees of this tx -- should not create any rewards. - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 a <- fillEpochs interpreter mockServer 3 assertBlockNoBackoff dbSync (fromIntegral $ 2 + length a) @@ -523,24 +524,24 @@ simpleRewards = st <- getAlonzoLedgerState interpreter -- False indicates that we provide the full expected list of addresses with rewards. - assertRewardCounts dbSync st False + assertRewardCounts dbSync st False (Just 3) [ (StakeIndexPoolLeader (PoolIndex 0), (1,0,0,0,0)) , (StakeIndexPoolLeader (PoolIndex 1), (1,0,0,0,0)) , (StakeIndexPoolLeader (PoolIndex 2), (1,0,0,0,0))] -- Now that pools are registered, we add a tx to fill the fees pot. -- Rewards will be distributed. - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - b <- fillEpochs interpreter mockServer 3 + b <- fillEpochs interpreter mockServer 2 assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 2 + length b) - assertRewardCount dbSync 17 - assertRewardCounts dbSync st True + assertRewardCount dbSync 14 + assertRewardCounts dbSync st True (Just 5) -- 2 pool leaders also delegate to pools. - [ (StakeIndexPoolLeader (PoolIndexId $ KeyHash "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"), (4,0,0,0,0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "5af582399de8c226391bfd21424f34d0b053419c4d93975802b7d107"), (4,1,0,0,0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "58eef2925db2789f76ea057c51069e52c5e0a44550f853c6cdf620f8"), (4,1,0,0,0)) + [ (StakeIndexPoolLeader (PoolIndexId $ KeyHash "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"), (1,0,0,0,0)) + , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "5af582399de8c226391bfd21424f34d0b053419c4d93975802b7d107"), (1,1,0,0,0)) + , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "58eef2925db2789f76ea057c51069e52c5e0a44550f853c6cdf620f8"), (1,1,0,0,0)) , (StakeIndexPoolMember 0 (PoolIndex 0), (0,1,0,0,0)) , (StakeIndexPoolMember 0 (PoolIndex 1), (0,1,0,0,0)) ] @@ -559,28 +560,28 @@ rewardsShelley :: IOManager -> [(Text, Text)] -> Assertion rewardsShelley = withFullConfig "config-shelley" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer - _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ + void $ withShelleyFindLeaderAndSubmitTx interpreter mockServer $ Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 a <- fillEpochs interpreter mockServer 3 assertRewardCount dbSync 3 - _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ + void $ withShelleyFindLeaderAndSubmitTx interpreter mockServer $ Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - b <- fillEpochs interpreter mockServer 3 + b <- fillEpochs interpreter mockServer 2 assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + 3) st <- withShelleyLedgerState interpreter Right -- Note we have 2 rewards less compared to Alonzo era - assertRewardCount dbSync 15 - assertRewardCounts dbSync st True + assertRewardCount dbSync 12 + assertRewardCounts dbSync st True (Just 5) -- Here we dont' have both leader and member rewards. - [ (StakeIndexPoolLeader (PoolIndexId $ KeyHash "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"), (4,0,0,0,0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "5af582399de8c226391bfd21424f34d0b053419c4d93975802b7d107"), (4,0,0,0,0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "58eef2925db2789f76ea057c51069e52c5e0a44550f853c6cdf620f8"), (4,0,0,0,0)) + [ (StakeIndexPoolLeader (PoolIndexId $ KeyHash "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"), (1,0,0,0,0)) + , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "5af582399de8c226391bfd21424f34d0b053419c4d93975802b7d107"), (1,0,0,0,0)) + , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "58eef2925db2789f76ea057c51069e52c5e0a44550f853c6cdf620f8"), (1,0,0,0,0)) , (StakeIndexPoolMember 0 (PoolIndex 0), (0,1,0,0,0)) , (StakeIndexPoolMember 0 (PoolIndex 1), (0,1,0,0,0)) ] @@ -592,14 +593,14 @@ rewardsDeregistration :: IOManager -> [(Text, Text)] -> Assertion rewardsDeregistration = withFullConfig defaultConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkDepositTxPools (UTxOIndex 1) 20000 -- first move to treasury from reserves - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> Alonzo.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do -- register the stake address and delegate to a pool let poolId = resolvePool (PoolIndex 0) st tx1 <- Alonzo.mkSimpleDCertTx @@ -617,34 +618,34 @@ rewardsDeregistration = -- Now that pools are registered, we add a tx to fill the fees pot. -- Rewards will be distributed. - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 b <- fillEpochs interpreter mockServer 2 assertBlockNoBackoff dbSync (fromIntegral $ 4 + length a + length b) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,1,0,0,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,1,0,0,0))] - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 c <- fillEpochs interpreter mockServer 2 assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + length b + length c) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,2,0,0,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,2,0,0,0))] d <- fillEpochs interpreter mockServer 1 e <- fillEpochPercentage interpreter mockServer 85 - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, DCertDeleg . DeRegKey)] f <- fillUntilNextEpoch interpreter mockServer assertBlockNoBackoff dbSync (fromIntegral $ 6 + length (a <> b <> c <> d <> e <> f)) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,2,0,0,0))] + -- stays at 2, since it's deregistered. + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,2,0,0,0))] g <- fillEpochs interpreter mockServer 2 - -- TODO: the last field should be 1. There should be some deposit refund assertBlockNoBackoff dbSync (fromIntegral $ 6 + length (a <> b <> c <> d <> e <> f <> g)) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,2,0,0,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,2,0,0,0))] where testLabel = "rewardsDeregistration" @@ -653,16 +654,16 @@ mirReward :: IOManager -> [(Text, Text)] -> Assertion mirReward = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer -- first move to treasury from reserves - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> Alonzo.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) - _ <- fillEpochPercentage interpreter mockServer 50 + void $ fillEpochPercentage interpreter mockServer 50 -- mir from treasury - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx1 <- Alonzo.mkSimpleDCertTx [(StakeIndex 1, \cred -> DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))))] st tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndex 1, @@ -671,11 +672,11 @@ mirReward = \cred -> DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 300))))] st pure [tx1, tx2, tx3] - _ <- fillUntilNextEpoch interpreter mockServer + void $ fillUntilNextEpoch interpreter mockServer st <- getAlonzoLedgerState interpreter -- 2 mir rewards from treasury are sumed - assertRewardCounts dbSync st True [(StakeIndex 1, (0,0,1,1,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndex 1, (0,0,1,1,0))] where testLabel = "mirReward" @@ -683,19 +684,19 @@ mirRewardRollback :: IOManager -> [(Text, Text)] -> Assertion mirRewardRollback = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer -- first move to treasury from reserves - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> Alonzo.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [ (StakeIndexNew 1, DCertDeleg . RegKey) ] a <- fillUntilNextEpoch interpreter mockServer b <- fillEpochPercentage interpreter mockServer 5 -- mir from treasury - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, \cred -> DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 1000))))] c <- fillEpochPercentage interpreter mockServer 50 @@ -703,20 +704,20 @@ mirRewardRollback = st <- getAlonzoLedgerState interpreter assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,0,0,1,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,0,0,1,0))] atomically $ rollback mockServer (blockPoint $ last c) assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c)) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,0,0,1,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,0,0,1,0))] stopDBSync dbSync startDBSync dbSync assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c)) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,0,0,1,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,0,0,1,0))] forM_ d $ atomically . addBlock mockServer e <- fillEpochPercentage interpreter mockServer 5 assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d <> e)) - assertRewardCounts dbSync st True [(StakeIndexNew 1, (0,0,0,1,0))] + assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0,0,0,1,0))] where testLabel = "mirRewardRollback" @@ -724,25 +725,25 @@ mirRewardShelley :: IOManager -> [(Text, Text)] -> Assertion mirRewardShelley = withFullConfig "config-shelley" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer - -- first move to treasury from reserves - _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ + -- TODO test that this has no effect. You can't send funds between reserves and + -- treasury before protocol version 5. + void $ withShelleyFindLeaderAndSubmitTx interpreter mockServer $ const $ Shelley.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) a <- fillEpochPercentage interpreter mockServer 50 - -- mir from treasury - _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ Shelley.mkSimpleDCertTx - [(StakeIndex 1, \cred -> DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))))] + -- mir from reserves + void $ withShelleyFindLeaderAndSubmitTx interpreter mockServer $ Shelley.mkSimpleDCertTx + [(StakeIndex 1, \cred -> DCertMir $ MIRCert ReservesMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))))] b <- fillUntilNextEpoch interpreter mockServer st <- withShelleyLedgerState interpreter Right - -- TODO: is this correct? It looks like there are no rewards. assertBlockNoBackoff dbSync (fromIntegral $ 3 + length a + length b) - assertRewardCounts dbSync st True [] + assertRewardCounts dbSync st False Nothing [(StakeIndex 1, (0,0,1,0,0))] where testLabel = "mirRewardShelley" @@ -751,16 +752,16 @@ mirRewardDereg :: IOManager -> [(Text, Text)] -> Assertion mirRewardDereg = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer -- first move to treasury from reserves - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> Alonzo.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) a <- fillUntilNextEpoch interpreter mockServer -- mir from treasury - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx1 <- Alonzo.mkSimpleDCertTx [(StakeIndex 1, \cred -> DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))))] st tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndex 1, @@ -770,13 +771,13 @@ mirRewardDereg = pure [tx1, tx2, tx3] b <- fillEpochPercentage interpreter mockServer 20 - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [(StakeIndex 1, DCertDeleg . DeRegKey)] assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b)) -- deregistration means empty rewards st <- getAlonzoLedgerState interpreter - assertRewardCounts dbSync st False [] + assertRewardCounts dbSync st False Nothing [] where testLabel = "mirRewardDereg" @@ -784,37 +785,66 @@ rewardsEmptyChainLast :: IOManager -> [(Text, Text)] -> Assertion rewardsEmptyChainLast = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer a <- fillEpochs interpreter mockServer 3 assertRewardCount dbSync 3 -- Now that pools are registered, we add a tx to fill the fees pot. -- Rewards will be distributed. - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 b <- fillUntilNextEpoch interpreter mockServer assertRewardCount dbSync 6 - c <- fillEpochPercentage interpreter mockServer 80 + c <- fillEpochPercentage interpreter mockServer 68 - -- Skip half an epoch - _ <- skipUntilNextEpoch interpreter mockServer [] + -- Skip a percentage of the epoch epoch + void $ skipUntilNextEpoch interpreter mockServer [] d <- fillUntilNextEpoch interpreter mockServer assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 1 + length b + length c + 1 + length d) assertRewardCount dbSync 17 where testLabel = "rewardsEmptyChainLast" +rewardsDelta :: IOManager -> [(Text, Text)] -> Assertion +rewardsDelta = + withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + -- These delegation push the computation of the 3 leader + -- rewards toward the 8k/f slot, so it can be delayed even more + -- with the missing blocks and create the delta reward. + -- This trick may break at some point in the future. + a <- delegateAndSendBlocks 1000 interpreter + forM_ a $ atomically . addBlock mockServer + void $ registerAllStakeCreds interpreter mockServer + b <- fillEpochs interpreter mockServer 3 + assertRewardCount dbSync 3 + + c <- fillUntilNextEpoch interpreter mockServer + assertRewardCount dbSync 6 + + d <- fillEpochPercentage interpreter mockServer 68 + assertRewardCount dbSync 6 + + -- Skip a percentage of the epoch epoch + void $ skipUntilNextEpoch interpreter mockServer [] + assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + length b + length c + 1 + length d) + -- These are delta rewards aka rewards that were added at the epoch boundary, because the reward + -- update was not complete on time, due to missing blocks. + assertRewardCount dbSync 9 + where + testLabel = "rewardsDelta" + rollbackBoundary :: IOManager -> [(Text, Text)] -> Assertion rollbackBoundary = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer a <- fillEpochs interpreter mockServer 2 - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 blks <- forgeAndSubmitBlocks interpreter mockServer 50 @@ -834,12 +864,12 @@ singleMIRCertMultiOut = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> Alonzo.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) a <- fillUntilNextEpoch interpreter mockServer - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \ state -> do + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \ state -> do stakeAddr0 <- resolveStakeCreds (StakeIndex 0) state stakeAddr1 <- resolveStakeCreds (StakeIndex 1) state let saMIR = StakeAddressesMIR (Map.fromList [(stakeAddr0, DeltaCoin 10), (stakeAddr1, DeltaCoin 20)]) @@ -876,7 +906,7 @@ delegations2000 = -- There are exactly 2000 entries on the second epoch, 5 from genesis and 1995 manually added assertEpochStakeEpoch dbSync 2 2000 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) assertEpochStakeEpoch dbSync 2 2000 where @@ -895,7 +925,7 @@ delegations2001 = -- The first block of epoch inserts 2000 out of 2001 epoch distribution. assertEpochStakeEpoch dbSync 2 2000 -- The remaining entry is inserted on the next block. - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) assertEpochStakeEpoch dbSync 2 2001 where @@ -912,16 +942,16 @@ delegations8000 = assertBlockNoBackoff dbSync (fromIntegral $ length a + length b) assertEpochStakeEpoch dbSync 3 2000 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertEpochStakeEpoch dbSync 3 4000 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertEpochStakeEpoch dbSync 3 6000 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertEpochStakeEpoch dbSync 3 8000 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertEpochStakeEpoch dbSync 3 8000 where testLabel = "delegations8000" @@ -941,10 +971,10 @@ delegationsMany = -- instead of 2000, because there are many delegations assertEpochStakeEpoch dbSync 7 2001 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertEpochStakeEpoch dbSync 7 4002 - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertEpochStakeEpoch dbSync 7 6003 where testLabel = "delegationsMany" @@ -970,7 +1000,7 @@ delegationsManyNotDense = replicateM_ 40 $ forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] - -- Even if the chain is not dense, all distributions are inserted. + -- Even if the chain is sparse, all distributions are inserted. assertEpochStakeEpoch dbSync 7 40005 where testLabel = "delegationsManyNotDense" @@ -979,11 +1009,11 @@ simpleScript :: IOManager -> [(Text, Text)] -> Assertion simpleScript = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer a <- fillUntilNextEpoch interpreter mockServer - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) @@ -999,14 +1029,14 @@ unlockScript :: IOManager -> [(Text, Text)] -> Assertion unlockScript = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer -- We don't use withAlonzoFindLeaderAndSubmitTx here, because we want access to the tx. tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 - _ <- forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 assertBlockNoBackoff dbSync 3 @@ -1018,9 +1048,9 @@ unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion unlockScriptSameBlock = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 st let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st @@ -1038,10 +1068,10 @@ failedScript = startDBSync dbSync tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 - _ <- forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 assertBlockNoBackoff dbSync 2 @@ -1053,9 +1083,9 @@ failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion failedScriptSameBlock = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- registerAllStakeCreds interpreter mockServer + void $ registerAllStakeCreds interpreter mockServer - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 st let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st @@ -1078,8 +1108,8 @@ multipleScripts = tx1 <- withAlonzoLedgerState interpreter $ Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - _ <- forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - _ <- forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) assertBlockNoBackoff dbSync 2 assertAlonzoCounts dbSync (1,2,1,1,3,2,0,0) @@ -1091,7 +1121,7 @@ multipleScriptsSameBlock = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st let utxo = Alonzo.mkUTxOAlonzo tx0 pair1 = head utxo @@ -1110,12 +1140,12 @@ multipleScriptsFailed = startDBSync dbSync tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 - _ <- forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) let utxos = Alonzo.mkUTxOAlonzo tx0 tx1 <- withAlonzoLedgerState interpreter $ Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - _ <- forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) assertBlockNoBackoff dbSync 2 assertAlonzoCounts dbSync (0,0,0,0,3,0,1,1) @@ -1127,7 +1157,7 @@ multipleScriptsFailedSameBlock = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st let utxos = tail $ Alonzo.mkUTxOAlonzo tx0 @@ -1144,7 +1174,7 @@ registrationScriptTx = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] assertBlockNoBackoff dbSync 1 assertScriptCert dbSync (0,0,0,1) @@ -1156,7 +1186,7 @@ deregistrationScriptTx = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] st tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, DCertDeleg . DeRegKey)] True st pure [tx0, tx1] @@ -1171,7 +1201,7 @@ deregistrationsScriptTxs = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] st tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, DCertDeleg . DeRegKey)] True st tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] st @@ -1189,11 +1219,12 @@ deregistrationsScriptTx = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] st tx1 <- Alonzo.mkScriptDCertTx [ (StakeIndexScript True, True, DCertDeleg . DeRegKey) , (StakeIndexScript True, False, DCertDeleg . RegKey) - , (StakeIndexScript True, True, DCertDeleg . DeRegKey)] + , (StakeIndexScript True, True, DCertDeleg . DeRegKey) + ] True st pure [tx0, tx1] @@ -1209,7 +1240,7 @@ deregistrationsScriptTx' = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] st tx1 <- Alonzo.mkScriptDCertTx [ (StakeIndexScript True, False, DCertDeleg . DeRegKey) , (StakeIndexScript True, False, DCertDeleg . RegKey) @@ -1231,7 +1262,7 @@ deregistrationsScriptTx'' = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, DCertDeleg . RegKey)] st tx1 <- Alonzo.mkScriptDCertTx [ (StakeIndexScript True, True, DCertDeleg . DeRegKey) , (StakeIndexScript True, False, DCertDeleg . RegKey) @@ -1249,7 +1280,7 @@ mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion mintMultiAsset = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \st -> do let val0 = Value 1 $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, Value 10000 mempty)] val0 True 100 st @@ -1262,7 +1293,7 @@ mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion mintMultiAssets = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do let assets0 = Map.fromList [(head assetNames,10), (assetNames !! 1,4)] let policy0 = PolicyID alwaysMintScriptHash let policy1 = PolicyID alwaysSucceedsScriptHash @@ -1280,7 +1311,7 @@ swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion swapMultiAssets = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] let policy0 = PolicyID alwaysMintScriptHash let policy1 = PolicyID alwaysSucceedsScriptHash @@ -1310,16 +1341,18 @@ poolReg = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 1 initCounter <- runQuery dbSync poolCountersQuery assertEqual "Unexpected init pool counter" (3,0,3,2,0,0) initCounter - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkDCertPoolTx [( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners)] + , Alonzo.consPoolParamsTwoOwners + ) + ] assertBlockNoBackoff dbSync 2 assertPoolCounters dbSync (addPoolCounters (1,1,1,2,0,1) initCounter) @@ -1334,7 +1367,7 @@ nonexistantPoolQuery = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 1 st <- getAlonzoLedgerState interpreter @@ -1348,17 +1381,17 @@ poolDeReg = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 1 initCounter <- runQuery dbSync poolCountersQuery assertEqual "Unexpected init pool counter" (3,0,3,2,0,0) initCounter - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkDCertPoolTx [ ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners) - + , Alonzo.consPoolParamsTwoOwners + ) , ([], PoolIndexNew 0, \_ poolId -> DCertPool $ RetirePool poolId 1) ] @@ -1387,54 +1420,56 @@ poolDeRegMany = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 1 initCounter <- runQuery dbSync poolCountersQuery assertEqual "Unexpected init pool counter" (3,0,3,2,0,0) initCounter - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkDCertPoolTx - [ - -- register + [ -- register ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners) - + , Alonzo.consPoolParamsTwoOwners + ) -- de register , ([], PoolIndexNew 0, mkPoolDereg 4) -- register , ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners) - + , Alonzo.consPoolParamsTwoOwners + ) -- register with different owner and reward address , ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners) + , Alonzo.consPoolParamsTwoOwners + ) ] - _ <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkDCertPoolTx - [ -- register - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners) - ] st - - tx1 <- Alonzo.mkDCertPoolTx - [ -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg 4) - - -- register - , ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners) - - -- deregister - , ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg 1) - ] st - pure [tx0, tx1] + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkDCertPoolTx + [ -- register + ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Alonzo.consPoolParamsTwoOwners + ) + ] st + + tx1 <- Alonzo.mkDCertPoolTx + [ -- deregister + ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg 4) + + -- register + , ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Alonzo.consPoolParamsTwoOwners + ) + + -- deregister + , ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg 1) + ] st + pure [tx0, tx1] assertBlockNoBackoff dbSync 3 -- TODO fix PoolOwner and PoolRelay unique key @@ -1457,10 +1492,9 @@ poolDeRegMany = where testLabel = "poolDeRegMany" - mkPoolDereg :: EpochNo - -> [StakeCredential StandardCrypto] - -> KeyHash 'StakePool StandardCrypto - -> DCert StandardCrypto + mkPoolDereg + :: EpochNo -> [StakeCredential StandardCrypto] -> KeyHash 'StakePool StandardCrypto + -> DCert StandardCrypto mkPoolDereg epochNo _creds keyHash = DCertPool $ RetirePool keyHash epochNo poolDelist :: IOManager -> [(Text, Text)] -> Assertion @@ -1468,18 +1502,20 @@ poolDelist = withFullConfig "config" testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 1 initCounter <- runQuery dbSync poolCountersQuery assertEqual "Unexpected init pool counter" (3,0,3,2,0,0) initCounter - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkDCertPoolTx - [( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners)] + [ ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Alonzo.consPoolParamsTwoOwners + ) + ] - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 3 st <- getAlonzoLedgerState interpreter assertPoolLayerCounters dbSync (0,0) [(PoolIndexNew 0, (Right False, False, True))] st @@ -1487,24 +1523,24 @@ poolDelist = let poolKeyHash = resolvePool (PoolIndexNew 0) st let poolId = dbToServantPoolId $ unKeyHashRaw poolKeyHash poolLayer <- getPoolLayer dbSync - _ <- dlAddDelistedPool poolLayer poolId + void $ dlAddDelistedPool poolLayer poolId -- This is not async, so we don't need to do exponential backoff -- delisted not retired assertPoolLayerCounters dbSync (0,1) [(PoolIndexNew 0, (Right False, True, True))] st - _ <- withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkDCertPoolTx [ ([], PoolIndexNew 0, \_ poolHash -> DCertPool $ RetirePool poolHash 1)] - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync 5 -- delisted and pending retirement assertPoolLayerCounters dbSync (0,1) [(PoolIndexNew 0, (Right False, True, True))] st a <- fillUntilNextEpoch interpreter mockServer - _ <- forgeNextFindLeaderAndSubmit interpreter mockServer [] + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + 1) -- delisted and retired assertPoolLayerCounters dbSync (1,1) [(PoolIndexNew 0, (Right True, True, False))] st @@ -1517,7 +1553,7 @@ hfBlockHash blk = case blk of BlockShelley sblk -> blockHash sblk BlockAlonzo ablk -> blockHash ablk - _ -> error "not supported block type" + _ -> error "hfBlockHash: unsupported block type" throwLeft :: Exception err => IO (Either err a) -> IO a throwLeft action = do diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs index d8b6a73a7..71b216ba1 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -158,9 +158,9 @@ assertCertCounts env expected = pure (registr - 5, deregistr, deleg - 5, withdrawal) assertRewardCounts :: (Crypto era ~ StandardCrypto) - => DBSyncEnv -> LedgerState (ShelleyBlock era) -> Bool + => DBSyncEnv -> LedgerState (ShelleyBlock era) -> Bool -> Maybe Word64 -> [(StakeIndex, (Word64, Word64, Word64, Word64, Word64))] -> IO () -assertRewardCounts env st filterAddr expected = do +assertRewardCounts env st filterAddr mEpoch expected = do assertEqBackoff env (groupByAddress <$> q) expectedMap defaultDelays "Unexpected rewards count" where expectedMap :: Map ByteString (Word64, Word64, Word64, Word64, Word64) @@ -198,9 +198,14 @@ assertRewardCounts env st filterAddr expected = do -> Map ByteString (Word64, Word64, Word64, Word64, Word64) updateMap (rew, addr) res = Map.alter (Just . updateAddrCounters rew) addr res + filterEpoch rw = case mEpoch of + Nothing -> val True + Just e -> rw ^. RewardSpendableEpoch ==. val e + q = do res <- select . from $ \ (reward `InnerJoin` stake_addr) -> do on (reward ^. RewardAddrId ==. stake_addr ^. StakeAddressId) + where_ (filterEpoch reward) pure (reward, stake_addr ^. StakeAddressHashRaw) pure $ fmap (bimap entityVal unValue) res diff --git a/cardano-chain-gen/test/testfiles/fingerprint/rewardsDelta b/cardano-chain-gen/test/testfiles/fingerprint/rewardsDelta new file mode 100644 index 000000000..5a5a3e78e --- /dev/null +++ b/cardano-chain-gen/test/testfiles/fingerprint/rewardsDelta @@ -0,0 +1 @@ +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1001,1011,1012,1023,1027,1030,1040,1045,1047,1048,1051,1060,1061,1063,1070,1073,1078,1079,1080,1082,1084,1085,1101,1120,1128,1133,1134,1139,1140,1159,1160,1161,1162,1167,1170,1181,1187,1196,1198,1213,1223,1225,1226,1229,1232,1234,1241,1244,1245,1247,1257,1263,1268,1273,1274,1276,1289,1291,1294,1301,1312,1320,1322,1331,1336,1337,1341,1346,1351,1361,1363,1375,1376,1379,1382,1383,1395,1399,1402,1405,1410,1412,1416,1420,1428,1429,1431,1434,1438,1447,1451,1452,1466,1470,1471,1473,1476,1479,1480,1481,1483,1485,1487,1494,1498,1499,1500,1505,1510,1528,1530,1532,1533,1537,1539,1541,1546,1548,1550,1553,1566,1567,1569,1578,1579,1583,1584,1585,1593,1602,1604,1606,1615,1619,1621,1626,1629,1631,1634,1643,1647,1653,1654,1656,1661,1663,1669,1672,1678,1679,1685,1696,1698,1699,1700,1702,1705,1713,1722,1723,1727,1730,1736,1738,1746,1748,1754,1761,1762,1780,1781,1785,1787,1788,1797,1798,1804,1813,1820,1833,1837,1844,1859,1877,1878,1882,1883,1886,1892,1897,1901,1909,1915,1917,1918,1920,1927,1931,1942,1953,1962,1969,1987,1995,1999,2001,2005,2006,2007,2014,2017,2026,2036,2040,2041,2066,2078,2080,2084,2087,2094,2099,2100,2109,2116,2124,2127,2128,2132,2140,2142,2152,2166,2167,2168,2173,2180,2183,2188,2189,2193,2204,2210,2215,2217,2223,2224,2225,2230,2236,2249,2250,2259,2269,2280,2290,2294,2300,2309,2314,2317,2325,2327,2332,2347,2350,2356,2357,2363,2365,2369,2371,2372,2373,2506] \ No newline at end of file diff --git a/cardano-chain-gen/test/testfiles/fingerprint/rewardsEmptyChainLast b/cardano-chain-gen/test/testfiles/fingerprint/rewardsEmptyChainLast index 765cc0213..46fbe0d3f 100644 --- a/cardano-chain-gen/test/testfiles/fingerprint/rewardsEmptyChainLast +++ b/cardano-chain-gen/test/testfiles/fingerprint/rewardsEmptyChainLast @@ -1 +1 @@ -[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1012,1014,1020,1022,1033,1034,1041,1047,1052,1056,1060,1068,1073,1100,1104,1111,1113,1119,1121,1129,1131,1140,1144,1147,1153,1159,1166,1169,1170,1171,1176,1184,1185,1189,1190,1193,1194,1198,1201,1208,1211,1212,1215,1219,1230,1231,1236,1237,1239,1250,1253,1256,1259,1265,1272,1277,1289,1290,1294,1307,1325,1328,1332,1334,1338,1340,1351,1358,1360,1365,1369,1374,1377,1378,1386,1387,1391,1393,1395,1398,1404,1411,1416,1417,1419,1437,1451,1464,1468,1469,1471,1482,1486,1492,1495,1502,1503,1512,1513,1519,1520,1521,1522,1525,1526,1529,1531,1541,1544,1545,1555,1564,1569,1578,1584,1592,1602,1604,1606,1607,1611,1621,1633,1636,1638,1640,1647,1651,1662,1663,1669,1675,1678,1686,1689,1700,1701,1704,1706,1710,1714,1715,1733,1738,1739,1743,1745,1755,1759,1760,1769,1779,1780,1783,1790,1794,1795,1796,1798,1799,1803,1804,1806,1811,1812,1820,1822,1832,1837,1841,1844,1882,1884,1899,1902,1905,1915,1916,1917,1923,1925,1931,1932,1933,1940,1942,1944,1946,1951,1952,1964,1980,1995,1996,2001,2005,2008,2023,2027,2034,2051,2056,2059,2061,2067,2069,2076,2078,2085,2088,2095,2100,2106,2107,2112,2114,2116,2121,2122,2123,2135,2159,2160,2169,2184,2189,2190,2191,2195,2199,2210,2214,2215,2216,2225,2229,2248,2251,2258,2263,2265,2266,2271,2272,2277,2285,2293,2299,2300,2308,2310,2316,2317,2318,2320,2331,2332,2336,2340,2347,2348,2349,2361,2362,2363,2376,2383,2387,2396,2407,2408,2411,2416,2419,2422,2502,2510,2514,2520,2527,2538,2541,2547,2548,2549,2555,2560,2563,2566,2570,2577,2581,2582,2585,2588,2591,2592,2593,2597,2606,2629,2638,2640,2641,2648,2649,2653,2664,2665,2667,2668,2669,2673,2677,2684,2688,2691,2693,2696,2722,2729,2742,2746,2747,2754,2758,2760,2766,2767,2775,2779,2780,2783,2792,2799,2809,2814,2817,2824,2829,2834,2839,2841,2844,2845,2862,2865,2868,2882,2886,2888,2891,2893,2909,2911,2916,2918,2926,2938,2955,2956,2961,2962,2976,2982,2991,2996,3002] \ No newline at end of file +[3,4,6,13,22,31,43,46,52,54,56,64,69,73,76,78,79,90,98,99,104,105,106,109,111,113,114,120,122,124,132,142,143,144,152,158,163,167,199,201,209,210,216,219,235,237,254,261,268,273,275,279,280,285,303,304,306,309,310,313,322,325,327,329,330,331,335,340,346,348,353,361,366,372,373,376,377,378,383,388,391,392,393,397,406,408,409,413,420,422,430,438,440,444,452,454,456,460,461,468,469,471,478,483,488,503,507,511,513,514,529,530,536,547,550,554,556,558,561,562,565,566,577,591,594,595,596,599,605,606,611,620,625,627,629,643,644,655,658,667,676,684,690,695,701,704,711,715,720,723,730,732,737,739,741,748,752,755,758,765,772,776,779,780,781,785,790,806,810,816,818,820,822,835,843,846,852,854,855,858,864,865,866,875,878,880,883,888,891,900,904,905,906,907,911,914,917,920,925,934,939,945,951,953,959,962,968,971,975,979,983,988,992,993,996,1012,1014,1020,1022,1033,1034,1041,1047,1052,1056,1060,1068,1073,1100,1104,1111,1113,1119,1121,1129,1131,1140,1144,1147,1153,1159,1166,1169,1170,1171,1176,1184,1185,1189,1190,1193,1194,1198,1201,1208,1211,1212,1215,1219,1230,1231,1236,1237,1239,1250,1253,1256,1259,1265,1272,1277,1289,1290,1294,1307,1325,1328,1332,1334,1338,1340,1351,1358,1360,1365,1369,1374,1377,1378,1386,1387,1391,1393,1395,1398,1404,1411,1416,1417,1419,1437,1451,1464,1468,1469,1471,1482,1486,1492,1495,1502,1503,1512,1513,1519,1520,1521,1522,1525,1526,1529,1531,1541,1544,1545,1555,1564,1569,1578,1584,1592,1602,1604,1606,1607,1611,1621,1633,1636,1638,1640,1647,1651,1662,1663,1669,1675,1678,1686,1689,1700,1701,1704,1706,1710,1714,1715,1733,1738,1739,1743,1745,1755,1759,1760,1769,1779,1780,1783,1790,1794,1795,1796,1798,1799,1803,1804,1806,1811,1812,1820,1822,1832,1837,1841,1844,1882,1884,1899,1902,1905,1915,1916,1917,1923,1925,1931,1932,1933,1940,1942,1944,1946,1951,1952,1964,1980,1995,1996,2001,2005,2008,2023,2027,2034,2051,2056,2059,2061,2067,2069,2076,2078,2085,2088,2095,2100,2106,2107,2112,2114,2116,2121,2122,2123,2135,2159,2160,2169,2184,2189,2190,2191,2195,2199,2210,2214,2215,2216,2225,2229,2248,2251,2258,2263,2265,2266,2271,2272,2277,2285,2293,2299,2300,2308,2310,2316,2317,2318,2320,2331,2332,2336,2340,2347,2348,2349,2361,2502,2510,2514,2520,2527,2538,2541,2547,2548,2549,2555,2560,2563,2566,2570,2577,2581,2582,2585,2588,2591,2592,2593,2597,2606,2629,2638,2640,2641,2648,2649,2653,2664,2665,2667,2668,2669,2673,2677,2684,2688,2691,2693,2696,2722,2729,2742,2746,2747,2754,2758,2760,2766,2767,2775,2779,2780,2783,2792,2799,2809,2814,2817,2824,2829,2834,2839,2841,2844,2845,2862,2865,2868,2882,2886,2888,2891,2893,2909,2911,2916,2918,2926,2938,2955,2956,2961,2962,2976,2982,2991,2996,3007] \ No newline at end of file From 3cd2a77a907c0d4b1ccb55187c87d04bf2872b05 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Wed, 27 Apr 2022 10:52:23 +1000 Subject: [PATCH 10/11] stylish: Remove NoImplicitPrelude to make 0.14.0.1 work --- .stylish-haskell.yaml | 1 - cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs | 2 +- cardano-db-sync/src/Cardano/DbSync/Metrics.hs | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 2e3b106c4..0acb6ca60 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -86,7 +86,6 @@ language_extensions: - LambdaCase - MultiParamTypeClasses - MultiWayIf - - NoImplicitPrelude - OverloadedStrings - PolyKinds - ScopedTypeVariables diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs index 0c2d53a10..969554925 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs @@ -12,8 +12,8 @@ module Cardano.DbSync.Era.Byron.Genesis import Cardano.Prelude -import Cardano.BM.Trace (Trace, logInfo) import qualified Cardano.Binary as Binary +import Cardano.BM.Trace (Trace, logInfo) import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.Genesis as Byron import qualified Cardano.Chain.UTxO as Byron diff --git a/cardano-db-sync/src/Cardano/DbSync/Metrics.hs b/cardano-db-sync/src/Cardano/DbSync/Metrics.hs index abcf5eb22..7d1314d70 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Metrics.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Metrics.hs @@ -23,8 +23,8 @@ import Ouroboros.Network.Block (BlockNo (..)) import System.Metrics.Prometheus.Concurrent.RegistryT (RegistryT (..), registerGauge, runRegistryT, unRegistryT) import System.Metrics.Prometheus.Http.Scrape (serveMetricsT) -import System.Metrics.Prometheus.Metric.Gauge (Gauge) import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge +import System.Metrics.Prometheus.Metric.Gauge (Gauge) data Metrics = Metrics { mNodeBlockHeight :: !Gauge From 52ebe3b7ce8e948df1b808415dfb1ff52981f48c Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Wed, 27 Apr 2022 18:58:55 +1000 Subject: [PATCH 11/11] Nix fix Patch-from: Hamish Mackenzie --- flake.lock | 6 +++--- nix/default.nix | 2 +- nix/pkgs.nix | 1 + 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/flake.lock b/flake.lock index e23edb154..cac5d9e7f 100644 --- a/flake.lock +++ b/flake.lock @@ -242,11 +242,11 @@ ] }, "locked": { - "lastModified": 1639647351, - "narHash": "sha256-AFkgM3A0Pjue+pd9o8gizXOwdzrQbBeLWqOLEkcqa9I=", + "lastModified": 1649070135, + "narHash": "sha256-UFKqcOSdPWk3TYUCPHF22p1zf7aXQpCmmgf7UMg7fWA=", "owner": "input-output-hk", "repo": "iohk-nix", - "rev": "57f8cc93630754eb6f576b587fd0697969a29c75", + "rev": "cecab9c71d1064f05f1615eead56ac0b9196bc20", "type": "github" }, "original": { diff --git a/nix/default.nix b/nix/default.nix index 0ebf4f16a..4a7e9ec1c 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -16,7 +16,7 @@ let sources = flakeSources // sourcesOverride; iohkNix = import sources.iohk-nix { inherit system; }; haskellNix = import sources."haskell.nix" { inherit system sourcesOverride; }; - nixpkgs = haskellNix.sources.nixpkgs-2111; + nixpkgs = haskellNix.sources.nixpkgs-unstable; # for inclusion in pkgs: overlays = diff --git a/nix/pkgs.nix b/nix/pkgs.nix index 79e5f58b5..a7a6b95c9 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -41,6 +41,7 @@ in { stylish-haskell = haskell-nix.tool compiler "stylish-haskell" { version = "latest"; + modules = [{ reinstallableLibGhc = true; }]; }; # systemd can't be statically linked: