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/cabal.project b/cabal.project index 8a5adf0ba..9dc1c2c61 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 diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index 286fe6468..49ecf02a1 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -44,6 +44,8 @@ library Cardano.Mock.ChainDB 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 @@ -63,17 +65,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 +104,7 @@ library , persistent , persistent-postgresql , plutus-core - , plutus-example + , plutus-ledger-api , pretty-show , prometheus , random-shuffle @@ -198,5 +201,4 @@ test-suite cardano-chain-gen , ouroboros-network , ouroboros-network-framework , persistent - , 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/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/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..5d254f97a 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs @@ -6,9 +6,11 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + 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) @@ -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)) @@ -109,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)) @@ -311,7 +336,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..fcfa9d2c8 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs @@ -11,20 +11,28 @@ 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 ((!?)) 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 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 @@ -36,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 @@ -71,7 +83,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 +97,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 +137,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 @@ -161,3 +173,18 @@ 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 + +{-# 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/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/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 f89d589aa..92fd4a0e1 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 @@ -36,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 @@ -84,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 @@ -92,9 +94,18 @@ 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 ] + , 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 @@ -414,7 +425,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 +443,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 +452,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 +482,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 @@ -513,7 +524,7 @@ 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))] @@ -522,15 +533,15 @@ simpleRewards = -- Rewards will be distributed. _ <- 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)) ] @@ -560,17 +571,17 @@ rewardsShelley = _ <- 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)) ] @@ -612,14 +623,14 @@ rewardsDeregistration = 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 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 @@ -629,12 +640,12 @@ rewardsDeregistration = 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" @@ -665,7 +676,7 @@ mirReward = 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" @@ -693,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" @@ -716,23 +727,23 @@ mirRewardShelley = startDBSync dbSync _ <- registerAllStakeCreds interpreter mockServer - -- first move to treasury from reserves + -- TODO test that this has no effect. You can't send funds between reserves and + -- treasury before protocol version 5. _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ const $ Shelley.mkDCertTx [DCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Wdrl mempty) a <- fillEpochPercentage interpreter mockServer 50 - -- mir from treasury + -- mir from reserves _ <- withShelleyFindLeaderAndSubmitTx interpreter mockServer $ Shelley.mkSimpleDCertTx - [(StakeIndex 1, \cred -> DCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))))] + [(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" @@ -766,7 +777,7 @@ mirRewardDereg = 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" @@ -787,9 +798,9 @@ rewardsEmptyChainLast = b <- fillUntilNextEpoch interpreter mockServer assertRewardCount dbSync 6 - c <- fillEpochPercentage interpreter mockServer 80 + c <- fillEpochPercentage interpreter mockServer 68 - -- Skip half an epoch + -- Skip a percentage of the epoch epoch _ <- skipUntilNextEpoch interpreter mockServer [] d <- fillUntilNextEpoch interpreter mockServer assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 1 + length b + length c + 1 + length d) @@ -797,6 +808,35 @@ rewardsEmptyChainLast = 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 + _ <- 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 + _ <- 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 @@ -842,6 +882,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 @@ -858,7 +1021,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/Test/Cardano/Db/Mock/Validate.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs index a47e74851..2cde9ba14 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] @@ -151,13 +154,13 @@ 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 + => 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) @@ -195,12 +198,35 @@ 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 +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-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-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/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-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/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 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 diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index 400fb6213..03d36e57f 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -98,6 +98,8 @@ library Cardano.DbSync.Metrics + Cardano.DbSync.Cache + Cardano.DbSync.Cache.LRU Cardano.DbSync.Default Cardano.DbSync.Epoch @@ -164,9 +166,9 @@ library , persistent-postgresql , pretty-show , prometheus + , psqueues , random-shuffle , small-steps - , split , stm , strict , strict-containers diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index c0fc816a0..39272025e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -30,6 +30,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,6 +56,7 @@ data SyncEnv = SyncEnv , envSystemStart :: !SystemStart , envBackend :: !SqlBackend , envOptions :: !SyncOptions + , envCache :: !Cache , envLedger :: !LedgerEnv } @@ -118,12 +120,14 @@ 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 20000 pure $ SyncEnv { envProtocol = SyncProtocolCardano , envNetworkMagic = nwMagic , envSystemStart = systemStart , envBackend = backend , envOptions = syncOptions + , envCache = cache , envLedger = ledgerEnv } 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..938710b1f --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Cache.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.DbSync.Cache + ( Cache + , CacheNew (..) + , newEmptyCache + , uninitiatedCache + , rollbackCache + , queryPoolKeyWithCache + , insertPoolKeyWithCache + , queryStakeAddrWithCache + , queryMAWithCache + , queryPrevBlockWithCache + , insertBlockAndCache + + -- * CacheStats + , CacheStats + , getCacheStats + , textShowStats + ) where + +import Cardano.Prelude hiding (atomically, (.)) + +import Control.Monad.Class.MonadSTM.Strict (StrictTVar, atomically, modifyTVar, newTVarIO, + readTVarIO, writeTVar) +import Control.Monad.Trans.Control +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 CacheStats + } + +data CacheStats = CacheStats + { credsHits :: Word64 + , credsQueries :: Word64 + , poolsHits :: Word64 + , poolsQueries :: Word64 + , multiAssetsHits :: Word64 + , multiAssetsQueries :: Word64 + , prevBlockHits :: Word64 + , prevBlockQueries :: Word64 + } + +hitCreds :: StrictTVar IO CacheStats -> IO () +hitCreds ref = atomically $ modifyTVar ref (\cs -> cs {credsHits = 1 + credsHits cs, credsQueries = 1 + credsQueries cs}) +missCreds :: StrictTVar IO CacheStats -> IO () +missCreds ref = atomically $ modifyTVar ref (\cs -> cs {credsQueries = 1 + credsQueries cs}) +hitPools :: StrictTVar IO CacheStats -> IO () +hitPools ref = atomically $ modifyTVar ref (\cs -> cs {poolsHits = 1 + poolsHits cs, poolsQueries = 1 + poolsQueries cs}) +missPools :: StrictTVar IO CacheStats -> IO () +missPools ref = atomically $ modifyTVar ref (\cs -> cs {poolsQueries = 1 + poolsQueries cs}) +hitMAssets :: StrictTVar IO CacheStats -> IO () +hitMAssets ref = atomically $ modifyTVar ref (\cs -> cs {multiAssetsHits = 1 + multiAssetsHits cs, multiAssetsQueries = 1 + multiAssetsQueries cs}) +missMAssets :: StrictTVar IO CacheStats -> IO () +missMAssets ref = atomically $ modifyTVar ref (\cs -> cs {multiAssetsQueries = 1 + multiAssetsQueries cs}) +hitPBlock :: StrictTVar IO CacheStats -> IO () +hitPBlock ref = atomically $ modifyTVar ref (\cs -> cs {prevBlockHits = 1 + prevBlockHits cs, prevBlockQueries = 1 + prevBlockQueries cs}) +missPBlock :: StrictTVar IO CacheStats -> IO () +missPBlock ref = atomically $ modifyTVar ref (\cs -> cs {prevBlockQueries = 1 + prevBlockQueries cs}) + +initCacheStats :: CacheStats +initCacheStats = CacheStats 0 0 0 0 0 0 0 0 + +getCacheStats :: Cache -> IO CacheStats +getCacheStats UninitiatedCache = pure initCacheStats +getCacheStats (Cache CacheInternal {cStats = ref}) = + readTVarIO ref + +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 + [ "Cache Statistics: " + , "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) + , ", 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) + , ", Multi Assets: ", "cache capacity: ", DB.textShow (LRU.getCapacity mAssets) + , ", cache size: ", DB.textShow (LRU.getCapacity 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) + , ", 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 $ Cache <$> + (CacheInternal + <$> newTVarIO Map.empty + <*> newTVarIO Map.empty + <*> newTVarIO (LRU.empty maCapacity) + <*> newTVarIO Nothing + <*> newTVarIO initCacheStats) + +-- 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 $ atomically $ writeTVar (cPools cache) Map.empty + liftIO $ atomically $ modifyTVar (cMultiAssets cache) LRU.cleanup + liftIO $ atomically $ writeTVar (cPrevBlock cache) Nothing + rollbackStakeAddr cache mBlockNo nBlocks + +rollbackStakeAddr :: MonadIO m => CacheInternal -> Maybe Word64 -> Word64 -> ReaderT SqlBackend m () +rollbackStakeAddr CacheInternal {cStakeCreds = ref} Nothing _nBlocks = + liftIO $ atomically $ writeTVar ref Map.empty +rollbackStakeAddr CacheInternal {cStakeCreds = ref} (Just blockNo) nBlocks = do + if nBlocks > 600 then + liftIO $ atomically $ writeTVar ref Map.empty + else do + initMp <- liftIO $ readTVarIO ref + stakeAddrIds <- DB.queryStakeAddressIdsAfter blockNo + let stakeAddrIdsSet = Set.fromList stakeAddrIds + let !mp = Map.filter (`Set.member` stakeAddrIdsSet) initMp + liftIO $ atomically $ writeTVar ref mp + +queryStakeAddrWithCache :: forall m. MonadIO m => Cache -> CacheNew -> StakeCred + -> ReaderT SqlBackend m (Either DB.LookupFail DB.StakeAddressId) +queryStakeAddrWithCache UninitiatedCache _cacheNew cred = + queryStakeAddress (unStakeCred cred) +queryStakeAddrWithCache (Cache CacheInternal {cStakeCreds = ref, cStats = sts}) cacheNew cred = do + mp <- liftIO $ readTVarIO ref + (mAddrId, mp') <- queryStakeAddrAux cacheNew mp sts cred + liftIO $ atomically $ writeTVar ref mp' + pure mAddrId + +queryStakeAddrAux :: MonadIO m => CacheNew -> StakeAddrCache + -> StrictTVar IO CacheStats -> 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 UninitiatedCache _cacheNew hsh = do + mPhId <- queryPoolHashId (unStakePoolKeyHash hsh) + case mPhId of + Nothing -> pure $ Left (DB.DbLookupMessage "StakePoolKeyHash") + Just phId -> pure $ Right phId +queryPoolKeyWithCache (Cache CacheInternal {cPools = ref, cStats = sts}) cacheNew hsh = do + mp <- liftIO $ readTVarIO ref + case Map.lookup hsh mp of + Just phId -> do + liftIO $ hitPools sts + -- hit so we can't cache even with 'CacheNew' + when (cacheNew == EvictAndReturn) $ + liftIO $ atomically $ modifyTVar ref $ Map.delete hsh + pure $ Right phId + Nothing -> do + liftIO $ missPools sts + 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 ref $ Map.insert hsh phId + pure $ Right phId + +insertPoolKeyWithCache + :: (MonadBaseControl IO m, MonadIO m) => Cache -> CacheNew -> KeyHash 'StakePool StandardCrypto + -> ReaderT SqlBackend m DB.PoolHashId +insertPoolKeyWithCache UninitiatedCache _cacheNew pHash = + DB.insertPoolHash $ + DB.PoolHash + { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash + , DB.poolHashView = Generic.unKeyHashView pHash + } +insertPoolKeyWithCache (Cache CacheInternal {cPools = ref, cStats = sts}) cacheNew pHash = do + mp <- liftIO $ readTVarIO ref + let !keyHash = Generic.toStakePoolKeyHash pHash + case Map.lookup keyHash mp of + Just phId -> do + liftIO $ hitPools sts + when (cacheNew == EvictAndReturn) $ + liftIO $ atomically $ modifyTVar ref $ Map.delete keyHash + pure phId + Nothing -> do + liftIO $ missPools sts + phId <- DB.insertPoolHash $ + DB.PoolHash + { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash + , DB.poolHashView = Generic.unKeyHashView pHash + } + when (cacheNew == CacheNew) $ + liftIO $ atomically $ modifyTVar ref $ Map.insert keyHash phId + pure phId + +queryMAWithCache :: MonadIO m => Cache -> ByteString -> AssetName + -> ReaderT SqlBackend m (Maybe DB.MultiAssetId) +queryMAWithCache UninitiatedCache policyId (AssetName aName) = + DB.queryMultiAssetId policyId aName +queryMAWithCache (Cache CacheInternal {cMultiAssets = ref, cStats = sts}) policyId a@(AssetName aName) = do + mp <- liftIO $ readTVarIO ref + case LRU.lookup (policyId, a) mp of + Just (maId, mp') -> do + liftIO $ hitMAssets sts + liftIO $ atomically $ writeTVar ref mp' + pure $ Just maId + Nothing -> do + liftIO $ missMAssets sts + -- miss. The lookup doesn't change the cache on a miss. + maId <- DB.queryMultiAssetId policyId aName + case maId of + Nothing -> do + pure Nothing + Just mId -> do + liftIO $ atomically $ modifyTVar ref $ LRU.insert (policyId, a) mId + pure maId + +queryPrevBlockWithCache :: MonadIO m => Text -> Cache -> ByteString + -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.BlockId +queryPrevBlockWithCache msg UninitiatedCache hsh = + liftLookupFail msg $ DB.queryBlockId hsh +queryPrevBlockWithCache msg (Cache CacheInternal {cPrevBlock = ref, cStats = sts}) hsh = do + mCachedPrev <- liftIO $ readTVarIO ref + case mCachedPrev of + -- if the cached block matches the requested hash, we return its db id. + Just (cachedBlockId, cachedHash) | cachedHash == hsh -> do + liftIO $ hitPBlock sts + pure cachedBlockId + -- else we query it from the db. + _ -> do + liftIO $ missPBlock sts + liftLookupFail msg $ DB.queryBlockId hsh + +insertBlockAndCache :: (MonadIO m, MonadBaseControl IO m) => Cache -> DB.Block -> ReaderT SqlBackend m DB.BlockId +insertBlockAndCache UninitiatedCache block = + DB.insertBlock block +insertBlockAndCache (Cache CacheInternal {cPrevBlock = ref, cStats = sts}) block = do + bid <- DB.insertBlock block + liftIO $ missPBlock sts + liftIO $ atomically $ writeTVar ref $ Just (bid, DB.blockHash block) + pure bid 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..3299f9d22 --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs @@ -0,0 +1,62 @@ +{-# 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 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 6405d8308..b52a1332d 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 Cardano.DbSync.Era.Shelley.Adjust (deleteRewards) 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) +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) @@ -72,24 +71,23 @@ 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) - handleLedgerEvents tracer (envLedger env) (lssPoint lStateSnap) (lssEvents lStateSnap) + handleLedgerEvents env (sdEpochNo details) (lssEvents lStateSnap) 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) @@ -102,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 @@ -124,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) () @@ -137,34 +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 - 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 -> - 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 $ deleteRewards 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) @@ -193,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/Byron/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs index 972d847ef..bdc65976f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -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,37 +60,38 @@ 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 = getTrace env + 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. - 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 <- 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) @@ -120,12 +123,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.unHeaderHash $ 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/Byron/Util.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Util.hs index 40919702f..336609000 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 @@ -40,6 +42,7 @@ import qualified Cardano.Chain.Slotting as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Chain.Update 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 = 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..2ff002dcc 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} module Cardano.DbSync.Era.Shelley.Adjust - ( adjustEpochRewards + ( deleteRewards ) where import Cardano.Prelude hiding (from, groupBy, on) @@ -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 ^." -} @@ -36,55 +38,44 @@ import Database.Esqueleto.Experimental (SqlBackend, delete, from, in_, -- been de-registered and not reregistered and then delete all rewards for those addresses and that -- epoch. -adjustEpochRewards +deleteRewards :: (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 - --- ------------------------------------------------------------------------------------------------ +deleteRewards 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/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/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..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._dstate . Shelley._delegationState - . 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/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index a2e30bff8..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) @@ -19,84 +26,137 @@ 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 Cardano.Slotting.Slot (EpochNo (..)) +import qualified Cardano.Ledger.Shelley.LedgerState as Shelley 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/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..2c3f2c4b6 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -18,8 +18,11 @@ 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 import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic import Cardano.DbSync.Era.Shelley.Insert import Cardano.DbSync.Era.Util (liftLookupFail) @@ -37,6 +40,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 (..)) @@ -141,7 +145,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) @@ -214,7 +218,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 @@ -240,10 +244,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 $ @@ -261,9 +266,12 @@ insertStaking tracer 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 tracer (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 -- ----------------------------------------------------------------------------- @@ -292,11 +300,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/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs index 009d499be..ee4773b26 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs @@ -9,11 +9,10 @@ module Cardano.DbSync.Era.Shelley.Insert ( insertShelleyBlock - , postEpochRewards - , postEpochStake -- These are exported for data in Shelley Genesis , insertPoolRegister + , insertStakeRegistration , insertDelegation , insertStakeAddressRefIfMissing ) where @@ -45,24 +44,25 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Ledger import qualified Cardano.Ledger.BaseTypes as Ledger import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Coin as Ledger +import Cardano.Ledger.Credential (Ptr (Ptr)) 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) @@ -78,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) @@ -110,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 @@ -137,9 +137,7 @@ insertShelleyBlock tracer lenv firstBlockOfEpoch blk lStateSnap details = do whenJust (lssNewEpoch lStateSnap) $ \ newEpoch -> do insertOnNewEpoch tracer blkId (Generic.blkSlotNo blk) (sdEpochNo details) newEpoch - 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 @@ -160,9 +158,7 @@ insertShelleyBlock tracer lenv firstBlockOfEpoch blk lStateSnap details = do renderInsertName :: Generic.BlockEra -> Text renderInsertName eraName = - case eraName of - Generic.Shelley -> "insertShelleyBlock" - other -> mconcat [ "insertShelleyBlock(", textShow other, ")" ] + mconcat ["Insert ", textShow eraName, " Block"] offlineModBase :: Word64 offlineModBase = @@ -170,6 +166,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 @@ -189,10 +192,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 @@ -228,7 +231,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) @@ -240,12 +243,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 @@ -255,10 +258,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 @@ -271,7 +274,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 @@ -309,15 +312,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" @@ -326,39 +329,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 @@ -373,7 +375,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 @@ -395,24 +397,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 @@ -435,29 +425,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 = @@ -469,17 +480,33 @@ insertStakeAddressRefIfMissing trce txId addr = Just <$> insertStakeAddress txId (Shelley.RewardAcnt nw cred) Ledger.StakeRefPtr ptr -> do mid <- queryStakeRefPtr ptr - when (isNothing mid) . - liftIO . logWarning trce $ "insertStakeRefIfMissing: query of " <> textShow ptr <> " returns Nothing" + when (isNothing mid) $ do + let Ptr sl txIx cIx = ptr + liftIO . logWarning trce $ "insertStakeRefIfMissing: query of " <> textShow ptr <> " (" + <> textShow sl <> " " <> textShow txIx <> " " <> textShow cIx <>") returns Nothing" 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 @@ -488,9 +515,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 @@ -502,11 +532,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 @@ -523,14 +553,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 @@ -549,9 +579,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 @@ -569,7 +599,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 @@ -583,7 +613,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 @@ -834,9 +864,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 @@ -851,7 +881,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 @@ -861,9 +891,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 @@ -878,7 +908,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 @@ -887,19 +917,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/Insert/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs index 347e70ec5..5839da5bf 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 - , postEpochStake + , insertStakeSlice + , insertEpochRewardTotalReceived + , sumRewardTotal ) where import Cardano.Prelude -import Cardano.BM.Trace (Trace, logInfo, logWarning) +import Cardano.BM.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 (flushTBQueue, isEmptyTBQueue, readTVar, - 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,131 +42,46 @@ 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 - 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 $ - 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) - -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 - -> 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) + => SyncEnv -> Generic.StakeSliceRes + -> ExceptT SyncNodeError (ReaderT SqlBackend m) () +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 = getTrace env + insertEpochStake :: (MonadBaseControl IO m, MonadIO m) - => Trace IO Text -> IndexCache -> EpochNo + => Cache -> EpochNo -> [(Generic.StakeCred, (Shelley.Coin, Generic.StakePoolKeyHash))] -> ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertEpochStake _tracer 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 @@ -185,9 +92,9 @@ insertEpochStake _tracer 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 @@ -196,7 +103,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. @@ -207,13 +114,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 @@ -221,111 +129,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 <- createNewCache 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 - } - - 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/Query.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs index 28086b561..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 @@ -23,10 +22,9 @@ 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 (..)) -import qualified Cardano.Ledger.Keys as Ledger +import Cardano.Ledger.Credential (Ptr (..)) import Cardano.DbSync.Util @@ -35,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) @@ -58,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 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 (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 (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 = @@ -138,7 +96,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/Era/Shelley/Validate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs index a8b688004..b04eb9e69 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,30 +38,34 @@ 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 liftIO . logWarning tracer $ mconcat - [ "validateEpochRewards: rewards spendable in epoch " + [ "Validate Epoch Rewards: rewards spendable in epoch " , textShow (unEpochNo $ Generic.rwdEpoch rmap), " expected total of " , 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 " + [ "Validate Epoch Rewards: total rewards that become spendable in epoch " , textShow (unEpochNo $ Generic.rwdEpoch rmap), " is ", textShow actual , " ADA" ] 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 9a1ea817a..d20684efb 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerEvent.hs @@ -27,12 +27,13 @@ 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) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Types import Cardano.Slotting.Slot (EpochNo (..)) import Control.State.Transition (Event) @@ -51,16 +52,30 @@ import Ouroboros.Consensus.TypeFamilyWrappers data LedgerEvent - = LedgerNewEpoch !EpochNo !SyncState - | LedgerStartAtEpoch !EpochNo - | LedgerRewards !SlotDetails !Generic.Rewards - | LedgerStakeDist !Generic.StakeDist - - | LedgerRewardDist !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 @@ -83,12 +98,19 @@ 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) + 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 @@ -105,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) @@ -150,16 +169,51 @@ 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 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 , 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 (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 - (NewEpochEvent (RewardEvent e m)) + (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..b332566f2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs +++ b/cardano-db-sync/src/Cardano/DbSync/LedgerState.hs @@ -4,14 +4,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Cardano.DbSync.LedgerState - ( BulkOperation (..) - , CardanoLedgerState (..) - , IndexCache (..) + ( CardanoLedgerState (..) , LedgerEnv (..) , LedgerEvent (..) , LedgerStateSnapshot (..) @@ -32,17 +31,14 @@ 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 - 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 (..)) @@ -54,8 +50,6 @@ import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import Cardano.DbSync.Config.Types import qualified Cardano.DbSync.Era.Cardano.Util as Cardano import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Generic.StakeCred -import Cardano.DbSync.Era.Shelley.Generic.StakePoolKeyHash import Cardano.DbSync.LedgerEvent import Cardano.DbSync.StateQuery import Cardano.DbSync.Types hiding (CardanoBlock) @@ -68,8 +62,8 @@ import Cardano.Slotting.EpochInfo (EpochInfo, epochInfoEpoch) import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..), fromWithOrigin) import qualified Control.Exception as Exception -import Control.Monad.Class.MonadSTM.Strict (StrictTMVar, StrictTVar, TBQueue, atomically, - newEmptyTMVarIO, newTBQueueIO, newTVarIO, readTVar, writeTVar) +import Control.Monad.Class.MonadSTM.Strict (StrictTVar, TBQueue, atomically, newTBQueueIO, + newTVarIO, readTVar, writeTVar) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS @@ -82,8 +76,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, @@ -125,19 +119,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 - | BulkStakeDistChunk !EpochNo !CardanoPoint !IndexCache ![(StakeCred, (Coin, StakePoolKeyHash))] - | BulkStakeDistReport !EpochNo !CardanoPoint !Int - -data IndexCache = IndexCache - { icAddressCache :: !(Map StakeCred DB.StakeAddressId) - , icPoolCache :: !(Map StakePoolKeyHash DB.PoolHashId) - } - data LedgerEnv = LedgerEnv { leTrace :: Trace IO Text , leProtocolInfo :: !(Consensus.ProtocolInfo IO CardanoBlock) @@ -148,34 +129,61 @@ data LedgerEnv = LedgerEnv , leInterpreter :: !(StrictTVar IO (Maybe CardanoInterpreter)) , leStateVar :: !(StrictTVar IO (Maybe LedgerDB)) , leEventState :: !(StrictTVar IO LedgerEventState) - , lePoolRewards :: !(StrictTMVar IO Generic.Rewards) - , leMirRewards :: !(StrictTMVar IO Generic.Rewards) -- 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) , 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 +197,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] } @@ -223,16 +232,12 @@ 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 - prvar <- newEmptyTMVarIO - mrvar <- newEmptyTMVarIO pure LedgerEnv { leTrace = trce , leProtocolInfo = protocolInfo @@ -243,10 +248,6 @@ mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do , leInterpreter = intervar , leStateVar = svar , leEventState = evar - , lePoolRewards = prvar - , leMirRewards = mrvar - , leIndexCache = ivar - , leBulkOpQueue = boq , leOfflineWorkQueue = owq , leOfflineResultQueue = orq , leEpochSyncTime = est @@ -258,15 +259,13 @@ mkLedgerEnv trce protocolInfo dir nw stableEpochSlot systemStart aop = do LedgerEventState { lesInitialized = False , lesEpochNo = Nothing - , lesLastRewardsEpoch = Nothing - , lesLastStateDistEpoch = Nothing - , lesLastAdded = GenesisPoint } 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,19 +290,23 @@ 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 pure $ LedgerStateSnapshot { lssState = newState , lssOldState = oldState - , lssNewEpoch = maybeToStrict $ mkNewEpoch oldState newState + , lssNewEpoch = maybeToStrict newEpoch , lssSlotDetails = details , lssPoint = blockPoint blk - , lssEvents = events ++ mapMaybe (convertAuxLedgerEvent (leNetwork env)) (lrEvents result) + , lssStakeSlice = stakeSlice newState details + , lssEvents = sort $ events ++ mapMaybe (convertAuxLedgerEvent (leNetwork env)) (lrEvents result) } where applyBlk @@ -315,7 +318,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 +328,35 @@ 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 } -generateEvents :: LedgerEnv -> LedgerEventState -> SlotDetails -> CardanoLedgerState -> CardanoPoint -> STM [LedgerEvent] -generateEvents env oldEventState details cls pnt = do + 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 -> STM [LedgerEvent] +generateEvents env oldEventState details = do writeTVar (leEventState env) newEventState pure $ catMaybes [ newEpochEvent - , LedgerRewards details <$> rewards - , LedgerStakeDist <$> stakeDist ] where currentEpochNo :: EpochNo @@ -349,54 +371,16 @@ 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) - - 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 { lesInitialized = True , lesEpochNo = Just currentEpochNo - , lesLastRewardsEpoch = - 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 - 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 +390,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 +408,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) @@ -492,9 +477,9 @@ cleanupLedgerStateFiles env slotNo = do -- Remove invalid (ie SlotNo >= current) ledger state files (occurs on rollback). deleteAndLogFiles env "invalid" invalid -- Remove all but 6 most recent state files. - deleteAndLogStateFile env "valid" (List.drop 6 valid) + deleteAndLogStateFile env "old" (List.drop 6 valid) -- Remove all but 6 most recent epoch boundary state files. - deleteAndLogStateFile env "epoch boundary" (List.drop 6 epochBoundary) + deleteAndLogStateFile env "old epoch boundary" (List.drop 6 epochBoundary) where groupFiles :: LedgerStateFile -> ([LedgerStateFile], [LedgerStateFile], [FilePath]) @@ -555,9 +540,15 @@ deleteNewerFiles env point = do deleteAndLogStateFile env "newer" newerFiles deleteAndLogFiles :: LedgerEnv -> Text -> [FilePath] -> IO () -deleteAndLogFiles env descr files = unless (null files) $ do - logInfo (leTrace env) $ mconcat ["Removing ", descr, " files ", textShow files] - mapM_ safeRemoveFile files +deleteAndLogFiles env descr files = + case files of + [] -> pure () + [fl] -> do + logInfo (leTrace env) $ mconcat ["Removing ", descr, " file ", Text.pack fl] + safeRemoveFile fl + _ -> do + logInfo (leTrace env) $ mconcat ["Removing ", descr, " files ", textShow files] + mapM_ safeRemoveFile files deleteAndLogStateFile :: LedgerEnv -> Text -> [LedgerStateFile] -> IO () deleteAndLogStateFile env descr lsfs = deleteAndLogFiles env descr (lsfFilePath <$> lsfs) @@ -639,9 +630,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 +645,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 @@ -697,23 +693,23 @@ 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 -- 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 +717,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-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-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-db/src/Cardano/Db/Query.hs b/cardano-db/src/Cardano/Db/Query.hs index 32044ae25..5c3617fab 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 @@ -57,6 +58,7 @@ module Cardano.Db.Query , queryTxOutCount , queryTxOutValue , queryTxOutCredentials + , queryEpochStakeCount , queryUtxoAtBlockNo , queryUtxoAtSlotNo , queryWithdrawalsUpToBlockNo @@ -78,6 +80,7 @@ module Cardano.Db.Query , queryDelegationScript , queryWithdrawalScript , queryStakeAddressScript + , queryStakeAddressIdsAfter , existsDelistedPool , existsPoolHash , existsPoolHashId @@ -213,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 @@ -279,7 +291,7 @@ queryBlocksAfterSlot slotNo = do -- | Calculate the Epoch table entry for the specified epoch. -- When syncing the chain or filling an empty table, this is called at each epoch boundary to --- calculate the Epcoh entry for the last epoch. +-- calculate the Epoch entry for the last epoch. -- When following the chain, this is called for each new block of the current epoch. queryCalcEpochEntry :: MonadIO m => Word64 -> ReaderT SqlBackend m Epoch queryCalcEpochEntry epochNum = do @@ -742,6 +754,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 @@ -984,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 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" diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs index 4fd369373..f36d3aff7 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs @@ -324,7 +324,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/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. diff --git a/flake.lock b/flake.lock index b7f576095..2ae3b297d 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,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1639357972, - "narHash": "sha256-NvVn00YOYZMqDUSiBbghJk/rm/nJItBEUJulWRGTgvk=", + "lastModified": 1650417240, + "narHash": "sha256-QlNKyTxbENaGr9Y89GMw7N8qvpZkRb7kyZBMOGqwMmE=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "54adf6e47e20831d9c49a2b62e12f7f218fd7752", + "rev": "937b5ba259e997a70b7c3cc4ced437ec22578737", "type": "github" }, "original": { @@ -130,15 +147,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 +167,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1639371915, - "narHash": "sha256-i5kW3hPptzXwzkpI2FAkfdDA/9QEDl/9mrwwoeBxDJg=", + "lastModified": 1650425121, + "narHash": "sha256-mT7y7JDJEkiQdZpp/ixrJnBuZQMnYVrJx5dhNEVZQzs=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "e95a1f0dacbc64603c31d11e36e4ba1af8f0eb43", + "rev": "f3ea06dcacc8a46b4a207a6a1fad14bc5ea41b19", "type": "github" }, "original": { @@ -177,6 +196,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 +239,51 @@ "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": "ed5bd7215292deba55d6ab7a4e8c21f8b1564dda", + "rev": "e109c94016e3b6e0db7ed413c793e2d4bdb24aa7", "type": "github" }, "original": { @@ -213,6 +292,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 +325,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 +341,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 +355,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": { @@ -309,11 +418,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1639185224, - "narHash": "sha256-ZBL0Lvqq8/Iwl8F5sT2N9J8+HTh0OY+09LkkUVtuUtY=", + "lastModified": 1650330907, + "narHash": "sha256-812eESX3MZjdI5psPg3VSV5Kw+afm2h8oefUYcSgst8=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "14819f5c85a92e5fb6e322cc809c803fa6419bd4", + "rev": "633edabd25111e59a7c457f7fd26e3fbf2264bbb", "type": "github" }, "original": { 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-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() ;