From 258f76caaca2f4ad0bc02548c4809434a2ef37a1 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 27 Oct 2021 15:56:15 +0300 Subject: [PATCH] Add initial working implementation of `ledger-state` benchmarking and analyzing tool --- cabal.project | 1 + eras/alonzo/impl/cardano-ledger-alonzo.cabal | 1 - libs/ledger-state/ChangeLog.md | 3 + libs/ledger-state/README.md | 58 ++ libs/ledger-state/Setup.hs | 3 + libs/ledger-state/app/Main.hs | 69 ++ libs/ledger-state/bench/Memory.hs | 86 ++ libs/ledger-state/ledger-state.cabal | 89 ++ libs/ledger-state/src/Cardano/Ledger/State.hs | 1 + .../src/Cardano/Ledger/State/Orphans.hs | 143 +++ .../src/Cardano/Ledger/State/Query.hs | 644 ++++++++++++++ .../src/Cardano/Ledger/State/Schema.hs | 130 +++ .../src/Cardano/Ledger/State/Transform.hs | 109 +++ .../src/Cardano/Ledger/State/UTxO.hs | 839 ++++++++++++++++++ .../src/Control/Iterate/SetAlgebra.hs | 3 + 15 files changed, 2178 insertions(+), 1 deletion(-) create mode 100644 libs/ledger-state/ChangeLog.md create mode 100644 libs/ledger-state/README.md create mode 100644 libs/ledger-state/Setup.hs create mode 100644 libs/ledger-state/app/Main.hs create mode 100644 libs/ledger-state/bench/Memory.hs create mode 100644 libs/ledger-state/ledger-state.cabal create mode 100644 libs/ledger-state/src/Cardano/Ledger/State.hs create mode 100644 libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs create mode 100644 libs/ledger-state/src/Cardano/Ledger/State/Query.hs create mode 100644 libs/ledger-state/src/Cardano/Ledger/State/Schema.hs create mode 100644 libs/ledger-state/src/Cardano/Ledger/State/Transform.hs create mode 100644 libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs diff --git a/cabal.project b/cabal.project index 074cd924ea..18f8ba806e 100644 --- a/cabal.project +++ b/cabal.project @@ -19,6 +19,7 @@ packages: libs/cardano-ledger-test libs/cardano-protocol-tpraos libs/plutus-preprocessor + libs/ledger-state libs/non-integral libs/small-steps libs/small-steps-test diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 6d55559110..e896e08cc2 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -66,7 +66,6 @@ library cardano-ledger-core, cardano-ledger-shelley-ma, cardano-prelude, - cardano-protocol-tpraos, cardano-slotting, containers, data-default, diff --git a/libs/ledger-state/ChangeLog.md b/libs/ledger-state/ChangeLog.md new file mode 100644 index 0000000000..63d1016f00 --- /dev/null +++ b/libs/ledger-state/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for ledegr-state + +## Unreleased changes diff --git a/libs/ledger-state/README.md b/libs/ledger-state/README.md new file mode 100644 index 0000000000..7dfe8a2847 --- /dev/null +++ b/libs/ledger-state/README.md @@ -0,0 +1,58 @@ +# ledger-state + +This tool allows loading the ledger state from binary encoded CBOR format into +sqlite database in order to perform various analysis. In particular benchmark +the memory overhead. + +## Dumping LedgerState + +In order to be able to use the tool we need to get ahold of current ledger +state. For this we need to start a cardano node and wait for it to sync. + +```haskell +$ export CARDANO_DATA="${HOME}/iohk/chain/mainnet" +$ mkdir -p "${CARDANO_DATA}"/db +$ cd "${CARDANO_DATA}" +``` + +Download all the [mainnet related config files](https://developers.cardano.org/docs/get-started/running-cardano/#mainnet--production): +``` +curl -O -J https://hydra.iohk.io/build/7370192/download/1/mainnet-config.json +curl -O -J https://hydra.iohk.io/build/7370192/download/1/mainnet-byron-genesis.json +curl -O -J https://hydra.iohk.io/build/7370192/download/1/mainnet-shelley-genesis.json +curl -O -J https://hydra.iohk.io/build/7370192/download/1/mainnet-alonzo-genesis.json +curl -O -J https://hydra.iohk.io/build/7370192/download/1/mainnet-topology.json +``` + +Start the node and wait for it to fully sync + +``` +$ export CARDANO_NODE_SOCKET_PATH="${CARDANO_DATA}/db/node.socket" +$ cardano-node run + --topology "${CARDANO_DATA}/mainnet-topology.json" \ + --database-path "${CARDANO_DATA}/db" \ + --socket-path "${CARDANO_NODE_SOCKET_PATH}" \ + --host-addr 127.0.0.1 \ + --port 3001 \ + --config "${CARDANO_DATA}/mainnet-config.json" & +``` + +Dump the ledger state and focus back onto the node: + +```shell +$ cardano-cli query ledger-state --mainnet --out-file "${CARDANO_DATA}/ledger-state.bin" +$ fg +``` +Hit Ctr-C to stop the node + +## Populate sqlite db + +```shell +$ cabal run ledger-state --new-epoch-state-cbor="${CARDANO_DATA}/ledger-state.bin" --new-epoch-state-sqlite="${CARDANO_DATA}/ledger-state.sqlite" +``` + +## Running benchmarks + +```shell +$ cabal bench ledger-state --benchmark-options="--new-epoch-state-cbor=\"${CARDANO_DATA}/ledger-state.bin\" --new-epoch-state-sqlite=\"${CARDANO_DATA}/ledger-state.sqlite\"" +``` diff --git a/libs/ledger-state/Setup.hs b/libs/ledger-state/Setup.hs new file mode 100644 index 0000000000..e8ef27dbba --- /dev/null +++ b/libs/ledger-state/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/libs/ledger-state/app/Main.hs b/libs/ledger-state/app/Main.hs new file mode 100644 index 0000000000..2912f7beec --- /dev/null +++ b/libs/ledger-state/app/Main.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.State.Query +import Cardano.Ledger.State.UTxO +import Control.Monad +import Data.Text as T (pack) +import Options.Applicative +import System.IO + +data Opts = Opts + { -- | Path to the CBOR encoded NewEpochState data type, which will be used to + -- load into sqlite database + optsLedgerStateBinaryFile :: Maybe FilePath, + -- | Path to Sqlite database file. + optsSqliteDbFile :: Maybe FilePath + } + deriving (Show) + +optsParser :: Parser Opts +optsParser = + Opts + <$> option + (Just <$> str) + ( long "new-epoch-state-cbor" + <> value Nothing + <> help + ( "Path to the CBOR encoded NewEpochState data type. " + <> "Can be produced by `cardano-cli query ledger-state` command. " + <> "When supplied stats about the state will be printed to stdout" + ) + ) + <*> option + (Just <$> str) + ( long "new-epoch-state-sqlite" + <> value Nothing + <> help + ( "Path to Sqlite database file. When supplied then new-epoch-state " + <> "will be loaded into the databse. Requires --new-epoch-state-cbor" + ) + ) + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + opts <- + execParser $ + info + ( optsParser + <* abortOption + (ShowHelpText Nothing) + (long "help" <> short 'h' <> help "Display this message.") + ) + (header "ledger-state - Tool for analyzing ledger state") + forM_ (optsLedgerStateBinaryFile opts) $ \binFp -> do + nes <- loadNewEpochState binFp + forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do + let dbFp = T.pack dbFpStr + storeEpochState dbFp $ nesEs nes + putStrLn "Loaded EpochState into the database" + printNewEpochStateStats $ countNewEpochStateStats nes + forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do + let dbFp = T.pack dbFpStr + km <- loadDbUTxO txIdSharingKeyMap dbFp + m <- loadDbUTxO noSharing dbFp + testKeyMap km m diff --git a/libs/ledger-state/bench/Memory.hs b/libs/ledger-state/bench/Memory.hs new file mode 100644 index 0000000000..be1235600c --- /dev/null +++ b/libs/ledger-state/bench/Memory.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Cardano.Ledger.State.Query +import Cardano.Ledger.State.UTxO +import Control.Monad +import qualified Data.Text as T +import Options.Applicative as O +import Weigh + +data Opts = Opts + { -- | Path to the CBOR encoded NewEpochState data type, which will be used to + -- load into sqlite database + optsLedgerStateBinaryFile :: Maybe FilePath, + -- | Path to Sqlite database file. + optsSqliteDbFile :: Maybe FilePath + } + deriving (Show) + +optsParser :: Parser Opts +optsParser = + Opts + <$> option + (Just <$> str) + ( long "new-epoch-state-cbor" + <> O.value Nothing + <> help + ("Benchmark loading CBOR encoded NewEpochState into memory.") + ) + <*> option + (Just <$> str) + ( long "new-epoch-state-sqlite" + <> O.value Nothing + <> help + ("Run various benchmarks on LedgerState representations") + ) + +main :: IO () +main = do + opts <- + execParser $ + info + ( optsParser + <* abortOption + (ShowHelpText Nothing) + (long "help" <> short 'h' <> help "Display this message.") + ) + (header "ledger-state:memory - Tool for analyzing memory consumption of ledger state") + let cols = [Case, Max, MaxOS, Live, Allocated, GCs] + !mEpochStateEntity <- mapM (loadEpochStateEntity . T.pack) (optsSqliteDbFile opts) + mainWith $ do + setColumns cols + forM_ (optsLedgerStateBinaryFile opts) $ \binFp -> do + io "NewEpochState" loadNewEpochState binFp + forM_ (optsSqliteDbFile opts) $ \dbFpStr -> do + let dbFp = T.pack dbFpStr + forM_ mEpochStateEntity $ \ese -> + wgroup "EpochState" $ do + io "SnapShots - no sharing" (loadSnapShotsNoSharing dbFp) ese + io "SnapShots - with sharing" (loadSnapShotsWithSharing dbFp) ese + wgroup "Baseline" $ do + io "DState" loadDStateNoSharing dbFp + io "UTxO" loadUTxONoSharing dbFp + io "LedgerState" getLedgerStateNoSharing dbFp + wgroup "UTxO (No TxOut)" $ do + io "IntMap (KeyMap TxId ())" (loadDbUTxO txIxSharingKeyMap_) dbFp + io "KeyMap TxId (IntMap TxId ())" (loadDbUTxO txIdSharingKeyMap_) dbFp + io "IntMap (Map TxId ())" (loadDbUTxO txIxSharing_) dbFp + io "Map TxIn ()" (loadDbUTxO noSharing_) dbFp + wgroup "LedgerState" $ do + wgroup "UTxO (Share DState)" $ do + io "IntMap (KeyMap TxId TxOut)" getLedgerStateDStateTxIxSharingKeyMap dbFp + io "KeyMap TxId (IntMap TxOut)" getLedgerStateDStateTxIdSharingKeyMap dbFp + io "IntMap (Map TxId TxOut)" getLedgerStateDStateTxIxSharing dbFp + io "Map TxIn TxOut" getLedgerStateDStateSharing dbFp + +-- wgroup "Share TxOut StakeCredential" $ do +-- io "Map TxIn TxOut'" getLedgerStateDStateTxOutSharing dbFp +-- wgroup "Share TxOut StakeCredential" $ do +-- io "Map TxIn TxOut'" getLedgerStateTxOutSharing dbFp +-- wgroup "No Sharing" $ do +-- wgroup "Share TxOut StakeCredential" $ do +-- io "IntMap (KeyMap TxId TxOut')" getLedgerStateWithSharingKeyMap dbFp +-- io "IntMap (Map TxId TxOut')" getLedgerStateWithSharing dbFp diff --git a/libs/ledger-state/ledger-state.cabal b/libs/ledger-state/ledger-state.cabal new file mode 100644 index 0000000000..e86749422b --- /dev/null +++ b/libs/ledger-state/ledger-state.cabal @@ -0,0 +1,89 @@ +cabal-version: 2.2 + +name: ledger-state +version: 0.1.0.0 +license: Apache-2.0 +author: IOHK Formal Methods Team +maintainer: formal.methods@iohk.io +description: This is a tool that helps us experiment with the UTxO map +build-type: Simple + +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/input-output-hk/cardano-ledger-specs.git + subdir: libs/utxo-state + +common project-config + default-language: Haskell2010 + build-depends: base >= 4.12 && < 4.15 + + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wunused-packages + +library + import: project-config + build-depends: bytestring + , cardano-binary + , cardano-crypto-class + , cardano-ledger-core + , cardano-ledger-alonzo + , cardano-ledger-shelley + , cardano-ledger-shelley-ma + , cardano-protocol-tpraos + , cborg + , conduit + , containers + , compact-map + , deepseq + , foldl + , persistent + , persistent-sqlite + , persistent-template + , prettyprinter + , strict-containers + , small-steps + , text + , transformers + exposed-modules: Cardano.Ledger.State + , Cardano.Ledger.State.UTxO + , Cardano.Ledger.State.Orphans + , Cardano.Ledger.State.Schema + , Cardano.Ledger.State.Transform + , Cardano.Ledger.State.Query + hs-source-dirs: src + +executable ledger-state + import: project-config + hs-source-dirs: app + main-is: Main.hs + ghc-options: -O2 + -threaded + -rtsopts + build-depends: cardano-ledger-shelley + , ledger-state + , optparse-applicative + , text + + +benchmark memory + type: exitcode-stdio-1.0 + main-is: Memory.hs + hs-source-dirs: bench + build-depends: base + , weigh + , ledger-state + , optparse-applicative + , text + ghc-options: -Wall + -O2 + -rtsopts + -with-rtsopts=-T + default-language: Haskell2010 diff --git a/libs/ledger-state/src/Cardano/Ledger/State.hs b/libs/ledger-state/src/Cardano/Ledger/State.hs new file mode 100644 index 0000000000..bde998eb05 --- /dev/null +++ b/libs/ledger-state/src/Cardano/Ledger/State.hs @@ -0,0 +1 @@ +module Cardano.Ledger.State where diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs new file mode 100644 index 0000000000..32f33ddd75 --- /dev/null +++ b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Ledger.State.Orphans where + +import Cardano.Binary +import Cardano.Crypto.Hash.Class +import Cardano.Ledger.Alonzo.PParams +import Cardano.Ledger.Alonzo.TxBody +import Cardano.Ledger.Coin +import Cardano.Ledger.Credential +import Cardano.Ledger.Keys +import Cardano.Ledger.SafeHash +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rewards +import Cardano.Ledger.Shelley.TxBody (PoolParams (..)) +import Cardano.Ledger.State.UTxO +import Cardano.Ledger.TxIn +import Control.DeepSeq +import Data.ByteString.Short +import qualified Data.Text as T +import Data.Typeable +import Database.Persist +import Database.Persist.Sqlite + +data SnapShotType + = SnapShotMark + | SnapShotSet + | SnapShotGo + deriving (Show, Eq, Enum, Bounded) + +instance PersistField SnapShotType where + toPersistValue = PersistInt64 . fromIntegral . fromEnum + fromPersistValue (PersistInt64 i64) = Right $ toEnum $ fromIntegral i64 + fromPersistValue _ = Left "Unexpected type" + +instance PersistFieldSql SnapShotType where + sqlType _ = SqlInt32 + +instance PersistField ShortByteString where + toPersistValue = PersistByteString . fromShort + fromPersistValue (PersistByteString bs) = Right $ toShort bs + fromPersistValue _ = Left "Unexpected type" + +instance PersistFieldSql ShortByteString where + sqlType _ = SqlBlob + +instance PersistField (TxId C) where + toPersistValue = PersistByteString . hashToBytes . extractHash . _unTxId + fromPersistValue (PersistByteString bs) = + case hashFromBytes bs of + Nothing -> Left "Invalid number of bytes for the hash" + Just h -> Right $ TxId $ unsafeMakeSafeHash h + fromPersistValue _ = Left "Unexpected type" + +instance PersistFieldSql (TxId C) where + sqlType _ = SqlBlob + +instance PersistField Coin where + toPersistValue = PersistInt64 . fromIntegral . unCoin + fromPersistValue (PersistInt64 i64) = Right $ Coin $ fromIntegral i64 + fromPersistValue _ = Left "Unexpected type" + +instance PersistFieldSql Coin where + sqlType _ = SqlInt64 + +instance PersistField DeltaCoin where + toPersistValue (DeltaCoin dc) = PersistInt64 $ fromIntegral dc + fromPersistValue (PersistInt64 i64) = Right $ DeltaCoin $ fromIntegral i64 + fromPersistValue _ = Left "Unexpected type" + +instance PersistFieldSql DeltaCoin where + sqlType _ = SqlInt64 + +instance NFData (TxOut CurrentEra) where + rnf = \case + TxOutCompact _ _ -> () + TxOutCompactDH _ _ _ -> () + +newtype Enc a = Enc {unEnc :: a} + +instance (ToCBOR a, FromCBOR a) => PersistField (Enc a) where + toPersistValue = PersistByteString . serialize' . unEnc + fromPersistValue = fmap Enc . decodePersistValue + +instance (ToCBOR a, FromCBOR a) => PersistFieldSql (Enc a) where + sqlType _ = SqlBlob + +decodePersistValue :: FromCBOR b => PersistValue -> Either T.Text b +decodePersistValue (PersistByteString bs) = + case decodeFull' bs of + Left err -> Left $ "Could not decode: " <> T.pack (show err) + Right v -> Right v +decodePersistValue _ = Left "Unexpected type" + +deriving via Enc (KeyHash r C) instance Typeable r => PersistField (KeyHash r C) + +deriving via Enc (KeyHash r C) instance Typeable r => PersistFieldSql (KeyHash r C) + +deriving via Enc (Credential r C) instance Typeable r => PersistField (Credential r C) + +deriving via Enc (Credential r C) instance Typeable r => PersistFieldSql (Credential r C) + +deriving via Enc Ptr instance PersistField Ptr + +deriving via Enc Ptr instance PersistFieldSql Ptr + +deriving via Enc (PPUPState CurrentEra) instance PersistField (PPUPState CurrentEra) + +deriving via Enc (PPUPState CurrentEra) instance PersistFieldSql (PPUPState CurrentEra) + +deriving via Enc (TxOut CurrentEra) instance PersistField (TxOut CurrentEra) + +deriving via Enc (TxOut CurrentEra) instance PersistFieldSql (TxOut CurrentEra) + +deriving via Enc (DState C) instance PersistField (DState C) + +deriving via Enc (DState C) instance PersistFieldSql (DState C) + +deriving via Enc (PState C) instance PersistField (PState C) + +deriving via Enc (PState C) instance PersistFieldSql (PState C) + +deriving via Enc (GenDelegs C) instance PersistField (GenDelegs C) + +deriving via Enc (GenDelegs C) instance PersistFieldSql (GenDelegs C) + +deriving via Enc (PoolParams C) instance PersistField (PoolParams C) + +deriving via Enc (PoolParams C) instance PersistFieldSql (PoolParams C) + +deriving via Enc (NonMyopic C) instance PersistField (NonMyopic C) + +deriving via Enc (NonMyopic C) instance PersistFieldSql (NonMyopic C) + +deriving via Enc (PParams CurrentEra) instance PersistField (PParams CurrentEra) + +deriving via Enc (PParams CurrentEra) instance PersistFieldSql (PParams CurrentEra) diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs new file mode 100644 index 0000000000..572d4dc75d --- /dev/null +++ b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs @@ -0,0 +1,644 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Ledger.State.Query where + +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo +import qualified Cardano.Ledger.Credential as Credential +import qualified Cardano.Ledger.Keys as Keys +import qualified Cardano.Ledger.Shelley.EpochBoundary as EpochBoundary +import qualified Cardano.Ledger.Shelley.LedgerState as Shelley +import qualified Cardano.Ledger.Shelley.UTxO as Shelley +import Cardano.Ledger.State.Orphans +import Cardano.Ledger.State.Schema +import Cardano.Ledger.State.Transform +import Cardano.Ledger.State.UTxO +import qualified Cardano.Ledger.TxIn as TxIn +import Conduit +import Control.Foldl (Fold (..)) +import Control.Iterate.SetAlgebra +import Control.Monad +import Control.Monad.Trans.Reader +import qualified Data.Compact.KeyMap as KeyMap +import Data.Functor +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import Data.Text as T +import Database.Persist.Sqlite + +-- Populate database + +insertGetKey :: + ( MonadIO m, + PersistUniqueWrite backend, + PersistRecordBackend record backend, + AtLeastOneUniqueKey record + ) => + record -> + ReaderT backend m (Key record) +insertGetKey = fmap (either entityKey id) . insertBy + +insertUTxOState :: + MonadIO m => + Shelley.UTxOState CurrentEra -> + ReaderT SqlBackend m (Key UtxoState) +insertUTxOState Shelley.UTxOState {..} = do + insert $ + UtxoState + { utxoStateDeposited = _deposited, + utxoStateFees = _fees, + utxoStatePpups = _ppups + } + +insertUTxO :: + MonadIO m => + Shelley.UTxO CurrentEra -> + Key UtxoState -> + ReaderT SqlBackend m () +insertUTxO utxo stateKey = do + mapM_ insertTxOut $ Map.toList (Shelley.unUTxO utxo) + where + insertTxOut (TxIn.TxIn txId txIx, out) = do + txKey <- + insert $ Tx {txInIx = fromIntegral txIx, txInId = txId, txOut = out} + txsKey <- + case toTxOut' mempty out of + TxOutNoStake' out' -> do + insert $ + Txs + { txsInIx = fromIntegral txIx, + txsInId = txId, + txsOut = out', + txsStakeCredential = Nothing + } + TxOut' out' cred -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + insert $ + Txs + { txsInIx = fromIntegral txIx, + txsInId = txId, + txsOut = out', + txsStakeCredential = Just credId + } + insert_ $ + UtxoEntry + { utxoEntryTxId = txKey, + utxoEntryTxsId = txsKey, + utxoEntryStateId = stateKey + } + +insertDState :: MonadIO m => Shelley.DState C -> ReaderT SqlBackend m DStateId +insertDState Shelley.DState {..} = do + let irDeltaReserves = Shelley.deltaReserves _irwd + let irDeltaTreasury = Shelley.deltaTreasury _irwd + dstateId <- insert $ DState (Enc _fGenDelegs) _genDelegs irDeltaReserves irDeltaTreasury + forM_ (Map.toList _rewards) $ \(cred, c) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + insert_ (Reward dstateId credId c) + forM_ (Map.toList _delegations) $ \(cred, spKeyHash) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + keyHashId <- insertGetKey (KeyHash (Keys.asWitness spKeyHash)) + insert_ (Delegation dstateId credId keyHashId) + forM_ (Map.toList (biMapToMap _ptrs)) $ \(ptr, cred) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + insert_ (Ptr dstateId credId ptr) + forM_ (Map.toList (Shelley.iRReserves _irwd)) $ \(cred, c) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + insert_ (IRReserves dstateId credId c) + forM_ (Map.toList (Shelley.iRTreasury _irwd)) $ \(cred, c) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + insert_ (IRTreasury dstateId credId c) + pure dstateId + +insertLedgerState :: + MonadIO m => EpochStateId -> Shelley.LedgerState CurrentEra -> ReaderT SqlBackend m () +insertLedgerState epochStateKey Shelley.LedgerState {..} = do + stateKey <- insertUTxOState _utxoState + insertUTxO (Shelley._utxo _utxoState) stateKey + dstateKey <- insertDState $ Shelley._dstate _delegationState + insert_ + LedgerState + { ledgerStateUtxoId = stateKey, + ledgerStateDstateId = dstateKey, + ledgerStatePstateBin = Shelley._pstate _delegationState, + ledgerStateEpochStateId = epochStateKey + } + +insertSnapShot :: + MonadIO m => + Key EpochState -> + SnapShotType -> + EpochBoundary.SnapShot C -> + ReaderT SqlBackend m () +insertSnapShot snapShotEpochStateId snapShotType EpochBoundary.SnapShot {..} = do + snapShotId <- insert $ SnapShot {snapShotType, snapShotEpochStateId} + forM_ (Map.toList (EpochBoundary.unStake _stake)) $ \(cred, c) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + insert_ (SnapShotStake snapShotId credId c) + forM_ (Map.toList _delegations) $ \(cred, spKeyHash) -> do + credId <- insertGetKey (Credential (Keys.asWitness cred)) + keyHashId <- insertGetKey (KeyHash (Keys.asWitness spKeyHash)) + insert_ (SnapShotDelegation snapShotId credId keyHashId) + forM_ (Map.toList _poolParams) $ \(keyHash, pps) -> do + keyHashId <- insertGetKey (KeyHash (Keys.asWitness keyHash)) + insert_ (SnapShotPool snapShotId keyHashId pps) + +insertSnapShots :: + MonadIO m => + Key EpochState -> + EpochBoundary.SnapShots C -> + ReaderT SqlBackend m () +insertSnapShots epochStateKey EpochBoundary.SnapShots {..} = do + mapM_ + (uncurry (insertSnapShot epochStateKey)) + [ (SnapShotMark, _pstakeMark), + (SnapShotSet, _pstakeSet), + (SnapShotGo, _pstakeGo) + ] + +insertEpochState :: + MonadIO m => Shelley.EpochState CurrentEra -> ReaderT SqlBackend m () +insertEpochState Shelley.EpochState {..} = do + epochStateKey <- + insert + EpochState + { epochStateTreasury = Shelley._treasury esAccountState, + epochStateReserves = Shelley._reserves esAccountState, + epochStatePrevPp = esPrevPp, + epochStatePp = esPp, + epochStateNonMyopic = esNonMyopic, + epochStateSnapShotsFee = EpochBoundary._feeSS esSnapshots + } + insertSnapShots epochStateKey esSnapshots + insertLedgerState epochStateKey esLState + +-- Query database + +selectMap :: + ( MonadResource m, + Ord k, + PersistEntity record, + PersistEntityBackend record ~ SqlBackend + ) => + [Filter record] -> + (record -> ReaderT SqlBackend m (k, a)) -> + ReaderT SqlBackend m (Map.Map k a) +selectMap fs f = + runConduit $ + selectSource fs [] .| mapMC (\(Entity _ a) -> f a) + .| foldlC (\m (k, v) -> Map.insert k v m) mempty + +getSnapShotNoSharing :: + MonadResource m => + Key EpochState -> + SnapShotType -> + ReaderT SqlBackend m (EpochBoundary.SnapShot C) +getSnapShotNoSharing epochStateId snapShotType = do + snapShotId <- + selectFirst + [SnapShotType ==. snapShotType, SnapShotEpochStateId ==. epochStateId] + [] + <&> \case + Nothing -> error $ "Missing a snapshot: " ++ show snapShotType + Just (Entity snapShotId _) -> snapShotId + stake <- + selectMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do + Credential credential <- getJust snapShotStakeCredentialId + pure (Keys.coerceKeyRole credential, snapShotStakeCoin) + delegations <- + selectMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do + Credential credential <- getJust snapShotDelegationCredentialId + KeyHash keyHash <- getJust snapShotDelegationKeyHash + --TODO ^ rename snapShotDelegationKeyHashId + pure (Keys.coerceKeyRole credential, Keys.coerceKeyRole keyHash) + poolParams <- + selectMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do + KeyHash keyHash <- getJust snapShotPoolKeyHashId + pure (Keys.coerceKeyRole keyHash, snapShotPoolParams) + pure + EpochBoundary.SnapShot + { _stake = EpochBoundary.Stake stake, + _delegations = delegations, + _poolParams = poolParams + } + +getSnapShotsNoSharing :: + MonadResource m => + Entity EpochState -> + ReaderT SqlBackend m (EpochBoundary.SnapShots C) +getSnapShotsNoSharing (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do + mark <- getSnapShotNoSharing epochStateId SnapShotMark + set <- getSnapShotNoSharing epochStateId SnapShotSet + go <- getSnapShotNoSharing epochStateId SnapShotGo + pure $ + EpochBoundary.SnapShots + { _pstakeMark = mark, + _pstakeSet = set, + _pstakeGo = go, + _feeSS = epochStateSnapShotsFee + } + +getSnapShotWithSharing :: + MonadResource m => + [EpochBoundary.SnapShot C] -> + Key EpochState -> + SnapShotType -> + ReaderT SqlBackend m (EpochBoundary.SnapShot C) +getSnapShotWithSharing otherSnapShots epochStateId snapShotType = do + let otherStakes = + EpochBoundary.unStake . EpochBoundary._stake <$> otherSnapShots + let otherPoolParams = EpochBoundary._poolParams <$> otherSnapShots + let otherDelegations = EpochBoundary._delegations <$> otherSnapShots + snapShotId <- + selectFirst + [SnapShotType ==. snapShotType, SnapShotEpochStateId ==. epochStateId] + [] + <&> \case + Nothing -> error $ "Missing a snapshot: " ++ show snapShotType + Just (Entity snapShotId _) -> snapShotId + stake <- + selectMap [SnapShotStakeSnapShotId ==. snapShotId] $ \SnapShotStake {..} -> do + Credential credential <- getJust snapShotStakeCredentialId + pure + (interns (Keys.coerceKeyRole credential) otherStakes, snapShotStakeCoin) + poolParams <- + selectMap [SnapShotPoolSnapShotId ==. snapShotId] $ \SnapShotPool {..} -> do + KeyHash keyHash <- getJust snapShotPoolKeyHashId + pure + ( interns (Keys.coerceKeyRole keyHash) otherPoolParams, + snapShotPoolParams + ) + delegations <- + selectMap [SnapShotDelegationSnapShotId ==. snapShotId] $ \SnapShotDelegation {..} -> do + Credential credential <- getJust snapShotDelegationCredentialId + KeyHash keyHash <- getJust snapShotDelegationKeyHash + pure + ( interns (Keys.coerceKeyRole credential) otherDelegations, + intern (Keys.coerceKeyRole keyHash) poolParams + ) + pure + EpochBoundary.SnapShot + { _stake = EpochBoundary.Stake stake, + _delegations = delegations, + _poolParams = poolParams + } + +getSnapShotsWithSharing :: + MonadResource m => + Entity EpochState -> + ReaderT SqlBackend m (EpochBoundary.SnapShots C) +getSnapShotsWithSharing (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do + mark <- getSnapShotWithSharing [] epochStateId SnapShotMark + set <- getSnapShotWithSharing [mark] epochStateId SnapShotSet + go <- getSnapShotWithSharing [mark, set] epochStateId SnapShotGo + pure $ + EpochBoundary.SnapShots + { _pstakeMark = mark, + _pstakeSet = set, + _pstakeGo = go, + _feeSS = epochStateSnapShotsFee + } + +sourceUTxO :: + MonadResource m => + ConduitM () (TxIn.TxIn C, Alonzo.TxOut CurrentEra) (ReaderT SqlBackend m) () +sourceUTxO = + selectSource [] [] + .| mapC (\(Entity _ Tx {..}) -> (TxIn.TxIn txInId (fromIntegral txInIx), txOut)) + +sourceUTxOs :: + MonadResource m => + Map.Map (Credential.StakeCredential C) a -> + ConduitM () (TxIn.TxIn C, TxOut') (ReaderT SqlBackend m) () +sourceUTxOs stakeCredentials = + selectSource [] [] + .| mapMC + ( \(Entity _ Txs {..}) -> do + let txi = TxIn.TxIn txsInId (fromIntegral txsInIx) + case txsStakeCredential of + Nothing -> pure (txi, TxOutNoStake' txsOut) + Just credId -> do + Credential credential <- getJust credId + let !sharedCredential = intern (Keys.coerceKeyRole credential) stakeCredentials + pure (txi, TxOut' txsOut sharedCredential) + ) + +foldDbUTxO :: + MonadUnliftIO m => + -- | Folding function + (a -> (TxIn.TxIn C, Alonzo.TxOut CurrentEra) -> a) -> + -- | Empty acc + a -> + -- | Path to Sqlite db + Text -> + m a +foldDbUTxO f m fp = runSqlite fp (runConduit (sourceUTxO .| foldlC f m)) + +-- sourceUTxOr :: +-- MonadResource m +-- => Int64 -> Int64 -> ConduitM () (TxIn.TxIn C, Alonzo.TxOut CurrentEra) (ReaderT SqlBackend m) () +-- sourceUTxOr b t = +-- selectSource [TxId >. TxKey (SqlBackendKey b) , TxId <. TxKey (SqlBackendKey t)] [] .| +-- mapC (\(Entity _ Tx {..}) -> (TxIn.TxIn txInId (fromIntegral txInIx), txOut)) + +-- foldDbUTxOr :: +-- MonadUnliftIO m +-- => Int64 +-- -> Int64 +-- -> (a -> (TxIn.TxIn C, Alonzo.TxOut CurrentEra) -> a) -- ^ Folding function +-- -> a -- ^ Empty acc +-- -> Text -- ^ Path to Sqlite db +-- -> m a +-- foldDbUTxOr b t f m fp = runSqlite fp (runConduit (sourceUTxOr b t .| foldlC f m)) + +lsId :: Key LedgerState +lsId = LedgerStateKey (SqlBackendKey 1) + +getLedgerState :: + MonadIO m => + Shelley.UTxO CurrentEra -> + LedgerState -> + Shelley.DState C -> + ReaderT SqlBackend m (Shelley.LedgerState CurrentEra) +getLedgerState utxo LedgerState {..} dstate = do + UtxoState {..} <- getJust ledgerStateUtxoId + pure + Shelley.LedgerState + { Shelley._utxoState = + Shelley.UTxOState + { Shelley._utxo = utxo, + Shelley._deposited = utxoStateDeposited, + Shelley._fees = utxoStateFees, + Shelley._ppups = utxoStatePpups + }, + Shelley._delegationState = + Shelley.DPState + { Shelley._dstate = dstate, + Shelley._pstate = ledgerStatePstateBin + } + } + +getDStateNoSharing :: + MonadIO m => Key DState -> ReaderT SqlBackend m (Shelley.DState C) +getDStateNoSharing dstateId = do + DState {..} <- getJust dstateId + rewards <- + Map.fromList <$> do + rws <- selectList [RewardDstateId ==. dstateId] [] + forM rws $ \(Entity _ Reward {..}) -> do + Credential credential <- getJust rewardCredentialId + pure (Keys.coerceKeyRole credential, rewardCoin) + delegations <- + Map.fromList <$> do + ds <- selectList [DelegationDstateId ==. dstateId] [] + forM ds $ \(Entity _ Delegation {..}) -> do + Credential credential <- getJust delegationCredentialId + KeyHash keyHash <- getJust delegationStakePoolId + pure (Keys.coerceKeyRole credential, Keys.coerceKeyRole keyHash) + ptrs <- + biMapFromList const <$> do + ps <- selectList [PtrDstateId ==. dstateId] [] + forM ps $ \(Entity _ Ptr {..}) -> do + Credential credential <- getJust ptrCredentialId + pure (ptrPtr, Keys.coerceKeyRole credential) + iRReserves <- + Map.fromList <$> do + ds <- selectList [IRReservesDstateId ==. dstateId] [] + forM ds $ \(Entity _ IRReserves {..}) -> do + Credential credential <- getJust iRReservesCredentialId + pure (Keys.coerceKeyRole credential, iRReservesCoin) + iRTreasury <- + Map.fromList <$> do + ds <- selectList [IRTreasuryDstateId ==. dstateId] [] + forM ds $ \(Entity _ IRTreasury {..}) -> do + Credential credential <- getJust iRTreasuryCredentialId + pure (Keys.coerceKeyRole credential, iRTreasuryCoin) + pure + Shelley.DState + { _rewards = rewards, + _delegations = delegations, + _ptrs = ptrs, + _fGenDelegs = unEnc dStateFGenDelegs, + _genDelegs = dStateGenDelegs, + _irwd = + Shelley.InstantaneousRewards + { iRReserves = iRReserves, + iRTreasury = iRTreasury, + deltaReserves = dStateIrDeltaReserves, + deltaTreasury = dStateIrDeltaTreasury + } + } + +getDStateWithSharing :: + MonadIO m => Key DState -> ReaderT SqlBackend m (Shelley.DState C) +getDStateWithSharing dstateId = do + DState {..} <- getJust dstateId + rewards <- + Map.fromList <$> do + rws <- selectList [RewardDstateId ==. dstateId] [] + forM rws $ \(Entity _ Reward {..}) -> do + Credential credential <- getJust rewardCredentialId + pure (Keys.coerceKeyRole credential, rewardCoin) + delegations <- + Map.fromList <$> do + ds <- selectList [DelegationDstateId ==. dstateId] [] + forM ds $ \(Entity _ Delegation {..}) -> do + Credential credential <- getJust delegationCredentialId + let !cred = intern (Keys.coerceKeyRole credential) rewards + KeyHash keyHash <- getJust delegationStakePoolId + pure (cred, Keys.coerceKeyRole keyHash) + ptrs <- + biMapFromList const <$> do + ps <- selectList [PtrDstateId ==. dstateId] [] + forM ps $ \(Entity _ Ptr {..}) -> do + Credential credential <- getJust ptrCredentialId + let !cred = intern (Keys.coerceKeyRole credential) rewards + pure (ptrPtr, cred) + iRReserves <- + Map.fromList <$> do + ds <- selectList [IRReservesDstateId ==. dstateId] [] + forM ds $ \(Entity _ IRReserves {..}) -> do + Credential credential <- getJust iRReservesCredentialId + let !cred = intern (Keys.coerceKeyRole credential) rewards + pure (cred, iRReservesCoin) + iRTreasury <- + Map.fromList <$> do + ds <- selectList [IRTreasuryDstateId ==. dstateId] [] + forM ds $ \(Entity _ IRTreasury {..}) -> do + Credential credential <- getJust iRTreasuryCredentialId + let !cred = intern (Keys.coerceKeyRole credential) rewards + pure (cred, iRTreasuryCoin) + pure + Shelley.DState + { _rewards = rewards, + _delegations = delegations, + _ptrs = ptrs, + _fGenDelegs = unEnc dStateFGenDelegs, + _genDelegs = dStateGenDelegs, + _irwd = + Shelley.InstantaneousRewards + { iRReserves = iRReserves, + iRTreasury = iRTreasury, + deltaReserves = dStateIrDeltaReserves, + deltaTreasury = dStateIrDeltaTreasury + } + } + +loadDStateNoSharing :: MonadUnliftIO m => Text -> m (Shelley.DState C) +loadDStateNoSharing fp = + runSqlite fp $ getDStateNoSharing (DStateKey (SqlBackendKey 1)) + +loadUTxONoSharing :: + MonadUnliftIO m => Text -> m (Shelley.UTxO CurrentEra) +loadUTxONoSharing fp = + runSqlite fp (Shelley.UTxO <$> runConduitFold sourceUTxO noSharing) + +getLedgerStateNoSharing :: + MonadUnliftIO m => Text -> m (Shelley.LedgerState CurrentEra) +getLedgerStateNoSharing fp = + runSqlite fp $ do + ledgerState@LedgerState {..} <- getJust lsId + dstate <- getDStateNoSharing ledgerStateDstateId + m <- runConduitFold sourceUTxO noSharing + getLedgerState (Shelley.UTxO m) ledgerState dstate + +getLedgerStateDStateSharing :: + MonadUnliftIO m => Text -> m (Shelley.LedgerState CurrentEra) +getLedgerStateDStateSharing fp = + runSqlite fp $ do + ledgerState@LedgerState {..} <- getJust lsId + dstate <- getDStateWithSharing ledgerStateDstateId + m <- runConduitFold sourceUTxO noSharing + getLedgerState (Shelley.UTxO m) ledgerState dstate + +getLedgerStateDStateTxIxSharing :: + MonadUnliftIO m => + Text -> + m + ( Shelley.LedgerState CurrentEra, + IntMap.IntMap (Map.Map (TxIn.TxId C) (Alonzo.TxOut CurrentEra)) + ) +getLedgerStateDStateTxIxSharing fp = + runSqlite fp $ do + ledgerState@LedgerState {..} <- getJust lsId + dstate <- getDStateWithSharing ledgerStateDstateId + ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate + m <- runConduitFold sourceUTxO txIxSharing + pure (ls, m) + +getLedgerStateDStateTxIxSharingKeyMap :: + MonadUnliftIO m => + Text -> + m + ( Shelley.LedgerState CurrentEra, + IntMap.IntMap (KeyMap.KeyMap (Alonzo.TxOut CurrentEra)) + ) +getLedgerStateDStateTxIxSharingKeyMap fp = + runSqlite fp $ do + ledgerState@LedgerState {..} <- getJust lsId + dstate <- getDStateWithSharing ledgerStateDstateId + m <- runConduitFold sourceUTxO txIxSharingKeyMap + ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate + pure (ls, m) + +getLedgerStateDStateTxIdSharingKeyMap :: + MonadUnliftIO m => + Text -> + m + ( Shelley.LedgerState CurrentEra, + KeyMap.KeyMap (IntMap.IntMap (Alonzo.TxOut CurrentEra)) + ) +getLedgerStateDStateTxIdSharingKeyMap fp = + runSqlite fp $ do + ledgerState@LedgerState {..} <- getJust lsId + dstate <- getDStateWithSharing ledgerStateDstateId + m <- runConduitFold sourceUTxO txIdSharingKeyMap + ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate + pure (ls, m) + +-- storeLedgerState :: +-- MonadUnliftIO m => Text -> Shelley.LedgerState CurrentEra -> m () +-- storeLedgerState fp ls = +-- runSqlite fp $ do +-- runMigration migrateAll +-- insertLedgerState ls + +storeEpochState :: + MonadUnliftIO m => Text -> Shelley.EpochState CurrentEra -> m () +storeEpochState fp es = + runSqlite fp $ do + runMigration migrateAll + insertEpochState es + +loadDbUTxO :: UTxOFold a -> Text -> IO a +loadDbUTxO (Fold f e g) fp = runSqlite fp (g <$> runConduit (sourceUTxO .| foldlC f e)) + +esId :: Key EpochState +esId = EpochStateKey (SqlBackendKey 1) + +loadEpochStateEntity :: MonadUnliftIO m => Text -> m (Entity EpochState) +loadEpochStateEntity fp = runSqlite fp (getJustEntity esId) + +loadSnapShotsNoSharing :: + MonadUnliftIO m => Text -> Entity EpochState -> m (EpochBoundary.SnapShots C) +loadSnapShotsNoSharing fp = runSqlite fp . getSnapShotsNoSharing + +loadSnapShotsWithSharing :: + MonadUnliftIO m => Text -> Entity EpochState -> m (EpochBoundary.SnapShots C) +loadSnapShotsWithSharing fp = runSqlite fp . getSnapShotsWithSharing + +-- getLedgerStateWithSharing :: +-- MonadUnliftIO m +-- => Text +-- -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (Map.Map (TxIn.TxId C) TxOut')) +-- getLedgerStateWithSharing fp = +-- runSqlite fp $ do +-- ledgerState@LedgerState {..} <- getJust lsId +-- dstate <- getDStateWithSharing ledgerStateDstateId +-- let stakeCredentials = Shelley._rewards dstate +-- ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate +-- m <- runConduitFold (sourceUTxOs stakeCredentials) txIxSharing +-- pure (ls, m) + +-- getLedgerStateDStateTxOutSharing :: +-- MonadUnliftIO m +-- => Text +-- -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut') +-- getLedgerStateDStateTxOutSharing fp = +-- runSqlite fp $ do +-- ledgerState@LedgerState {..} <- getJust lsId +-- dstate <- getDStateWithSharing ledgerStateDstateId +-- let stakeCredentials = Shelley._rewards dstate +-- ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate +-- m <- runConduitFold (sourceUTxOs stakeCredentials) noSharing +-- pure (ls, m) + +-- getLedgerStateTxOutSharing :: +-- MonadUnliftIO m +-- => Text +-- -> m (Shelley.LedgerState CurrentEra, Map.Map (TxIn.TxIn C) TxOut') +-- getLedgerStateTxOutSharing fp = +-- runSqlite fp $ do +-- ledgerState@LedgerState {..} <- getJust lsId +-- dstate <- getDStateNoSharing ledgerStateDstateId +-- let stakeCredentials = Shelley._rewards dstate +-- ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate +-- m <- runConduitFold (sourceUTxOs stakeCredentials) noSharing +-- pure (ls, m) + +-- getLedgerStateWithSharingKeyMap :: +-- MonadUnliftIO m +-- => Text +-- -> m (Shelley.LedgerState CurrentEra, IntMap.IntMap (KeyMap.KeyMap TxOut')) +-- getLedgerStateWithSharingKeyMap fp = +-- runSqlite fp $ do +-- ledgerState@LedgerState {..} <- getJust lsId +-- dstate <- getDStateWithSharing ledgerStateDstateId +-- let stakeCredentials = Shelley._rewards dstate +-- ls <- getLedgerState (Shelley.UTxO mempty) ledgerState dstate +-- m <- runConduitFold (sourceUTxOs stakeCredentials) txIxSharingKeyMap +-- pure (ls, m) diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs new file mode 100644 index 0000000000..834bd1bed1 --- /dev/null +++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Ledger.State.Schema where + +import qualified Cardano.Ledger.Alonzo.PParams as Alonzo +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo +import Cardano.Ledger.Coin +import qualified Cardano.Ledger.Credential as Credential +import qualified Cardano.Ledger.Keys as Keys +import qualified Cardano.Ledger.Shelley.LedgerState as Shelley +import qualified Cardano.Ledger.Shelley.Rewards as Shelley +import qualified Cardano.Ledger.Shelley.TxBody as Shelley +import Cardano.Ledger.State.Orphans (Enc, SnapShotType (..)) +import Cardano.Ledger.State.UTxO +import qualified Cardano.Ledger.TxIn as TxIn +import qualified Data.Map.Strict as Map +import Data.Word +import Database.Persist.Sqlite +import Database.Persist.TH + +type FGenDelegs = (Enc (Map.Map (Shelley.FutureGenDeleg C) (Keys.GenDelegPair C))) + +type CredentialWitness = Credential.Credential 'Keys.Witness C + +type KeyHashWitness = Keys.KeyHash 'Keys.Witness C + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| +EpochState + treasury Coin + reserves Coin + prevPp (Alonzo.PParams CurrentEra) + pp (Alonzo.PParams CurrentEra) + nonMyopic (Shelley.NonMyopic C) + snapShotsFee Coin + +SnapShot + type SnapShotType + epochStateId EpochStateId + -- UniqueSnapShot type epochStateId +SnapShotStake + snapShotId SnapShotId + credentialId CredentialId + coin Coin + UniqueSnapShotStake snapShotId credentialId +SnapShotDelegation + snapShotId SnapShotId + credentialId CredentialId + keyHash KeyHashId + UniqueSnapShotDelegation snapShotId credentialId +SnapShotPool + snapShotId SnapShotId + keyHashId KeyHashId + params (Shelley.PoolParams C) + UniqueSnapShotPool snapShotId keyHashId + +LedgerState + utxoId UtxoStateId + dstateId DStateId + epochStateId EpochStateId + pstateBin (Shelley.PState C) +UtxoState + deposited Coin + fees Coin + ppups (Shelley.PPUPState CurrentEra) +DState + fGenDelegs FGenDelegs + genDelegs (Keys.GenDelegs C) + irDeltaReserves DeltaCoin + irDeltaTreasury DeltaCoin + +Credential + witness CredentialWitness + UniqueCredential witness +KeyHash + witness KeyHashWitness + UniqueKeyHash witness +Tx + inIx Word64 + inId (TxIn.TxId C) + out (Alonzo.TxOut CurrentEra) + UniqueTx inIx inId +Txs + inIx Word64 + inId (TxIn.TxId C) + out (Alonzo.TxOut CurrentEra) + stakeCredential CredentialId Maybe + UniqueTxs inIx inId +UtxoEntry + txId TxId + txsId TxsId + stateId UtxoStateId +Reward + dstateId DStateId + credentialId CredentialId + coin Coin + UniqueReward dstateId credentialId coin +Delegation + dstateId DStateId + credentialId CredentialId + stakePoolId KeyHashId + UniqueDelegation dstateId credentialId +Ptr + dstateId DStateId + credentialId CredentialId + ptr Credential.Ptr + UniquePtrPtr dstateId ptr + UniquePtrCredential dstateId credentialId +IRReserves + dstateId DStateId + credentialId CredentialId + coin Coin + UniqueIRReserves dstateId credentialId +IRTreasury + dstateId DStateId + credentialId CredentialId + coin Coin + UniqueIRTreasury dstateId credentialId +|] diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Transform.hs b/libs/ledger-state/src/Cardano/Ledger/State/Transform.hs new file mode 100644 index 0000000000..fe6fb25f3d --- /dev/null +++ b/libs/ledger-state/src/Cardano/Ledger/State/Transform.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns #-} + +module Cardano.Ledger.State.Transform where + +import Cardano.Ledger.Address +import Cardano.Ledger.Alonzo.TxBody as Alonzo +import Cardano.Ledger.Credential +import Cardano.Ledger.Shelley.CompactAddr +import Cardano.Ledger.State.UTxO +import Control.DeepSeq +import Data.Map.Strict.Internal + +-- data Addr' +-- = AddrKeyIx' !Network !Ix1 !StakeIx +-- | AddrKeyHash' !Network !(Keys.KeyHash 'Shelley.Payment C) !StakeIx +-- | AddrScript' !Network !(Shelley.ScriptHash C) !StakeIx +-- | AddrBoot' !(CompactAddr C) + +-- data TxOut' +-- = TxOut' !Addr' !Word64 +-- | TxOutMA' !Addr' !Word64 !Word32 !ShortByteString +-- | TxOutDH' !Addr' !Word64 !(DataHash C) +-- | TxOutMADH' !Addr' !Word64 !Word32 !ShortByteString !(DataHash C) + +data TxOut' + = TxOut' !(Alonzo.TxOut CurrentEra) !(StakeCredential C) + | TxOutNoStake' !(Alonzo.TxOut CurrentEra) + +instance NFData TxOut' where + rnf (TxOut' _ _) = () + rnf (TxOutNoStake' _) = () + +-- transTxOut :: TxOut CurrentEra -> TxOut' CurrentEra +-- transTxOut = \case + +toTxOut' :: Map (StakeCredential C) a -> Alonzo.TxOut CurrentEra -> TxOut' +toTxOut' m txOut = + case txOut of + Alonzo.TxOutCompact cAddr cVal + | Just (cAddr', sr) <- restructureAddr cAddr -> + TxOut' (Alonzo.TxOutCompact cAddr' cVal) sr + Alonzo.TxOutCompactDH cAddr cVal dh + | Just (cAddr', sr) <- restructureAddr cAddr -> + TxOut' (Alonzo.TxOutCompactDH cAddr' cVal dh) sr + _ -> TxOutNoStake' txOut + where + restructureAddr cAddr = + case decompactAddr cAddr of + Addr ni pc (StakeRefBase sr) -> + Just (compactAddr (Addr ni pc StakeRefNull), intern sr m) + _ -> Nothing + +-- intern' :: (Show k, Ord k) => k -> Map k a -> k +-- intern' k m = +-- case Map.lookupIndex k m of +-- Nothing -> k +-- Just ix -> fst $ Map.elemAt ix m + +intern :: Ord k => k -> Map k a -> k +intern !k m = + case internMaybe k m of + Just kx -> kx + Nothing -> k + +interns :: Ord k => k -> [Map k a] -> k +interns !k = go + where + go [] = k + go (m : ms) = + case internMaybe k m of + Just kx -> kx + Nothing -> go ms + +internMaybe :: Ord k => k -> Map k a -> Maybe k +internMaybe !k = go + where + go Tip = Nothing + go (Bin _ kx _ l r) = + case compare k kx of + LT -> go l + GT -> go r + EQ -> Just kx + +internVal :: (Eq a, Ord k) => k -> a -> Map k a -> a +internVal !k !a m = + case internValMaybe k a m of + Just ax -> ax + Nothing -> a + +internsVal :: (Eq a, Ord k) => k -> a -> [Map k a] -> a +internsVal !k !a = go + where + go [] = a + go (m : ms) = + case internValMaybe k a m of + Just ax -> ax + Nothing -> go ms + +internValMaybe :: (Eq a, Ord k) => k -> a -> Map k a -> Maybe a +internValMaybe !k !a = go + where + go Tip = Nothing + go (Bin _ kx ax l r) = + case compare k kx of + LT -> go l + GT -> go r + EQ + | a == ax -> Just ax + | otherwise -> Nothing diff --git a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs new file mode 100644 index 0000000000..106f661594 --- /dev/null +++ b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs @@ -0,0 +1,839 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans -funbox-strict-fields #-} + +module Cardano.Ledger.State.UTxO where + +import Cardano.Binary (FromCBOR (..)) +import Cardano.Ledger.Address +import Cardano.Ledger.Alonzo +import Cardano.Ledger.Alonzo.Data hiding (scripts) +import Cardano.Ledger.Alonzo.TxBody as Alonzo +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Credential +import Cardano.Ledger.Crypto +import Cardano.Ledger.Mary.Value +import qualified Cardano.Ledger.Mary.Value as Mary +import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rewards +import Cardano.Protocol.TPraos (individualPoolStakeVrf) +import Codec.CBOR.Read (deserialiseFromBytes) +import Conduit +import Control.Exception (throwIO) +import Control.Foldl (Fold (..)) +import Control.Iterate.SetAlgebra (range) +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Compact.KeyMap as KeyMap hiding (Stat) +import qualified Data.Conduit.List as C +import Data.Foldable as F +import Data.Functor +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import Data.Proxy +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Read as T +import Data.Typeable +import Numeric.Natural +import Prettyprinter +import Text.Printf + +type C = StandardCrypto + +type CurrentEra = AlonzoEra C + +--- Loading + +loadNewEpochState :: FilePath -> IO (NewEpochState CurrentEra) +loadNewEpochState fp = + LBS.readFile fp <&> deserialiseFromBytes fromCBOR >>= \case + Left exc -> throwIO exc + Right (extra, newEpochState) -> do + unless (LBS.null extra) $ + putStrLn $ + "Unexpected leftover: " + <> case LBS.splitAt 50 extra of + (_, "") -> show extra + (extraCut, _) -> show (extraCut <> "...") + pure newEpochState + +loadLedgerState :: FilePath -> IO (LedgerState CurrentEra) +loadLedgerState fp = esLState . nesEs <$> loadNewEpochState fp + +runConduitFold :: Monad m => ConduitT () a m () -> Fold a b -> m b +runConduitFold source (Fold f e g) = (g <$> runConduit (source .| foldlC f e)) + +type UTxOFold b = Fold (TxIn C, Alonzo.TxOut CurrentEra) b + +noSharing :: Fold (TxIn C, a) (Map.Map (TxIn C) a) +noSharing = Fold (\ !m !(!k, !v) -> Map.insert k v m) mempty id + +noSharing_ :: UTxOFold (Map.Map (TxIn C) ()) +noSharing_ = Fold (\ !m !(!k, _) -> Map.insert k () m) mempty id + +txIdSharing :: + UTxOFold (Map.Map (TxId C) (IntMap.IntMap (Alonzo.TxOut CurrentEra))) +txIdSharing = Fold txIdNestedInsert mempty id + +txIdSharing_ :: UTxOFold (Map.Map (TxId C) (IntMap.IntMap ())) +txIdSharing_ = Fold (\a v -> txIdNestedInsert a (() <$ v)) mempty id + +txIdNestedInsert :: + Map.Map (TxId C) (IntMap.IntMap a) -> + (TxIn C, a) -> + Map.Map (TxId C) (IntMap.IntMap a) +txIdNestedInsert !m (TxIn !txId !txIx, !v) = + let !e = IntMap.singleton (fromIntegral txIx) v + in Map.insertWith (<>) txId e m + +txIxSharing :: Fold (TxIn C, a) (IntMap.IntMap (Map.Map (TxId C) a)) +txIxSharing = Fold txIxNestedInsert mempty id + +txIxSharing_ :: UTxOFold (IntMap.IntMap (Map.Map (TxId C) ())) +txIxSharing_ = Fold (\a v -> txIxNestedInsert a (() <$ v)) mempty id + +txIxNestedInsert :: + IntMap.IntMap (Map.Map (TxId C) a) -> + (TxIn C, a) -> + IntMap.IntMap (Map.Map (TxId C) a) +txIxNestedInsert !im (TxIn !txId !txIx, !v) = + let f = + \case + Nothing -> Just $! Map.singleton txId v + Just !m -> Just $! Map.insert txId v m + in IntMap.alter f (fromIntegral txIx) im + +txIxSharingKeyMap :: Fold (TxIn C, a) (IntMap.IntMap (KeyMap.KeyMap a)) +txIxSharingKeyMap = Fold txIxNestedInsertKeyMap mempty id + +txIxSharingKeyMap_ :: UTxOFold (IntMap.IntMap (KeyMap.KeyMap ())) +txIxSharingKeyMap_ = + Fold ((\m (k, _) -> txIxNestedInsertKeyMap m (k, ()))) mempty id + +txIxNestedInsertKeyMap :: + IntMap.IntMap (KeyMap.KeyMap a) -> + (TxIn C, a) -> + IntMap.IntMap (KeyMap.KeyMap a) +txIxNestedInsertKeyMap !m (TxInCompact32 x1 x2 x3 x4 txIx, !v) = + let !key = KeyMap.Key x1 x2 x3 x4 + f = + \case + Nothing -> Just $! KeyMap.Leaf key v + Just hm -> Just $! KeyMap.insert key v hm + in IntMap.alter f (fromIntegral txIx) m +txIxNestedInsertKeyMap _ _ = error "Impossible" + +txIdSharingKeyMap :: Fold (TxIn C, a) (KeyMap.KeyMap (IntMap.IntMap a)) +txIdSharingKeyMap = Fold txIdNestedInsertKeyMap KeyMap.Empty id + +txIdSharingKeyMap_ :: UTxOFold (KeyMap.KeyMap (IntMap.IntMap ())) +txIdSharingKeyMap_ = Fold (\a (k, _) -> txIdNestedInsertKeyMap a (k, ())) KeyMap.Empty id + +txIdNestedInsertKeyMap :: + KeyMap.KeyMap (IntMap.IntMap a) -> + (TxIn C, a) -> + KeyMap.KeyMap (IntMap.IntMap a) +txIdNestedInsertKeyMap !m (TxInCompact32 x1 x2 x3 x4 txIx, !a) = + let !key = KeyMap.Key x1 x2 x3 x4 + !v = IntMap.singleton (fromIntegral txIx) a + in KeyMap.insertWith (<>) key v m +txIdNestedInsertKeyMap _ _ = error "Impossible" + +testKeyMap :: + KeyMap.KeyMap (IntMap.IntMap (Alonzo.TxOut CurrentEra)) -> + Map.Map (TxIn C) (Alonzo.TxOut CurrentEra) -> + IO () +testKeyMap km m = + case Map.foldlWithKey' test km m of + KeyMap.Empty -> putStrLn "Tested UTxO equality: Pass" + _ -> error "Expected the KeyMap to be empty, but it's not." + where + test :: + KeyMap.KeyMap (IntMap.IntMap (Alonzo.TxOut CurrentEra)) -> + TxIn C -> + Alonzo.TxOut CurrentEra -> + KeyMap.KeyMap (IntMap.IntMap (Alonzo.TxOut CurrentEra)) + test acc txIn@(TxInCompact32 x1 x2 x3 x4 txIx) txOut = + let !key = KeyMap.Key x1 x2 x3 x4 + in case KeyMap.lookupHM key acc of + Nothing -> error $ "Can't find txId: " <> show txIn + Just im -> + let txIx' = fromIntegral txIx + im' = IntMap.delete txIx' im + in case IntMap.lookup txIx' im of + Nothing -> error $ "Can't find txIx: " <> show txIn + Just txOut' + | txOut /= txOut' -> + error $ "Found mismatching TxOuts for " <> show txIn + | IntMap.null im' -> KeyMap.delete key acc + | otherwise -> KeyMap.insert key im' acc + test _ _ _ = error "Impossible" + +totalADA :: Map.Map (TxIn C) (Alonzo.TxOut CurrentEra) -> Mary.Value C +totalADA = foldMap (\(Alonzo.TxOut _ v _) -> v) + +loadBinUTxO :: FilePath -> IO (UTxO CurrentEra) +loadBinUTxO fp = do + ls <- loadNewEpochState fp + pure $! _utxo $ _utxoState $ esLState $ nesEs ls + +newtype Count = Count Int + deriving (Eq, Ord, Enum, Real, Integral, Num, Pretty) + +data Stat k = Stat + { statUnique :: !(Set.Set k), + statCount :: !Count + } + +instance Ord k => Semigroup (Stat k) where + (<>) s1 s2 = Stat (statUnique s1 <> statUnique s2) (statCount s1 + statCount s2) + +instance Ord k => Monoid (Stat k) where + mempty = Stat mempty 0 + +instance Pretty (Stat k) where + pretty Stat {..} = + pretty n + <+> "/" + <+> pretty statCount + <+> "(" <> pretty (intPercent n statCount) <> " unique)" + where + n = Set.size statUnique + +data Percent = Percent Int Int + +instance Pretty Percent where + pretty (Percent x y) = pretty (printf "%d.%02d%%" x y :: String) + +intPercent :: Integral i => Int -> i -> Percent +intPercent x y + | y == 0 = Percent 0 0 + | otherwise = uncurry Percent (((10000 * x) `div` fromIntegral y) `quotRem` 100) + +statSingleton :: a -> Stat a +statSingleton a = Stat (Set.singleton a) 1 + +statSet :: Set.Set a -> Stat a +statSet s = Stat s (Count (Set.size s)) + +statMapKeys :: Map.Map k v -> Stat k +statMapKeys = statSet . Map.keysSet + +statFoldable :: (Ord a, Foldable t) => t a -> Stat a +statFoldable m = Stat (Set.fromList (F.toList m)) (Count (F.length m)) + +prettyRecord :: Doc ann -> [Doc ann] -> Doc ann +prettyRecord h content = h <> ":" <+> line <> indent 2 (vsep content) + +(<:>) :: (Typeable a, Pretty a) => Doc ann -> a -> Doc ann +(<:>) x y = + "[" <> x <> "]:" <+> pretty y <+> "<" <> pretty (showsTypeRep (typeOf y) ">") + +infixr 6 <:> + +data SnapShotStats = SnapShotStats + { sssStake :: !(Stat (Credential 'Staking C)), + sssDelegationCredential :: !(Stat (Credential 'Staking C)), + sssDelegationStakePool :: !(Stat (KeyHash 'StakePool C)), + sssPoolParams :: !(Stat (KeyHash 'StakePool C)), + sssPoolParamsStats :: !PoolParamsStats + } + +instance Semigroup SnapShotStats where + (<>) (SnapShotStats x1 x2 x3 x4 x5) (SnapShotStats y1 y2 y3 y4 y5) = + SnapShotStats + (x1 <> y1) + (x2 <> y2) + (x3 <> y3) + (x4 <> y4) + (x5 <> y5) + +instance Monoid SnapShotStats where + mempty = SnapShotStats mempty mempty mempty mempty mempty + +instance Pretty SnapShotStats where + pretty SnapShotStats {..} = + prettyRecord + "SnapShot" + [ "Stake" <:> sssStake, + "DelegationCredential" <:> sssDelegationCredential, + "DelegationStakePool" <:> sssDelegationStakePool, + "PoolParams" <:> sssPoolParams, + pretty sssPoolParamsStats + ] + +instance AggregateStat SnapShotStats where + aggregateStat SnapShotStats {..} = + (aggregateStat sssPoolParamsStats) + { gsCredentialStaking = sssStake <> sssDelegationCredential, + gsKeyHashStakePool = sssDelegationStakePool <> sssPoolParams + } + +countSnapShotStat :: SnapShot C -> SnapShotStats +countSnapShotStat SnapShot {..} = + SnapShotStats + { sssStake = statMapKeys (unStake _stake), + sssDelegationCredential = statMapKeys _delegations, + sssDelegationStakePool = statFoldable _delegations, + sssPoolParams = statMapKeys _poolParams, + sssPoolParamsStats = foldMap countPoolParamsStats _poolParams + } + +data PoolParamsStats = PoolParamsStats + { ppsPoolId :: !(Stat (KeyHash 'StakePool C)), + ppsRewardAcnt :: !(Stat (Credential 'Staking C)), + ppsOwners :: !(Stat (KeyHash 'Staking C)) + } + +instance Semigroup PoolParamsStats where + (<>) (PoolParamsStats x1 x2 x3) (PoolParamsStats y1 y2 y3) = + PoolParamsStats + (x1 <> y1) + (x2 <> y2) + (x3 <> y3) + +instance Monoid PoolParamsStats where + mempty = PoolParamsStats mempty mempty mempty + +instance Pretty PoolParamsStats where + pretty PoolParamsStats {..} = + prettyRecord + "PoolParamsStats" + [ "PoolId" <:> ppsPoolId, + "RewardAcnt" <:> ppsRewardAcnt, + "Owners" <:> ppsOwners + ] + +instance AggregateStat PoolParamsStats where + aggregateStat PoolParamsStats {..} = + mempty {gsCredentialStaking = ppsRewardAcnt, gsKeyHashStakePool = ppsPoolId} + +countPoolParamsStats :: PoolParams C -> PoolParamsStats +countPoolParamsStats PoolParams {..} = + PoolParamsStats + { ppsPoolId = statSingleton _poolId, + ppsRewardAcnt = statSingleton (getRwdCred _poolRAcnt), + ppsOwners = statSet _poolOwners + } + +data RewardUpdateStats = RewardUpdateStats + +instance Pretty RewardUpdateStats where + pretty RewardUpdateStats {} = + prettyRecord "RewardUpdateStats" [] + +instance AggregateStat RewardUpdateStats where + aggregateStat RewardUpdateStats = mempty + +data PoolDistrStats = PoolDistrStats + { pdsStakePoolKeyHash :: !(Stat (KeyHash 'StakePool C)), + pdsStakePoolStakeVrf :: !(Stat (Hash C (VerKeyVRF C))) + } + +instance Pretty PoolDistrStats where + pretty PoolDistrStats {..} = + prettyRecord + "PoolDistrStats" + [ "StakePoolKeyHash" <:> pdsStakePoolKeyHash, + "StakePoolStakeVrf" <:> pdsStakePoolStakeVrf + ] + +instance AggregateStat PoolDistrStats where + aggregateStat PoolDistrStats {..} = + mempty + { gsKeyHashStakePool = pdsStakePoolKeyHash, + gsVerKeyVRF = pdsStakePoolStakeVrf + } + +calcPoolDistrStats :: PoolDistr C -> PoolDistrStats +calcPoolDistrStats (PoolDistr pd) = + PoolDistrStats + { pdsStakePoolKeyHash = statMapKeys pd, + pdsStakePoolStakeVrf = statFoldable (individualPoolStakeVrf <$> Map.elems pd) + } + +data NewEpochStateStats = NewEpochStateStats + { nessPrevBlocksMade :: !(Stat (KeyHash 'StakePool C)), + nessCurBlocksMade :: !(Stat (KeyHash 'StakePool C)), + nessBlocksMade :: !(Stat (KeyHash 'StakePool C)), + nessEpochStateStats :: !EpochStateStats, + nessRewardUpdate :: !RewardUpdateStats, + nessPoolDistrStats :: !PoolDistrStats, + nessAggregateStats :: !AggregateStats + } + +instance Pretty NewEpochStateStats where + pretty NewEpochStateStats {..} = + prettyRecord + "NewEpochStateStats" + [ "PrevBlocksMade" <:> statCount nessPrevBlocksMade, + "CurBlocksMade" <:> statCount nessCurBlocksMade, + "BlocksMade" <:> nessBlocksMade, + pretty nessEpochStateStats, + pretty nessRewardUpdate <> "TODO", + pretty nessPoolDistrStats, + pretty nessAggregateStats + ] + +countNewEpochStateStats :: NewEpochState CurrentEra -> NewEpochStateStats +countNewEpochStateStats NewEpochState {..} = + let ness = + NewEpochStateStats + { nessPrevBlocksMade = statMapKeys (unBlocksMade nesBprev), + nessCurBlocksMade = statMapKeys (unBlocksMade nesBcur), + nessBlocksMade = mempty, + nessEpochStateStats = countEpochStateStats nesEs, + nessRewardUpdate = RewardUpdateStats, + nessPoolDistrStats = calcPoolDistrStats nesPd, + nessAggregateStats = mempty + } + in ness + { nessBlocksMade = nessPrevBlocksMade ness <> nessCurBlocksMade ness, + nessAggregateStats = + mconcat + [ aggregateStat (nessPrevBlocksMade ness), + aggregateStat (nessCurBlocksMade ness), + aggregateStat (nessRewardUpdate ness), + essAggregateStats (nessEpochStateStats ness), + aggregateStat (nessPoolDistrStats ness) + ] + } + +printNewEpochStateStats :: NewEpochStateStats -> IO () +printNewEpochStateStats = putStrLn . show . pretty + +data EpochStateStats = EpochStateStats + { essMarkSnapShotStats :: !SnapShotStats, + essSetSnapShotStats :: !SnapShotStats, + essGoSnapShotStats :: !SnapShotStats, + essSnapShotsStats :: !SnapShotStats, + essLedgerStateStats :: !LedgerStateStats, + essNonMyopic :: !(Stat (KeyHash 'StakePool C)), + essAggregateStats :: !AggregateStats + } + +instance Pretty EpochStateStats where + pretty EpochStateStats {..} = + prettyRecord + "EpochStateStats" + [ "mark" <:> statCount (sssStake essMarkSnapShotStats), + "set" <:> statCount (sssStake essSetSnapShotStats), + "go" <:> statCount (sssStake essGoSnapShotStats), + "mark+set+go =" <+> pretty essSnapShotsStats, + pretty essLedgerStateStats, + "NonMyopic" <:> essNonMyopic, + pretty essAggregateStats + ] + +countEpochStateStats :: EpochState CurrentEra -> EpochStateStats +countEpochStateStats EpochState {..} = + let markSnap = countSnapShotStat (_pstakeMark esSnapshots) + setSnap = countSnapShotStat (_pstakeSet esSnapshots) + goSnap = countSnapShotStat (_pstakeGo esSnapshots) + stats = + EpochStateStats + { essMarkSnapShotStats = markSnap, + essSetSnapShotStats = setSnap, + essGoSnapShotStats = goSnap, + essSnapShotsStats = markSnap <> setSnap <> goSnap, + essLedgerStateStats = countLedgerStateStats esLState, + essNonMyopic = statMapKeys (likelihoodsNM esNonMyopic), + essAggregateStats = mempty + } + in stats + { essAggregateStats = + mconcat + [ aggregateStat (essSnapShotsStats stats), + aggregateStat (essLedgerStateStats stats), + aggregateStat (essNonMyopic stats) + ] + } + +data DStateStats = DStateStats + { dssCredentialStaking :: !(Stat (Credential 'Staking C)), + dssDelegations :: !(Stat (KeyHash 'StakePool C)), + dssKeyHashGenesis :: !(Stat (KeyHash 'Genesis C)), + dssKeyHashGenesisDelegate :: !(Stat (KeyHash 'GenesisDelegate C)), + dssHashVerKeyVRF :: !(Stat (Hash C (VerKeyVRF C))) + } + +instance Pretty DStateStats where + pretty DStateStats {..} = + prettyRecord + "DStateStats" + [ "CredentialStaking" <:> dssCredentialStaking, + "Delegations" <:> dssDelegations, + "KeyHashGenesis" <:> dssKeyHashGenesis, + "KeyHashGenesisDelegate" <:> dssKeyHashGenesisDelegate, + "HashVerKeyVRF" <:> dssHashVerKeyVRF + ] + +instance AggregateStat DStateStats where + aggregateStat DStateStats {..} = + mempty + { gsCredentialStaking = dssCredentialStaking, + gsKeyHashStakePool = dssDelegations, + gsKeyHashGenesis = dssKeyHashGenesis, + gsKeyHashGenesisDelegate = dssKeyHashGenesisDelegate, + gsVerKeyVRF = dssHashVerKeyVRF + } + +countDStateStats :: DState C -> DStateStats +countDStateStats DState {..} = + DStateStats + { dssCredentialStaking = + statMapKeys _rewards + <> statMapKeys _delegations + <> statSet (range _ptrs), + dssDelegations = statFoldable _delegations, + dssKeyHashGenesis = + statFoldable (fGenDelegGenKeyHash <$> Map.keys _fGenDelegs) + <> statMapKeys (unGenDelegs _genDelegs), + dssKeyHashGenesisDelegate = + statFoldable (genDelegKeyHash <$> Map.elems _fGenDelegs) + <> statFoldable + (genDelegKeyHash <$> Map.elems (unGenDelegs _genDelegs)), + dssHashVerKeyVRF = + statFoldable (genDelegVrfHash <$> Map.elems _fGenDelegs) + <> statFoldable + (genDelegVrfHash <$> Map.elems (unGenDelegs _genDelegs)) + } + +data PStateStats = PStateStats + { pssKeyHashStakePool :: !(Stat (KeyHash 'StakePool C)), + pssPoolParamsStats :: !PoolParamsStats + } + +instance Pretty PStateStats where + pretty PStateStats {..} = + prettyRecord + "PStateStats" + [ "KeyHashStakePool" <:> pssKeyHashStakePool, + pretty pssPoolParamsStats + ] + +instance AggregateStat PStateStats where + aggregateStat PStateStats {..} = + (aggregateStat pssPoolParamsStats) {gsKeyHashStakePool = pssKeyHashStakePool} + +countPStateStats :: PState C -> PStateStats +countPStateStats PState {..} = + PStateStats + { pssKeyHashStakePool = + statMapKeys _pParams + <> statMapKeys _fPParams + <> statMapKeys _retiring, + pssPoolParamsStats = + foldMap countPoolParamsStats _pParams <> foldMap countPoolParamsStats _fPParams + } + +data LedgerStateStats = LedgerStateStats + { lssUTxOStats :: !UTxOStats, + lssDStateStats :: !DStateStats, + lssPStateStats :: !PStateStats + } + +instance Pretty LedgerStateStats where + pretty LedgerStateStats {..} = + prettyRecord + "LedgerStateStats" + [ pretty lssUTxOStats, + pretty lssDStateStats, + pretty lssPStateStats + ] + +instance AggregateStat LedgerStateStats where + aggregateStat LedgerStateStats {..} = + mconcat + [ aggregateStat lssUTxOStats, + aggregateStat lssDStateStats, + aggregateStat lssPStateStats + ] + +countLedgerStateStats :: LedgerState CurrentEra -> LedgerStateStats +countLedgerStateStats LedgerState {..} = + LedgerStateStats + { lssUTxOStats = countUTxOStats (_utxo _utxoState), + lssDStateStats = countDStateStats (_dstate _delegationState), + lssPStateStats = countPStateStats (_pstate _delegationState) + } + +data TxInStats = TxInStats + { tisTxId :: !(Stat (TxId C)), + tisTxIx :: !(Stat Natural) + } + +instance Pretty TxInStats where + pretty TxInStats {..} = + prettyRecord "TxInStats" ["TxId" <:> tisTxId, "TxIx" <:> tisTxIx] + +countTxInStats :: [TxIn C] -> TxInStats +countTxInStats txIns = + case unzip (fmap (\(TxIn txId txIx) -> (txId, txIx)) txIns) of + (txIds, txIxs) -> + TxInStats + { tisTxId = statFoldable txIds, + tisTxIx = statFoldable txIxs + } + +data TxOutStats = TxOutStats + { tosBootstrap :: !(Stat (BootstrapAddress C)), + tosPaymentCredential :: !(Stat (Credential 'Payment C)), + tosStakingCredential :: !(Stat (Credential 'Staking C)), + tosStakingPtr :: !(Stat Ptr), + tosNetwork :: !(Stat Network), + tosValue :: !(Stat Integer), + tosPolicyId :: !(Stat (PolicyID C)), + tosAssetName :: !(Stat AssetName), + tosAssetValue :: !(Stat Integer), + tosDataHash :: !(Stat (DataHash C)) + } + +instance Semigroup TxOutStats where + (<>) (TxOutStats x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) (TxOutStats y0 y1 y2 y3 y4 y5 y6 y7 y8 y9) = + TxOutStats + (x0 <> y0) + (x1 <> y1) + (x2 <> y2) + (x3 <> y3) + (x4 <> y4) + (x5 <> y5) + (x6 <> y6) + (x7 <> y7) + (x8 <> y8) + (x9 <> y9) + +instance Monoid TxOutStats where + mempty = TxOutStats mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty + +instance Pretty TxOutStats where + pretty TxOutStats {..} = + prettyRecord + "TxOutStats" + [ "Bootstrap" <:> tosBootstrap, + "PaymentCredential" <:> tosPaymentCredential, + "StakingCredential" <:> tosStakingCredential, + "StakingPtr" <:> tosStakingPtr, + "Network" <:> tosNetwork, + "Value" <:> tosValue, + "PolicyId" <:> tosPolicyId, + "AssetName" <:> tosAssetName, + "AssetValue" <:> tosAssetValue, + "DataHash" <:> tosDataHash + ] + +instance AggregateStat TxOutStats where + aggregateStat TxOutStats {..} = aggregateStat tosStakingCredential + +countTxOutStats :: [Alonzo.TxOut CurrentEra] -> TxOutStats +countTxOutStats = foldMap countTxOutStat + where + countTxOutStat :: Alonzo.TxOut CurrentEra -> TxOutStats + countTxOutStat (Alonzo.TxOut addr (Value v vm) mData) = + let !dataStat = + strictMaybe + mempty + (\d -> mempty {tosDataHash = statSingleton d}) + mData + !vmElems = Map.elems vm + !valueStat = + dataStat + { tosValue = statSingleton v, + tosPolicyId = statMapKeys vm, + tosAssetName = foldMap statMapKeys vmElems, + tosAssetValue = foldMap statFoldable vmElems + } + !networkStat = valueStat {tosNetwork = statSingleton (getNetwork addr)} + in case addr of + AddrBootstrap addrBootstrap -> + networkStat {tosBootstrap = statSingleton addrBootstrap} + Addr _ pc sr -> + let stakeStat = + case sr of + StakeRefNull -> networkStat + StakeRefPtr ptr -> + networkStat {tosStakingPtr = statSingleton ptr} + StakeRefBase cred -> + networkStat {tosStakingCredential = statSingleton cred} + in stakeStat {tosPaymentCredential = statSingleton pc} + +data UTxOStats = UTxOStats + { usTxInStats :: !TxInStats, + usTxOutStats :: !TxOutStats + } + +instance Pretty UTxOStats where + pretty UTxOStats {..} = + prettyRecord + "UTxOStats" + [pretty usTxInStats, pretty usTxOutStats] + +instance AggregateStat UTxOStats where + aggregateStat = aggregateStat . usTxOutStats + +countUTxOStats :: UTxO (AlonzoEra StandardCrypto) -> UTxOStats +countUTxOStats (UTxO m) = + UTxOStats + { usTxInStats = countTxInStats (Map.keys m), + usTxOutStats = countTxOutStats (Map.elems m) + } + +data AggregateStats = AggregateStats + { gsCredentialStaking :: !(Stat (Credential 'Staking C)), + gsKeyHashStakePool :: !(Stat (KeyHash 'StakePool C)), + gsKeyHashGenesis :: !(Stat (KeyHash 'Genesis C)), + gsKeyHashGenesisDelegate :: !(Stat (KeyHash 'GenesisDelegate C)), + gsVerKeyVRF :: !(Stat (Hash C (VerKeyVRF C))), + gsScriptHash :: !(Stat (ScriptHash C)) + } + +instance Semigroup AggregateStats where + (<>) (AggregateStats x1 x2 x3 x4 x5 x6) (AggregateStats y1 y2 y3 y4 y5 y6) = + AggregateStats + (x1 <> y1) + (x2 <> y2) + (x3 <> y3) + (x4 <> y4) + (x5 <> y5) + (x6 <> y6) + +instance Monoid AggregateStats where + mempty = AggregateStats mempty mempty mempty mempty mempty mempty + +instance Pretty AggregateStats where + pretty AggregateStats {..} = + prettyRecord + "AggregateStats" + [ "StakingCredential" <:> gsCredentialStaking, + "KeyHashStakePool" <:> gsKeyHashStakePool, + "ScriptHash" <:> gsScriptHash + ] + +class AggregateStat s where + aggregateStat :: s -> AggregateStats + +instance AggregateStat (Stat (Credential 'Staking C)) where + aggregateStat s = mempty {gsCredentialStaking = s} + +instance AggregateStat (Stat (KeyHash 'StakePool C)) where + aggregateStat s = mempty {gsKeyHashStakePool = s} + +instance AggregateStat (Stat (ScriptHash C)) where + aggregateStat s = mempty {gsScriptHash = s} + +-- Initial attempt at UTxO stats, which was mostly superseded by the above +-- approach that works for the whole state + +data UTxOUniques = UTxOUniques + { paymentKeys :: !(Set.Set (KeyHash 'Payment C)), + paymentScripts :: !(Set.Set (ScriptHash C)), + stakeKeys :: !(Set.Set (KeyHash 'Staking C)), + stakeScripts :: !(Set.Set (ScriptHash C)), + stakePtrs :: !(Set.Set Ptr), + scripts :: !(Set.Set (ScriptHash C)), + txIds :: !(Set.Set (TxId C)), + txIxs :: !(Set.Set Natural) + } + +emptyUniques :: UTxOUniques +emptyUniques = UTxOUniques mempty mempty mempty mempty mempty mempty mempty mempty + +data UTxOStats' = UTxOStats' + { statsTotalTxOuts :: !Int, + statsByronTxOuts :: !Int, + statsTotalPaymentKeys :: !Int, + statsTotalPaymentScripts :: !Int, + statsTotalStakeKeys :: !Int, + statsTotalStakeScripts :: !Int, + statsTotalStakePtrs :: !Int, + stateTotalStakeNulls :: !Int + } + deriving (Show) + +initStats :: UTxOStats' +initStats = UTxOStats' 0 0 0 0 0 0 0 0 + +collectStats :: ConduitT (TxIn C, Alonzo.TxOut CurrentEra) Void IO () +collectStats = do + (uniques, stats) <- foldlC collect (emptyUniques, initStats) + lift $ reportStats uniques stats + where + collect :: + (UTxOUniques, UTxOStats') -> + (TxIn C, Alonzo.TxOut CurrentEra) -> + (UTxOUniques, UTxOStats') + collect (u@UTxOUniques {..}, s@UTxOStats' {..}) (TxIn txId txIx, Alonzo.TxOut addr _val _datum) = + let u' = u {txIds = Set.insert txId txIds, txIxs = Set.insert txIx txIxs} + s' = s {statsTotalTxOuts = statsTotalTxOuts + 1} + updateStakingStats sr (su, ss) = + case sr of + StakeRefNull -> + (su, ss {stateTotalStakeNulls = stateTotalStakeNulls + 1}) + StakeRefPtr ptr -> + ( su {stakePtrs = Set.insert ptr stakePtrs}, + ss {statsTotalStakePtrs = statsTotalStakePtrs + 1} + ) + StakeRefBase a + | KeyHashObj kh <- a -> + ( su {stakeKeys = Set.insert kh stakeKeys}, + ss {statsTotalStakeKeys = statsTotalStakeKeys + 1} + ) + | ScriptHashObj sh <- a -> + ( su {stakeScripts = Set.insert sh stakeScripts}, + ss {statsTotalStakeScripts = statsTotalStakeScripts + 1} + ) + in case addr of + AddrBootstrap _ -> + (u', s' {statsByronTxOuts = statsByronTxOuts + 1}) + Addr _ni pc sr + | KeyHashObj kh <- pc -> + updateStakingStats + sr + ( u' {paymentKeys = Set.insert kh paymentKeys}, + s' {statsTotalPaymentKeys = statsTotalPaymentKeys + 1} + ) + | ScriptHashObj kh <- pc -> + updateStakingStats + sr + ( u' {paymentScripts = Set.insert kh paymentScripts}, + s' {statsTotalPaymentScripts = statsTotalPaymentScripts + 1} + ) + +reportStats :: UTxOUniques -> UTxOStats' -> IO () +reportStats UTxOUniques {..} UTxOStats' {..} = do + let showPercent x y + | y == 0 = "0" + | otherwise = + case ((1000 * x) `div` y) `quotRem` 10 of + (q, r) -> + show x <> ", " <> show q <> "." <> show r <> "% of total" + putStrLn $ + unlines + [ "Total TxOuts = " <> show statsTotalTxOuts, + "Byron TxOuts = " <> showPercent statsByronTxOuts statsTotalTxOuts, + "Unique TxIds = " <> showPercent (Set.size txIds) statsTotalTxOuts, + "Unique TxIxs = " <> showPercent (Set.size txIxs) statsTotalTxOuts, + "Shelley Total Payment Keys = " <> show statsTotalPaymentKeys, + "Shelley Unique Payment Keys = " <> showPercent (Set.size paymentKeys) statsTotalPaymentKeys, + "Shelley Total Payment Scripts = " <> show statsTotalPaymentScripts, + "Shelley Unique Payment Scripts = " + <> showPercent (Set.size paymentScripts) statsTotalPaymentScripts, + "Shelley Total Stake Keys = " <> show statsTotalStakeKeys, + "Shelley Unique Stake Keys = " <> showPercent (Set.size stakeKeys) statsTotalStakeKeys, + "Shelley Total Stake Scripts = " <> show statsTotalStakeScripts, + "Shelley Unique Stake Scripts = " + <> showPercent (Set.size stakeScripts) statsTotalStakeScripts, + "Shelley Total Stake Ptrs = " <> show statsTotalStakePtrs, + "Shelley Unique Stake Ptrs = " <> showPercent (Set.size stakePtrs) statsTotalStakePtrs + ] diff --git a/libs/small-steps/src/Control/Iterate/SetAlgebra.hs b/libs/small-steps/src/Control/Iterate/SetAlgebra.hs index c5460429fa..950b60a7be 100644 --- a/libs/small-steps/src/Control/Iterate/SetAlgebra.hs +++ b/libs/small-steps/src/Control/Iterate/SetAlgebra.hs @@ -147,6 +147,9 @@ data BiMap v a b where MkBiMap :: (v ~ b) => !(Map.Map a b) -> !(Map.Map b (Set. -- ^ the 1st and 3rd parameter must be the same: ^ ^ +biMapToMap :: BiMap v a b -> Map a b +biMapToMap (MkBiMap m _) = m + -- ============== begin necessary Cardano.Binary instances =============== instance (Ord a, Ord b, ToCBOR a, ToCBOR b) => ToCBOR (BiMap b a b) where -- The `toCBOR` instance encodes only the forward map. We wrap this in a