diff --git a/cabal.project b/cabal.project index e897f7a98..be5886bfd 100644 --- a/cabal.project +++ b/cabal.project @@ -10,8 +10,8 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2024-10-10T00:52:24Z - , cardano-haskell-packages 2024-11-26T16:00:26Z + , hackage.haskell.org 2025-02-05T12:01:20Z + , cardano-haskell-packages 2025-02-04T11:56:25Z packages: cardano-db diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs index 759a7c5fc..11a8ba26c 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -232,7 +232,7 @@ queryDBSync env = DB.runWithConnectionNoLogging (getDBSyncPGPass env) getPoolLayer :: DBSyncEnv -> IO PoolDataLayer getPoolLayer env = do pgconfig <- runOrThrowIO $ DB.readPGPass (enpPGPassSource $ dbSyncParams env) - pool <- runNoLoggingT $ createPostgresqlPool (DB.toConnectionString pgconfig) 1 -- Pool size of 1 for tests + pool <- runNoLoggingT $ createPostgresqlPool (DB.toConnectionSetting pgconfig) 1 -- Pool size of 1 for tests pure $ postgresqlPoolDataLayer nullTracer diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs new file mode 100644 index 000000000..d529206bf --- /dev/null +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +module Test.Cardano.Db.Mock.Unit.Alonzo.Plutus ( + -- plutus spend scripts + simpleScript, + unlockScriptSameBlock, + failedScript, + failedScriptSameBlock, + multipleScripts, + multipleScriptsSameBlock, + multipleScriptsFailed, + multipleScriptsFailedSameBlock, + -- plutus cert scripts + registrationScriptTx, + deregistrationScriptTx, + deregistrationsScriptTxs, + deregistrationsScriptTx, + deregistrationsScriptTx', + deregistrationsScriptTx'', + -- plutus multiAsset scripts + mintMultiAsset, + mintMultiAssets, + swapMultiAssets, +) where + +import qualified Cardano.Crypto.Hash as Crypto +import Cardano.Db (TxOutTableType (..)) +import qualified Cardano.Db as DB +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V +import qualified Cardano.Db.Schema.Variant.TxOutCore as C +import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) +import Cardano.Ledger.Coin +import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) +import Cardano.Ledger.Plutus.Data (hashData) +import Cardano.Ledger.SafeHash (extractHash) +import Cardano.Ledger.Shelley.TxCert +import Cardano.Mock.ChainSync.Server (IOManager) +import Cardano.Mock.Forging.Interpreter (withAlonzoLedgerState) +import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo +import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( + alwaysMintScriptAddr, + alwaysMintScriptHash, + alwaysSucceedsScriptAddr, + alwaysSucceedsScriptHash, + assetNames, + plutusDataList, + ) +import Cardano.Mock.Forging.Types ( + MockBlock (..), + NodeId (..), + StakeIndex (..), + TxEra (..), + UTxOIndex (..), + ) +import Control.Monad (void) +import qualified Data.Map as Map +import Data.Text (Text) +import Ouroboros.Consensus.Cardano.Block (StandardAlonzo) +import Test.Cardano.Db.Mock.Config (alonzoConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) +import Test.Cardano.Db.Mock.UnifiedApi ( + fillUntilNextEpoch, + forgeNextAndSubmit, + registerAllStakeCreds, + withAlonzoFindLeaderAndSubmit, + withAlonzoFindLeaderAndSubmitTx, + ) +import Test.Cardano.Db.Mock.Validate ( + assertAlonzoCounts, + assertBlockNoBackoff, + assertEqQuery, + assertScriptCert, + ) +import Test.Tasty.HUnit (Assertion) + +---------------------------------------------------------------------------------------------------------- +-- Plutus Spend Scripts +---------------------------------------------------------------------------------------------------------- +simpleScript :: IOManager -> [(Text, Text)] -> Assertion +simpleScript = + withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ registerAllStakeCreds interpreter mockServer + + a <- fillUntilNextEpoch interpreter mockServer + + void $ + withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 + + assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) + assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs TxOutCore) [expectedFields] "Unexpected script outputs" + where + testLabel = "simpleScript-alonzo" + getOutFields txOutW = case txOutW of + DB.CTxOutW txOut -> + ( C.txOutAddress txOut + , C.txOutAddressHasScript txOut + , C.txOutValue txOut + , C.txOutDataHash txOut + ) + DB.VTxOutW txout mAddress -> case mAddress of + Just address -> + ( V.addressAddress address + , V.addressHasScript address + , V.txOutValue txout + , V.txOutDataHash txout + ) + Nothing -> error "AlonzoSimpleScript: expected an address" + expectedFields = + ( renderAddress alwaysSucceedsScriptAddr + , True + , DB.DbLovelace 20000 + , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardAlonzo plutusDataList) + ) + +_unlockScript :: IOManager -> [(Text, Text)] -> Assertion +_unlockScript = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ registerAllStakeCreds interpreter mockServer + + -- We don't use withAlonzoFindLeaderAndSubmitTx here, because we want access to the tx. + tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + + let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) + void $ + withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 + + assertBlockNoBackoff dbSync 3 + assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) + where + testLabel = "unlockScript-alonzo" + +unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion +unlockScriptSameBlock = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ registerAllStakeCreds interpreter mockServer + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 st + let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) + tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) + where + testLabel = "unlockScriptSameBlock-alonzo" + +failedScript :: IOManager -> [(Text, Text)] -> Assertion +failedScript = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + + let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) + void $ + withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) + where + testLabel = "failedScript-alonzo" + +failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion +failedScriptSameBlock = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ registerAllStakeCreds interpreter mockServer + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 st + let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) + tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) + where + testLabel = "failedScriptSameBlock-alonzo" + +multipleScripts :: IOManager -> [(Text, Text)] -> Assertion +multipleScripts = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 + let utxo = Alonzo.mkUTxOAlonzo tx0 + pair1 = head utxo + pair2 = utxo !! 2 + tx1 <- + withAlonzoLedgerState interpreter $ + Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 + + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) + where + testLabel = "multipleScripts-alonzo" + +multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsSameBlock = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st + let utxo = Alonzo.mkUTxOAlonzo tx0 + pair1 = head utxo + pair2 = utxo !! 2 + tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) + where + testLabel = "multipleScriptsSameBlock-alonzo" + +multipleScriptsFailed :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsFailed = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) + + let utxos = Alonzo.mkUTxOAlonzo tx0 + tx1 <- + withAlonzoLedgerState interpreter $ + Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) + where + testLabel = "multipleScriptsFailed-alonzo" + +multipleScriptsFailedSameBlock :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsFailedSameBlock = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st + + let utxos = tail $ Alonzo.mkUTxOAlonzo tx0 + tx1 <- Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) + where + testLabel = "multipleScriptsFailedSameBlock-alonzo" + +---------------------------------------------------------------------------------------------------------- +-- Plutus Cert Scripts +---------------------------------------------------------------------------------------------------------- + +registrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion +registrationScriptTx = + withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ + withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ + Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (0, 0, 0, 1) + where + testLabel = "registrationScriptTx-alonzo" + +deregistrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion +deregistrationScriptTx = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (1, 0, 0, 1) + where + testLabel = "deregistrationScriptTx-alonzo" + +deregistrationsScriptTxs :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTxs = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st + tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx3 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st + pure [tx0, tx1, Alonzo.addValidityInterval 1000 tx2, Alonzo.addValidityInterval 2000 tx3] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (2, 0, 0, 1) + assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTxs-alonzo" + +deregistrationsScriptTx :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTx = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- + Alonzo.mkScriptDCertTx + [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) + , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + ] + True + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (2, 0, 0, 1) + assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTx-alonzo" + +-- Like previous but missing a redeemer. This is a known ledger issue +deregistrationsScriptTx' :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTx' = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- + Alonzo.mkScriptDCertTx + [ (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) + , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + ] + True + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + -- TODO: This is a bug! The first field should be 2. However the deregistrations + -- are missing the redeemers + assertScriptCert dbSync (0, 0, 0, 1) + assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTx'-alonzo" + +-- Like previous but missing the other redeemer. This is a known ledger issue +deregistrationsScriptTx'' :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTx'' = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- + Alonzo.mkScriptDCertTx + [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) + ] + True + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (2, 0, 0, 1) + assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTx''-alonzo" + +---------------------------------------------------------------------------------------------------------- +-- Plutus MultiAsset Scripts +---------------------------------------------------------------------------------------------------------- + +mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion +mintMultiAsset = + withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \st -> do + let val0 = MultiAsset $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) + Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val0 True 100 st + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (1, 1, 1, 1, 0, 0, 0, 0) + where + testLabel = "mintMultiAsset-alonzo" + +mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion +mintMultiAssets = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + let assets0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] + let policy0 = PolicyID alwaysMintScriptHash + let policy1 = PolicyID alwaysSucceedsScriptHash + let val1 = MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] + tx0 <- Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val1 True 100 st + tx1 <- Alonzo.mkMAssetsScriptTx [UTxOIndex 2] (UTxOIndex 3) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val1 True 200 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (2, 4, 1, 2, 0, 0, 0, 0) + where + testLabel = "mintMultiAssets-alonzo" + +swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion +swapMultiAssets = + withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do + let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] + let policy0 = PolicyID alwaysMintScriptHash + let policy1 = PolicyID alwaysSucceedsScriptHash + let mintValue0 = MultiAsset $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)] + let assets0 = Map.fromList [(head assetNames, 5), (assetNames !! 1, 2)] + let outValue0 = MaryValue (Coin 20) $ MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] + + tx0 <- + Alonzo.mkMAssetsScriptTx + [UTxOIndex 0] + (UTxOIndex 1) + [(UTxOAddress alwaysSucceedsScriptAddr, outValue0), (UTxOAddress alwaysMintScriptAddr, outValue0)] + mintValue0 + True + 100 + st + + let utxos = Alonzo.mkUTxOAlonzo tx0 + tx1 <- + Alonzo.mkMAssetsScriptTx + [UTxOPair (head utxos), UTxOPair (utxos !! 1), UTxOIndex 2] + (UTxOIndex 3) + [ (UTxOAddress alwaysSucceedsScriptAddr, outValue0) + , (UTxOAddress alwaysMintScriptAddr, outValue0) + , (UTxOAddressNew 0, outValue0) + , (UTxOAddressNew 0, outValue0) + ] + mintValue0 + True + 200 + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (2, 6, 1, 2, 4, 2, 0, 0) + where + testLabel = "swapMultiAssets-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs new file mode 100644 index 000000000..182cd0dd9 --- /dev/null +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} + +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +module Test.Cardano.Db.Mock.Unit.Babbage.Plutus ( + -- plutus spend scripts + simpleScript, + unlockScriptSameBlock, + failedScript, + failedScriptFees, + failedScriptSameBlock, + multipleScripts, + multipleScriptsRollback, + multipleScriptsSameBlock, + multipleScriptsFailed, + multipleScriptsFailedSameBlock, + -- plutus cert scripts + registrationScriptTx, + deregistrationsScriptTx, + deregistrationScriptTx, + deregistrationsScriptTxs, + deregistrationsScriptTx', + deregistrationsScriptTx'', + -- plutus MultiAsset scripts + mintMultiAsset, + mintMultiAssets, + swapMultiAssets, +) where + +import qualified Cardano.Crypto.Hash as Crypto +import qualified Cardano.Db as DB +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V +import qualified Cardano.Db.Schema.Variant.TxOutCore as C +import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) +import Cardano.Ledger.Coin +import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) +import Cardano.Ledger.Plutus.Data (hashData) +import Cardano.Ledger.SafeHash (extractHash) +import Cardano.Ledger.Shelley.TxCert +import Cardano.Mock.ChainSync.Server (IOManager) +import Cardano.Mock.Forging.Interpreter (withBabbageLedgerState) +import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( + alwaysMintScriptAddr, + alwaysMintScriptHash, + alwaysSucceedsScriptAddr, + alwaysSucceedsScriptHash, + assetNames, + plutusDataList, + ) +import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage +import Cardano.Mock.Forging.Types ( + MockBlock (..), + NodeId (..), + StakeIndex (..), + TxEra (..), + UTxOIndex (..), + ) +import Control.Monad (void) +import qualified Data.Map as Map +import Data.Text (Text) +import Ouroboros.Consensus.Cardano.Block (StandardBabbage) +import Ouroboros.Network.Block (genesisPoint) +import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, txOutTableTypeFromConfig, withFullConfig, withFullConfigAndDropDB) +import Test.Cardano.Db.Mock.UnifiedApi ( + fillUntilNextEpoch, + forgeNextAndSubmit, + forgeNextFindLeaderAndSubmit, + registerAllStakeCreds, + rollbackTo, + withBabbageFindLeaderAndSubmit, + withBabbageFindLeaderAndSubmitTx, + ) +import Test.Cardano.Db.Mock.Validate ( + assertAlonzoCounts, + assertBlockNoBackoff, + assertEqQuery, + assertNonZeroFeesContract, + assertScriptCert, + ) +import Test.Tasty.HUnit (Assertion) + +---------------------------------------------------------------------------------------------------------- +-- Plutus Spend Scripts +---------------------------------------------------------------------------------------------------------- + +simpleScript :: IOManager -> [(Text, Text)] -> Assertion +simpleScript = + withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + let txOutTableType = txOutTableTypeFromConfig dbSync + void $ registerAllStakeCreds interpreter mockServer + + a <- fillUntilNextEpoch interpreter mockServer + + void $ + withBabbageFindLeaderAndSubmitTx interpreter mockServer $ + Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 + + assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) + assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs txOutTableType) [expectedFields] "Unexpected script outputs" + where + testLabel = "simpleScript" + getOutFields txOutW = + case txOutW of + DB.CTxOutW txOut -> + ( C.txOutAddress txOut + , C.txOutAddressHasScript txOut + , C.txOutValue txOut + , C.txOutDataHash txOut + ) + DB.VTxOutW txOut mAddress -> case mAddress of + Just address -> + ( V.addressAddress address + , V.addressHasScript address + , V.txOutValue txOut + , V.txOutDataHash txOut + ) + Nothing -> error "BabbageSimpleScript: expected an address" + + expectedFields = + ( renderAddress alwaysSucceedsScriptAddr + , True + , DB.DbLovelace 20000 + , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardBabbage plutusDataList) + ) + +unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion +unlockScriptSameBlock = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ registerAllStakeCreds interpreter mockServer + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 st + let utxo0 = head (Babbage.mkUTxOBabbage tx0) + tx1 <- Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) + where + testLabel = "unlockScriptSameBlock" + +failedScript :: IOManager -> [(Text, Text)] -> Assertion +failedScript = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) + + let utxo0 = head (Babbage.mkUTxOBabbage tx0) + void $ + withBabbageFindLeaderAndSubmitTx interpreter mockServer $ + Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) + where + testLabel = "failedScript" + +failedScriptFees :: IOManager -> [(Text, Text)] -> Assertion +failedScriptFees = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) + + let utxo0 = head (Babbage.mkUTxOBabbage tx0) + void $ + withBabbageFindLeaderAndSubmitTx interpreter mockServer $ + Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) + assertNonZeroFeesContract dbSync + where + testLabel = "failedScriptFees" + +failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion +failedScriptSameBlock = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ registerAllStakeCreds interpreter mockServer + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 st + let utxo0 = head (Babbage.mkUTxOBabbage tx0) + tx1 <- Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) + where + testLabel = "failedScriptSameBlock" + +multipleScripts :: IOManager -> [(Text, Text)] -> Assertion +multipleScripts = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 + let utxo = Babbage.mkUTxOBabbage tx0 + pair1 = head utxo + pair2 = utxo !! 2 + tx1 <- + withBabbageLedgerState interpreter $ + Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 + + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) + where + testLabel = "multipleScripts" + +multipleScriptsRollback :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsRollback = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 + let utxo = Babbage.mkUTxOBabbage tx0 + pair1 = head utxo + pair2 = utxo !! 2 + tx1 <- + withBabbageLedgerState interpreter $ + Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 + + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) + + rollbackTo interpreter mockServer genesisPoint + void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] + + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) + assertBlockNoBackoff dbSync 3 + + assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) + where + testLabel = "multipleScriptsRollback" + +multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsSameBlock = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 st + let utxo = Babbage.mkUTxOBabbage tx0 + pair1 = head utxo + pair2 = utxo !! 2 + tx1 <- Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) + where + testLabel = "multipleScriptsSameBlock" + +multipleScriptsFailed :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsFailed = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) + + let utxos = Babbage.mkUTxOBabbage tx0 + tx1 <- + withBabbageLedgerState interpreter $ + Babbage.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 + void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) + + assertBlockNoBackoff dbSync 2 + assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) + where + testLabel = "multipleScriptsFailed" + +multipleScriptsFailedSameBlock :: IOManager -> [(Text, Text)] -> Assertion +multipleScriptsFailedSameBlock = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 st + + let utxos = tail $ Babbage.mkUTxOBabbage tx0 + tx1 <- Babbage.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) + where + testLabel = "multipleScriptsFailedSameBlock" + +---------------------------------------------------------------------------------------------------------- +-- Plutus Cert Scripts +---------------------------------------------------------------------------------------------------------- + +registrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion +registrationScriptTx = + withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ + withBabbageFindLeaderAndSubmitTx interpreter mockServer $ + Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (0, 0, 0, 1) + where + testLabel = "registrationScriptTx" + +deregistrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion +deregistrationScriptTx = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (1, 0, 0, 1) + where + testLabel = "deregistrationScriptTx" + +deregistrationsScriptTxs :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTxs = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st + tx2 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx3 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st + pure [tx0, tx1, Babbage.addValidityInterval 1000 tx2, Babbage.addValidityInterval 2000 tx3] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (2, 0, 0, 1) + assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTxs" + +deregistrationsScriptTx :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTx = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- + Babbage.mkScriptDCertTx + [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) + , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + ] + True + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (2, 0, 0, 1) + assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTx" + +-- Like previous but missing a redeemer. This is a known ledger issue +deregistrationsScriptTx' :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTx' = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- + Babbage.mkScriptDCertTx + [ (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) + , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + ] + True + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + -- TODO: This is a bug! The first field should be 2. However the deregistrations + -- are missing the redeemers + assertScriptCert dbSync (0, 0, 0, 1) + assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTx'" + +-- Like previous but missing the other redeemer. This is a known ledger issue +deregistrationsScriptTx'' :: IOManager -> [(Text, Text)] -> Assertion +deregistrationsScriptTx'' = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st + tx1 <- + Babbage.mkScriptDCertTx + [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) + , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) + ] + True + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertScriptCert dbSync (2, 0, 0, 1) + assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) + where + testLabel = "deregistrationsScriptTx''" + +---------------------------------------------------------------------------------------------------------- +-- Plutus MultiAsset Scripts +---------------------------------------------------------------------------------------------------------- + +mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion +mintMultiAsset = + withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ \st -> do + let val0 = MultiAsset $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) + Babbage.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val0 True 100 st + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (1, 1, 1, 1, 0, 0, 0, 0) + where + testLabel = "mintMultiAsset" + +mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion +mintMultiAssets = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + let assets0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] + let policy0 = PolicyID alwaysMintScriptHash + let policy1 = PolicyID alwaysSucceedsScriptHash + let val1 = MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] + tx0 <- Babbage.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val1 True 100 st + tx1 <- Babbage.mkMAssetsScriptTx [UTxOIndex 2] (UTxOIndex 3) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val1 True 200 st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (2, 4, 1, 2, 0, 0, 0, 0) + where + testLabel = "mintMultiAssets" + +swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion +swapMultiAssets = + withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do + startDBSync dbSync + void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do + let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] + let policy0 = PolicyID alwaysMintScriptHash + let policy1 = PolicyID alwaysSucceedsScriptHash + let mintValue0 = MultiAsset $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)] + let assets0 = Map.fromList [(head assetNames, 5), (assetNames !! 1, 2)] + let outValue0 = MaryValue (Coin 20) $ MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] + + tx0 <- + Babbage.mkMAssetsScriptTx + [UTxOIndex 0] + (UTxOIndex 1) + [(UTxOAddress alwaysSucceedsScriptAddr, outValue0), (UTxOAddress alwaysMintScriptAddr, outValue0)] + [] + mintValue0 + True + 100 + st + + let utxos = Babbage.mkUTxOBabbage tx0 + tx1 <- + Babbage.mkMAssetsScriptTx + [UTxOPair (head utxos), UTxOPair (utxos !! 1), UTxOIndex 2] + (UTxOIndex 3) + [ (UTxOAddress alwaysSucceedsScriptAddr, outValue0) + , (UTxOAddress alwaysMintScriptAddr, outValue0) + , (UTxOAddressNew 0, outValue0) + , (UTxOAddressNew 0, outValue0) + ] + [] + mintValue0 + True + 200 + st + pure [tx0, tx1] + + assertBlockNoBackoff dbSync 1 + assertAlonzoCounts dbSync (2, 6, 1, 2, 4, 2, 0, 0) + where + testLabel = "swapMultiAssets" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs index 541786e3e..6bb1645d6 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs @@ -37,8 +37,8 @@ module Test.Cardano.Db.Mock.Unit.Conway.Plutus ( import Cardano.Crypto.Hash.Class (hashToBytes) import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V +import qualified Cardano.Db.Schema.Variant.TxOutCore as C import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) 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 0cf96ff0a..2a2d58ad6 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -45,8 +45,8 @@ module Test.Cardano.Db.Mock.Validate ( import Cardano.Db import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V +import qualified Cardano.Db.Schema.Variant.TxOutCore as C import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Util import qualified Cardano.Ledger.Address as Ledger diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index c3010c23a..badf076d9 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -184,6 +184,8 @@ library , extra , filepath , groups + , hasql + , hasql-pool , http-client , http-client-tls , http-types diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index 32fe21b1b..7cab7633e 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -23,6 +23,18 @@ module Cardano.DbSync ( SimplifiedOffChainPoolData (..), extractSyncOptions, ) where +import Control.Monad.Extra (whenJust) +import qualified Data.Strict.Maybe as Strict +import qualified Data.Text as Text +import Data.Version (showVersion) +import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) +import qualified Ouroboros.Consensus.HardFork.Simple as HardFork +import Ouroboros.Network.NodeToClient (IOManager, withIOManager) +import Paths_cardano_db_sync (version) +import System.Directory (createDirectoryIfMissing) +import Prelude (id) +import qualified Hasql.Connection as HsqlC +import qualified Hasql.Connection.Setting as HsqlSet import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) import qualified Cardano.Crypto as Crypto @@ -47,16 +59,6 @@ import Cardano.DbSync.Util.Constraint (queryIsJsonbInSchema) import Cardano.Prelude hiding (Nat, (%)) import Cardano.Slotting.Slot (EpochNo (..)) import Control.Concurrent.Async -import Control.Monad.Extra (whenJust) -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text as Text -import Data.Version (showVersion) -import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) -import qualified Ouroboros.Consensus.HardFork.Simple as HardFork -import Ouroboros.Network.NodeToClient (IOManager, withIOManager) -import Paths_cardano_db_sync (version) -import System.Directory (createDirectoryIfMissing) -import Prelude (id) runDbSyncNode :: MetricSetters -> [(Text, Text)] -> SyncNodeParams -> SyncNodeConfig -> IO () runDbSyncNode metricsSetters knownMigrations params syncNodeConfigFromFile = @@ -112,7 +114,7 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil then logInfo trce "All user indexes were created" else logInfo trce "New user indexes were not created. They may be created later if necessary." - let connectionString = Db.toConnectionString pgConfig + let dbConnectionSetting = Db.toConnectionSetting pgConfig -- For testing and debugging. whenJust (enpMaybeRollback params) $ \slotNo -> @@ -121,7 +123,7 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil metricsSetters trce iomgr - connectionString + dbConnectionSetting (void . runMigration) syncNodeConfigFromFile params @@ -148,14 +150,15 @@ runSyncNode :: MetricSetters -> Trace IO Text -> IOManager -> - ConnectionString -> + -- | Database connection settings + HsqlSet.Setting -> -- | run migration function RunMigration -> SyncNodeConfig -> SyncNodeParams -> SyncOptions -> IO () -runSyncNode metricsSetters trce iomgr dbConnString runMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do +runSyncNode metricsSetters trce iomgr dbConnSetting runMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do whenJust maybeLedgerDir $ \enpLedgerStateDir -> do createDirectoryIfMissing True (unLedgerStateDir enpLedgerStateDir) @@ -164,19 +167,21 @@ runSyncNode metricsSetters trce iomgr dbConnString runMigrationFnc syncNodeConfi logInfo trce $ "Using alonzo genesis file from: " <> (show . unGenesisFile $ dncAlonzoGenesisFile syncNodeConfigFromFile) let useLedger = shouldUseLedger (sioLedger $ dncInsertOptions syncNodeConfigFromFile) - - Db.runIohkLogging trce $ - withPostgresqlConn dbConnString $ - \backend -> liftIO $ do + -- Our main thread + bracket + (runOrThrowIO $ HsqlC.acquire [dbConnSetting]) + release + (\dbConn -> do runOrThrowIO $ runExceptT $ do + let dbEnv = Db.DbEnv dbConn (dncEnableDbLogging syncNodeConfigFromFile) genCfg <- readCardanoGenesisConfig syncNodeConfigFromFile - isJsonbInSchema <- queryIsJsonbInSchema backend + isJsonbInSchema <- queryIsJsonbInSchema dbEnv logProtocolMagicId trce $ genesisProtocolMagicId genCfg syncEnv <- ExceptT $ mkSyncEnvFromConfig trce - backend + dbEnv dbConnString syncOptions genCfg @@ -196,7 +201,7 @@ runSyncNode metricsSetters trce iomgr dbConnString runMigrationFnc syncNodeConfi liftIO $ runExtraMigrationsMaybe syncEnv unless useLedger $ liftIO $ do logInfo trce "Migrating to a no ledger schema" - Db.noLedgerMigrations backend trce + Db.noLedgerMigrations pool trce insertValidateGenesisDist syncEnv (dncNetworkName syncNodeConfigFromFile) genCfg (useShelleyInit syncNodeConfigFromFile) -- communication channel between datalayer thread and chainsync-client thread diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index a24f1baae..86ad78a2b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -84,6 +84,7 @@ import qualified Data.Strict.Maybe as Strict import Data.Time.Clock (getCurrentTime) import Database.Persist.Postgresql (ConnectionString) import Database.Persist.Sql (SqlBackend) +import qualified Hasql.Connection as HqlC import Ouroboros.Consensus.Block.Abstract (BlockProtocol, HeaderHash, Point (..), fromRawHash) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..)) import Ouroboros.Consensus.Config (SecurityParam (..), TopLevelConfig, configSecurityParam) @@ -118,7 +119,7 @@ getIsConsumedFixed env = where txOutTableType = getTxOutTableType env pcm = soptPruneConsumeMigration $ envOptions env - backend = envBackend env + backend = envDbEnv env getDisableInOutState :: SyncEnv -> IO Bool getDisableInOutState syncEnv = do @@ -155,7 +156,7 @@ runExtraMigrationsMaybe syncEnv = do let pcm = getPruneConsume syncEnv txOutTableType = getTxOutTableType syncEnv logInfo (getTrace syncEnv) $ "runExtraMigrationsMaybe: " <> textShow pcm - DB.runDbIohkNoLogging (envBackend syncEnv) $ + DB.runDbIohkNoLogging (envDbEnv syncEnv) $ DB.runExtraMigrations (getTrace syncEnv) txOutTableType @@ -164,11 +165,17 @@ runExtraMigrationsMaybe syncEnv = do runAddJsonbToSchema :: SyncEnv -> IO () runAddJsonbToSchema syncEnv = - void $ DB.runDbIohkNoLogging (envBackend syncEnv) DB.enableJsonbInSchema - -runRemoveJsonbFromSchema :: SyncEnv -> IO () -runRemoveJsonbFromSchema syncEnv = - void $ DB.runDbIohkNoLogging (envBackend syncEnv) DB.disableJsonbInSchema + void $ DB.runDbIohkNoLogging (envDbEnv syncEnv) DB.enableJsonbInSchema + +runRemoveJsonbFromSchema :: + (MonadIO m, AsDbError e) => + SyncEnv -> + DbAction e m () +runRemoveJsonbFromSchema syncEnv = do + DB.runDbT DB.Write transx + where + dbEnv = envDbEnv syncEnv + transx = mkDbTransaction "runRemoveJsonbFromSchema" mkCallSite (DB.disableJsonbInSchema (dbConnection dbEnv)) getSafeBlockNoDiff :: SyncEnv -> Word64 getSafeBlockNoDiff syncEnv = 2 * getSecurityParam syncEnv @@ -278,12 +285,12 @@ getDbLatestBlockInfo backend = do getDbTipBlockNo :: SyncEnv -> IO (Point.WithOrigin BlockNo) getDbTipBlockNo env = do - mblk <- getDbLatestBlockInfo (envBackend env) + mblk <- getDbLatestBlockInfo (envDbEnv env) pure $ maybe Point.Origin (Point.At . bBlockNo) mblk logDbState :: SyncEnv -> IO () logDbState env = do - mblk <- getDbLatestBlockInfo (envBackend env) + mblk <- getDbLatestBlockInfo (envDbEnv env) case mblk of Nothing -> logInfo tracer "Database is empty" Just tip -> logInfo tracer $ mconcat ["Database tip is at ", showTip tip] @@ -302,14 +309,66 @@ logDbState env = do getCurrentTipBlockNo :: SyncEnv -> IO (WithOrigin BlockNo) getCurrentTipBlockNo env = do - maybeTip <- getDbLatestBlockInfo (envBackend env) + maybeTip <- getDbLatestBlockInfo (envDbEnv env) case maybeTip of Just tip -> pure $ At (bBlockNo tip) Nothing -> pure Origin +mkSyncEnvFromConfig :: + Trace IO Text -> + Db.DbEnv -> + ConnectionString -> + SyncOptions -> + GenesisConfig -> + SyncNodeConfig -> + SyncNodeParams -> + -- | migrations were ran on startup + Bool -> + -- | run migration function + RunMigration -> + IO (Either SyncNodeError SyncEnv) +mkSyncEnvFromConfig trce dbEnv connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams ranMigration runMigrationFnc = + case genCfg of + GenesisCardano _ bCfg sCfg _ _ + | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) -> + pure + . Left + . SNErrCardanoConfig + $ mconcat + [ "ProtocolMagicId " + , textShow (unProtocolMagicId $ Byron.configProtocolMagicId bCfg) + , " /= " + , textShow (Shelley.sgNetworkMagic $ scConfig sCfg) + ] + | Byron.gdStartTime (Byron.configGenesisData bCfg) /= Shelley.sgSystemStart (scConfig sCfg) -> + pure + . Left + . SNErrCardanoConfig + $ mconcat + [ "SystemStart " + , textShow (Byron.gdStartTime $ Byron.configGenesisData bCfg) + , " /= " + , textShow (Shelley.sgSystemStart $ scConfig sCfg) + ] + | otherwise -> + Right + <$> mkSyncEnv + trce + dbEnv + connectionString + syncOptions + (fst $ mkProtocolInfoCardano genCfg []) + (Shelley.sgNetworkId $ scConfig sCfg) + (NetworkMagic . unProtocolMagicId $ Byron.configProtocolMagicId bCfg) + (SystemStart . Byron.gdStartTime $ Byron.configGenesisData bCfg) + syncNodeConfigFromFile + syncNodeParams + ranMigration + runMigrationFnc + mkSyncEnv :: Trace IO Text -> - SqlBackend -> + Db.DbEnv -> ConnectionString -> SyncOptions -> ProtocolInfo CardanoBlock -> @@ -320,7 +379,7 @@ mkSyncEnv :: SyncNodeParams -> RunMigration -> IO SyncEnv -mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runMigrationFnc = do +mkSyncEnv trce dbEnv connectionString syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runMigrationFnc = do dbCNamesVar <- newTVarIO =<< dbConstraintNamesExists backend cache <- if soptCache syncOptions @@ -367,7 +426,7 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS pure $ SyncEnv - { envBackend = backend + { envDbEnv = dbEnv , envBootstrap = bootstrapVar , envCache = cache , envConnectionString = connectionString @@ -393,7 +452,7 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS mkSyncEnvFromConfig :: Trace IO Text -> - SqlBackend -> + Pool -> ConnectionString -> SyncOptions -> GenesisConfig -> @@ -402,7 +461,7 @@ mkSyncEnvFromConfig :: -- | run migration function RunMigration -> IO (Either SyncNodeError SyncEnv) -mkSyncEnvFromConfig trce backend connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams runMigrationFnc = +mkSyncEnvFromConfig trce dbPool connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams ranMigration runMigrationFnc = case genCfg of GenesisCardano _ bCfg sCfg _ _ | unProtocolMagicId (Byron.configProtocolMagicId bCfg) /= Shelley.sgNetworkMagic (scConfig sCfg) -> @@ -429,7 +488,7 @@ mkSyncEnvFromConfig trce backend connectionString syncOptions genCfg syncNodeCon Right <$> mkSyncEnv trce - backend + dbPool connectionString syncOptions (fst $ mkProtocolInfoCardano genCfg []) @@ -449,7 +508,7 @@ getLatestPoints env = do verifySnapshotPoint env snapshotPoints NoLedger _ -> do -- Brings the 5 latest. - lastPoints <- DB.runDbIohkNoLogging (envBackend env) DB.queryLatestPoints + lastPoints <- DB.runDbIohkNoLogging (envDbEnv env) DB.queryLatestPoints pure $ mapMaybe convert lastPoints where convert (Nothing, _) = Nothing @@ -461,7 +520,7 @@ verifySnapshotPoint env snapPoints = where validLedgerFileToPoint :: SnapshotPoint -> IO (Maybe (CardanoPoint, Bool)) validLedgerFileToPoint (OnDisk lsf) = do - hashes <- getSlotHash (envBackend env) (lsfSlotNo lsf) + hashes <- getSlotHash (envDbEnv env) (lsfSlotNo lsf) let valid = find (\(_, h) -> lsfHash lsf == hashToAnnotation h) hashes case valid of Just (slot, hash) | slot == lsfSlotNo lsf -> pure $ convertToDiskPoint slot hash @@ -470,7 +529,7 @@ verifySnapshotPoint env snapPoints = case pnt of GenesisPoint -> pure Nothing BlockPoint slotNo hsh -> do - hashes <- getSlotHash (envBackend env) slotNo + hashes <- getSlotHash (envDbEnv env) slotNo let valid = find (\(_, dbHash) -> getHeaderHash hsh == dbHash) hashes case valid of Just (dbSlotNo, _) | slotNo == dbSlotNo -> pure $ Just (pnt, True) diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs index cb10af966..2d0a0b006 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs @@ -32,12 +32,12 @@ import Control.Concurrent.Class.MonadSTM.Strict.TBQueue (StrictTBQueue) import qualified Data.Strict.Maybe as Strict import Data.Time.Clock (UTCTime) import Database.Persist.Postgresql (ConnectionString) -import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..)) import Ouroboros.Network.Magic (NetworkMagic (..)) + data SyncEnv = SyncEnv - { envBackend :: !SqlBackend + { envDbEnv :: !!DB.DbEnv , envCache :: !CacheStatus , envConnectionString :: !ConnectionString , envConsistentLevel :: !(StrictTVar IO ConsistentLevel) diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache.hs b/cardano-db-sync/src/Cardano/DbSync/Cache.hs index 36c8315fd..95a0c4046 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache.hs @@ -32,7 +32,7 @@ module Cardano.DbSync.Cache ( import Cardano.BM.Trace import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Variant.TxOut as V +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V import Cardano.DbSync.Cache.Epoch (rollbackMapEpochInCache) import qualified Cardano.DbSync.Cache.FIFO as FIFO import qualified Cardano.DbSync.Cache.LRU as LRU diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs index 9c060f907..71293c371 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs @@ -31,7 +31,7 @@ module Cardano.DbSync.Cache.Types ( ) where import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Variant.TxOut as V +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V import Cardano.DbSync.Cache.FIFO (FIFOCache) import qualified Cardano.DbSync.Cache.FIFO as FIFO import Cardano.DbSync.Cache.LRU (LRUCache) diff --git a/cardano-db-sync/src/Cardano/DbSync/Config.hs b/cardano-db-sync/src/Cardano/DbSync/Config.hs index f38e65307..389c377ff 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config.hs @@ -67,6 +67,7 @@ coalesceConfig pcfg ncfg adjustGenesisPath = do , dncProtocol = ncProtocol ncfg , dncRequiresNetworkMagic = ncRequiresNetworkMagic ncfg , dncEnableLogging = pcEnableLogging pcfg + , dncEnableDbLogging = pcEnableDbLogging pcfg , dncEnableMetrics = pcEnableMetrics pcfg , dncPrometheusPort = pcPrometheusPort pcfg , dncPBftSignatureThreshold = ncPBftSignatureThreshold ncfg diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index 333405a7e..03ebef05a 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -123,6 +123,7 @@ data SyncNodeConfig = SyncNodeConfig , dncProtocol :: !SyncProtocol , dncRequiresNetworkMagic :: !RequiresNetworkMagic , dncEnableLogging :: !Bool + , dncEnableDbLogging :: !Bool , dncEnableMetrics :: !Bool , dncPrometheusPort :: !Int , dncPBftSignatureThreshold :: !(Maybe Double) @@ -151,6 +152,7 @@ data SyncPreConfig = SyncPreConfig , pcNodeConfigFile :: !NodeConfigFile , pcEnableFutureGenesis :: !Bool , pcEnableLogging :: !Bool + , pcEnableDbLogging :: !Bool , pcEnableMetrics :: !Bool , pcPrometheusPort :: !Int , pcInsertConfig :: !SyncInsertConfig @@ -384,7 +386,7 @@ isPlutusEnabled PlutusDisable = False isPlutusEnabled PlutusEnable = True isPlutusEnabled (PlutusScripts _) = True --- ------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- instance FromJSON SyncPreConfig where parseJSON = @@ -398,6 +400,7 @@ parseGenSyncNodeConfig o = <*> fmap NodeConfigFile (o .: "NodeConfigFile") <*> fmap (fromMaybe True) (o .:? "EnableFutureGenesis") <*> o .: "EnableLogging" + <*> fmap (fromMaybe False) (o .:? "EnableDbLogging") <*> o .: "EnableLogMetrics" <*> fmap (fromMaybe 8080) (o .:? "PrometheusPort") <*> o .:? "insert_options" .!= def @@ -451,6 +454,7 @@ parseOverrides obj baseOptions = do <*> obj .:? "pool_stat" .!= sioPoolStats baseOptions <*> obj .:? "json_type" .!= sioJsonType baseOptions <*> obj .:? "remove_jsonb_from_schema" .!= sioRemoveJsonbFromSchema baseOptions + <*> obj .:? "db_debug" .!= sioDbDebug baseOptions instance ToJSON SyncInsertConfig where toJSON (SyncInsertConfig preset options) = @@ -472,6 +476,7 @@ optionsToList SyncInsertOptions {..} = , toJsonIfSet "pool_stat" sioPoolStats , toJsonIfSet "json_type" sioJsonType , toJsonIfSet "remove_jsonb_from_schema" sioRemoveJsonbFromSchema + , toJsonIfSet "db_debug" sioDbDebug ] toJsonIfSet :: ToJSON a => Text -> a -> Maybe Pair @@ -493,6 +498,7 @@ instance FromJSON SyncInsertOptions where <*> obj .:? "pool_stat" .!= sioPoolStats def <*> obj .:? "json_type" .!= sioJsonType def <*> obj .:? "remove_jsonb_from_schema" .!= sioRemoveJsonbFromSchema def + <*> obj .:? "db_debug" .!= sioDbDebug def instance ToJSON SyncInsertOptions where toJSON SyncInsertOptions {..} = @@ -509,6 +515,7 @@ instance ToJSON SyncInsertOptions where , "pool_stat" .= sioPoolStats , "json_type" .= sioJsonType , "remove_jsonb_from_schema" .= sioRemoveJsonbFromSchema + , "db_debug" .= sioDbDebug ] instance ToJSON RewardsConfig where diff --git a/cardano-db-sync/src/Cardano/DbSync/Database.hs b/cardano-db-sync/src/Cardano/DbSync/Database.hs index 4583b8204..ee6a764b4 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Database.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Database.hs @@ -44,39 +44,97 @@ runDbThread :: ThreadChannels -> IO () runDbThread syncEnv metricsSetters queue = do - logInfo trce "Running DB thread" - logException trce "runDBThread: " loop - logInfo trce "Shutting down DB thread" + logInfo tracer "Starting DB thread" + logException tracer "runDbThread: " processQueue + logInfo tracer "Shutting down DB thread" where - trce = getTrace syncEnv - loop = do - xs <- blockingFlushDbActionQueue queue - - when (length xs > 1) $ do - logDebug trce $ "runDbThread: " <> textShow (length xs) <> " blocks" - - case hasRestart xs of - Nothing -> do - eNextState <- runExceptT $ runActions syncEnv xs - - mBlock <- getDbLatestBlockInfo (envBackend syncEnv) - whenJust mBlock $ \block -> do - setDbBlockHeight metricsSetters $ bBlockNo block - setDbSlotHeight metricsSetters $ bSlotNo block - - case eNextState of - Left err -> logError trce $ show err - Right Continue -> loop - Right Done -> pure () - Just resultVar -> do - -- In this case the syncing thread has restarted, so ignore all blocks that are not - -- inserted yet. - logInfo trce "Chain Sync client thread has restarted" - latestPoints <- getLatestPoints syncEnv - currentTip <- getCurrentTipBlockNo syncEnv - logDbState syncEnv - atomically $ putTMVar resultVar (latestPoints, currentTip) - loop + tracer = getTrace syncEnv + + -- Main loop to process the queue + processQueue :: IO () + processQueue = do + actions <- blockingFlushDbActionQueue queue + + -- Log the number of blocks being processed if there are multiple + when (length actions > 1) $ do + logDebug tracer $ "Processing " <> textShow (length actions) <> " blocks" + + -- Handle the case where the syncing thread has restarted + case hasRestart actions of + Just resultVar -> handleRestart resultVar + Nothing -> processActions actions + + -- Process a list of actions + processActions :: [DbAction] -> IO () + processActions actions = do + result <- runExceptT $ runActions syncEnv actions -- runActions is where we start inserting information we recieve from the node. + + -- Update metrics with the latest block information + updateBlockMetrics + + -- Handle the result of running the actions + case result of + Left err -> logError tracer $ "Error: " <> show err + Right Continue -> processQueue -- Continue processing + Right Done -> pure () -- Stop processing + + -- Handle the case where the syncing thread has restarted + handleRestart :: TMVar (LatestPoints, CurrentTip) -> IO () + handleRestart resultVar = do + logInfo tracer "Chain Sync client thread has restarted" + latestPoints <- getLatestPoints syncEnv + currentTip <- getCurrentTipBlockNo syncEnv + logDbState syncEnv + atomically $ putTMVar resultVar (latestPoints, currentTip) + processQueue -- Continue processing + + -- Update block and slot height metrics + updateBlockMetrics :: IO () + updateBlockMetrics = do + mBlock <- getDbLatestBlockInfo (envDbEnv syncEnv) + whenJust mBlock $ \block -> do + setDbBlockHeight metricsSetters $ bBlockNo block + setDbSlotHeight metricsSetters $ bSlotNo block + +-- runDbThread :: +-- SyncEnv -> +-- MetricSetters -> +-- ThreadChannels -> +-- IO () +-- runDbThread syncEnv metricsSetters queue = do +-- logInfo trce "Running DB thread" +-- logException trce "runDBThread: " loop +-- logInfo trce "Shutting down DB thread" +-- where +-- trce = getTrace syncEnv +-- loop = do +-- xs <- blockingFlushDbActionQueue queue + +-- when (length xs > 1) $ do +-- logDebug trce $ "runDbThread: " <> textShow (length xs) <> " blocks" + +-- case hasRestart xs of +-- Nothing -> do +-- eNextState <- runExceptT $ runActions syncEnv xs + +-- mBlock <- getDbLatestBlockInfo (envDbEnv syncEnv) +-- whenJust mBlock $ \block -> do +-- setDbBlockHeight metricsSetters $ bBlockNo block +-- setDbSlotHeight metricsSetters $ bSlotNo block + +-- case eNextState of +-- Left err -> logError trce $ show err +-- Right Continue -> loop +-- Right Done -> pure () +-- Just resultVar -> do +-- -- In this case the syncing thread has restarted, so ignore all blocks that are not +-- -- inserted yet. +-- logInfo trce "Chain Sync client thread has restarted" +-- latestPoints <- getLatestPoints syncEnv +-- currentTip <- getCurrentTipBlockNo syncEnv +-- logDbState syncEnv +-- atomically $ putTMVar resultVar (latestPoints, currentTip) +-- loop -- | Run the list of 'DbAction's. Block are applied in a single set (as a transaction) -- and other operations are applied one-by-one. @@ -148,7 +206,7 @@ rollbackLedger syncEnv point = -- 'Consistent' Level is correct based on the db tip. validateConsistentLevel :: SyncEnv -> CardanoPoint -> IO () validateConsistentLevel syncEnv stPoint = do - dbTipInfo <- getDbLatestBlockInfo (envBackend syncEnv) + dbTipInfo <- getDbLatestBlockInfo (envDbEnv syncEnv) cLevel <- getConsistentLevel syncEnv compareTips stPoint dbTipInfo cLevel where diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 1703a584d..1d1627e56 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -51,7 +51,7 @@ insertListBlocks :: [CardanoBlock] -> IO (Either SyncNodeError ()) insertListBlocks synEnv blocks = do - DB.runDbIohkLogging (envBackend synEnv) tracer + DB.runDbIohkLogging (envDbEnv synEnv) tracer . runExceptT $ traverse_ (applyAndInsertBlockMaybe synEnv tracer) blocks where diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs index 493f5f4e5..e1be23f73 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs @@ -17,8 +17,8 @@ import qualified Cardano.Chain.Genesis as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto as Crypto import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V +import qualified Cardano.Db.Schema.Variant.TxOutCore as C import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (SyncEnv (..)) import Cardano.DbSync.Cache (insertAddressUsingCache) @@ -49,8 +49,8 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do -- Setting this to True will log all 'Persistent' operations which is great -- for debugging, but otherwise *way* too chatty. if False - then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer insertAction - else newExceptT $ DB.runDbIohkNoLogging (envBackend syncEnv) insertAction + then newExceptT $ DB.runDbIohkLogging (envDbEnv syncEnv) tracer insertAction + else newExceptT $ DB.runDbIohkNoLogging (envDbEnv syncEnv) insertAction where tracer = getTrace syncEnv 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 0cc49a38e..39264227e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -72,8 +72,8 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do liftIO $ logError tracer $ show SNErrIgnoreShelleyInitiation throwError SNErrIgnoreShelleyInitiation if False - then newExceptT $ DB.runDbIohkLogging (envBackend syncEnv) tracer (insertAction prunes) - else newExceptT $ DB.runDbIohkNoLogging (envBackend syncEnv) (insertAction prunes) + then newExceptT $ DB.runDbIohkLogging (envDbEnv syncEnv) tracer (insertAction prunes) + else newExceptT $ DB.runDbIohkNoLogging (envDbEnv syncEnv) (insertAction prunes) where tracer = getTrace syncEnv diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs index 6de4a5362..08e795e4e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs @@ -335,7 +335,7 @@ insertCommitteeHash cred = do insertDrep :: (MonadBaseControl IO m, MonadIO m) => DRep StandardCrypto -> ReaderT SqlBackend m DB.DrepHashId insertDrep = \case DRepCredential cred -> insertCredDrepHash cred - DRepAlwaysAbstain -> DB.insertAlwaysAbstainDrep + DRepAlwaysAbstain -> DB.insertDrepHashAlwaysAbstain DRepAlwaysNoConfidence -> DB.insertAlwaysNoConfidence insertCredDrepHash :: (MonadBaseControl IO m, MonadIO m) => Ledger.Credential 'DRepRole StandardCrypto -> ReaderT SqlBackend m DB.DrepHashId diff --git a/cardano-db-sync/src/Cardano/DbSync/Error.hs b/cardano-db-sync/src/Cardano/DbSync/Error.hs index e01a3d3ba..eb28771e9 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Error.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Error.hs @@ -23,6 +23,7 @@ import Cardano.BM.Trace (Trace, logError) import qualified Cardano.Chain.Genesis as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto as Crypto (serializeCborHash) +import qualified Cardano.Db as DB import qualified Cardano.DbSync.Era.Byron.Util as Byron import Cardano.DbSync.Util import Cardano.Prelude @@ -41,6 +42,7 @@ data SyncInvariant data SyncNodeError = SNErrDefault !Text + | SNErrDatabase !DB.DbError | SNErrInvariant !Text !SyncInvariant | SNEErrBlockMismatch !Word64 !ByteString !ByteString | SNErrIgnoreShelleyInitiation @@ -65,6 +67,7 @@ instance Show SyncNodeError where show = \case SNErrDefault t -> "Error SNErrDefault: " <> show t + SNErrDatabase err -> "Error SNErrDatabase: " <> show err SNErrInvariant loc i -> "Error SNErrInvariant: " <> Show.show loc <> ": " <> show (renderSyncInvariant i) SNEErrBlockMismatch blkNo hashDb hashBlk -> mconcat diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain.hs index b89201791..4e7193de3 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain.hs @@ -148,8 +148,8 @@ insertOffChainVoteResults trce resultQueue = do void $ DB.insertOffChainVoteGovActionData ocvga whenJust (offChainVoteDrep accessors ocvdId) $ \ocvdr -> void $ DB.insertOffChainVoteDrepData ocvdr - DB.insertOffChainVoteAuthors $ offChainVoteAuthors accessors ocvdId - DB.insertOffChainVoteReference $ offChainVoteReferences accessors ocvdId + DB.insertManyOffChainVoteAuthors $ offChainVoteAuthors accessors ocvdId + DB.insertManyOffChainVoteReference $ offChainVoteReferences accessors ocvdId DB.insertOffChainVoteExternalUpdate $ offChainVoteExternalUpdates accessors ocvdId OffChainVoteResultError fe -> void $ DB.insertOffChainVoteFetchError fe diff --git a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs index 9124bae6d..573611b72 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs @@ -65,7 +65,7 @@ rollbackFromBlockNo syncEnv blkNo = do prepareRollback :: SyncEnv -> CardanoPoint -> Tip CardanoBlock -> IO (Either SyncNodeError Bool) prepareRollback syncEnv point serverTip = - DB.runDbIohkNoLogging (envBackend syncEnv) $ runExceptT action + DB.runDbIohkNoLogging (envDbEnv syncEnv) $ runExceptT action where trce = getTrace syncEnv diff --git a/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs b/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs index af266a6e2..356774e1d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs @@ -37,13 +37,13 @@ constraintNameReward = ConstraintNameDB "unique_reward" -- We manually create unique constraints to improve insert speeds when syncing -- This function checks if those constraints have already been created -dbConstraintNamesExists :: MonadIO m => SqlBackend -> m ManualDbConstraints -dbConstraintNamesExists sqlBackend = do +dbConstraintNamesExists :: MonadIO m => DB.DbEnv -> m ManualDbConstraints +dbConstraintNamesExists dbEnv = do runReaderT queryRewardAndEpochStakeConstraints sqlBackend -queryIsJsonbInSchema :: MonadIO m => SqlBackend -> m Bool -queryIsJsonbInSchema sqlBackend = do - runReaderT DB.queryJsonbInSchemaExists sqlBackend +queryIsJsonbInSchema :: MonadIO m => DB.DbEnv -> m Bool +queryIsJsonbInSchema dbEnv = do + runReaderT DB.queryJsonbInSchemaExists dbEnv queryRewardAndEpochStakeConstraints :: MonadIO m => diff --git a/cardano-db-sync/test/Cardano/DbSync/Gen.hs b/cardano-db-sync/test/Cardano/DbSync/Gen.hs index 2fbbdb406..dd670baaf 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Gen.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Gen.hs @@ -54,6 +54,7 @@ syncPreConfig = <*> Gen.bool <*> Gen.bool <*> Gen.bool + <*> Gen.bool <*> Gen.int (Range.linear 0 10000) <*> syncInsertConfig <*> Gen.list (Range.linear 0 10) (Gen.text (Range.linear 0 100) Gen.unicode) diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs index d229f045e..536647697 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs @@ -11,8 +11,8 @@ module Cardano.DbTool.Validate.TxAccounting ( ) where import Cardano.Db -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V +import qualified Cardano.Db.Schema.Variant.TxOutAddress as V +import qualified Cardano.Db.Schema.Variant.TxOutCore as C import Cardano.DbTool.Validate.Util import Control.Monad (replicateM, when) import Control.Monad.IO.Class (MonadIO, liftIO) diff --git a/cardano-db/app/gen-schema-docs.hs b/cardano-db/app/gen-schema-docs.hs index 3f9cd7bd0..e6a68d1ef 100644 --- a/cardano-db/app/gen-schema-docs.hs +++ b/cardano-db/app/gen-schema-docs.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} import Cardano.Db (schemaDocs) -import Cardano.Db.Schema.Core.TxOut (schemaDocsTxOutCore) -import Cardano.Db.Schema.Variant.TxOut (schemaDocsTxOutVariant) +import Cardano.Db.Schema.Variants.TxOutAddress (schemaDocsTxOutVariant) +import Cardano.Db.Schema.Variants.TxOutCore (schemaDocsTxOutCore) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text diff --git a/cardano-db/cardano-db.cabal b/cardano-db/cardano-db.cabal index d8afa1a33..dd3f6f028 100644 --- a/cardano-db/cardano-db.cabal +++ b/cardano-db/cardano-db.cabal @@ -30,8 +30,8 @@ library -Wunused-packages exposed-modules: Cardano.Db - Cardano.Db.Schema.Core.TxOut - Cardano.Db.Schema.Variant.TxOut + Cardano.Db.Schema.Core + Cardano.Db.Schema.Variants other-modules: Cardano.Db.Error Cardano.Db.Git.RevFromGit @@ -53,9 +53,34 @@ library Cardano.Db.Operations.TxOut.TxOutQuery Cardano.Db.PGConfig Cardano.Db.Run - Cardano.Db.Schema.BaseSchema + Cardano.Db.Schema.Core.Base + Cardano.Db.Schema.Core.EpochAndProtocol + Cardano.Db.Schema.Core.GovernanceAndVoting + Cardano.Db.Schema.Core.MultiAsset + Cardano.Db.Schema.Core.OffChain + Cardano.Db.Schema.Core.Pool + Cardano.Db.Schema.Core.StakeDeligation + Cardano.Db.Schema.Ids Cardano.Db.Schema.Orphans Cardano.Db.Schema.Types + Cardano.Db.Schema.Variants.TxOutAddress + Cardano.Db.Schema.Variants.TxOutCore + Cardano.Db.Schema.Variants.TxOutUtxoHd + Cardano.Db.Schema.Variants.TxOutUtxoHdAddress + Cardano.Db.Statement + Cardano.Db.Statement.Function.Core + Cardano.Db.Statement.Function.Delete + Cardano.Db.Statement.Function.Query + Cardano.Db.Statement.Function.Insert + Cardano.Db.Statement.Base + Cardano.Db.Statement.EpochAndProtocol + Cardano.Db.Statement.GovernanceAndVoting + Cardano.Db.Statement.MultiAsset + Cardano.Db.Statement.OffChain + Cardano.Db.Statement.Pool + Cardano.Db.Statement.StakeDeligation + Cardano.Db.Statement.Types + Cardano.Db.Statement.Variants.TxOut Cardano.Db.Types build-depends: aeson @@ -70,20 +95,20 @@ library , containers , conduit-extra , contra-tracer + , contravariant-extras , cryptonite , directory - , esqueleto , extra , fast-logger , filepath , file-embed + , hasql , iohk-monitoring , lifted-base , memory , monad-control , monad-logger , persistent - , persistent-documentation , persistent-postgresql , postgresql-simple , process diff --git a/cardano-db/src/Cardano/Db.hs b/cardano-db/src/Cardano/Db.hs index 630df6f2a..a3ff9b6e6 100644 --- a/cardano-db/src/Cardano/Db.hs +++ b/cardano-db/src/Cardano/Db.hs @@ -13,19 +13,10 @@ import Cardano.Db.Git.Version (gitRev) import Cardano.Db.Migration as X import Cardano.Db.Migration.Version as X import Cardano.Db.Operations.AlterTable as X -import Cardano.Db.Operations.Delete as X -import Cardano.Db.Operations.Insert as X -import Cardano.Db.Operations.Other.ConsumedTxOut as X -import Cardano.Db.Operations.Other.JsonbQuery as X -import Cardano.Db.Operations.Other.MinId as X -import Cardano.Db.Operations.Query as X -import Cardano.Db.Operations.QueryHelper as X -import Cardano.Db.Operations.TxOut.TxOutDelete as X -import Cardano.Db.Operations.TxOut.TxOutInsert as X -import Cardano.Db.Operations.TxOut.TxOutQuery as X -import Cardano.Db.Operations.Types as X import Cardano.Db.PGConfig as X import Cardano.Db.Run as X -import Cardano.Db.Schema.BaseSchema as X +import Cardano.Db.Schema.Core as X import Cardano.Db.Schema.Types as X +import Cardano.Db.Schema.Variants as X +import Cardano.Db.Statement as X import Cardano.Db.Types as X diff --git a/cardano-db/src/Cardano/Db/Error.hs b/cardano-db/src/Cardano/Db/Error.hs index b98f6bd92..df9271bfe 100644 --- a/cardano-db/src/Cardano/Db/Error.hs +++ b/cardano-db/src/Cardano/Db/Error.hs @@ -1,63 +1,95 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Cardano.Db.Error ( - LookupFail (..), + -- AsDbError (..), + CallSite (..), + DbError (..), runOrThrowIODb, + runOrThrowIO, logAndThrowIO, + base16encode, ) where import Cardano.BM.Trace (Trace, logError) -import Cardano.Db.Schema.BaseSchema -import Cardano.Prelude (throwIO) +import Cardano.Prelude (MonadIO, throwIO) import Control.Exception (Exception) import qualified Data.ByteString.Base16 as Base16 import Data.ByteString.Char8 (ByteString) import Data.Text (Text) import qualified Data.Text.Encoding as Text -import Data.Word (Word16, Word64) -import GHC.Generics (Generic) - -data LookupFail - = DbLookupBlockHash !ByteString - | DbLookupBlockId !Word64 - | DbLookupMessage !Text - | DbLookupTxHash !ByteString - | DbLookupTxOutPair !ByteString !Word16 - | DbLookupEpochNo !Word64 - | DbLookupSlotNo !Word64 - | DbLookupGovActionPair !TxId !Word64 - | DbMetaEmpty - | DbMetaMultipleRows - | DBMultipleGenesis - | DBExtraMigration !String - | DBPruneConsumed !String - | DBRJsonbInSchema !String - | DBTxOutVariant !String - deriving (Eq, Generic) - -instance Exception LookupFail - -instance Show LookupFail where - show = - \case - DbLookupBlockHash h -> "The block hash " <> show (base16encode h) <> " is missing from the DB." - DbLookupBlockId blkid -> "block id " <> show blkid - DbLookupMessage txt -> show txt - DbLookupTxHash h -> "tx hash " <> show (base16encode h) - DbLookupTxOutPair h i -> concat ["tx out pair (", show $ base16encode h, ", ", show i, ")"] - DbLookupEpochNo e -> "epoch number " ++ show e - DbLookupSlotNo s -> "slot number " ++ show s - DbLookupGovActionPair txId index -> concat ["missing GovAction (", show txId, ", ", show index, ")"] - DbMetaEmpty -> "Meta table is empty" - DbMetaMultipleRows -> "Multiple rows in Meta table which should only contain one" - DBMultipleGenesis -> "Multiple Genesis blocks found. These are blocks without an EpochNo" - DBExtraMigration e -> "DBExtraMigration : " <> e - DBPruneConsumed e -> "DBExtraMigration" <> e - DBRJsonbInSchema e -> "DBRJsonbInSchema" <> e - DBTxOutVariant e -> "DbTxOutVariant" <> e + +import qualified Hasql.Session as HsqlSes + +data DbError = DbError + { dbErrorCallSite :: !CallSite + , dbErrorMessage :: !Text + , dbErrorCause :: !(Maybe HsqlSes.SessionError) -- Now a Maybe + } + deriving (Show, Eq) + +instance Exception DbError + +-- class AsDbError e where +-- toDbError :: DbError -> e +-- fromDbError :: e -> Maybe DbError + +-- data DbError +-- = DbError !CallSite !Text !HsqlS.SessionError +-- | DbLookupError !CallSite !Text !LookupContext +-- deriving (Show, Eq) + +-- instance Exception DbError + +data CallSite = CallSite + { csModule :: !Text + , csFile :: !Text + , csLine :: !Int + } + deriving (Show, Eq) + +-- data LookupContext +-- = BlockHashContext !ByteString +-- | BlockIdContext !Word64 +-- | MessageContext !Text +-- | TxHashContext !ByteString +-- | TxOutPairContext !ByteString !Word16 +-- | EpochNoContext !Word64 +-- | SlotNoContext !Word64 +-- | GovActionPairContext !TxId !Word64 +-- | MetaEmptyContext +-- | MetaMultipleRowsContext +-- | MultipleGenesisContext +-- | ExtraMigrationContext !String +-- | PruneConsumedContext !String +-- | RJsonbInSchemaContext !String +-- | TxOutVariantContext !String +-- deriving (Show, Eq, Generic) + +-- instance Exception LookupContext + +-- catchDbError :: String -> HsqlT.Transaction a -> HsqlT.Transaction a +-- catchDbError context action = +-- action `catch` \e -> +-- throwError $ DbError $ context ++ ": " ++ show e + +-- instance Show LookupFail where +-- show = +-- \case +-- DbLookupBlockHash h -> "The block hash " <> show (base16encode h) <> " is missing from the DB." +-- DbLookupBlockId blkid -> "block id " <> show blkid +-- DbLookupMessage txt -> show txt +-- DbLookupTxHash h -> "tx hash " <> show (base16encode h) +-- DbLookupTxOutPair h i -> concat ["tx out pair (", show $ base16encode h, ", ", show i, ")"] +-- DbLookupEpochNo e -> "epoch number " ++ show e +-- DbLookupSlotNo s -> "slot number " ++ show s +-- DbLookupGovActionPair txId index -> concat ["missing GovAction (", show txId, ", ", show index, ")"] +-- DbMetaEmpty -> "Meta table is empty" +-- DbMetaMultipleRows -> "Multiple rows in Meta table which should only contain one" +-- DBMultipleGenesis -> "Multiple Genesis blocks found. These are blocks without an EpochNo" +-- DBExtraMigration e -> "DBExtraMigration : " <> e +-- DBPruneConsumed e -> "DBExtraMigration" <> e +-- DBRJsonbInSchema e -> "DBRJsonbInSchema" <> e +-- DBTxOutVariant e -> "DbTxOutVariant" <> e base16encode :: ByteString -> Text base16encode = Text.decodeUtf8 . Base16.encode @@ -69,6 +101,13 @@ runOrThrowIODb ioEither = do Left err -> throwIO err Right a -> pure a +runOrThrowIO :: forall e a m. (MonadIO m) => (Exception e) => m (Either e a) -> m a +runOrThrowIO ioEither = do + et <- ioEither + case et of + Left err -> throwIO err + Right a -> pure a + logAndThrowIO :: Trace IO Text -> Text -> IO a logAndThrowIO tracer msg = do logError tracer msg diff --git a/cardano-db/src/Cardano/Db/Migration.hs b/cardano-db/src/Cardano/Db/Migration.hs index be65062c1..e56d155fb 100644 --- a/cardano-db/src/Cardano/Db/Migration.hs +++ b/cardano-db/src/Cardano/Db/Migration.hs @@ -24,23 +24,11 @@ module Cardano.Db.Migration ( queryPgIndexesCount, ) where -import Cardano.BM.Trace (Trace) -import Cardano.Crypto.Hash (Blake2b_256, ByteString, Hash, hashToStringAsHex, hashWith) -import Cardano.Db.Migration.Haskell -import Cardano.Db.Migration.Version -import Cardano.Db.Operations.Query -import Cardano.Db.Operations.Types (TxOutTableType (..)) -import Cardano.Db.PGConfig -import Cardano.Db.Run -import Cardano.Db.Schema.BaseSchema -import Cardano.Db.Schema.Core.TxOut (migrateCoreTxOutCardanoDb) -import Cardano.Db.Schema.Variant.TxOut (migrateVariantAddressCardanoDb) import Cardano.Prelude (Typeable, textShow) import Control.Exception (Exception, SomeException, handle) import Control.Monad.Extra import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString.Char8 as BS import Data.Char (isDigit) @@ -50,22 +38,15 @@ import Data.Either (partitionEithers) import Data.List ((\\)) import qualified Data.List as List import Data.Maybe (fromMaybe) -import Data.Text (Text, intercalate, pack) import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import qualified Data.Text.Encoding as TextEnc import Data.Time.Clock (getCurrentTime) import Data.Time.Format.ISO8601 -import Database.Persist.Sql ( - Single (..), - SqlBackend, - SqlPersistT, - entityVal, - getMigration, - rawExecute, - rawSql, - selectFirst, - ) import GHC.Word (Word64) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlS +import qualified Hasql.Statement as HsqlStm import System.Directory (listDirectory) import System.Exit (ExitCode (..), exitFailure) import System.FilePath (takeExtension, takeFileName, ()) @@ -80,6 +61,16 @@ import System.IO ( ) import Text.Read (readMaybe) +import Cardano.BM.Trace (Trace) +import Cardano.Crypto.Hash (Blake2b_256, ByteString, Hash, hashToStringAsHex, hashWith) +import Cardano.Db.Migration.Haskell +import Cardano.Db.Migration.Version +import Cardano.Db.PGConfig +import Cardano.Db.Run +import Cardano.Db.Schema.Variants (TxOutTableType) +import qualified Cardano.Db.Statement.Function.Core as DB +import qualified Cardano.Db.Types as DB + newtype MigrationDir = MigrationDir FilePath deriving (Show) @@ -88,14 +79,14 @@ newtype LogFileDir = LogFileDir FilePath data MigrationValidate = MigrationValidate - { mvHash :: Text - , mvFilepath :: Text + { mvHash :: !Text.Text + , mvFilepath :: !Text.Text } deriving (Eq, Show) data MigrationValidateError = UnknownMigrationsFound - { missingMigrations :: [MigrationValidate] - , extraMigrations :: [MigrationValidate] + { missingMigrations :: ![MigrationValidate] + , extraMigrations :: ![MigrationValidate] } deriving (Eq, Show, Typeable) @@ -158,7 +149,7 @@ runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutTableType = do TxOutVariantAddress -> mvStage mv == 4 && mvVersion mv > 1 -- Build hash for each file found in a directory. -validateMigrations :: MigrationDir -> [(Text, Text)] -> IO (Maybe (MigrationValidateError, Bool)) +validateMigrations :: MigrationDir -> [(Text.Text, Text.Text)] -> IO (Maybe (MigrationValidateError, Bool)) validateMigrations migrationDir knownMigrations = do let knownMigs = uncurry MigrationValidate <$> knownMigrations scripts <- filter (isOfficialMigrationFile . Text.unpack . mvFilepath) <$> liftIO (hashMigrations migrationDir) @@ -185,12 +176,12 @@ applyMigration (MigrationDir location) quiet pgconfig mLogFilename logHandle (ve let command = List.unwords [ "psql" - , BS.unpack (pgcDbname pgconfig) + , Text.unpack (pgcDbname pgconfig) , "--no-password" , "--quiet" - , "--username=" <> BS.unpack (pgcUser pgconfig) - , "--host=" <> BS.unpack (pgcHost pgconfig) - , "--port=" <> BS.unpack (pgcPort pgconfig) + , "--username=" <> Text.unpack (pgcUser pgconfig) + , "--host=" <> Text.unpack (pgcHost pgconfig) + , "--port=" <> Text.unpack (pgcPort pgconfig) , "--no-psqlrc" -- Ignore the ~/.psqlrc file. , "--single-transaction" -- Run the file as a transaction. , "--set ON_ERROR_STOP=on" -- Exit with non-zero on error. @@ -220,90 +211,58 @@ applyMigration (MigrationDir location) quiet pgconfig mLogFilename logHandle (ve Just logFilename -> putStrLn $ "\nErrors in file: " ++ logFilename ++ "\n" exitFailure --- | Create a database migration (using functionality built into Persistent). If no --- migration is needed return 'Nothing' otherwise return the migration as 'Text'. +-- | Create a database migration. +-- NOTE: This functionality will need to be reimplemented without Persistent. +-- For now, this serves as a placeholder. createMigration :: PGPassSource -> MigrationDir -> TxOutTableType -> IO (Maybe FilePath) -createMigration source (MigrationDir migdir) txOutTableType = do - mt <- runDbNoLogging source create - case mt of - Nothing -> pure Nothing - Just (ver, mig) -> do - let fname = renderMigrationVersionFile ver - Text.writeFile (migdir fname) mig - pure $ Just fname - where - create :: ReaderT SqlBackend (NoLoggingT IO) (Maybe (MigrationVersion, Text)) - create = do - ver <- getSchemaVersion - statementsBase <- getMigration migrateBaseCardanoDb - -- handle what type of migration to generate - statements <- - case txOutTableType of - TxOutCore -> do - statementsTxOut <- getMigration migrateCoreTxOutCardanoDb - pure $ statementsBase <> statementsTxOut - TxOutVariantAddress -> do - statementsTxOut <- getMigration migrateVariantAddressCardanoDb - pure $ statementsBase <> statementsTxOut - if null statements - then pure Nothing - else do - nextVer <- liftIO $ nextMigrationVersion ver - pure $ Just (nextVer, genScript statements (mvVersion nextVer)) - - genScript :: [Text] -> Int -> Text - genScript statements next_version = - Text.concat $ - [ "-- Persistent generated migration.\n\n" - , "CREATE FUNCTION migrate() RETURNS void AS $$\n" - , "DECLARE\n" - , " next_version int ;\n" - , "BEGIN\n" - , " SELECT stage_two + 1 INTO next_version FROM schema_version ;\n" - , " IF next_version = " <> textShow next_version <> " THEN\n" - ] - ++ concatMap buildStatement statements - ++ [ " -- Hand written SQL statements can be added here.\n" - , " UPDATE schema_version SET stage_two = next_version ;\n" - , " RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ;\n" - , " END IF ;\n" - , "END ;\n" - , "$$ LANGUAGE plpgsql ;\n\n" - , "SELECT migrate() ;\n\n" - , "DROP FUNCTION migrate() ;\n" - ] - - buildStatement :: Text -> [Text] - buildStatement sql = [" EXECUTE '", sql, "' ;\n"] - - getSchemaVersion :: SqlPersistT (NoLoggingT IO) MigrationVersion - getSchemaVersion = do - res <- selectFirst [] [] - case res of - Nothing -> error "getSchemaVersion failed!" - Just x -> do - -- Only interested in the stage2 version because that is the only stage for - -- which Persistent migrations are generated. - let (SchemaVersion _ stage2 _) = entityVal x - pure $ MigrationVersion 2 stage2 0 +createMigration _source (MigrationDir _migdir) _txOutTableType = do + -- This would need to be completely rewritten to generate migrations manually + -- or using a different schema management tool + putStrLn "Warning: createMigration not implemented for Hasql. Manual migration creation required." + pure Nothing recreateDB :: PGPassSource -> IO () recreateDB pgpass = do runWithConnectionNoLogging pgpass $ do - rawExecute "drop schema if exists public cascade" [] - rawExecute "create schema public" [] - -getAllTableNames :: PGPassSource -> IO [Text] + DB.runDbSession (DB.mkCallInfo "recreateDB-dropSchema") $ + HsqlS.statement () $ + HsqlStm.Statement + "DROP SCHEMA IF EXISTS public CASCADE" + HsqlE.noParams + HsqlD.noResult + True + + DB.runDbSession (DB.mkCallInfo "recreateDB-createSchema") $ + HsqlS.statement () $ + HsqlStm.Statement + "CREATE SCHEMA public" + HsqlE.noParams + HsqlD.noResult + True + +getAllTableNames :: PGPassSource -> IO [Text.Text] getAllTableNames pgpass = do runWithConnectionNoLogging pgpass $ do - fmap unSingle <$> rawSql "SELECT tablename FROM pg_catalog.pg_tables WHERE schemaname = current_schema()" [] - -truncateTables :: PGPassSource -> [Text] -> IO () + DB.runDbSession (DB.mkCallInfo "getAllTableNames") $ + HsqlS.statement () $ + HsqlStm.Statement + "SELECT tablename FROM pg_catalog.pg_tables WHERE schemaname = current_schema()" + HsqlE.noParams + (HsqlD.rowList $ HsqlD.column (HsqlD.nonNullable HsqlD.text)) + True + +truncateTables :: PGPassSource -> [Text.Text] -> IO () truncateTables pgpass tables = runWithConnectionNoLogging pgpass $ do - rawExecute ("TRUNCATE " <> intercalate (pack ", ") tables <> " CASCADE") [] - -getMaintenancePsqlConf :: PGConfig -> IO Text + DB.runDbSession (DB.mkCallInfo "truncateTables") $ + HsqlS.statement () $ + HsqlStm.Statement + (TextEnc.encodeUtf8 ("TRUNCATE " <> Text.intercalate ", " tables <> " CASCADE")) + HsqlE.noParams + HsqlD.noResult + True + +getMaintenancePsqlConf :: PGConfig -> IO Text.Text getMaintenancePsqlConf pgconfig = runWithConnectionNoLogging (PGPassCached pgconfig) $ do mem <- showMaintenanceWorkMem workers <- showMaxParallelMaintenanceWorkers @@ -316,13 +275,25 @@ getMaintenancePsqlConf pgconfig = runWithConnectionNoLogging (PGPassCached pgcon , mconcat workers ] -showMaintenanceWorkMem :: ReaderT SqlBackend (NoLoggingT IO) [Text] +showMaintenanceWorkMem :: DB.DbAction (NoLoggingT IO) [Text.Text] showMaintenanceWorkMem = - fmap unSingle <$> rawSql "show maintenance_work_mem" [] - -showMaxParallelMaintenanceWorkers :: ReaderT SqlBackend (NoLoggingT IO) [Text] + DB.runDbSession (DB.mkCallInfo "showMaintenanceWorkMem") $ + HsqlS.statement () $ + HsqlStm.Statement + "SHOW maintenance_work_mem" + HsqlE.noParams + (HsqlD.rowList $ HsqlD.column (HsqlD.nonNullable HsqlD.text)) + True + +showMaxParallelMaintenanceWorkers :: DB.DbAction (NoLoggingT IO) [Text.Text] showMaxParallelMaintenanceWorkers = - fmap unSingle <$> rawSql "show max_parallel_maintenance_workers" [] + DB.runDbSession (DB.mkCallInfo "showMaxParallelMaintenanceWorkers") $ + HsqlS.statement () $ + HsqlStm.Statement + "SHOW max_parallel_maintenance_workers" + HsqlE.noParams + (HsqlD.rowList $ HsqlD.column (HsqlD.nonNullable HsqlD.text)) + True -- This doesn't clean the DOMAIN, so droppping the schema is a better alternative -- for a proper cleanup @@ -330,15 +301,26 @@ dropTables :: PGPassSource -> IO () dropTables pgpass = do runWithConnectionNoLogging pgpass $ do mstr <- - rawSql - ( mconcat - [ "select string_agg('drop table \"' || tablename || '\" cascade', '; ')" - , "from pg_tables where schemaname = 'public'" - ] - ) - [] - whenJust (join $ listToMaybe mstr) $ \(Single dropsCommand) -> - rawExecute dropsCommand [] + DB.runDbSession (DB.mkCallInfo "dropTables-getCommand") $ + HsqlS.statement () $ + HsqlStm.Statement + ( mconcat + [ "SELECT string_agg('drop table \"' || tablename || '\" cascade', '; ')" + , "FROM pg_tables WHERE schemaname = 'public'" + ] + ) + HsqlE.noParams + (HsqlD.rowMaybe $ HsqlD.column (HsqlD.nonNullable HsqlD.text)) + True + + whenJust mstr $ \dropsCommand -> + DB.runDbSession (DB.mkCallInfo "dropTables-execute") $ + HsqlS.statement dropsCommand $ + HsqlStm.Statement + "$1" + (HsqlE.param $ HsqlE.nonNullable HsqlE.text) + HsqlD.noResult + True -------------------------------------------------------------------------------- @@ -368,7 +350,7 @@ hashMigrations migrationDir@(MigrationDir location) = do hashAs :: ByteString -> Hash Blake2b_256 ByteString hashAs = hashWith id -renderMigrationValidateError :: MigrationValidateError -> Text +renderMigrationValidateError :: MigrationValidateError -> Text.Text renderMigrationValidateError = \case UnknownMigrationsFound missing unknown -> mconcat @@ -393,23 +375,59 @@ readStageFromFilename fn = case takeWhile isDigit . drop 1 $ dropWhile (/= '-') (takeFileName fn) of stage -> fromMaybe 0 $ readMaybe stage -noLedgerMigrations :: SqlBackend -> Trace IO Text -> IO () -noLedgerMigrations backend trce = do - void $ runDbIohkLogging backend trce $ do - rawExecute "update redeemer set fee = null" [] - rawExecute "delete from reward" [] - rawExecute "delete from epoch_stake" [] - rawExecute "delete from ada_pots" [] - rawExecute "delete from epoch_param" [] - -queryPgIndexesCount :: MonadIO m => ReaderT SqlBackend m Word64 +noLedgerMigrations :: DB.DbEnv -> Trace IO Text.Text -> IO () +noLedgerMigrations dbEnv trce = do + let action = do + DB.runDbSession (DB.mkCallInfo "noLedgerMigrations-redeemer") $ + HsqlS.statement () $ + HsqlStm.Statement + "UPDATE redeemer SET fee = NULL" + HsqlE.noParams + HsqlD.noResult + True + + DB.runDbSession (DB.mkCallInfo "noLedgerMigrations-reward") $ + HsqlS.statement () $ + HsqlStm.Statement + "DELETE FROM reward" + HsqlE.noParams + HsqlD.noResult + True + + DB.runDbSession (DB.mkCallInfo "noLedgerMigrations-epoch_stake") $ + HsqlS.statement () $ + HsqlStm.Statement + "DELETE FROM epoch_stake" + HsqlE.noParams + HsqlD.noResult + True + + DB.runDbSession (DB.mkCallInfo "noLedgerMigrations-ada_pots") $ + HsqlS.statement () $ + HsqlStm.Statement + "DELETE FROM ada_pots" + HsqlE.noParams + HsqlD.noResult + True + + DB.runDbSession (DB.mkCallInfo "noLedgerMigrations-epoch_param") $ + HsqlS.statement () $ + HsqlStm.Statement + "DELETE FROM epoch_param" + HsqlE.noParams + HsqlD.noResult + True + + void $ runDbIohkLogging trce dbEnv action + +queryPgIndexesCount :: MonadIO m => DB.DbAction m Word64 queryPgIndexesCount = do - indexesExists :: [Text] <- - fmap unSingle - <$> rawSql - ( mconcat - [ "SELECT indexname FROM pg_indexes WHERE schemaname = 'public'" - ] - ) - [] + indexesExists <- + DB.runDbSession (DB.mkCallInfo "queryPgIndexesCount") $ + HsqlS.statement () $ + HsqlStm.Statement + "SELECT indexname FROM pg_indexes WHERE schemaname = 'public'" + HsqlE.noParams + (HsqlD.rowList $ HsqlD.column (HsqlD.nonNullable HsqlD.text)) + True pure $ fromIntegral (length indexesExists) diff --git a/cardano-db/src/Cardano/Db/Migration/Haskell.hs b/cardano-db/src/Cardano/Db/Migration/Haskell.hs index d45c7f29a..9029a30f4 100644 --- a/cardano-db/src/Cardano/Db/Migration/Haskell.hs +++ b/cardano-db/src/Cardano/Db/Migration/Haskell.hs @@ -7,15 +7,19 @@ module Cardano.Db.Migration.Haskell ( import Cardano.Db.Migration.Version import Cardano.Db.PGConfig -import Cardano.Db.Run -import Control.Exception (SomeException, handle) -import Control.Monad.Logger (MonadLogger) -import Control.Monad.Trans.Reader (ReaderT) -import Data.Map.Strict (Map) +import qualified Cardano.Db.Types as DB +import Control.Monad.Logger (LoggingT) import qualified Data.Map.Strict as Map -import Database.Persist.Sql (SqlBackend) -import System.Exit (exitFailure) -import System.IO (Handle, hClose, hFlush, hPutStrLn, stdout) +import System.IO (Handle, hPutStrLn) + +-- Simplified version that just logs if executed +runHaskellMigration :: PGPassSource -> Handle -> MigrationVersion -> IO () +runHaskellMigration _ logHandle mversion = + hPutStrLn logHandle $ "No Haskell migration for version " ++ renderMigrationVersion mversion + +-- Empty migration map +_migrationMap :: Map.Map MigrationVersion (DB.DbAction (LoggingT IO) ()) +_migrationMap = Map.empty -- | Run a migration written in Haskell (eg one that cannot easily be done in SQL). -- The Haskell migration is paired with an SQL migration and uses the same MigrationVersion @@ -28,37 +32,37 @@ import System.IO (Handle, hClose, hFlush, hPutStrLn, stdout) -- 2. Haskell migration 'MigrationVersion 2 8 20190731' populates new column from data already -- in the database. -- 3. 'migration-2-0009-20190731.sql' makes the new column NOT NULL. -runHaskellMigration :: PGPassSource -> Handle -> MigrationVersion -> IO () -runHaskellMigration source logHandle mversion = - case Map.lookup mversion migrationMap of - Nothing -> pure () - Just action -> do - hPutStrLn logHandle $ "Running : migration-" ++ renderMigrationVersion mversion ++ ".hs" - putStr $ " migration-" ++ renderMigrationVersion mversion ++ ".hs ... " - hFlush stdout - handle handler $ runDbHandleLogger logHandle source action - putStrLn "ok" - where - handler :: SomeException -> IO a - handler e = do - putStrLn $ "runHaskellMigration: " ++ show e - hPutStrLn logHandle $ "runHaskellMigration: " ++ show e - hClose logHandle - exitFailure +-- runHaskellMigration :: PGPassSource -> Handle -> MigrationVersion -> IO () +-- runHaskellMigration source logHandle mversion = +-- case Map.lookup mversion migrationMap of +-- Nothing -> pure () +-- Just action -> do +-- hPutStrLn logHandle $ "Running : migration-" ++ renderMigrationVersion mversion ++ ".hs" +-- putStr $ " migration-" ++ renderMigrationVersion mversion ++ ".hs ... " +-- hFlush stdout +-- handle handler $ runDbHandleLogger logHandle source action +-- putStrLn "ok" +-- where +-- handler :: SomeException -> IO a +-- handler e = do +-- putStrLn $ "runHaskellMigration: " ++ show e +-- hPutStrLn logHandle $ "runHaskellMigration: " ++ show e +-- hClose logHandle +-- exitFailure --------------------------------------------------------------------------------- +-- -------------------------------------------------------------------------------- -migrationMap :: MonadLogger m => Map MigrationVersion (ReaderT SqlBackend m ()) -migrationMap = - Map.fromList - [ (MigrationVersion 2 1 20190731, migration0001) - ] +-- migrationMap :: MonadLogger m => Map MigrationVersion (ReaderT SqlBackend m ()) +-- migrationMap = +-- Map.fromList +-- [ (MigrationVersion 2 1 20190731, migration0001) +-- ] --------------------------------------------------------------------------------- +-- -------------------------------------------------------------------------------- -migration0001 :: MonadLogger m => ReaderT SqlBackend m () -migration0001 = - -- Place holder. - pure () +-- migration0001 :: MonadLogger m => ReaderT SqlBackend m () +-- migration0001 = +-- -- Place holder. +-- pure () --------------------------------------------------------------------------------- +-- -------------------------------------------------------------------------------- diff --git a/cardano-db/src/Cardano/Db/Operations/Delete.hs b/cardano-db/src/Cardano/Db/Operations/Delete.hs index e84c71cec..c9e7579f0 100644 --- a/cardano-db/src/Cardano/Db/Operations/Delete.hs +++ b/cardano-db/src/Cardano/Db/Operations/Delete.hs @@ -9,50 +9,53 @@ {-# LANGUAGE TypeOperators #-} module Cardano.Db.Operations.Delete ( - deleteDelistedPool, - deleteBlocksBlockId, - queryDelete, - deleteBlocksSlotNo, - deleteBlocksSlotNoNoTrace, - deleteBlocksForTests, - deleteBlock, -) where + ) where -import Cardano.BM.Trace (Trace, logInfo, logWarning, nullTracer) -import Cardano.Db.Operations.Insert ( - setNullDropped, - setNullEnacted, - setNullExpired, - setNullRatified, - ) -import Cardano.Db.Operations.Other.ConsumedTxOut (querySetNullTxOut) -import Cardano.Db.Operations.Other.MinId (MinIds (..), MinIdsWrapper (..), completeMinId, textToMinIds) -import Cardano.Db.Operations.Query -import Cardano.Db.Operations.Types (TxOutTableType (..)) -import Cardano.Db.Schema.BaseSchema -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.Prelude (Int64) -import Cardano.Slotting.Slot (SlotNo (..)) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (ReaderT) -import Data.ByteString (ByteString) -import Data.List (partition) -import Data.Maybe (isJust) -import Data.Text (Text, intercalate, pack) -import Data.Word (Word64) -import Database.Esqueleto.Experimental (persistIdField) -import Database.Persist ( - PersistEntity, - PersistEntityBackend, - PersistField, - (!=.), - (==.), - (>.), - (>=.), - ) -import Database.Persist.Sql (Filter, SqlBackend, delete, deleteWhere, deleteWhereCount, selectKeysList) +-- deleteDelistedPool, +-- deleteBlocksBlockId, +-- queryDelete, +-- deleteBlocksSlotNo, +-- deleteBlocksSlotNoNoTrace, +-- deleteBlocksForTests, +-- deleteBlock, + +-- import Cardano.BM.Trace (Trace, logInfo, logWarning, nullTracer) +-- import Cardano.Db.Operations.Insert ( +-- setNullDropped, +-- setNullEnacted, +-- setNullExpired, +-- setNullRatified, +-- ) +-- import Cardano.Db.Operations.Other.ConsumedTxOut (querySetNullTxOut) +-- import Cardano.Db.Operations.Other.MinId (MinIds (..), MinIdsWrapper (..), completeMinId, textToMinIds) +-- import Cardano.Db.Operations.Query +-- import Cardano.Db.Operations.Types (TxOutTableType (..)) +-- import Cardano.Db.Schema.Core +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Cardano.Prelude (Int64) +-- import Cardano.Slotting.Slot (SlotNo (..)) +import Cardano.Slotting.Slot () + +-- import Control.Monad (void) +-- import Control.Monad.IO.Class (MonadIO, liftIO) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import Data.ByteString (ByteString) +-- import Data.List (partition) +-- import Data.Maybe (isJust) +-- import Data.Text (Text, intercalate, pack) +-- import Data.Word (Word64) +-- import Database.Esqueleto.Experimental (persistIdField) +-- import Database.Persist ( +-- PersistEntity, +-- PersistEntityBackend, +-- PersistField, +-- (!=.), +-- (==.), +-- (>.), +-- (>=.), +-- ) +-- import Database.Persist.Sql (Filter, SqlBackend, delete, deleteWhere, deleteWhereCount, selectKeysList) -- | Delete a block if it exists. Returns 'True' if it did exist and has been -- deleted and 'False' if it did not exist. @@ -73,325 +76,325 @@ deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) isConsumedTxOut = do void $ deleteBlocksBlockId trce txOutTableType blockId epochN isConsumedTxOut pure True --- | Delete starting from a 'BlockId'. -deleteBlocksBlockId :: - MonadIO m => - Trace IO Text -> - TxOutTableType -> - BlockId -> - -- | The 'EpochNo' of the block to delete. - Word64 -> - -- | Is ConsumeTxout - Bool -> - ReaderT SqlBackend m Int64 -deleteBlocksBlockId trce txOutTableType blockId epochN isConsumedTxOut = do - mMinIds <- fmap (textToMinIds txOutTableType =<<) <$> queryReverseIndexBlockId blockId - (cminIds, completed) <- findMinIdsRec mMinIds mempty - mTxId <- queryMinRefId TxBlockId blockId - minIds <- if completed then pure cminIds else completeMinId mTxId cminIds - deleteEpochLogs <- deleteUsingEpochNo epochN - (deleteBlockCount, blockDeleteLogs) <- deleteTablesAfterBlockId txOutTableType blockId mTxId minIds - setNullLogs <- - if isConsumedTxOut - then querySetNullTxOut txOutTableType mTxId - else pure ("ConsumedTxOut is not active so no Nulls set", 0) - -- log all the deleted rows in the rollback - liftIO $ logInfo trce $ mkRollbackSummary (deleteEpochLogs <> blockDeleteLogs) setNullLogs - pure deleteBlockCount - where - findMinIdsRec :: MonadIO m => [Maybe MinIdsWrapper] -> MinIdsWrapper -> ReaderT SqlBackend m (MinIdsWrapper, Bool) - findMinIdsRec [] minIds = pure (minIds, True) - findMinIdsRec (mMinIds : rest) minIds = - case mMinIds of - Nothing -> do - liftIO $ - logWarning - trce - "Failed to find ReverseIndex. Deletion may take longer." - pure (minIds, False) - Just minIdDB -> do - let minIds' = minIds <> minIdDB - if isComplete minIds' - then pure (minIds', True) - else findMinIdsRec rest minIds' +-- -- | Delete starting from a 'BlockId'. +-- deleteBlocksBlockId :: +-- MonadIO m => +-- Trace IO Text -> +-- TxOutTableType -> +-- BlockId -> +-- -- | The 'EpochNo' of the block to delete. +-- Word64 -> +-- -- | Is ConsumeTxout +-- Bool -> +-- ReaderT SqlBackend m Int64 +-- deleteBlocksBlockId trce txOutTableType blockId epochN isConsumedTxOut = do +-- mMinIds <- fmap (textToMinIds txOutTableType =<<) <$> queryReverseIndexBlockId blockId +-- (cminIds, completed) <- findMinIdsRec mMinIds mempty +-- mTxId <- queryMinRefId TxBlockId blockId +-- minIds <- if completed then pure cminIds else completeMinId mTxId cminIds +-- deleteEpochLogs <- deleteUsingEpochNo epochN +-- (deleteBlockCount, blockDeleteLogs) <- deleteTablesAfterBlockId txOutTableType blockId mTxId minIds +-- setNullLogs <- +-- if isConsumedTxOut +-- then querySetNullTxOut txOutTableType mTxId +-- else pure ("ConsumedTxOut is not active so no Nulls set", 0) +-- -- log all the deleted rows in the rollback +-- liftIO $ logInfo trce $ mkRollbackSummary (deleteEpochLogs <> blockDeleteLogs) setNullLogs +-- pure deleteBlockCount +-- where +-- findMinIdsRec :: MonadIO m => [Maybe MinIdsWrapper] -> MinIdsWrapper -> ReaderT SqlBackend m (MinIdsWrapper, Bool) +-- findMinIdsRec [] minIds = pure (minIds, True) +-- findMinIdsRec (mMinIds : rest) minIds = +-- case mMinIds of +-- Nothing -> do +-- liftIO $ +-- logWarning +-- trce +-- "Failed to find ReverseIndex. Deletion may take longer." +-- pure (minIds, False) +-- Just minIdDB -> do +-- let minIds' = minIds <> minIdDB +-- if isComplete minIds' +-- then pure (minIds', True) +-- else findMinIdsRec rest minIds' - isComplete minIdsW = case minIdsW of - CMinIdsWrapper (MinIds m1 m2 m3) -> isJust m1 && isJust m2 && isJust m3 - VMinIdsWrapper (MinIds m1 m2 m3) -> isJust m1 && isJust m2 && isJust m3 +-- isComplete minIdsW = case minIdsW of +-- CMinIdsWrapper (MinIds m1 m2 m3) -> isJust m1 && isJust m2 && isJust m3 +-- VMinIdsWrapper (MinIds m1 m2 m3) -> isJust m1 && isJust m2 && isJust m3 -deleteUsingEpochNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(Text, Int64)] -deleteUsingEpochNo epochN = do - countLogs <- - concat - <$> sequence - [ onlyDelete "Epoch" [EpochNo ==. epochN] - , onlyDelete "DrepDistr" [DrepDistrEpochNo >. epochN] - , onlyDelete "RewardRest" [RewardRestSpendableEpoch >. epochN] - , onlyDelete "PoolStat" [PoolStatEpochNo >. epochN] - ] - nullLogs <- do - a <- setNullEnacted epochN - b <- setNullRatified epochN - c <- setNullDropped epochN - e <- setNullExpired epochN - pure [("GovActionProposal Nulled", a + b + c + e)] - pure $ countLogs <> nullLogs +-- deleteUsingEpochNo :: MonadIO m => Word64 -> ReaderT SqlBackend m [(Text, Int64)] +-- deleteUsingEpochNo epochN = do +-- countLogs <- +-- concat +-- <$> sequence +-- [ onlyDelete "Epoch" [EpochNo ==. epochN] +-- , onlyDelete "DrepDistr" [DrepDistrEpochNo >. epochN] +-- , onlyDelete "RewardRest" [RewardRestSpendableEpoch >. epochN] +-- , onlyDelete "PoolStat" [PoolStatEpochNo >. epochN] +-- ] +-- nullLogs <- do +-- a <- setNullEnacted epochN +-- b <- setNullRatified epochN +-- c <- setNullDropped epochN +-- e <- setNullExpired epochN +-- pure [("GovActionProposal Nulled", a + b + c + e)] +-- pure $ countLogs <> nullLogs -deleteTablesAfterBlockId :: - MonadIO m => - TxOutTableType -> - BlockId -> - Maybe TxId -> - MinIdsWrapper -> - ReaderT SqlBackend m (Int64, [(Text, Int64)]) -deleteTablesAfterBlockId txOutTableType blkId mtxId minIdsW = do - initialLogs <- - concat - <$> sequence - [ onlyDelete "AdaPots" [AdaPotsBlockId >=. blkId] - , onlyDelete "ReverseIndex" [ReverseIndexBlockId >=. blkId] - , onlyDelete "EpochParam" [EpochParamBlockId >=. blkId] - ] +-- deleteTablesAfterBlockId :: +-- MonadIO m => +-- TxOutTableType -> +-- BlockId -> +-- Maybe TxId -> +-- MinIdsWrapper -> +-- ReaderT SqlBackend m (Int64, [(Text, Int64)]) +-- deleteTablesAfterBlockId txOutTableType blkId mtxId minIdsW = do +-- initialLogs <- +-- concat +-- <$> sequence +-- [ onlyDelete "AdaPots" [AdaPotsBlockId >=. blkId] +-- , onlyDelete "ReverseIndex" [ReverseIndexBlockId >=. blkId] +-- , onlyDelete "EpochParam" [EpochParamBlockId >=. blkId] +-- ] - -- Handle off-chain related deletions - mvaId <- queryMinRefId VotingAnchorBlockId blkId - offChainLogs <- case mvaId of - Nothing -> pure [] - Just vaId -> do - mocvdId <- queryMinRefId OffChainVoteDataVotingAnchorId vaId - logsVoting <- case mocvdId of - Nothing -> pure [] - Just ocvdId -> - concat - <$> sequence - [ queryDeleteAndLog "OffChainVoteGovActionData" OffChainVoteGovActionDataOffChainVoteDataId ocvdId - , queryDeleteAndLog "OffChainVoteDrepData" OffChainVoteDrepDataOffChainVoteDataId ocvdId - , queryDeleteAndLog "OffChainVoteAuthor" OffChainVoteAuthorOffChainVoteDataId ocvdId - , queryDeleteAndLog "OffChainVoteReference" OffChainVoteReferenceOffChainVoteDataId ocvdId - , queryDeleteAndLog "OffChainVoteExternalUpdate" OffChainVoteExternalUpdateOffChainVoteDataId ocvdId - ] +-- -- Handle off-chain related deletions +-- mvaId <- queryMinRefId VotingAnchorBlockId blkId +-- offChainLogs <- case mvaId of +-- Nothing -> pure [] +-- Just vaId -> do +-- mocvdId <- queryMinRefId OffChainVoteDataVotingAnchorId vaId +-- logsVoting <- case mocvdId of +-- Nothing -> pure [] +-- Just ocvdId -> +-- concat +-- <$> sequence +-- [ queryDeleteAndLog "OffChainVoteGovActionData" OffChainVoteGovActionDataOffChainVoteDataId ocvdId +-- , queryDeleteAndLog "OffChainVoteDrepData" OffChainVoteDrepDataOffChainVoteDataId ocvdId +-- , queryDeleteAndLog "OffChainVoteAuthor" OffChainVoteAuthorOffChainVoteDataId ocvdId +-- , queryDeleteAndLog "OffChainVoteReference" OffChainVoteReferenceOffChainVoteDataId ocvdId +-- , queryDeleteAndLog "OffChainVoteExternalUpdate" OffChainVoteExternalUpdateOffChainVoteDataId ocvdId +-- ] - offChain <- - concat - <$> sequence - [ queryDeleteAndLog "OffChainVoteData" OffChainVoteDataVotingAnchorId vaId - , queryDeleteAndLog "OffChainVoteFetchError" OffChainVoteFetchErrorVotingAnchorId vaId - , onlyDelete "VotingAnchor" [VotingAnchorId >=. vaId] - ] - pure $ logsVoting <> offChain - -- Additional deletions based on TxId and minimum IDs - afterTxIdLogs <- deleteTablesAfterTxId txOutTableType mtxId minIdsW - -- Final block deletions - blockLogs <- onlyDelete "Block" [BlockId >=. blkId] - -- Aggregate and return all logs - pure (sum $ map snd blockLogs, initialLogs <> blockLogs <> offChainLogs <> afterTxIdLogs) +-- offChain <- +-- concat +-- <$> sequence +-- [ queryDeleteAndLog "OffChainVoteData" OffChainVoteDataVotingAnchorId vaId +-- , queryDeleteAndLog "OffChainVoteFetchError" OffChainVoteFetchErrorVotingAnchorId vaId +-- , onlyDelete "VotingAnchor" [VotingAnchorId >=. vaId] +-- ] +-- pure $ logsVoting <> offChain +-- -- Additional deletions based on TxId and minimum IDs +-- afterTxIdLogs <- deleteTablesAfterTxId txOutTableType mtxId minIdsW +-- -- Final block deletions +-- blockLogs <- onlyDelete "Block" [BlockId >=. blkId] +-- -- Aggregate and return all logs +-- pure (sum $ map snd blockLogs, initialLogs <> blockLogs <> offChainLogs <> afterTxIdLogs) -deleteTablesAfterTxId :: - (MonadIO m) => - TxOutTableType -> - Maybe TxId -> - MinIdsWrapper -> - ReaderT SqlBackend m [(Text, Int64)] -deleteTablesAfterTxId txOutTableType mtxId minIdsW = do - -- Handle deletions and log accumulation from MinIdsWrapper - minIdsLogs <- case minIdsW of - CMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> - concat - <$> sequence - [ maybe (pure []) (\txInId -> onlyDelete "TxIn" [TxInId >=. txInId]) mtxInId - , maybe (pure []) (\txOutId -> onlyDelete "TxOut" [C.TxOutId >=. txOutId]) mtxOutId - , maybe (pure []) (\maTxOutId -> onlyDelete "MaTxOut" [C.MaTxOutId >=. maTxOutId]) mmaTxOutId - ] - VMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> - concat - <$> sequence - [ maybe (pure []) (\txInId -> onlyDelete "TxIn" [TxInId >=. txInId]) mtxInId - , maybe (pure []) (\txOutId -> onlyDelete "TxOut" [V.TxOutId >=. txOutId]) mtxOutId - , maybe (pure []) (\maTxOutId -> onlyDelete "MaTxOut" [V.MaTxOutId >=. maTxOutId]) mmaTxOutId - ] - -- Handle deletions and log accumulation using the specified TxId - txIdLogs <- case mtxId of - Nothing -> pure [] -- If no TxId is provided, skip further deletions - Just txId -> do - result <- - -- Sequentially delete records with associated transaction ID - concat - <$> sequence - [ case txOutTableType of - TxOutCore -> queryDeleteAndLog "CollateralTxOut" C.CollateralTxOutTxId txId - TxOutVariantAddress -> queryDeleteAndLog "CollateralTxOut" V.CollateralTxOutTxId txId - , queryDeleteAndLog "CollateralTxIn" CollateralTxInTxInId txId - , queryDeleteAndLog "ReferenceTxIn" ReferenceTxInTxInId txId - , queryDeleteAndLog "PoolRetire" PoolRetireAnnouncedTxId txId - , queryDeleteAndLog "StakeRegistration" StakeRegistrationTxId txId - , queryDeleteAndLog "StakeDeregistration" StakeDeregistrationTxId txId - , queryDeleteAndLog "Delegation" DelegationTxId txId - , queryDeleteAndLog "TxMetadata" TxMetadataTxId txId - , queryDeleteAndLog "Withdrawal" WithdrawalTxId txId - , queryDeleteAndLog "Treasury" TreasuryTxId txId - , queryDeleteAndLog "Reserve" ReserveTxId txId - , queryDeleteAndLog "PotTransfer" PotTransferTxId txId - , queryDeleteAndLog "MaTxMint" MaTxMintTxId txId - , queryDeleteAndLog "Redeemer" RedeemerTxId txId - , queryDeleteAndLog "Script" ScriptTxId txId - , queryDeleteAndLog "Datum" DatumTxId txId - , queryDeleteAndLog "RedeemerData" RedeemerDataTxId txId - , queryDeleteAndLog "ExtraKeyWitness" ExtraKeyWitnessTxId txId - , queryDeleteAndLog "TxCbor" TxCborTxId txId - , queryDeleteAndLog "ParamProposal" ParamProposalRegisteredTxId txId - , queryDeleteAndLog "DelegationVote" DelegationVoteTxId txId - , queryDeleteAndLog "CommitteeRegistration" CommitteeRegistrationTxId txId - , queryDeleteAndLog "CommitteeDeRegistration" CommitteeDeRegistrationTxId txId - , queryDeleteAndLog "DrepRegistration" DrepRegistrationTxId txId - , queryDeleteAndLog "VotingProcedure" VotingProcedureTxId txId - ] - -- Handle GovActionProposal related deletions if present - mgaId <- queryMinRefId GovActionProposalTxId txId - gaLogs <- case mgaId of - Nothing -> pure [] -- No GovActionProposal ID found, skip this step - Just gaId -> - -- Delete records related to the GovActionProposal ID - concat - <$> sequence - [ queryDeleteAndLog "TreasuryWithdrawal" TreasuryWithdrawalGovActionProposalId gaId - , queryThenNull "Committee" CommitteeGovActionProposalId gaId - , queryThenNull "Constitution" ConstitutionGovActionProposalId gaId - , onlyDelete "GovActionProposal" [GovActionProposalId >=. gaId] - ] - -- Handle PoolMetadataRef related deletions if present - minPmr <- queryMinRefId PoolMetadataRefRegisteredTxId txId - pmrLogs <- case minPmr of - Nothing -> pure [] -- No PoolMetadataRef ID found, skip this step - Just pmrId -> - -- Delete records related to PoolMetadataRef - concat - <$> sequence - [ queryDeleteAndLog "OffChainPoolData" OffChainPoolDataPmrId pmrId - , queryDeleteAndLog "OffChainPoolFetchError" OffChainPoolFetchErrorPmrId pmrId - , onlyDelete "PoolMetadataRef" [PoolMetadataRefId >=. pmrId] - ] - -- Handle PoolUpdate related deletions if present - minPoolUpdate <- queryMinRefId PoolUpdateRegisteredTxId txId - poolUpdateLogs <- case minPoolUpdate of - Nothing -> pure [] -- No PoolUpdate ID found, skip this step - Just puid -> do - -- Delete records related to PoolUpdate - concat - <$> sequence - [ queryDeleteAndLog "PoolOwner" PoolOwnerPoolUpdateId puid - , queryDeleteAndLog "PoolRelay" PoolRelayUpdateId puid - , onlyDelete "PoolUpdate" [PoolUpdateId >=. puid] - ] - -- Final deletions for the given TxId - txLogs <- onlyDelete "Tx" [TxId >=. txId] - -- Combine all logs from the operations above - pure $ result <> gaLogs <> pmrLogs <> poolUpdateLogs <> txLogs - -- Return the combined logs of all operations - pure $ minIdsLogs <> txIdLogs +-- deleteTablesAfterTxId :: +-- MonadIO m => +-- TxOutTableType -> +-- Maybe TxId -> +-- MinIdsWrapper -> +-- ReaderT SqlBackend m [(Text, Int64)] +-- deleteTablesAfterTxId txOutTableType mtxId minIdsW = do +-- -- Handle deletions and log accumulation from MinIdsWrapper +-- minIdsLogs <- case minIdsW of +-- CMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> +-- concat +-- <$> sequence +-- [ maybe (pure []) (\txInId -> onlyDelete "TxIn" [TxInId >=. txInId]) mtxInId +-- , maybe (pure []) (\txOutId -> onlyDelete "TxOut" [C.TxOutId >=. txOutId]) mtxOutId +-- , maybe (pure []) (\maTxOutId -> onlyDelete "MaTxOut" [C.MaTxOutId >=. maTxOutId]) mmaTxOutId +-- ] +-- VMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> +-- concat +-- <$> sequence +-- [ maybe (pure []) (\txInId -> onlyDelete "TxIn" [TxInId >=. txInId]) mtxInId +-- , maybe (pure []) (\txOutId -> onlyDelete "TxOut" [V.TxOutId >=. txOutId]) mtxOutId +-- , maybe (pure []) (\maTxOutId -> onlyDelete "MaTxOut" [V.MaTxOutId >=. maTxOutId]) mmaTxOutId +-- ] +-- -- Handle deletions and log accumulation using the specified TxId +-- txIdLogs <- case mtxId of +-- Nothing -> pure [] -- If no TxId is provided, skip further deletions +-- Just txId -> do +-- result <- +-- -- Sequentially delete records with associated transaction ID +-- concat +-- <$> sequence +-- [ case txOutTableType of +-- TxOutCore -> queryDeleteAndLog "CollateralTxOut" C.CollateralTxOutTxId txId +-- TxOutVariantAddress -> queryDeleteAndLog "CollateralTxOut" V.CollateralTxOutTxId txId +-- , queryDeleteAndLog "CollateralTxIn" CollateralTxInTxInId txId +-- , queryDeleteAndLog "ReferenceTxIn" ReferenceTxInTxInId txId +-- , queryDeleteAndLog "PoolRetire" PoolRetireAnnouncedTxId txId +-- , queryDeleteAndLog "StakeRegistration" StakeRegistrationTxId txId +-- , queryDeleteAndLog "StakeDeregistration" StakeDeregistrationTxId txId +-- , queryDeleteAndLog "Delegation" DelegationTxId txId +-- , queryDeleteAndLog "TxMetadata" TxMetadataTxId txId +-- , queryDeleteAndLog "Withdrawal" WithdrawalTxId txId +-- , queryDeleteAndLog "Treasury" TreasuryTxId txId +-- , queryDeleteAndLog "Reserve" ReserveTxId txId +-- , queryDeleteAndLog "PotTransfer" PotTransferTxId txId +-- , queryDeleteAndLog "MaTxMint" MaTxMintTxId txId +-- , queryDeleteAndLog "Redeemer" RedeemerTxId txId +-- , queryDeleteAndLog "Script" ScriptTxId txId +-- , queryDeleteAndLog "Datum" DatumTxId txId +-- , queryDeleteAndLog "RedeemerData" RedeemerDataTxId txId +-- , queryDeleteAndLog "ExtraKeyWitness" ExtraKeyWitnessTxId txId +-- , queryDeleteAndLog "TxCbor" TxCborTxId txId +-- , queryDeleteAndLog "ParamProposal" ParamProposalRegisteredTxId txId +-- , queryDeleteAndLog "DelegationVote" DelegationVoteTxId txId +-- , queryDeleteAndLog "CommitteeRegistration" CommitteeRegistrationTxId txId +-- , queryDeleteAndLog "CommitteeDeRegistration" CommitteeDeRegistrationTxId txId +-- , queryDeleteAndLog "DrepRegistration" DrepRegistrationTxId txId +-- , queryDeleteAndLog "VotingProcedure" VotingProcedureTxId txId +-- ] +-- -- Handle GovActionProposal related deletions if present +-- mgaId <- queryMinRefId GovActionProposalTxId txId +-- gaLogs <- case mgaId of +-- Nothing -> pure [] -- No GovActionProposal ID found, skip this step +-- Just gaId -> +-- -- Delete records related to the GovActionProposal ID +-- concat +-- <$> sequence +-- [ queryDeleteAndLog "TreasuryWithdrawal" TreasuryWithdrawalGovActionProposalId gaId +-- , queryThenNull "Committee" CommitteeGovActionProposalId gaId +-- , queryThenNull "Constitution" ConstitutionGovActionProposalId gaId +-- , onlyDelete "GovActionProposal" [GovActionProposalId >=. gaId] +-- ] +-- -- Handle PoolMetadataRef related deletions if present +-- minPmr <- queryMinRefId PoolMetadataRefRegisteredTxId txId +-- pmrLogs <- case minPmr of +-- Nothing -> pure [] -- No PoolMetadataRef ID found, skip this step +-- Just pmrId -> +-- -- Delete records related to PoolMetadataRef +-- concat +-- <$> sequence +-- [ queryDeleteAndLog "OffChainPoolData" OffChainPoolDataPmrId pmrId +-- , queryDeleteAndLog "OffChainPoolFetchError" OffChainPoolFetchErrorPmrId pmrId +-- , onlyDelete "PoolMetadataRef" [PoolMetadataRefId >=. pmrId] +-- ] +-- -- Handle PoolUpdate related deletions if present +-- minPoolUpdate <- queryMinRefId PoolUpdateRegisteredTxId txId +-- poolUpdateLogs <- case minPoolUpdate of +-- Nothing -> pure [] -- No PoolUpdate ID found, skip this step +-- Just puid -> do +-- -- Delete records related to PoolUpdate +-- concat +-- <$> sequence +-- [ queryDeleteAndLog "PoolOwner" PoolOwnerPoolUpdateId puid +-- , queryDeleteAndLog "PoolRelay" PoolRelayUpdateId puid +-- , onlyDelete "PoolUpdate" [PoolUpdateId >=. puid] +-- ] +-- -- Final deletions for the given TxId +-- txLogs <- onlyDelete "Tx" [TxId >=. txId] +-- -- Combine all logs from the operations above +-- pure $ result <> gaLogs <> pmrLogs <> poolUpdateLogs <> txLogs +-- -- Return the combined logs of all operations +-- pure $ minIdsLogs <> txIdLogs -queryDelete :: - forall m record field. - (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => - EntityField record field -> - field -> - ReaderT SqlBackend m () -queryDelete fieldIdField fieldId = do - mRecordId <- queryMinRefId fieldIdField fieldId - case mRecordId of - Nothing -> pure () - Just recordId -> deleteWhere [persistIdField @record >=. recordId] +-- queryDelete :: +-- forall m record field. +-- (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => +-- EntityField record field -> +-- field -> +-- ReaderT SqlBackend m () +-- queryDelete fieldIdField fieldId = do +-- mRecordId <- queryMinRefId fieldIdField fieldId +-- case mRecordId of +-- Nothing -> pure () +-- Just recordId -> deleteWhere [persistIdField @record >=. recordId] -queryDeleteAndLog :: - forall m record field. - (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => - Text -> - EntityField record field -> - field -> - ReaderT SqlBackend m [(Text, Int64)] -queryDeleteAndLog tableName txIdField fieldId = do - mRecordId <- queryMinRefId txIdField fieldId - case mRecordId of - Nothing -> pure [(tableName, 0)] - Just recordId -> do - count <- deleteWhereCount [persistIdField @record >=. recordId] - pure [(tableName, count)] +-- queryDeleteAndLog :: +-- forall m record field. +-- (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => +-- Text -> +-- EntityField record field -> +-- field -> +-- ReaderT SqlBackend m [(Text, Int64)] +-- queryDeleteAndLog tableName txIdField fieldId = do +-- mRecordId <- queryMinRefId txIdField fieldId +-- case mRecordId of +-- Nothing -> pure [(tableName, 0)] +-- Just recordId -> do +-- count <- deleteWhereCount [persistIdField @record >=. recordId] +-- pure [(tableName, count)] -onlyDelete :: - forall m record. - (MonadIO m, PersistEntity record, PersistEntityBackend record ~ SqlBackend) => - Text -> - [Filter record] -> - ReaderT SqlBackend m [(Text, Int64)] -onlyDelete tableName filters = do - count <- deleteWhereCount filters - pure [(tableName, count)] +-- onlyDelete :: +-- forall m record. +-- (MonadIO m, PersistEntity record, PersistEntityBackend record ~ SqlBackend) => +-- Text -> +-- [Filter record] -> +-- ReaderT SqlBackend m [(Text, Int64)] +-- onlyDelete tableName filters = do +-- count <- deleteWhereCount filters +-- pure [(tableName, count)] -queryThenNull :: - forall m record field. - (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => - Text -> - EntityField record (Maybe field) -> - field -> - ReaderT SqlBackend m [(Text, Int64)] -queryThenNull tableName txIdField txId = do - mRecordId <- queryMinRefIdNullable txIdField txId - case mRecordId of - Nothing -> pure [(tableName, 0)] - Just recordId -> do - count <- deleteWhereCount [persistIdField @record >=. recordId, txIdField !=. Nothing] - pure [(tableName, count)] +-- queryThenNull :: +-- forall m record field. +-- (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => +-- Text -> +-- EntityField record (Maybe field) -> +-- field -> +-- ReaderT SqlBackend m [(Text, Int64)] +-- queryThenNull tableName txIdField txId = do +-- mRecordId <- queryMinRefIdNullable txIdField txId +-- case mRecordId of +-- Nothing -> pure [(tableName, 0)] +-- Just recordId -> do +-- count <- deleteWhereCount [persistIdField @record >=. recordId, txIdField !=. Nothing] +-- pure [(tableName, count)] --- | Delete a delisted pool if it exists. Returns 'True' if it did exist and has been --- deleted and 'False' if it did not exist. -deleteDelistedPool :: MonadIO m => ByteString -> ReaderT SqlBackend m Bool -deleteDelistedPool poolHash = do - keys <- selectKeysList [DelistedPoolHashRaw ==. poolHash] [] - mapM_ delete keys - pure $ not (null keys) +-- -- | Delete a delisted pool if it exists. Returns 'True' if it did exist and has been +-- -- deleted and 'False' if it did not exist. +-- deleteDelistedPool :: MonadIO m => ByteString -> ReaderT SqlBackend m Bool +-- deleteDelistedPool poolHash = do +-- keys <- selectKeysList [DelistedPoolHashRaw ==. poolHash] [] +-- mapM_ delete keys +-- pure $ not (null keys) -mkRollbackSummary :: [(Text, Int64)] -> (Text, Int64) -> Text -mkRollbackSummary logs setNullLogs = - "\n----------------------- Rollback Summary: ----------------------- \n" - <> formattedLog - <> zeroDeletedEntry - <> formatSetNullLog setNullLogs - <> "\n" - where - (zeroDeletes, nonZeroDeletes) = partition ((== 0) . snd) logs +-- mkRollbackSummary :: [(Text, Int64)] -> (Text, Int64) -> Text +-- mkRollbackSummary logs setNullLogs = +-- "\n----------------------- Rollback Summary: ----------------------- \n" +-- <> formattedLog +-- <> zeroDeletedEntry +-- <> formatSetNullLog setNullLogs +-- <> "\n" +-- where +-- (zeroDeletes, nonZeroDeletes) = partition ((== 0) . snd) logs - formattedLog = intercalate "\n" (map formatEntry nonZeroDeletes) +-- formattedLog = intercalate "\n" (map formatEntry nonZeroDeletes) - zeroDeletedEntry - | null zeroDeletes = "" - | otherwise = "\n\nNo Deletes in tables: " <> intercalate ", " (map fst zeroDeletes) +-- zeroDeletedEntry +-- | null zeroDeletes = "" +-- | otherwise = "\n\nNo Deletes in tables: " <> intercalate ", " (map fst zeroDeletes) - formatEntry (tableName, rowCount) = - "Table: " <> tableName <> " - Count: " <> pack (show rowCount) +-- formatEntry (tableName, rowCount) = +-- "Table: " <> tableName <> " - Count: " <> pack (show rowCount) - formatSetNullLog (nullMessage, nullCount) = - "\n\nSet Null: " - <> if nullCount == 0 - then nullMessage - else "\n\nSet Null: " <> nullMessage <> " - Count: " <> pack (show nullCount) +-- formatSetNullLog (nullMessage, nullCount) = +-- "\n\nSet Null: " +-- <> if nullCount == 0 +-- then nullMessage +-- else "\n\nSet Null: " <> nullMessage <> " - Count: " <> pack (show nullCount) --- Tools +-- -- Tools -deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool -deleteBlocksSlotNoNoTrace txOutTableType slotNo = deleteBlocksSlotNo nullTracer txOutTableType slotNo True +-- deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool +-- deleteBlocksSlotNoNoTrace txOutTableType slotNo = deleteBlocksSlotNo nullTracer txOutTableType slotNo True --- Tests +-- -- Tests -deleteBlocksForTests :: MonadIO m => TxOutTableType -> BlockId -> Word64 -> ReaderT SqlBackend m () -deleteBlocksForTests txOutTableType blockId epochN = do - void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN False +-- deleteBlocksForTests :: MonadIO m => TxOutTableType -> BlockId -> Word64 -> ReaderT SqlBackend m () +-- deleteBlocksForTests txOutTableType blockId epochN = do +-- void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN False --- | Delete a block if it exists. Returns 'True' if it did exist and has been --- deleted and 'False' if it did not exist. -deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool -deleteBlock txOutTableType block = do - mBlockId <- queryBlockHash block - case mBlockId of - Nothing -> pure False - Just (blockId, epochN) -> do - void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN False - pure True +-- -- | Delete a block if it exists. Returns 'True' if it did exist and has been +-- -- deleted and 'False' if it did not exist. +-- deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool +-- deleteBlock txOutTableType block = do +-- mBlockId <- queryBlockHash block +-- case mBlockId of +-- Nothing -> pure False +-- Just (blockId, epochN) -> do +-- void $ deleteBlocksBlockId nullTracer txOutTableType blockId epochN False +-- pure True diff --git a/cardano-db/src/Cardano/Db/Operations/Insert.hs b/cardano-db/src/Cardano/Db/Operations/Insert.hs index f498ae285..f51879046 100644 --- a/cardano-db/src/Cardano/Db/Operations/Insert.hs +++ b/cardano-db/src/Cardano/Db/Operations/Insert.hs @@ -5,114 +5,116 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Cardano.Db.Operations.Insert ( - insertAdaPots, - insertBlock, - insertCollateralTxIn, - insertReferenceTxIn, - insertDelegation, - insertEpoch, - insertEpochParam, - insertEpochSyncTime, - insertExtraKeyWitness, - insertManyEpochStakes, - insertManyRewards, - insertManyRewardRests, - insertManyDrepDistr, - insertManyTxIn, - insertMaTxMint, - insertMeta, - insertMultiAssetUnchecked, - insertParamProposal, - insertPotTransfer, - insertPoolHash, - insertPoolMetadataRef, - insertPoolOwner, - insertPoolRelay, - insertPoolRetire, - insertPoolUpdate, - insertReserve, - insertScript, - insertSlotLeader, - insertStakeAddress, - insertStakeDeregistration, - insertStakeRegistration, - insertTreasury, - insertTx, - insertTxCBOR, - insertTxIn, - insertManyTxMint, - insertManyTxMetadata, - insertWithdrawal, - insertRedeemer, - insertCostModel, - insertDatum, - insertRedeemerData, - insertReverseIndex, - insertCheckOffChainPoolData, - insertCheckOffChainPoolFetchError, - insertOffChainVoteData, - insertOffChainVoteGovActionData, - insertOffChainVoteDrepData, - insertOffChainVoteAuthors, - insertOffChainVoteReference, - insertOffChainVoteExternalUpdate, - insertOffChainVoteFetchError, - insertReservedPoolTicker, - insertDelistedPool, - insertExtraMigration, - insertEpochStakeProgress, - updateSetComplete, - updateGovActionEnacted, - updateGovActionRatified, - updateGovActionDropped, - updateGovActionExpired, - setNullEnacted, - setNullRatified, - setNullExpired, - setNullDropped, - replaceAdaPots, - insertAnchor, - insertConstitution, - insertGovActionProposal, - insertTreasuryWithdrawal, - insertCommittee, - insertCommitteeMember, - insertVotingProcedure, - insertDrepHash, - insertCommitteeHash, - insertDelegationVote, - insertCommitteeRegistration, - insertCommitteeDeRegistration, - insertDrepRegistration, - insertEpochState, - insertManyPoolStat, - insertAlwaysAbstainDrep, - insertAlwaysNoConfidence, - insertUnchecked, - insertMany', - -- Export mainly for testing. - insertBlockChecked, -) where - -import Cardano.Db.Operations.Query -import Cardano.Db.Schema.BaseSchema -import Cardano.Db.Types -import Cardano.Prelude (textShow) -import Control.Exception.Lifted (Exception, handle, throwIO) -import Control.Monad (unless, void, when) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Data.ByteString.Char8 as BS -import Data.Int (Int64) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word64) -import Database.Persist (updateWhere, (!=.), (=.), (==.), (>.)) + ) where + +-- insertAdaPots, +-- insertBlock, +-- insertCollateralTxIn, +-- insertReferenceTxIn, +-- insertDelegation, +-- insertEpoch, +-- insertEpochParam, +-- insertEpochSyncTime, +-- insertExtraKeyWitness, +-- insertManyEpochStakes, +-- insertManyRewards, +-- insertManyRewardRests, +-- insertManyDrepDistr, +-- insertManyTxIn, +-- insertMaTxMint, +-- insertMeta, +-- insertMultiAssetUnchecked, +-- insertParamProposal, +-- insertPotTransfer, +-- insertPoolHash, +-- insertPoolMetadataRef, +-- insertPoolOwner, +-- insertPoolRelay, +-- insertPoolRetire, +-- insertPoolUpdate, +-- insertReserve, +-- insertScript, +-- insertSlotLeader, +-- insertStakeAddress, +-- insertStakeDeregistration, +-- insertStakeRegistration, +-- insertTreasury, +-- insertTx, +-- insertTxCBOR, +-- insertTxIn, +-- insertManyTxMint, +-- insertManyTxMetadata, +-- insertWithdrawal, +-- insertRedeemer, +-- insertCostModel, +-- insertDatum, +-- insertRedeemerData, +-- insertReverseIndex, +-- insertCheckOffChainPoolData, +-- insertCheckOffChainPoolFetchError, +-- insertOffChainVoteData, +-- insertOffChainVoteGovActionData, +-- insertOffChainVoteDrepData, +-- insertManyOffChainVoteAuthors, +-- insertManyOffChainVoteReference, +-- insertOffChainVoteExternalUpdate, +-- insertOffChainVoteFetchError, +-- insertReservedPoolTicker, +-- insertDelistedPool, +-- insertExtraMigration, +-- insertEpochStakeProgress, +-- updateSetComplete, +-- updateGovActionEnacted, +-- updateGovActionRatified, +-- updateGovActionDropped, +-- updateGovActionExpired, +-- setNullEnacted, +-- setNullRatified, +-- setNullExpired, +-- setNullDropped, +-- replaceAdaPots, +-- insertAnchor, +-- insertConstitution, +-- insertGovActionProposal, +-- insertTreasuryWithdrawal, +-- insertCommittee, +-- insertCommitteeMember, +-- insertVotingProcedure, +-- insertDrepHash, +-- insertCommitteeHash, +-- insertDelegationVote, +-- insertCommitteeRegistration, +-- insertCommitteeDeRegistration, +-- insertDrepRegistration, +-- insertEpochState, +-- insertManyPoolStat, +-- insertDrepHashAlwaysAbstain, +-- insertAlwaysNoConfidence, +-- insertUnchecked, +-- insertMany', +-- Export mainly for testing. +-- insertBlockChecked, + +-- import Cardano.Db.Operations.Query +-- import Cardano.Db.Schema.Core +-- import Cardano.Db.Types +-- import Cardano.Prelude (textShow) +-- import Control.Exception.Lifted (Exception, handle, throwIO) +-- import Control.Monad (unless, void, when) +-- import Control.Monad.IO.Class (MonadIO, liftIO) +-- import Control.Monad.Trans.Control (MonadBaseControl) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import qualified Data.ByteString.Char8 as BS +-- import Data.Int (Int64) +-- import qualified Data.List.NonEmpty as NonEmpty +-- import Data.Proxy (Proxy (..)) +-- import Data.Text (Text) +-- import qualified Data.Text as Text +-- import Data.Word (Word64) +-- import Database.Persist (updateWhere, (!=.), (=.), (==.), (>.)) import Database.Persist.Class ( AtLeastOneUniqueKey, PersistEntity, @@ -124,7 +126,8 @@ import Database.Persist.Class ( replaceUnique, ) import Database.Persist.EntityDef.Internal (entityDB, entityUniques) -import Database.Persist.Postgresql (upsertWhere) + +-- import Database.Persist.Postgresql (upsertWhere) import Database.Persist.Sql ( OnlyOneUniqueKey, PersistRecordBackend, @@ -141,7 +144,8 @@ import Database.Persist.Sql ( uniqueFields, updateWhereCount, ) -import qualified Database.Persist.Sql.Util as Util + +-- import qualified Database.Persist.Sql.Util as Util import Database.Persist.Types ( ConstraintNameDB (..), Entity (..), @@ -150,7 +154,9 @@ import Database.Persist.Types ( PersistValue, entityKey, ) -import Database.PostgreSQL.Simple (SqlError) + +-- import Database.PostgreSQL.Simple (SqlError) +-- import Hasql.Statement (Statement) -- The original naive way of inserting rows into Postgres was: -- @@ -168,555 +174,279 @@ import Database.PostgreSQL.Simple (SqlError) -- Instead we use `insertUnchecked` for tables where there is no uniqueness constraints -- and `insertChecked` for tables where the uniqueness constraint might hit. -insertAdaPots :: (MonadBaseControl IO m, MonadIO m) => AdaPots -> ReaderT SqlBackend m AdaPotsId -insertAdaPots = insertUnchecked "AdaPots" - -insertBlock :: (MonadBaseControl IO m, MonadIO m) => Block -> ReaderT SqlBackend m BlockId -insertBlock = insertUnchecked "Block" - -insertCollateralTxIn :: (MonadBaseControl IO m, MonadIO m) => CollateralTxIn -> ReaderT SqlBackend m CollateralTxInId -insertCollateralTxIn = insertUnchecked "CollateralTxIn" - -insertReferenceTxIn :: (MonadBaseControl IO m, MonadIO m) => ReferenceTxIn -> ReaderT SqlBackend m ReferenceTxInId -insertReferenceTxIn = insertUnchecked "ReferenceTxIn" - -insertDelegation :: (MonadBaseControl IO m, MonadIO m) => Delegation -> ReaderT SqlBackend m DelegationId -insertDelegation = insertUnchecked "Delegation" - -insertEpoch :: (MonadBaseControl IO m, MonadIO m) => Epoch -> ReaderT SqlBackend m EpochId -insertEpoch = insertCheckUnique "Epoch" - -insertEpochParam :: (MonadBaseControl IO m, MonadIO m) => EpochParam -> ReaderT SqlBackend m EpochParamId -insertEpochParam = insertUnchecked "EpochParam" - -insertEpochSyncTime :: (MonadBaseControl IO m, MonadIO m) => EpochSyncTime -> ReaderT SqlBackend m EpochSyncTimeId -insertEpochSyncTime = insertReplace "EpochSyncTime" - -insertExtraKeyWitness :: (MonadBaseControl IO m, MonadIO m) => ExtraKeyWitness -> ReaderT SqlBackend m ExtraKeyWitnessId -insertExtraKeyWitness = insertUnchecked "ExtraKeyWitness" - -insertManyEpochStakes :: - (MonadBaseControl IO m, MonadIO m) => - -- | Does constraint already exists - Bool -> - ConstraintNameDB -> - [EpochStake] -> - ReaderT SqlBackend m () -insertManyEpochStakes = insertManyWithManualUnique "Many EpochStake" - -insertManyRewards :: - (MonadBaseControl IO m, MonadIO m) => - -- | Does constraint already exists - Bool -> - ConstraintNameDB -> - [Reward] -> - ReaderT SqlBackend m () -insertManyRewards = insertManyWithManualUnique "Many Rewards" - -insertManyRewardRests :: - (MonadBaseControl IO m, MonadIO m) => - [RewardRest] -> - ReaderT SqlBackend m () -insertManyRewardRests = insertManyUnique "Many Rewards Rest" Nothing - -insertManyDrepDistr :: - (MonadBaseControl IO m, MonadIO m) => - [DrepDistr] -> - ReaderT SqlBackend m () -insertManyDrepDistr = insertManyCheckUnique "Many DrepDistr" - -insertManyTxIn :: (MonadBaseControl IO m, MonadIO m) => [TxIn] -> ReaderT SqlBackend m [TxInId] -insertManyTxIn = insertMany' "Many TxIn" - -insertMaTxMint :: (MonadBaseControl IO m, MonadIO m) => MaTxMint -> ReaderT SqlBackend m MaTxMintId -insertMaTxMint = insertUnchecked "insertMaTxMint" - -insertMeta :: (MonadBaseControl IO m, MonadIO m) => Meta -> ReaderT SqlBackend m MetaId -insertMeta = insertCheckUnique "Meta" - -insertMultiAssetUnchecked :: (MonadBaseControl IO m, MonadIO m) => MultiAsset -> ReaderT SqlBackend m MultiAssetId -insertMultiAssetUnchecked = insertUnchecked "MultiAsset" - -insertParamProposal :: (MonadBaseControl IO m, MonadIO m) => ParamProposal -> ReaderT SqlBackend m ParamProposalId -insertParamProposal = insertUnchecked "ParamProposal" - -insertPotTransfer :: (MonadBaseControl IO m, MonadIO m) => PotTransfer -> ReaderT SqlBackend m PotTransferId -insertPotTransfer = insertUnchecked "PotTransfer" - -insertPoolHash :: (MonadBaseControl IO m, MonadIO m) => PoolHash -> ReaderT SqlBackend m PoolHashId -insertPoolHash = insertCheckUnique "PoolHash" - -insertPoolMetadataRef :: (MonadBaseControl IO m, MonadIO m) => PoolMetadataRef -> ReaderT SqlBackend m PoolMetadataRefId -insertPoolMetadataRef = insertUnchecked "PoolMetadataRef" - -insertPoolOwner :: (MonadBaseControl IO m, MonadIO m) => PoolOwner -> ReaderT SqlBackend m PoolOwnerId -insertPoolOwner = insertUnchecked "PoolOwner" - -insertPoolRelay :: (MonadBaseControl IO m, MonadIO m) => PoolRelay -> ReaderT SqlBackend m PoolRelayId -insertPoolRelay = insertUnchecked "PoolRelay" - -insertPoolRetire :: (MonadBaseControl IO m, MonadIO m) => PoolRetire -> ReaderT SqlBackend m PoolRetireId -insertPoolRetire = insertUnchecked "PoolRetire" - -insertPoolUpdate :: (MonadBaseControl IO m, MonadIO m) => PoolUpdate -> ReaderT SqlBackend m PoolUpdateId -insertPoolUpdate = insertUnchecked "PoolUpdate" - -insertReserve :: (MonadBaseControl IO m, MonadIO m) => Reserve -> ReaderT SqlBackend m ReserveId -insertReserve = insertUnchecked "Reserve" - -insertScript :: (MonadBaseControl IO m, MonadIO m) => Script -> ReaderT SqlBackend m ScriptId -insertScript = insertCheckUnique "insertScript" - -insertSlotLeader :: (MonadBaseControl IO m, MonadIO m) => SlotLeader -> ReaderT SqlBackend m SlotLeaderId -insertSlotLeader = insertCheckUnique "SlotLeader" - -insertStakeAddress :: (MonadBaseControl IO m, MonadIO m) => StakeAddress -> ReaderT SqlBackend m StakeAddressId -insertStakeAddress = insertCheckUnique "StakeAddress" - -insertStakeDeregistration :: (MonadBaseControl IO m, MonadIO m) => StakeDeregistration -> ReaderT SqlBackend m StakeDeregistrationId -insertStakeDeregistration = insertUnchecked "StakeDeregistration" - -insertStakeRegistration :: (MonadBaseControl IO m, MonadIO m) => StakeRegistration -> ReaderT SqlBackend m StakeRegistrationId -insertStakeRegistration = insertUnchecked "StakeRegistration" - -insertTreasury :: (MonadBaseControl IO m, MonadIO m) => Treasury -> ReaderT SqlBackend m TreasuryId -insertTreasury = insertUnchecked "Treasury" - -insertTx :: (MonadBaseControl IO m, MonadIO m) => Tx -> ReaderT SqlBackend m TxId -insertTx tx = insertUnchecked ("Tx: " ++ show (BS.length (txHash tx))) tx - -insertTxIn :: (MonadBaseControl IO m, MonadIO m) => TxIn -> ReaderT SqlBackend m TxInId -insertTxIn = insertUnchecked "TxIn" - -insertManyTxMetadata :: (MonadBaseControl IO m, MonadIO m) => [TxMetadata] -> ReaderT SqlBackend m [TxMetadataId] -insertManyTxMetadata = insertMany' "TxMetadata" - -insertManyTxMint :: (MonadBaseControl IO m, MonadIO m) => [MaTxMint] -> ReaderT SqlBackend m [MaTxMintId] -insertManyTxMint = insertMany' "TxMint" - -insertTxCBOR :: (MonadBaseControl IO m, MonadIO m) => TxCbor -> ReaderT SqlBackend m TxCborId -insertTxCBOR = insertUnchecked "TxCBOR" - -insertWithdrawal :: (MonadBaseControl IO m, MonadIO m) => Withdrawal -> ReaderT SqlBackend m WithdrawalId -insertWithdrawal = insertUnchecked "Withdrawal" - -insertRedeemer :: (MonadBaseControl IO m, MonadIO m) => Redeemer -> ReaderT SqlBackend m RedeemerId -insertRedeemer = insertUnchecked "Redeemer" - -insertCostModel :: (MonadBaseControl IO m, MonadIO m) => CostModel -> ReaderT SqlBackend m CostModelId -insertCostModel = insertCheckUnique "CostModel" - -insertDatum :: (MonadBaseControl IO m, MonadIO m) => Datum -> ReaderT SqlBackend m DatumId -insertDatum = insertCheckUnique "Datum" - -insertRedeemerData :: (MonadBaseControl IO m, MonadIO m) => RedeemerData -> ReaderT SqlBackend m RedeemerDataId -insertRedeemerData = insertCheckUnique "RedeemerData" - -insertReverseIndex :: (MonadBaseControl IO m, MonadIO m) => ReverseIndex -> ReaderT SqlBackend m ReverseIndexId -insertReverseIndex = insertUnchecked "ReverseIndex" - -insertCheckOffChainPoolData :: (MonadBaseControl IO m, MonadIO m) => OffChainPoolData -> ReaderT SqlBackend m () -insertCheckOffChainPoolData pod = do - foundPool <- existsPoolHashId (offChainPoolDataPoolId pod) - foundMeta <- existsPoolMetadataRefId (offChainPoolDataPmrId pod) - when (foundPool && foundMeta) . void $ insertCheckUnique "OffChainPoolData" pod - -insertCheckOffChainPoolFetchError :: (MonadBaseControl IO m, MonadIO m) => OffChainPoolFetchError -> ReaderT SqlBackend m () -insertCheckOffChainPoolFetchError pofe = do - foundPool <- existsPoolHashId (offChainPoolFetchErrorPoolId pofe) - foundMeta <- existsPoolMetadataRefId (offChainPoolFetchErrorPmrId pofe) - when (foundPool && foundMeta) . void $ insertCheckUnique "OffChainPoolFetchError" pofe - -insertOffChainVoteData :: (MonadBaseControl IO m, MonadIO m) => OffChainVoteData -> ReaderT SqlBackend m (Maybe OffChainVoteDataId) -insertOffChainVoteData ocvd = do - foundVotingAnchor <- existsVotingAnchorId (offChainVoteDataVotingAnchorId ocvd) - if foundVotingAnchor - then Just <$> insertCheckUnique "OffChainVoteData" ocvd - else pure Nothing - -insertOffChainVoteGovActionData :: (MonadBaseControl IO m, MonadIO m) => OffChainVoteGovActionData -> ReaderT SqlBackend m OffChainVoteGovActionDataId -insertOffChainVoteGovActionData = insertUnchecked "OffChainVoteGovActionData" - -insertOffChainVoteDrepData :: (MonadBaseControl IO m, MonadIO m) => OffChainVoteDrepData -> ReaderT SqlBackend m OffChainVoteDrepDataId -insertOffChainVoteDrepData = insertUnchecked "OffChainVoteDrepData" - -insertOffChainVoteAuthors :: (MonadBaseControl IO m, MonadIO m) => [OffChainVoteAuthor] -> ReaderT SqlBackend m () -insertOffChainVoteAuthors = void . insertMany' "OffChainVoteAuthor" - -insertOffChainVoteReference :: (MonadBaseControl IO m, MonadIO m) => [OffChainVoteReference] -> ReaderT SqlBackend m () -insertOffChainVoteReference = void . insertMany' "OffChainVoteReference" - -insertOffChainVoteExternalUpdate :: (MonadBaseControl IO m, MonadIO m) => [OffChainVoteExternalUpdate] -> ReaderT SqlBackend m () -insertOffChainVoteExternalUpdate = void . insertMany' "OffChainVoteExternalUpdate" - -insertOffChainVoteFetchError :: (MonadBaseControl IO m, MonadIO m) => OffChainVoteFetchError -> ReaderT SqlBackend m () -insertOffChainVoteFetchError ocvfe = do - foundVotingAnchor <- existsVotingAnchorId (offChainVoteFetchErrorVotingAnchorId ocvfe) - when foundVotingAnchor . void $ insertCheckUnique "OffChainVoteFetchError" ocvfe - -insertReservedPoolTicker :: (MonadBaseControl IO m, MonadIO m) => ReservedPoolTicker -> ReaderT SqlBackend m (Maybe ReservedPoolTickerId) -insertReservedPoolTicker ticker = do - isUnique <- checkUnique ticker - case isUnique of - Nothing -> Just <$> insertUnchecked "ReservedPoolTicker" ticker - Just _key -> pure Nothing - -insertDelistedPool :: (MonadBaseControl IO m, MonadIO m) => DelistedPool -> ReaderT SqlBackend m DelistedPoolId -insertDelistedPool = insertCheckUnique "DelistedPool" - -insertExtraMigration :: (MonadBaseControl IO m, MonadIO m) => ExtraMigration -> ReaderT SqlBackend m () -insertExtraMigration token = void . insert $ ExtraMigrations (textShow token) (Just $ extraDescription token) - -insertEpochStakeProgress :: (MonadBaseControl IO m, MonadIO m) => [EpochStakeProgress] -> ReaderT SqlBackend m () -insertEpochStakeProgress = - insertManyCheckUnique "Many EpochStakeProgress" - -updateSetComplete :: MonadIO m => Word64 -> ReaderT SqlBackend m () -updateSetComplete epoch = do - upsertWhere (EpochStakeProgress epoch True) [EpochStakeProgressCompleted Database.Persist.=. True] [EpochStakeProgressEpochNo Database.Persist.==. epoch] - -updateGovActionEnacted :: MonadIO m => GovActionProposalId -> Word64 -> ReaderT SqlBackend m Int64 -updateGovActionEnacted gaid eNo = - updateWhereCount [GovActionProposalId ==. gaid, GovActionProposalEnactedEpoch ==. Nothing] [GovActionProposalEnactedEpoch =. Just eNo] - -updateGovActionRatified :: MonadIO m => GovActionProposalId -> Word64 -> ReaderT SqlBackend m () -updateGovActionRatified gaid eNo = - updateWhere [GovActionProposalId ==. gaid, GovActionProposalRatifiedEpoch ==. Nothing] [GovActionProposalRatifiedEpoch =. Just eNo] - -updateGovActionDropped :: MonadIO m => GovActionProposalId -> Word64 -> ReaderT SqlBackend m () -updateGovActionDropped gaid eNo = - updateWhere [GovActionProposalId ==. gaid, GovActionProposalDroppedEpoch ==. Nothing] [GovActionProposalDroppedEpoch =. Just eNo] - -updateGovActionExpired :: MonadIO m => GovActionProposalId -> Word64 -> ReaderT SqlBackend m () -updateGovActionExpired gaid eNo = - updateWhere [GovActionProposalId ==. gaid, GovActionProposalExpiredEpoch ==. Nothing] [GovActionProposalExpiredEpoch =. Just eNo] - -setNullEnacted :: MonadIO m => Word64 -> ReaderT SqlBackend m Int64 -setNullEnacted eNo = - updateWhereCount [GovActionProposalEnactedEpoch !=. Nothing, GovActionProposalEnactedEpoch >. Just eNo] [GovActionProposalEnactedEpoch =. Nothing] - -setNullRatified :: MonadIO m => Word64 -> ReaderT SqlBackend m Int64 -setNullRatified eNo = - updateWhereCount [GovActionProposalRatifiedEpoch !=. Nothing, GovActionProposalRatifiedEpoch >. Just eNo] [GovActionProposalRatifiedEpoch =. Nothing] - -setNullExpired :: MonadIO m => Word64 -> ReaderT SqlBackend m Int64 -setNullExpired eNo = - updateWhereCount [GovActionProposalExpiredEpoch !=. Nothing, GovActionProposalExpiredEpoch >. Just eNo] [GovActionProposalExpiredEpoch =. Nothing] - -setNullDropped :: MonadIO m => Word64 -> ReaderT SqlBackend m Int64 -setNullDropped eNo = - updateWhereCount [GovActionProposalDroppedEpoch !=. Nothing, GovActionProposalDroppedEpoch >. Just eNo] [GovActionProposalDroppedEpoch =. Nothing] - -replaceAdaPots :: (MonadBaseControl IO m, MonadIO m) => BlockId -> AdaPots -> ReaderT SqlBackend m Bool -replaceAdaPots blockId adapots = do - mAdaPotsId <- queryAdaPotsId blockId - case mAdaPotsId of - Nothing -> pure False - Just adaPotsDB - | entityVal adaPotsDB == adapots -> - pure False - Just adaPotsDB -> do - replace (entityKey adaPotsDB) adapots - pure True - -insertAnchor :: (MonadBaseControl IO m, MonadIO m) => VotingAnchor -> ReaderT SqlBackend m VotingAnchorId -insertAnchor = insertCheckUnique "VotingAnchor" - -insertConstitution :: (MonadBaseControl IO m, MonadIO m) => Constitution -> ReaderT SqlBackend m ConstitutionId -insertConstitution = insertUnchecked "Constitution" - -insertGovActionProposal :: (MonadBaseControl IO m, MonadIO m) => GovActionProposal -> ReaderT SqlBackend m GovActionProposalId -insertGovActionProposal = insertUnchecked "GovActionProposal" - -insertTreasuryWithdrawal :: (MonadBaseControl IO m, MonadIO m) => TreasuryWithdrawal -> ReaderT SqlBackend m TreasuryWithdrawalId -insertTreasuryWithdrawal = insertUnchecked "TreasuryWithdrawal" - -insertCommittee :: (MonadBaseControl IO m, MonadIO m) => Committee -> ReaderT SqlBackend m CommitteeId -insertCommittee = insertUnchecked "Committee" - -insertCommitteeMember :: (MonadBaseControl IO m, MonadIO m) => CommitteeMember -> ReaderT SqlBackend m CommitteeMemberId -insertCommitteeMember = insertUnchecked "CommitteeMember" - -insertVotingProcedure :: (MonadBaseControl IO m, MonadIO m) => VotingProcedure -> ReaderT SqlBackend m VotingProcedureId -insertVotingProcedure = insertUnchecked "VotingProcedure" - -insertDrepHash :: (MonadBaseControl IO m, MonadIO m) => DrepHash -> ReaderT SqlBackend m DrepHashId -insertDrepHash = insertCheckUnique "DrepHash" - -insertCommitteeHash :: (MonadBaseControl IO m, MonadIO m) => CommitteeHash -> ReaderT SqlBackend m CommitteeHashId -insertCommitteeHash = insertCheckUnique "CommitteeHash" - -insertDelegationVote :: (MonadBaseControl IO m, MonadIO m) => DelegationVote -> ReaderT SqlBackend m DelegationVoteId -insertDelegationVote = insertUnchecked "DelegationVote" - -insertCommitteeRegistration :: (MonadBaseControl IO m, MonadIO m) => CommitteeRegistration -> ReaderT SqlBackend m CommitteeRegistrationId -insertCommitteeRegistration = insertUnchecked "CommitteeRegistration" - -insertCommitteeDeRegistration :: (MonadBaseControl IO m, MonadIO m) => CommitteeDeRegistration -> ReaderT SqlBackend m CommitteeDeRegistrationId -insertCommitteeDeRegistration = insertUnchecked "CommitteeDeRegistration" - -insertDrepRegistration :: (MonadBaseControl IO m, MonadIO m) => DrepRegistration -> ReaderT SqlBackend m DrepRegistrationId -insertDrepRegistration = insertUnchecked "DrepRegistration" - -insertEpochState :: (MonadBaseControl IO m, MonadIO m) => EpochState -> ReaderT SqlBackend m EpochStateId -insertEpochState = insertUnchecked "EpochState" - -insertManyPoolStat :: (MonadBaseControl IO m, MonadIO m) => [PoolStat] -> ReaderT SqlBackend m () -insertManyPoolStat = void . insertMany' "EpochState" - -insertAlwaysAbstainDrep :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m DrepHashId -insertAlwaysAbstainDrep = do - qr <- queryDrepHashAlwaysAbstain - maybe ins pure qr - where - ins = - insertUnchecked "DrepHashAlwaysAbstain" $ - DrepHash - { drepHashRaw = Nothing - , drepHashView = hardcodedAlwaysAbstain - , drepHashHasScript = False - } - -insertAlwaysNoConfidence :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m DrepHashId -insertAlwaysNoConfidence = do - qr <- queryDrepHashAlwaysNoConfidence - maybe ins pure qr - where - ins = - insertUnchecked "DrepHashAlwaysNoConfidence" $ - DrepHash - { drepHashRaw = Nothing - , drepHashView = hardcodedAlwaysNoConfidence - , drepHashHasScript = False - } - --------------------------------------------------------------------------------- --- Custom insert functions --------------------------------------------------------------------------------- -data DbInsertException - = DbInsertException String SqlError - deriving (Show) - -instance Exception DbInsertException - -insertMany' :: - forall m record. - ( MonadBaseControl IO m - , MonadIO m - , PersistRecordBackend record SqlBackend - , SafeToInsert record - ) => - String -> - [record] -> - ReaderT SqlBackend m [Key record] -insertMany' vtype records = handle exceptHandler (insertMany records) - where - exceptHandler :: SqlError -> ReaderT SqlBackend m [Key record] - exceptHandler e = - liftIO $ throwIO (DbInsertException vtype e) - --- -insertManyUnique :: - forall m record. - ( MonadBaseControl IO m - , MonadIO m - , PersistEntity record - ) => - String -> - -- | Does constraint already exists - Maybe ConstraintNameDB -> - [record] -> - ReaderT SqlBackend m () -insertManyUnique vtype mConstraintName records = do - unless (null records) $ - handle exceptHandler (rawExecute query values) - where - query :: Text - query = - Text.concat - [ "INSERT INTO " - , unEntityNameDB (entityDB . entityDef $ records) - , " (" - , Util.commaSeparated fieldNames - , ") VALUES " - , Util.commaSeparated - . replicate (length records) - . Util.parenWrapped - . Util.commaSeparated - $ placeholders - , conflictQuery - ] - - values :: [PersistValue] - values = concatMap Util.mkInsertValues records - - conflictQuery :: Text - conflictQuery = - case mConstraintName of - Just constraintName -> - Text.concat - [ " ON CONFLICT ON CONSTRAINT " - , unConstraintNameDB constraintName - , " DO NOTHING" - ] - _ -> "" - - fieldNames, placeholders :: [Text] - (fieldNames, placeholders) = - unzip (Util.mkInsertPlaceholders (entityDef (Proxy @record)) escapeFieldName) - - exceptHandler :: SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DbInsertException vtype e) - -insertManyWithManualUnique :: - forall m record. - ( MonadBaseControl IO m - , MonadIO m - , PersistRecordBackend record SqlBackend - ) => - String -> - -- | Does constraint already exists - Bool -> - ConstraintNameDB -> - [record] -> - ReaderT SqlBackend m () -insertManyWithManualUnique str contraintExists constraintName = - insertManyUnique str mConstraintName - where - mConstraintName = if contraintExists then Just constraintName else Nothing - -insertManyCheckUnique :: - forall m record. - ( MonadBaseControl IO m - , MonadIO m - , OnlyOneUniqueKey record - ) => - String -> - [record] -> - ReaderT SqlBackend m () -insertManyCheckUnique vtype records = do - let constraintName = uniqueDBName $ onlyOneUniqueDef (Proxy @record) - insertManyUnique vtype (Just constraintName) records - --- Insert, getting PostgreSQL to check the uniqueness constaint. If it is violated, --- simply returns the Key, without changing anything. -insertCheckUnique :: - forall m record. - ( MonadBaseControl IO m - , MonadIO m - , OnlyOneUniqueKey record - , PersistRecordBackend record SqlBackend - ) => - String -> - record -> - ReaderT SqlBackend m (Key record) -insertCheckUnique vtype record = do - res <- handle exceptHandler $ rawSql query values - case res of - [ident] -> pure ident - _other -> error $ mconcat ["insertCheckUnique: Inserting ", vtype, " failed with ", show res] - where - query :: Text - query = - Text.concat - [ "INSERT INTO " - , unEntityNameDB (entityDB . entityDef $ Just record) - , " (" - , Util.commaSeparated fieldNames - , ") VALUES (" - , Util.commaSeparated placeholders - , ") ON CONFLICT ON CONSTRAINT " - , unConstraintNameDB (uniqueDBName $ onlyOneUniqueDef (Proxy @record)) - , -- An update is necessary, to force Postgres to return the Id. 'EXCLUDED' - -- is used for the new row. 'dummyUpdateField' is a part of the Unique key - -- so even if it is updated with the new value on conflict, no actual - -- effect will take place. - " DO UPDATE SET " - , dummyUpdateField - , " = EXCLUDED." - , dummyUpdateField - , " RETURNING id ;" - ] - - values :: [PersistValue] - values = map toPersistValue (toPersistFields record) - - fieldNames, placeholders :: [Text] - (fieldNames, placeholders) = - unzip (Util.mkInsertPlaceholders (entityDef (Proxy @record)) escapeFieldName) - - exceptHandler :: SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DbInsertException vtype e) - - -- The first field of the Unique key - dummyUpdateField :: Text - dummyUpdateField = escapeFieldName . snd . NonEmpty.head . uniqueFields $ onlyOneUniqueDef (Proxy @record) - -insertReplace :: - forall m record. - ( AtLeastOneUniqueKey record - , Eq (Unique record) - , MonadBaseControl IO m - , MonadIO m - , PersistRecordBackend record SqlBackend - , SafeToInsert record - ) => - String -> - record -> - ReaderT SqlBackend m (Key record) -insertReplace vtype record = - handle exceptHandler $ do - eres <- insertBy record - case eres of - Right rid -> pure rid - Left rec -> do - mres <- replaceUnique (entityKey rec) record - maybe (pure $ entityKey rec) (const . pure $ entityKey rec) mres - where - exceptHandler :: SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DbInsertException vtype e) - --- Insert without checking uniqueness constraints. This should be safe for most tables --- even tables with uniqueness constraints, especially block, tx and many others, where --- uniqueness is enforced by the ledger. -insertUnchecked :: - ( MonadIO m - , MonadBaseControl IO m - , PersistEntityBackend record ~ SqlBackend - , SafeToInsert record - , PersistEntity record - ) => - String -> - record -> - ReaderT SqlBackend m (Key record) -insertUnchecked vtype = - handle exceptHandler . insert - where - exceptHandler :: MonadIO m => SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DbInsertException vtype e) - --- This is cargo culted from Persistent because it is not exported. -escapeFieldName :: FieldNameDB -> Text -escapeFieldName (FieldNameDB s) = - Text.pack $ '"' : go (Text.unpack s) ++ "\"" - where - go "" = "" - go ('"' : xs) = "\"\"" ++ go xs - go (x : xs) = x : go xs +-- insertManyEpochStakes :: +-- (MonadBaseControl IO m, MonadIO m) => +-- -- | Does constraint already exists +-- Bool -> +-- ConstraintNameDB -> +-- [EpochStake] -> +-- ReaderT SqlBackend m () +-- insertManyEpochStakes = insertManyWithManualUnique "Many EpochStake" + +-- insertManyRewards :: +-- (MonadBaseControl IO m, MonadIO m) => +-- -- | Does constraint already exists +-- Bool -> +-- ConstraintNameDB -> +-- [Reward] -> +-- ReaderT SqlBackend m () +-- insertManyRewards = insertManyWithManualUnique "Many Rewards" + +-- insertManyRewardRests :: +-- (MonadBaseControl IO m, MonadIO m) => +-- [RewardRest] -> +-- ReaderT SqlBackend m () +-- insertManyRewardRests = insertManyUnique "Many Rewards Rest" Nothing + +-- insertManyDrepDistr :: +-- (MonadBaseControl IO m, MonadIO m) => +-- [DrepDistr] -> +-- ReaderT SqlBackend m () +-- insertManyDrepDistr = insertManyCheckUnique "Many DrepDistr" + +-- updateSetComplete :: MonadIO m => Word64 -> ReaderT SqlBackend m () +-- updateSetComplete epoch = do +-- upsertWhere (EpochStakeProgress epoch True) [EpochStakeProgressCompleted Database.Persist.=. True] [EpochStakeProgressEpochNo Database.Persist.==. epoch] + +-- replaceAdaPots :: (MonadBaseControl IO m, MonadIO m) => BlockId -> AdaPots -> ReaderT SqlBackend m Bool +-- replaceAdaPots blockId adapots = do +-- mAdaPotsId <- queryAdaPotsId blockId +-- case mAdaPotsId of +-- Nothing -> pure False +-- Just adaPotsDB +-- | entityVal adaPotsDB == adapots -> +-- pure False +-- Just adaPotsDB -> do +-- replace (entityKey adaPotsDB) adapots +-- pure True + +-- -------------------------------------------------------------------------------- +-- -- Custom insert functions +-- -------------------------------------------------------------------------------- +-- data DbInsertException +-- = DbInsertException String SqlError +-- deriving (Show) + +-- instance Exception DbInsertException + +-- insertMany' :: +-- forall m record. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- , PersistRecordBackend record SqlBackend +-- , SafeToInsert record +-- ) => +-- String -> +-- [record] -> +-- ReaderT SqlBackend m [Key record] +-- insertMany' vtype records = handle exceptHandler (insertMany records) +-- where +-- exceptHandler :: SqlError -> ReaderT SqlBackend m [Key record] +-- exceptHandler e = +-- liftIO $ throwIO (DbInsertException vtype e) + +-- -- +-- insertManyUnique :: +-- forall m record. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- , PersistEntity record +-- ) => +-- String -> +-- -- | Does constraint already exists +-- Maybe ConstraintNameDB -> +-- [record] -> +-- ReaderT SqlBackend m () +-- insertManyUnique vtype mConstraintName records = do +-- unless (null records) $ +-- handle exceptHandler (rawExecute query values) +-- where +-- query :: Text +-- query = +-- Text.concat +-- [ "INSERT INTO " +-- , unEntityNameDB (entityDB . entityDef $ records) +-- , " (" +-- , Util.commaSeparated fieldNames +-- , ") VALUES " +-- , Util.commaSeparated +-- . replicate (length records) +-- . Util.parenWrapped +-- . Util.commaSeparated +-- $ placeholders +-- , conflictQuery +-- ] + +-- values :: [PersistValue] +-- values = concatMap Util.mkInsertValues records + +-- conflictQuery :: Text +-- conflictQuery = +-- case mConstraintName of +-- Just constraintName -> +-- Text.concat +-- [ " ON CONFLICT ON CONSTRAINT " +-- , unConstraintNameDB constraintName +-- , " DO NOTHING" +-- ] +-- _ -> "" + +-- fieldNames, placeholders :: [Text] +-- (fieldNames, placeholders) = +-- unzip (Util.mkInsertPlaceholders (entityDef (Proxy @record)) escapeFieldName) + +-- exceptHandler :: SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DbInsertException vtype e) + +-- insertManyWithManualUnique :: +-- forall m record. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- , PersistRecordBackend record SqlBackend +-- ) => +-- String -> +-- -- | Does constraint already exists +-- Bool -> +-- ConstraintNameDB -> +-- [record] -> +-- ReaderT SqlBackend m () +-- insertManyWithManualUnique str contraintExists constraintName = +-- insertManyUnique str mConstraintName +-- where +-- mConstraintName = if contraintExists then Just constraintName else Nothing + +-- -- insertManyCheckUnique :: +-- -- forall m record. +-- -- ( MonadBaseControl IO m +-- -- , MonadIO m +-- -- , OnlyOneUniqueKey record +-- -- ) => +-- -- String -> +-- -- [record] -> +-- -- ReaderT SqlBackend m () +-- -- insertManyCheckUnique vtype records = do +-- -- let constraintName = uniqueDBName $ onlyOneUniqueDef (Proxy @record) +-- -- insertManyUnique vtype (Just constraintName) records + +-- -- Insert, getting PostgreSQL to check the uniqueness constaint. If it is violated, +-- -- simply returns the Key, without changing anything. +-- insertCheckUnique :: +-- forall m record. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- , OnlyOneUniqueKey record +-- , PersistRecordBackend record SqlBackend +-- ) => +-- String -> +-- record -> +-- ReaderT SqlBackend m (Key record) +-- insertCheckUnique vtype record = do +-- res <- handle exceptHandler $ rawSql query values +-- case res of +-- [ident] -> pure ident +-- _other -> error $ mconcat ["insertCheckUnique: Inserting ", vtype, " failed with ", show res] +-- where +-- query :: Text +-- query = +-- Text.concat +-- [ "INSERT INTO " +-- , unEntityNameDB (entityDB . entityDef $ Just record) +-- , " (" +-- , Util.commaSeparated fieldNames +-- , ") VALUES (" +-- , Util.commaSeparated placeholders +-- , ") ON CONFLICT ON CONSTRAINT " +-- , unConstraintNameDB (uniqueDBName $ onlyOneUniqueDef (Proxy @record)) +-- , -- An update is necessary, to force Postgres to return the Id. 'EXCLUDED' +-- -- is used for the new row. 'dummyUpdateField' is a part of the Unique key +-- -- so even if it is updated with the new value on conflict, no actual +-- -- effect will take place. +-- " DO UPDATE SET " +-- , dummyUpdateField +-- , " = EXCLUDED." +-- , dummyUpdateField +-- , " RETURNING id ;" +-- ] + +-- values :: [PersistValue] +-- values = map toPersistValue (toPersistFields record) + +-- fieldNames, placeholders :: [Text] +-- (fieldNames, placeholders) = +-- unzip (Util.mkInsertPlaceholders (entityDef (Proxy @record)) escapeFieldName) + +-- exceptHandler :: SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DbInsertException vtype e) + +-- -- The first field of the Unique key +-- dummyUpdateField :: Text +-- dummyUpdateField = escapeFieldName . snd . NonEmpty.head . uniqueFields $ onlyOneUniqueDef (Proxy @record) + +-- insertReplace :: +-- forall m record. +-- ( AtLeastOneUniqueKey record +-- , Eq (Unique record) +-- , MonadBaseControl IO m +-- , MonadIO m +-- , PersistRecordBackend record SqlBackend +-- , SafeToInsert record +-- ) => +-- String -> +-- record -> +-- ReaderT SqlBackend m (Key record) +-- insertReplace vtype record = +-- handle exceptHandler $ do +-- eres <- insertBy record +-- case eres of +-- Right rid -> pure rid +-- Left rec -> do +-- mres <- replaceUnique (entityKey rec) record +-- maybe (pure $ entityKey rec) (const . pure $ entityKey rec) mres +-- where +-- exceptHandler :: SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DbInsertException vtype e) + +-- -- Insert without checking uniqueness constraints. This should be safe for most tables +-- -- even tables with uniqueness constraints, especially block, tx and many others, where +-- -- uniqueness is enforced by the ledger. +-- insertUnchecked :: +-- ( MonadIO m +-- , MonadBaseControl IO m +-- , PersistEntityBackend record ~ SqlBackend +-- , SafeToInsert record +-- , PersistEntity record +-- ) => +-- String -> +-- record -> +-- ReaderT SqlBackend m (Key record) +-- insertUnchecked vtype = +-- handle exceptHandler . insert +-- where +-- exceptHandler :: MonadIO m => SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DbInsertException vtype e) + +-- -- This is cargo culted from Persistent because it is not exported. +-- escapeFieldName :: FieldNameDB -> Text +-- escapeFieldName (FieldNameDB s) = +-- Text.pack $ '"' : go (Text.unpack s) ++ "\"" +-- where +-- go "" = "" +-- go ('"' : xs) = "\"\"" ++ go xs +-- go (x : xs) = x : go xs -- This is cargo culted from Persistent because it is not exported. -- https://github.com/yesodweb/persistent/issues/1194 -onlyOneUniqueDef :: OnlyOneUniqueKey record => proxy record -> UniqueDef -onlyOneUniqueDef prxy = - case entityUniques (entityDef prxy) of - [uniq] -> uniq - _ -> error "impossible due to OnlyOneUniqueKey constraint" +-- onlyOneUniqueDef :: OnlyOneUniqueKey record => proxy record -> UniqueDef +-- onlyOneUniqueDef prxy = +-- case entityUniques (entityDef prxy) of +-- [uniq] -> uniq +-- _ -> error "impossible due to OnlyOneUniqueKey constraint" -- Used in tests -insertBlockChecked :: (MonadBaseControl IO m, MonadIO m) => Block -> ReaderT SqlBackend m BlockId -insertBlockChecked = insertCheckUnique "Block" +-- insertBlockChecked :: (MonadBaseControl IO m, MonadIO m) => Block -> ReaderT SqlBackend m BlockId +-- insertBlockChecked = insertCheckUnique "Block" diff --git a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs index 47f68e513..56447fec0 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs @@ -13,571 +13,571 @@ module Cardano.Db.Operations.Other.ConsumedTxOut where -import Cardano.BM.Trace (Trace, logInfo) -import Cardano.Db.Error (LookupFail (..), logAndThrowIO) -import Cardano.Db.Operations.Insert (insertExtraMigration) -import Cardano.Db.Operations.Query (listToMaybe, queryAllExtraMigrations, queryBlockHeight, queryBlockNo, queryMaxRefId) -import Cardano.Db.Operations.QueryHelper (isJust) -import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTable, TxOutTableType (..), isTxOutVariantAddress) -import Cardano.Db.Schema.BaseSchema -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.Db.Types (ExtraMigration (..), MigrationValues (..), PruneConsumeMigration (..), processMigrationValues) -import Cardano.Prelude (textShow, void) -import Control.Exception (throw) -import Control.Exception.Lifted (handle, throwIO) -import Control.Monad.Extra (unless, when, whenJust) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word64) -import Database.Esqueleto.Experimental hiding (update, (<=.), (=.), (==.)) -import qualified Database.Esqueleto.Experimental as E -import Database.Persist ((<=.), (=.), (==.)) -import Database.Persist.Class (update) -import Database.Persist.Sql (deleteWhereCount) -import Database.PostgreSQL.Simple (SqlError) - -pageSize :: Word64 -pageSize = 100_000 - -data ConsumedTriplet = ConsumedTriplet - { ctTxOutTxId :: TxId -- The txId of the txOut - , ctTxOutIndex :: Word64 -- Tx index of the txOut - , ctTxInTxId :: TxId -- The txId of the txId - } - --------------------------------------------------------------------------------------------------- --- Queries --------------------------------------------------------------------------------------------------- -querySetNullTxOut :: - MonadIO m => - TxOutTableType -> - Maybe TxId -> - ReaderT SqlBackend m (Text, Int64) -querySetNullTxOut txOutTableType mMinTxId = do - case mMinTxId of - Nothing -> do - pure ("No tx_out to set to null", 0) - Just txId -> do - txOutIds <- getTxOutConsumedAfter txId - mapM_ setNullTxOutConsumedAfter txOutIds - let updatedEntriesCount = length txOutIds - pure ("tx_out.consumed_by_tx_id", fromIntegral updatedEntriesCount) - where - -- \| This requires an index at TxOutConsumedByTxId. - getTxOutConsumedAfter :: MonadIO m => TxId -> ReaderT SqlBackend m [TxOutIdW] - getTxOutConsumedAfter txId = - case txOutTableType of - TxOutCore -> wrapTxOutIds CTxOutIdW (queryConsumedTxOutIds @'TxOutCore txId) - TxOutVariantAddress -> wrapTxOutIds VTxOutIdW (queryConsumedTxOutIds @'TxOutVariantAddress txId) - where - wrapTxOutIds constructor = fmap (map constructor) - - queryConsumedTxOutIds :: - forall a m. - (TxOutFields a, MonadIO m) => - TxId -> - ReaderT SqlBackend m [TxOutIdFor a] - queryConsumedTxOutIds txId' = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - where_ (txOut ^. txOutConsumedByTxIdField @a >=. just (val txId')) - pure $ txOut ^. txOutIdField @a - pure $ map unValue res - - -- \| This requires an index at TxOutConsumedByTxId. - setNullTxOutConsumedAfter :: MonadIO m => TxOutIdW -> ReaderT SqlBackend m () - setNullTxOutConsumedAfter txOutId = - case txOutTableType of - TxOutCore -> setNull - TxOutVariantAddress -> setNull - where - setNull :: - (MonadIO m) => - ReaderT SqlBackend m () - setNull = do - case txOutId of - CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Nothing] - VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Nothing] - -runExtraMigrations :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> TxOutTableType -> Word64 -> PruneConsumeMigration -> ReaderT SqlBackend m () -runExtraMigrations trce txOutTableType blockNoDiff pcm = do - ems <- queryAllExtraMigrations - isTxOutNull <- queryTxOutIsNull txOutTableType - let migrationValues = processMigrationValues ems pcm - isTxOutVariant = isTxOutVariantAddress txOutTableType - isTxOutAddressSet = isTxOutAddressPreviouslySet migrationValues - - -- can only run "use_address_table" on a non populated database but don't throw if the migration was previously set - when (isTxOutVariant && not isTxOutNull && not isTxOutAddressSet) $ - throw $ - DBExtraMigration "runExtraMigrations: The use of the config 'tx_out.use_address_table' can only be caried out on a non populated database." - -- Make sure the config "use_address_table" is there if the migration wasn't previously set in the past - when (not isTxOutVariant && isTxOutAddressSet) $ - throw $ - DBExtraMigration "runExtraMigrations: The configuration option 'tx_out.use_address_table' was previously set and the database updated. Unfortunately reverting this isn't possible." - -- Has the user given txout address config && the migration wasn't previously set - when (isTxOutVariant && not isTxOutAddressSet) $ do - updateTxOutAndCreateAddress trce - insertExtraMigration TxOutAddressPreviouslySet - -- first check if pruneTxOut flag is missing and it has previously been used - when (isPruneTxOutPreviouslySet migrationValues && not (pcmPruneTxOut pcm)) $ - throw $ - DBExtraMigration - "If --prune-tx-out flag is enabled and then db-sync is stopped all future executions of db-sync should still have this flag activated. Otherwise, it is considered bad usage and can cause crashes." - handleMigration migrationValues - where - handleMigration :: (MonadBaseControl IO m, MonadIO m) => MigrationValues -> ReaderT SqlBackend m () - handleMigration migrationValues@MigrationValues {..} = do - let PruneConsumeMigration {..} = pruneConsumeMigration - case (isConsumeTxOutPreviouslySet, pcmConsumedTxOut, pcmPruneTxOut) of - -- No Migration Needed - (False, False, False) -> do - liftIO $ logInfo trce "runExtraMigrations: No extra migration specified" - -- Already migrated - (True, True, False) -> do - liftIO $ logInfo trce "runExtraMigrations: Extra migration consumed_tx_out already executed" - -- Invalid State - (True, False, False) -> liftIO $ logAndThrowIO trce "runExtraMigrations: consumed-tx-out or prune-tx-out is not set, but consumed migration is found." - -- Consume TxOut - (False, True, False) -> do - liftIO $ logInfo trce "runExtraMigrations: Running extra migration consumed_tx_out" - insertExtraMigration ConsumeTxOutPreviouslySet - migrateTxOut trce txOutTableType $ Just migrationValues - -- Prune TxOut - (_, _, True) -> do - unless isPruneTxOutPreviouslySet $ insertExtraMigration PruneTxOutFlagPreviouslySet - if isConsumeTxOutPreviouslySet - then do - liftIO $ logInfo trce "runExtraMigrations: Running extra migration prune tx_out" - deleteConsumedTxOut trce txOutTableType blockNoDiff - else deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues blockNoDiff - -queryWrongConsumedBy :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 -queryWrongConsumedBy = \case - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Word64 - query = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - where_ (just (txOut ^. txOutTxIdField @a) E.==. txOut ^. txOutConsumedByTxIdField @a) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --------------------------------------------------------------------------------------------------- --- Queries Tests --------------------------------------------------------------------------------------------------- - --- | This is a count of the null consumed_by_tx_id -queryTxOutConsumedNullCount :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 -queryTxOutConsumedNullCount = \case - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Word64 - query = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - where_ (isNothing $ txOut ^. txOutConsumedByTxIdField @a) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryTxOutConsumedCount :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 -queryTxOutConsumedCount = \case - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Word64 - query = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - where_ (not_ $ isNothing $ txOut ^. txOutConsumedByTxIdField @a) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryTxOutIsNull :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Bool -queryTxOutIsNull = \case - TxOutCore -> pure False - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Bool - query = do - res <- select $ do - _ <- from $ table @(TxOutTable a) - limit 1 - pure (val (1 :: Int)) - pure $ null res - --------------------------------------------------------------------------------------------------- --- Updates --------------------------------------------------------------------------------------------------- -updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () -updateListTxOutConsumedByTxId ls = do - mapM_ (uncurry updateTxOutConsumedByTxId) ls - where - updateTxOutConsumedByTxId :: MonadIO m => TxOutIdW -> TxId -> ReaderT SqlBackend m () - updateTxOutConsumedByTxId txOutId txId = - case txOutId of - CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Just txId] - VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Just txId] - -migrateTxOut :: - ( MonadBaseControl IO m - , MonadIO m - ) => - Trace IO Text -> - TxOutTableType -> - Maybe MigrationValues -> - ReaderT SqlBackend m () -migrateTxOut trce txOutTableType mMvs = do - whenJust mMvs $ \mvs -> do - when (pcmConsumedTxOut (pruneConsumeMigration mvs) && not (isTxOutAddressPreviouslySet mvs)) $ do - liftIO $ logInfo trce "migrateTxOut: adding consumed-by-id Index" - void createConsumedIndexTxOut - when (pcmPruneTxOut (pruneConsumeMigration mvs)) $ do - liftIO $ logInfo trce "migrateTxOut: adding prune contraint on tx_out table" - void createPruneConstraintTxOut - migrateNextPageTxOut (Just trce) txOutTableType 0 - -migrateNextPageTxOut :: MonadIO m => Maybe (Trace IO Text) -> TxOutTableType -> Word64 -> ReaderT SqlBackend m () -migrateNextPageTxOut mTrce txOutTableType offst = do - whenJust mTrce $ \trce -> - liftIO $ logInfo trce $ "migrateNextPageTxOut: Handling input offset " <> textShow offst - page <- getInputPage offst pageSize - updatePageEntries txOutTableType page - when (fromIntegral (length page) == pageSize) $ - migrateNextPageTxOut mTrce txOutTableType $! - (offst + pageSize) - --------------------------------------------------------------------------------------------------- --- Delete + Update --------------------------------------------------------------------------------------------------- -deleteAndUpdateConsumedTxOut :: - forall m. - (MonadIO m, MonadBaseControl IO m) => - Trace IO Text -> - TxOutTableType -> - MigrationValues -> - Word64 -> - ReaderT SqlBackend m () -deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues blockNoDiff = do - maxTxId <- findMaxTxInId blockNoDiff - case maxTxId of - Left errMsg -> do - liftIO $ logInfo trce $ "No tx_out were deleted as no blocks found: " <> errMsg - liftIO $ logInfo trce "deleteAndUpdateConsumedTxOut: Now Running extra migration prune tx_out" - migrateTxOut trce txOutTableType $ Just migrationValues - insertExtraMigration ConsumeTxOutPreviouslySet - Right mTxId -> do - migrateNextPage mTxId False 0 - where - migrateNextPage :: TxId -> Bool -> Word64 -> ReaderT SqlBackend m () - migrateNextPage maxTxId ranCreateConsumedTxOut offst = do - pageEntries <- getInputPage offst pageSize - resPageEntries <- splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pageEntries - when (fromIntegral (length pageEntries) == pageSize) $ - migrateNextPage maxTxId resPageEntries $! - offst - + pageSize - --- Split the page entries by maxTxInId and process -splitAndProcessPageEntries :: - forall m. - (MonadIO m, MonadBaseControl IO m) => - Trace IO Text -> - TxOutTableType -> - Bool -> - TxId -> - [ConsumedTriplet] -> - ReaderT SqlBackend m Bool -splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pageEntries = do - let entriesSplit = span (\tr -> ctTxInTxId tr <= maxTxId) pageEntries - case entriesSplit of - ([], []) -> do - shouldCreateConsumedTxOut trce ranCreateConsumedTxOut - pure True - -- the whole list is less that maxTxInId - (xs, []) -> do - deletePageEntries txOutTableType xs - pure False - -- the whole list is greater that maxTxInId - ([], ys) -> do - shouldCreateConsumedTxOut trce ranCreateConsumedTxOut - updatePageEntries txOutTableType ys - pure True - -- the list has both bellow and above maxTxInId - (xs, ys) -> do - deletePageEntries txOutTableType xs - shouldCreateConsumedTxOut trce ranCreateConsumedTxOut - updatePageEntries txOutTableType ys - pure True - -shouldCreateConsumedTxOut :: - (MonadIO m, MonadBaseControl IO m) => - Trace IO Text -> - Bool -> - ReaderT SqlBackend m () -shouldCreateConsumedTxOut trce rcc = - unless rcc $ do - liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." - createConsumedIndexTxOut - --- | Update -updatePageEntries :: - MonadIO m => - TxOutTableType -> - [ConsumedTriplet] -> - ReaderT SqlBackend m () -updatePageEntries txOutTableType = mapM_ (updateTxOutConsumedByTxIdUnique txOutTableType) - -updateTxOutConsumedByTxIdUnique :: MonadIO m => TxOutTableType -> ConsumedTriplet -> ReaderT SqlBackend m () -updateTxOutConsumedByTxIdUnique txOutTableType ConsumedTriplet {ctTxOutTxId, ctTxOutIndex, ctTxInTxId} = - case txOutTableType of - TxOutCore -> updateWhere [C.TxOutTxId ==. ctTxOutTxId, C.TxOutIndex ==. ctTxOutIndex] [C.TxOutConsumedByTxId =. Just ctTxInTxId] - TxOutVariantAddress -> updateWhere [V.TxOutTxId ==. ctTxOutTxId, V.TxOutIndex ==. ctTxOutIndex] [V.TxOutConsumedByTxId =. Just ctTxInTxId] - --- this builds up a single delete query using the pageEntries list -deletePageEntries :: - MonadIO m => - TxOutTableType -> - [ConsumedTriplet] -> - ReaderT SqlBackend m () -deletePageEntries txOutTableType = mapM_ (\ConsumedTriplet {ctTxOutTxId, ctTxOutIndex} -> deleteTxOutConsumed txOutTableType ctTxOutTxId ctTxOutIndex) - -deleteTxOutConsumed :: MonadIO m => TxOutTableType -> TxId -> Word64 -> ReaderT SqlBackend m () -deleteTxOutConsumed txOutTableType txOutId index = case txOutTableType of - TxOutCore -> deleteWhere [C.TxOutTxId ==. txOutId, C.TxOutIndex ==. index] - TxOutVariantAddress -> deleteWhere [V.TxOutTxId ==. txOutId, V.TxOutIndex ==. index] - --------------------------------------------------------------------------------------------------- --- Raw Queries --------------------------------------------------------------------------------------------------- - -createConsumedIndexTxOut :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - ReaderT SqlBackend m () -createConsumedIndexTxOut = do - handle exceptHandler $ rawExecute createIndex [] - where - createIndex = - "CREATE INDEX IF NOT EXISTS idx_tx_out_consumed_by_tx_id ON tx_out (consumed_by_tx_id)" - - exceptHandler :: SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DBPruneConsumed $ show e) - -createPruneConstraintTxOut :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - ReaderT SqlBackend m () -createPruneConstraintTxOut = do - handle exceptHandler $ rawExecute addConstraint [] - where - addConstraint = - Text.unlines - [ "do $$" - , "begin" - , " if not exists (" - , " select 1" - , " from information_schema.table_constraints" - , " where constraint_name = 'ma_tx_out_tx_out_id_fkey'" - , " and table_name = 'ma_tx_out'" - , " ) then" - , " execute 'alter table ma_tx_out add constraint ma_tx_out_tx_out_id_fkey foreign key(tx_out_id) references tx_out(id) on delete cascade on update restrict';" - , " end if;" - , "end $$;" - ] - - exceptHandler :: SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DBPruneConsumed $ show e) - --- Be very mindfull that these queries can fail silently and make tests fail making it hard to know why. --- To help mitigate this, logs are printed after each query is ran, so one can know where it stopped. -updateTxOutAndCreateAddress :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - Trace IO Text -> - ReaderT SqlBackend m () -updateTxOutAndCreateAddress trc = do - handle exceptHandler $ rawExecute dropViewsQuery [] - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Dropped views" - handle exceptHandler $ rawExecute alterTxOutQuery [] - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Altered tx_out" - handle exceptHandler $ rawExecute alterCollateralTxOutQuery [] - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Altered collateral_tx_out" - handle exceptHandler $ rawExecute createAddressTableQuery [] - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Created address table" - handle exceptHandler $ rawExecute createIndexPaymentCredQuery [] - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Created index payment_cred" - handle exceptHandler $ rawExecute createIndexRawQuery [] - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Created index raw" - liftIO $ logInfo trc "updateTxOutAndCreateAddress: Completed" - where - dropViewsQuery = - Text.unlines - [ "DROP VIEW IF EXISTS utxo_byron_view;" - , "DROP VIEW IF EXISTS utxo_view;" - ] - - alterTxOutQuery = - Text.unlines - [ "ALTER TABLE \"tx_out\"" - , " ADD COLUMN \"address_id\" INT8 NOT NULL," - , " DROP COLUMN \"address\"," - , " DROP COLUMN \"address_has_script\"," - , " DROP COLUMN \"payment_cred\"" - ] - - alterCollateralTxOutQuery = - Text.unlines - [ "ALTER TABLE \"collateral_tx_out\"" - , " ADD COLUMN \"address_id\" INT8 NOT NULL," - , " DROP COLUMN \"address\"," - , " DROP COLUMN \"address_has_script\"," - , " DROP COLUMN \"payment_cred\"" - ] - - createAddressTableQuery = - Text.unlines - [ "CREATE TABLE \"address\" (" - , " \"id\" SERIAL8 PRIMARY KEY UNIQUE," - , " \"address\" VARCHAR NOT NULL," - , " \"raw\" BYTEA NOT NULL," - , " \"has_script\" BOOLEAN NOT NULL," - , " \"payment_cred\" hash28type NULL," - , " \"stake_address_id\" INT8 NULL" - , ")" - ] - - createIndexPaymentCredQuery = - "CREATE INDEX IF NOT EXISTS idx_address_payment_cred ON address(payment_cred);" - - createIndexRawQuery = - "CREATE INDEX IF NOT EXISTS idx_address_raw ON address USING HASH (raw);" - - exceptHandler :: SqlError -> ReaderT SqlBackend m a - exceptHandler e = - liftIO $ throwIO (DBPruneConsumed $ show e) - --------------------------------------------------------------------------------------------------- --- Delete --------------------------------------------------------------------------------------------------- -deleteConsumedTxOut :: - forall m. - MonadIO m => - Trace IO Text -> - TxOutTableType -> - Word64 -> - ReaderT SqlBackend m () -deleteConsumedTxOut trce txOutTableType blockNoDiff = do - maxTxInId <- findMaxTxInId blockNoDiff - case maxTxInId of - Left errMsg -> liftIO $ logInfo trce $ "No tx_out was deleted: " <> errMsg - Right mxtid -> deleteConsumedBeforeTx trce txOutTableType mxtid - -deleteConsumedBeforeTx :: MonadIO m => Trace IO Text -> TxOutTableType -> TxId -> ReaderT SqlBackend m () -deleteConsumedBeforeTx trce txOutTableType txId = do - countDeleted <- case txOutTableType of - TxOutCore -> deleteWhereCount [C.TxOutConsumedByTxId <=. Just txId] - TxOutVariantAddress -> deleteWhereCount [V.TxOutConsumedByTxId <=. Just txId] - liftIO $ logInfo trce $ "Deleted " <> textShow countDeleted <> " tx_out" - --------------------------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------------------------- -migrateTxOutDbTool :: (MonadIO m, MonadBaseControl IO m) => TxOutTableType -> ReaderT SqlBackend m () -migrateTxOutDbTool txOutTableType = do - _ <- createConsumedIndexTxOut - migrateNextPageTxOut Nothing txOutTableType 0 - -findMaxTxInId :: forall m. MonadIO m => Word64 -> ReaderT SqlBackend m (Either Text TxId) -findMaxTxInId blockNoDiff = do - mBlockHeight <- queryBlockHeight - maybe (pure $ Left "No blocks found") findConsumed mBlockHeight - where - findConsumed :: Word64 -> ReaderT SqlBackend m (Either Text TxId) - findConsumed tipBlockNo = do - if tipBlockNo <= blockNoDiff - then pure $ Left $ "Tip blockNo is " <> textShow tipBlockNo - else do - mBlockId <- queryBlockNo $ tipBlockNo - blockNoDiff - maybe - (pure $ Left $ "BlockNo hole found at " <> textShow (tipBlockNo - blockNoDiff)) - findConsumedBeforeBlock - mBlockId - - findConsumedBeforeBlock :: BlockId -> ReaderT SqlBackend m (Either Text TxId) - findConsumedBeforeBlock blockId = do - mTxId <- queryMaxRefId TxBlockId blockId False - case mTxId of - Nothing -> pure $ Left $ "No txs found before " <> textShow blockId - Just txId -> pure $ Right txId - -getInputPage :: MonadIO m => Word64 -> Word64 -> ReaderT SqlBackend m [ConsumedTriplet] -getInputPage offs pgSize = do - res <- select $ do - txIn <- from $ table @TxIn - limit (fromIntegral pgSize) - offset (fromIntegral offs) - orderBy [asc (txIn ^. TxInId)] - pure txIn - pure $ convert <$> res - where - convert txIn = - ConsumedTriplet - { ctTxOutTxId = txInTxOutId (entityVal txIn) - , ctTxOutIndex = txInTxOutIndex (entityVal txIn) - , ctTxInTxId = txInTxInId (entityVal txIn) - } - -countTxIn :: MonadIO m => ReaderT SqlBackend m Word64 -countTxIn = do - res <- select $ do - _ <- from $ table @TxIn - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -countConsumed :: - MonadIO m => - TxOutTableType -> - ReaderT SqlBackend m Word64 -countConsumed = \case - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Word64 - query = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - where_ (isJust $ txOut ^. txOutConsumedByTxIdField @a) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) +-- import Cardano.BM.Trace (Trace, logInfo) +-- import Cardano.Db.Error (LookupFail (..), logAndThrowIO) +-- import Cardano.Db.Operations.Insert (insertExtraMigration) +-- import Cardano.Db.Operations.Query (listToMaybe, queryAllExtraMigrations, queryBlockHeight, queryBlockNo, queryMaxRefId) +-- import Cardano.Db.Operations.QueryHelper (isJust) +-- import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTable, TxOutTableType (..), isTxOutVariantAddress) +-- import Cardano.Db.Schema.Core +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Cardano.Db.Types (ExtraMigration (..), MigrationValues (..), PruneConsumeMigration (..), processMigrationValues) +-- import Cardano.Prelude (textShow, void) +-- import Control.Exception (throw) +-- import Control.Exception.Lifted (handle, throwIO) +-- import Control.Monad.Extra (unless, when, whenJust) +-- import Control.Monad.IO.Class (MonadIO, liftIO) +-- import Control.Monad.Trans.Control (MonadBaseControl) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import Data.Int (Int64) +-- import Data.Text (Text) +-- import qualified Data.Text as Text +-- import Data.Word (Word64) +-- import Database.Esqueleto.Experimental hiding (update, (<=.), (=.), (==.)) +-- import qualified Database.Esqueleto.Experimental as E +-- import Database.Persist ((<=.), (=.), (==.)) +-- import Database.Persist.Class (update) +-- import Database.Persist.Sql (deleteWhereCount) +-- import Database.PostgreSQL.Simple (SqlError) + +-- pageSize :: Word64 +-- pageSize = 100_000 + +-- data ConsumedTriplet = ConsumedTriplet +-- { ctTxOutTxId :: TxId -- The txId of the txOut +-- , ctTxOutIndex :: Word64 -- Tx index of the txOut +-- , ctTxInTxId :: TxId -- The txId of the txId +-- } + +-- -------------------------------------------------------------------------------------------------- +-- -- Queries +-- -------------------------------------------------------------------------------------------------- +-- querySetNullTxOut :: +-- MonadIO m => +-- TxOutTableType -> +-- Maybe TxId -> +-- ReaderT SqlBackend m (Text, Int64) +-- querySetNullTxOut txOutTableType mMinTxId = do +-- case mMinTxId of +-- Nothing -> do +-- pure ("No tx_out to set to null", 0) +-- Just txId -> do +-- txOutIds <- getTxOutConsumedAfter txId +-- mapM_ setNullTxOutConsumedAfter txOutIds +-- let updatedEntriesCount = length txOutIds +-- pure ("tx_out.consumed_by_tx_id", fromIntegral updatedEntriesCount) +-- where +-- -- \| This requires an index at TxOutConsumedByTxId. +-- getTxOutConsumedAfter :: MonadIO m => TxId -> ReaderT SqlBackend m [TxOutIdW] +-- getTxOutConsumedAfter txId = +-- case txOutTableType of +-- TxOutCore -> wrapTxOutIds CTxOutIdW (queryConsumedTxOutIds @'TxOutCore txId) +-- TxOutVariantAddress -> wrapTxOutIds VTxOutIdW (queryConsumedTxOutIds @'TxOutVariantAddress txId) +-- where +-- wrapTxOutIds constructor = fmap (map constructor) + +-- queryConsumedTxOutIds :: +-- forall a m. +-- (TxOutFields a, MonadIO m) => +-- TxId -> +-- ReaderT SqlBackend m [TxOutIdFor a] +-- queryConsumedTxOutIds txId' = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- where_ (txOut ^. txOutConsumedByTxIdField @a >=. just (val txId')) +-- pure $ txOut ^. txOutIdField @a +-- pure $ map unValue res + +-- -- \| This requires an index at TxOutConsumedByTxId. +-- setNullTxOutConsumedAfter :: MonadIO m => TxOutIdW -> ReaderT SqlBackend m () +-- setNullTxOutConsumedAfter txOutId = +-- case txOutTableType of +-- TxOutCore -> setNull +-- TxOutVariantAddress -> setNull +-- where +-- setNull :: +-- MonadIO m => +-- ReaderT SqlBackend m () +-- setNull = do +-- case txOutId of +-- CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Nothing] +-- VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Nothing] + +-- runExtraMigrations :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> TxOutTableType -> Word64 -> PruneConsumeMigration -> ReaderT SqlBackend m () +-- runExtraMigrations trce txOutTableType blockNoDiff pcm = do +-- ems <- queryAllExtraMigrations +-- isTxOutNull <- queryTxOutIsNull txOutTableType +-- let migrationValues = processMigrationValues ems pcm +-- isTxOutVariant = isTxOutVariantAddress txOutTableType +-- isTxOutAddressSet = isTxOutAddressPreviouslySet migrationValues + +-- -- can only run "use_address_table" on a non populated database but don't throw if the migration was previously set +-- when (isTxOutVariant && not isTxOutNull && not isTxOutAddressSet) $ +-- throw $ +-- DBExtraMigration "runExtraMigrations: The use of the config 'tx_out.use_address_table' can only be caried out on a non populated database." +-- -- Make sure the config "use_address_table" is there if the migration wasn't previously set in the past +-- when (not isTxOutVariant && isTxOutAddressSet) $ +-- throw $ +-- DBExtraMigration "runExtraMigrations: The configuration option 'tx_out.use_address_table' was previously set and the database updated. Unfortunately reverting this isn't possible." +-- -- Has the user given txout address config && the migration wasn't previously set +-- when (isTxOutVariant && not isTxOutAddressSet) $ do +-- updateTxOutAndCreateAddress trce +-- insertExtraMigration TxOutAddressPreviouslySet +-- -- first check if pruneTxOut flag is missing and it has previously been used +-- when (isPruneTxOutPreviouslySet migrationValues && not (pcmPruneTxOut pcm)) $ +-- throw $ +-- DBExtraMigration +-- "If --prune-tx-out flag is enabled and then db-sync is stopped all future executions of db-sync should still have this flag activated. Otherwise, it is considered bad usage and can cause crashes." +-- handleMigration migrationValues +-- where +-- handleMigration :: (MonadBaseControl IO m, MonadIO m) => MigrationValues -> ReaderT SqlBackend m () +-- handleMigration migrationValues@MigrationValues {..} = do +-- let PruneConsumeMigration {..} = pruneConsumeMigration +-- case (isConsumeTxOutPreviouslySet, pcmConsumedTxOut, pcmPruneTxOut) of +-- -- No Migration Needed +-- (False, False, False) -> do +-- liftIO $ logInfo trce "runExtraMigrations: No extra migration specified" +-- -- Already migrated +-- (True, True, False) -> do +-- liftIO $ logInfo trce "runExtraMigrations: Extra migration consumed_tx_out already executed" +-- -- Invalid State +-- (True, False, False) -> liftIO $ logAndThrowIO trce "runExtraMigrations: consumed-tx-out or prune-tx-out is not set, but consumed migration is found." +-- -- Consume TxOut +-- (False, True, False) -> do +-- liftIO $ logInfo trce "runExtraMigrations: Running extra migration consumed_tx_out" +-- insertExtraMigration ConsumeTxOutPreviouslySet +-- migrateTxOut trce txOutTableType $ Just migrationValues +-- -- Prune TxOut +-- (_, _, True) -> do +-- unless isPruneTxOutPreviouslySet $ insertExtraMigration PruneTxOutFlagPreviouslySet +-- if isConsumeTxOutPreviouslySet +-- then do +-- liftIO $ logInfo trce "runExtraMigrations: Running extra migration prune tx_out" +-- deleteConsumedTxOut trce txOutTableType blockNoDiff +-- else deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues blockNoDiff + +-- queryWrongConsumedBy :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 +-- queryWrongConsumedBy = \case +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Word64 +-- query = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- where_ (just (txOut ^. txOutTxIdField @a) E.==. txOut ^. txOutConsumedByTxIdField @a) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- -------------------------------------------------------------------------------------------------- +-- -- Queries Tests +-- -------------------------------------------------------------------------------------------------- + +-- -- | This is a count of the null consumed_by_tx_id +-- queryTxOutConsumedNullCount :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 +-- queryTxOutConsumedNullCount = \case +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Word64 +-- query = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- where_ (isNothing $ txOut ^. txOutConsumedByTxIdField @a) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryTxOutConsumedCount :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Word64 +-- queryTxOutConsumedCount = \case +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Word64 +-- query = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- where_ (not_ $ isNothing $ txOut ^. txOutConsumedByTxIdField @a) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryTxOutIsNull :: TxOutTableType -> MonadIO m => ReaderT SqlBackend m Bool +-- queryTxOutIsNull = \case +-- TxOutCore -> pure False +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Bool +-- query = do +-- res <- select $ do +-- _ <- from $ table @(TxOutTable a) +-- limit 1 +-- pure (val (1 :: Int)) +-- pure $ null res + +-- -------------------------------------------------------------------------------------------------- +-- -- Updates +-- -------------------------------------------------------------------------------------------------- +-- updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, TxId)] -> ReaderT SqlBackend m () +-- updateListTxOutConsumedByTxId ls = do +-- mapM_ (uncurry updateTxOutConsumedByTxId) ls +-- where +-- updateTxOutConsumedByTxId :: MonadIO m => TxOutIdW -> TxId -> ReaderT SqlBackend m () +-- updateTxOutConsumedByTxId txOutId txId = +-- case txOutId of +-- CTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Just txId] +-- VTxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Just txId] + +-- migrateTxOut :: +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- Trace IO Text -> +-- TxOutTableType -> +-- Maybe MigrationValues -> +-- ReaderT SqlBackend m () +-- migrateTxOut trce txOutTableType mMvs = do +-- whenJust mMvs $ \mvs -> do +-- when (pcmConsumedTxOut (pruneConsumeMigration mvs) && not (isTxOutAddressPreviouslySet mvs)) $ do +-- liftIO $ logInfo trce "migrateTxOut: adding consumed-by-id Index" +-- void createConsumedIndexTxOut +-- when (pcmPruneTxOut (pruneConsumeMigration mvs)) $ do +-- liftIO $ logInfo trce "migrateTxOut: adding prune contraint on tx_out table" +-- void createPruneConstraintTxOut +-- migrateNextPageTxOut (Just trce) txOutTableType 0 + +-- migrateNextPageTxOut :: MonadIO m => Maybe (Trace IO Text) -> TxOutTableType -> Word64 -> ReaderT SqlBackend m () +-- migrateNextPageTxOut mTrce txOutTableType offst = do +-- whenJust mTrce $ \trce -> +-- liftIO $ logInfo trce $ "migrateNextPageTxOut: Handling input offset " <> textShow offst +-- page <- getInputPage offst pageSize +-- updatePageEntries txOutTableType page +-- when (fromIntegral (length page) == pageSize) $ +-- migrateNextPageTxOut mTrce txOutTableType $! +-- (offst + pageSize) + +-- -------------------------------------------------------------------------------------------------- +-- -- Delete + Update +-- -------------------------------------------------------------------------------------------------- +-- deleteAndUpdateConsumedTxOut :: +-- forall m. +-- (MonadIO m, MonadBaseControl IO m) => +-- Trace IO Text -> +-- TxOutTableType -> +-- MigrationValues -> +-- Word64 -> +-- ReaderT SqlBackend m () +-- deleteAndUpdateConsumedTxOut trce txOutTableType migrationValues blockNoDiff = do +-- maxTxId <- findMaxTxInId blockNoDiff +-- case maxTxId of +-- Left errMsg -> do +-- liftIO $ logInfo trce $ "No tx_out were deleted as no blocks found: " <> errMsg +-- liftIO $ logInfo trce "deleteAndUpdateConsumedTxOut: Now Running extra migration prune tx_out" +-- migrateTxOut trce txOutTableType $ Just migrationValues +-- insertExtraMigration ConsumeTxOutPreviouslySet +-- Right mTxId -> do +-- migrateNextPage mTxId False 0 +-- where +-- migrateNextPage :: TxId -> Bool -> Word64 -> ReaderT SqlBackend m () +-- migrateNextPage maxTxId ranCreateConsumedTxOut offst = do +-- pageEntries <- getInputPage offst pageSize +-- resPageEntries <- splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pageEntries +-- when (fromIntegral (length pageEntries) == pageSize) $ +-- migrateNextPage maxTxId resPageEntries $! +-- offst +-- + pageSize + +-- -- Split the page entries by maxTxInId and process +-- splitAndProcessPageEntries :: +-- forall m. +-- (MonadIO m, MonadBaseControl IO m) => +-- Trace IO Text -> +-- TxOutTableType -> +-- Bool -> +-- TxId -> +-- [ConsumedTriplet] -> +-- ReaderT SqlBackend m Bool +-- splitAndProcessPageEntries trce txOutTableType ranCreateConsumedTxOut maxTxId pageEntries = do +-- let entriesSplit = span (\tr -> ctTxInTxId tr <= maxTxId) pageEntries +-- case entriesSplit of +-- ([], []) -> do +-- shouldCreateConsumedTxOut trce ranCreateConsumedTxOut +-- pure True +-- -- the whole list is less that maxTxInId +-- (xs, []) -> do +-- deletePageEntries txOutTableType xs +-- pure False +-- -- the whole list is greater that maxTxInId +-- ([], ys) -> do +-- shouldCreateConsumedTxOut trce ranCreateConsumedTxOut +-- updatePageEntries txOutTableType ys +-- pure True +-- -- the list has both bellow and above maxTxInId +-- (xs, ys) -> do +-- deletePageEntries txOutTableType xs +-- shouldCreateConsumedTxOut trce ranCreateConsumedTxOut +-- updatePageEntries txOutTableType ys +-- pure True + +-- shouldCreateConsumedTxOut :: +-- (MonadIO m, MonadBaseControl IO m) => +-- Trace IO Text -> +-- Bool -> +-- ReaderT SqlBackend m () +-- shouldCreateConsumedTxOut trce rcc = +-- unless rcc $ do +-- liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." +-- createConsumedIndexTxOut + +-- -- | Update +-- updatePageEntries :: +-- MonadIO m => +-- TxOutTableType -> +-- [ConsumedTriplet] -> +-- ReaderT SqlBackend m () +-- updatePageEntries txOutTableType = mapM_ (updateTxOutConsumedByTxIdUnique txOutTableType) + +-- updateTxOutConsumedByTxIdUnique :: MonadIO m => TxOutTableType -> ConsumedTriplet -> ReaderT SqlBackend m () +-- updateTxOutConsumedByTxIdUnique txOutTableType ConsumedTriplet {ctTxOutTxId, ctTxOutIndex, ctTxInTxId} = +-- case txOutTableType of +-- TxOutCore -> updateWhere [C.TxOutTxId ==. ctTxOutTxId, C.TxOutIndex ==. ctTxOutIndex] [C.TxOutConsumedByTxId =. Just ctTxInTxId] +-- TxOutVariantAddress -> updateWhere [V.TxOutTxId ==. ctTxOutTxId, V.TxOutIndex ==. ctTxOutIndex] [V.TxOutConsumedByTxId =. Just ctTxInTxId] + +-- -- this builds up a single delete query using the pageEntries list +-- deletePageEntries :: +-- MonadIO m => +-- TxOutTableType -> +-- [ConsumedTriplet] -> +-- ReaderT SqlBackend m () +-- deletePageEntries txOutTableType = mapM_ (\ConsumedTriplet {ctTxOutTxId, ctTxOutIndex} -> deleteTxOutConsumed txOutTableType ctTxOutTxId ctTxOutIndex) + +-- deleteTxOutConsumed :: MonadIO m => TxOutTableType -> TxId -> Word64 -> ReaderT SqlBackend m () +-- deleteTxOutConsumed txOutTableType txOutId index = case txOutTableType of +-- TxOutCore -> deleteWhere [C.TxOutTxId ==. txOutId, C.TxOutIndex ==. index] +-- TxOutVariantAddress -> deleteWhere [V.TxOutTxId ==. txOutId, V.TxOutIndex ==. index] + +-- -------------------------------------------------------------------------------------------------- +-- -- Raw Queries +-- -------------------------------------------------------------------------------------------------- + +-- createConsumedIndexTxOut :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- ReaderT SqlBackend m () +-- createConsumedIndexTxOut = do +-- handle exceptHandler $ rawExecute createIndex [] +-- where +-- createIndex = +-- "CREATE INDEX IF NOT EXISTS idx_tx_out_consumed_by_tx_id ON tx_out (consumed_by_tx_id)" + +-- exceptHandler :: SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DBPruneConsumed $ show e) + +-- createPruneConstraintTxOut :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- ReaderT SqlBackend m () +-- createPruneConstraintTxOut = do +-- handle exceptHandler $ rawExecute addConstraint [] +-- where +-- addConstraint = +-- Text.unlines +-- [ "do $$" +-- , "begin" +-- , " if not exists (" +-- , " select 1" +-- , " from information_schema.table_constraints" +-- , " where constraint_name = 'ma_tx_out_tx_out_id_fkey'" +-- , " and table_name = 'ma_tx_out'" +-- , " ) then" +-- , " execute 'alter table ma_tx_out add constraint ma_tx_out_tx_out_id_fkey foreign key(tx_out_id) references tx_out(id) on delete cascade on update restrict';" +-- , " end if;" +-- , "end $$;" +-- ] + +-- exceptHandler :: SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DBPruneConsumed $ show e) + +-- -- Be very mindfull that these queries can fail silently and make tests fail making it hard to know why. +-- -- To help mitigate this, logs are printed after each query is ran, so one can know where it stopped. +-- updateTxOutAndCreateAddress :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- Trace IO Text -> +-- ReaderT SqlBackend m () +-- updateTxOutAndCreateAddress trc = do +-- handle exceptHandler $ rawExecute dropViewsQuery [] +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Dropped views" +-- handle exceptHandler $ rawExecute alterTxOutQuery [] +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Altered tx_out" +-- handle exceptHandler $ rawExecute alterCollateralTxOutQuery [] +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Altered collateral_tx_out" +-- handle exceptHandler $ rawExecute createAddressTableQuery [] +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Created address table" +-- handle exceptHandler $ rawExecute createIndexPaymentCredQuery [] +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Created index payment_cred" +-- handle exceptHandler $ rawExecute createIndexRawQuery [] +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Created index raw" +-- liftIO $ logInfo trc "updateTxOutAndCreateAddress: Completed" +-- where +-- dropViewsQuery = +-- Text.unlines +-- [ "DROP VIEW IF EXISTS utxo_byron_view;" +-- , "DROP VIEW IF EXISTS utxo_view;" +-- ] + +-- alterTxOutQuery = +-- Text.unlines +-- [ "ALTER TABLE \"tx_out\"" +-- , " ADD COLUMN \"address_id\" INT8 NOT NULL," +-- , " DROP COLUMN \"address\"," +-- , " DROP COLUMN \"address_has_script\"," +-- , " DROP COLUMN \"payment_cred\"" +-- ] + +-- alterCollateralTxOutQuery = +-- Text.unlines +-- [ "ALTER TABLE \"collateral_tx_out\"" +-- , " ADD COLUMN \"address_id\" INT8 NOT NULL," +-- , " DROP COLUMN \"address\"," +-- , " DROP COLUMN \"address_has_script\"," +-- , " DROP COLUMN \"payment_cred\"" +-- ] + +-- createAddressTableQuery = +-- Text.unlines +-- [ "CREATE TABLE \"address\" (" +-- , " \"id\" SERIAL8 PRIMARY KEY UNIQUE," +-- , " \"address\" VARCHAR NOT NULL," +-- , " \"raw\" BYTEA NOT NULL," +-- , " \"has_script\" BOOLEAN NOT NULL," +-- , " \"payment_cred\" hash28type NULL," +-- , " \"stake_address_id\" INT8 NULL" +-- , ")" +-- ] + +-- createIndexPaymentCredQuery = +-- "CREATE INDEX IF NOT EXISTS idx_address_payment_cred ON address(payment_cred);" + +-- createIndexRawQuery = +-- "CREATE INDEX IF NOT EXISTS idx_address_raw ON address USING HASH (raw);" + +-- exceptHandler :: SqlError -> ReaderT SqlBackend m a +-- exceptHandler e = +-- liftIO $ throwIO (DBPruneConsumed $ show e) + +-- -------------------------------------------------------------------------------------------------- +-- -- Delete +-- -------------------------------------------------------------------------------------------------- +-- deleteConsumedTxOut :: +-- forall m. +-- MonadIO m => +-- Trace IO Text -> +-- TxOutTableType -> +-- Word64 -> +-- ReaderT SqlBackend m () +-- deleteConsumedTxOut trce txOutTableType blockNoDiff = do +-- maxTxInId <- findMaxTxInId blockNoDiff +-- case maxTxInId of +-- Left errMsg -> liftIO $ logInfo trce $ "No tx_out was deleted: " <> errMsg +-- Right mxtid -> deleteConsumedBeforeTx trce txOutTableType mxtid + +-- deleteConsumedBeforeTx :: MonadIO m => Trace IO Text -> TxOutTableType -> TxId -> ReaderT SqlBackend m () +-- deleteConsumedBeforeTx trce txOutTableType txId = do +-- countDeleted <- case txOutTableType of +-- TxOutCore -> deleteWhereCount [C.TxOutConsumedByTxId <=. Just txId] +-- TxOutVariantAddress -> deleteWhereCount [V.TxOutConsumedByTxId <=. Just txId] +-- liftIO $ logInfo trce $ "Deleted " <> textShow countDeleted <> " tx_out" + +-- -------------------------------------------------------------------------------------------------- +-- -- Helpers +-- -------------------------------------------------------------------------------------------------- +-- migrateTxOutDbTool :: (MonadIO m, MonadBaseControl IO m) => TxOutTableType -> ReaderT SqlBackend m () +-- migrateTxOutDbTool txOutTableType = do +-- _ <- createConsumedIndexTxOut +-- migrateNextPageTxOut Nothing txOutTableType 0 + +-- findMaxTxInId :: forall m. MonadIO m => Word64 -> ReaderT SqlBackend m (Either Text TxId) +-- findMaxTxInId blockNoDiff = do +-- mBlockHeight <- queryBlockHeight +-- maybe (pure $ Left "No blocks found") findConsumed mBlockHeight +-- where +-- findConsumed :: Word64 -> ReaderT SqlBackend m (Either Text TxId) +-- findConsumed tipBlockNo = do +-- if tipBlockNo <= blockNoDiff +-- then pure $ Left $ "Tip blockNo is " <> textShow tipBlockNo +-- else do +-- mBlockId <- queryBlockNo $ tipBlockNo - blockNoDiff +-- maybe +-- (pure $ Left $ "BlockNo hole found at " <> textShow (tipBlockNo - blockNoDiff)) +-- findConsumedBeforeBlock +-- mBlockId + +-- findConsumedBeforeBlock :: BlockId -> ReaderT SqlBackend m (Either Text TxId) +-- findConsumedBeforeBlock blockId = do +-- mTxId <- queryMaxRefId TxBlockId blockId False +-- case mTxId of +-- Nothing -> pure $ Left $ "No txs found before " <> textShow blockId +-- Just txId -> pure $ Right txId + +-- getInputPage :: MonadIO m => Word64 -> Word64 -> ReaderT SqlBackend m [ConsumedTriplet] +-- getInputPage offs pgSize = do +-- res <- select $ do +-- txIn <- from $ table @TxIn +-- limit (fromIntegral pgSize) +-- offset (fromIntegral offs) +-- orderBy [asc (txIn ^. TxInId)] +-- pure txIn +-- pure $ convert <$> res +-- where +-- convert txIn = +-- ConsumedTriplet +-- { ctTxOutTxId = txInTxOutId (entityVal txIn) +-- , ctTxOutIndex = txInTxOutIndex (entityVal txIn) +-- , ctTxInTxId = txInTxInId (entityVal txIn) +-- } + +-- countTxIn :: MonadIO m => ReaderT SqlBackend m Word64 +-- countTxIn = do +-- res <- select $ do +-- _ <- from $ table @TxIn +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- countConsumed :: +-- MonadIO m => +-- TxOutTableType -> +-- ReaderT SqlBackend m Word64 +-- countConsumed = \case +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Word64 +-- query = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- where_ (isJust $ txOut ^. txOutConsumedByTxIdField @a) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) diff --git a/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs b/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs index 7ae86600b..ac255b949 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs @@ -5,121 +5,109 @@ module Cardano.Db.Operations.Other.JsonbQuery where -import Cardano.Db.Error (LookupFail (..)) -import Control.Exception.Lifted (handle, throwIO) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) +import Cardano.Prelude (ExceptT, MonadError (..)) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import qualified Hasql.Connection as HsqlC +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlS +import qualified Hasql.Statement as HsqlS -import Database.Esqueleto.Experimental -import Database.PostgreSQL.Simple (SqlError) +import Cardano.Db.Error (DbError (..)) +import Cardano.Db.Statement.Function.Core (mkCallSite) -enableJsonbInSchema :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - ReaderT SqlBackend m () +enableJsonbInSchema :: HsqlS.Statement () () enableJsonbInSchema = do - handle exceptHandler $ - rawExecute - "ALTER TABLE tx_metadata ALTER COLUMN json TYPE jsonb USING json::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE script ALTER COLUMN json TYPE jsonb USING json::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE datum ALTER COLUMN value TYPE jsonb USING value::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE redeemer_data ALTER COLUMN value TYPE jsonb USING value::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE cost_model ALTER COLUMN costs TYPE jsonb USING costs::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE gov_action_proposal ALTER COLUMN description TYPE jsonb USING description::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE off_chain_pool_data ALTER COLUMN json TYPE jsonb USING json::jsonb" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE off_chain_vote_data ALTER COLUMN json TYPE jsonb USING json::jsonb" - [] + HsqlS.Statement + ( mconcat $ + zipWith + ( \s i -> + (if i > (0 :: Integer) then "; " else "") + <> "ALTER TABLE " + <> fst s + <> " ALTER COLUMN " + <> snd s + <> " TYPE jsonb USING " + <> snd s + <> "::jsonb" + ) + jsonbColumns + [0 ..] + ) + HsqlE.noParams + HsqlD.noResult + True + where + jsonbColumns :: [(ByteString, ByteString)] + jsonbColumns = + [ ("tx_metadata", "json") + , ("script", "json") + , ("datum", "value") + , ("redeemer_data", "value") + , ("cost_model", "costs") + , ("gov_action_proposal", "description") + , ("off_chain_pool_data", "json") + , ("off_chain_vote_data", "json") + ] -disableJsonbInSchema :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - ReaderT SqlBackend m () -disableJsonbInSchema = do - handle exceptHandler $ - rawExecute - "ALTER TABLE tx_metadata ALTER COLUMN json TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE script ALTER COLUMN json TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE datum ALTER COLUMN value TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE redeemer_data ALTER COLUMN value TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE cost_model ALTER COLUMN costs TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE gov_action_proposal ALTER COLUMN description TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE off_chain_pool_data ALTER COLUMN json TYPE VARCHAR" - [] - handle exceptHandler $ - rawExecute - "ALTER TABLE off_chain_vote_data ALTER COLUMN json TYPE VARCHAR" - [] +disableJsonbInSchema :: HsqlS.Statement () () +disableJsonbInSchema = + HsqlS.Statement + ( mconcat $ + zipWith + ( \columnDef i -> + (if i > (0 :: Integer) then "; " else "") + <> "ALTER TABLE " + <> fst columnDef + <> " ALTER COLUMN " + <> snd columnDef + <> " TYPE VARCHAR" + ) + jsonColumnsToRevert + [0 ..] + ) + HsqlE.noParams + HsqlD.noResult + True + where + -- List of table and column pairs to convert back from JSONB + jsonColumnsToRevert :: [(ByteString, ByteString)] + jsonColumnsToRevert = + [ ("tx_metadata", "json") + , ("script", "json") + , ("datum", "value") + , ("redeemer_data", "value") + , ("cost_model", "costs") + , ("gov_action_proposal", "description") + , ("off_chain_pool_data", "json") + , ("off_chain_vote_data", "json") + ] -queryJsonbInSchemaExists :: - (MonadIO m) => - ReaderT SqlBackend m Bool -queryJsonbInSchemaExists = do - isjsonb <- rawSql query [] - pure $ case isjsonb of - [Single (1 :: Int)] -> True - _other -> False +queryJsonbInSchemaExists :: HsqlC.Connection -> ExceptT DbError IO Bool +queryJsonbInSchemaExists conn = do + result <- liftIO $ HsqlS.run (HsqlS.statement () jsonbSchemaStatement) conn + case result of + Left err -> throwError $ DbError mkCallSite "queryJsonbInSchemaExists" $ Just err + Right countRes -> pure $ countRes == 1 where - tableName = "'tx_metadata'" - columnName = "'json'" - -- check if the column is of type jsonb + jsonbSchemaStatement :: HsqlS.Statement () Int64 + jsonbSchemaStatement = + HsqlS.Statement + query + HsqlE.noParams -- No parameters needed + decoder + True -- Prepared statement query = - mconcat - [ "SELECT COUNT(*) FROM information_schema.columns " - , "WHERE table_name =" - , tableName - , "AND column_name =" - , columnName - , "AND data_type = 'jsonb';" - ] + "SELECT COUNT(*) \ + \FROM information_schema.columns \ + \WHERE table_name = 'tx_metadata' \ + \AND column_name = 'json' \ + \AND data_type = 'jsonb';" -exceptHandler :: - forall m a. - MonadIO m => - SqlError -> - ReaderT SqlBackend m a -exceptHandler e = - liftIO $ throwIO (DBRJsonbInSchema $ show e) + decoder :: HsqlD.Result Int64 + decoder = + HsqlD.singleRow $ + HsqlD.column $ + HsqlD.nonNullable HsqlD.int8 diff --git a/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs index 261c47064..114e8ad14 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs @@ -10,155 +10,154 @@ module Cardano.Db.Operations.Other.MinId where -import Cardano.Db.Operations.Query (queryMinRefId) -import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..), TxOutTableType (..)) -import Cardano.Db.Schema.BaseSchema -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.Prelude -import qualified Data.Text as Text -import Database.Persist.Sql (PersistEntity, PersistField, SqlBackend, fromSqlKey, toSqlKey) - -data MinIds (a :: TxOutTableType) = MinIds - { minTxInId :: Maybe TxInId - , minTxOutId :: Maybe (TxOutIdFor a) - , minMaTxOutId :: Maybe (MaTxOutIdFor a) - } - -instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (MaTxOutIdFor a)) => Monoid (MinIds a) where - mempty = MinIds Nothing Nothing Nothing - -instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (MaTxOutIdFor a)) => Semigroup (MinIds a) where - mn1 <> mn2 = - MinIds - { minTxInId = minJust (minTxInId mn1) (minTxInId mn2) - , minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2) - , minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2) - } - -data MinIdsWrapper - = CMinIdsWrapper (MinIds 'TxOutCore) - | VMinIdsWrapper (MinIds 'TxOutVariantAddress) - -instance Monoid MinIdsWrapper where - mempty = CMinIdsWrapper mempty -- or VMinIdsWrapper mempty, depending on your preference - -instance Semigroup MinIdsWrapper where - (CMinIdsWrapper a) <> (CMinIdsWrapper b) = CMinIdsWrapper (a <> b) - (VMinIdsWrapper a) <> (VMinIdsWrapper b) = VMinIdsWrapper (a <> b) - _ <> b = b -- If types don't match, return the second argument which is a no-op - -minIdsToText :: MinIdsWrapper -> Text -minIdsToText (CMinIdsWrapper minIds) = minIdsCoreToText minIds -minIdsToText (VMinIdsWrapper minIds) = minIdsVariantToText minIds - -textToMinIds :: TxOutTableType -> Text -> Maybe MinIdsWrapper -textToMinIds txOutTableType txt = - case txOutTableType of - TxOutCore -> CMinIdsWrapper <$> textToMinIdsCore txt - TxOutVariantAddress -> VMinIdsWrapper <$> textToMinIdsVariant txt - -minIdsCoreToText :: MinIds 'TxOutCore -> Text -minIdsCoreToText minIds = - Text.intercalate - ":" - [ maybe "" (Text.pack . show . fromSqlKey) $ minTxInId minIds - , maybe "" (Text.pack . show . fromSqlKey) $ minTxOutId minIds - , maybe "" (Text.pack . show . fromSqlKey) $ minMaTxOutId minIds - ] - -minIdsVariantToText :: MinIds 'TxOutVariantAddress -> Text -minIdsVariantToText minIds = - Text.intercalate - ":" - [ maybe "" (Text.pack . show . fromSqlKey) $ minTxInId minIds - , maybe "" (Text.pack . show) $ minTxOutId minIds - , maybe "" (Text.pack . show . fromSqlKey) $ minMaTxOutId minIds - ] - -textToMinIdsCore :: Text -> Maybe (MinIds 'TxOutCore) -textToMinIdsCore txt = - case Text.split (== ':') txt of - [tminTxInId, tminTxOutId, tminMaTxOutId] -> - Just $ - MinIds - { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) - , minTxOutId = toSqlKey <$> readMaybe (Text.unpack tminTxOutId) - , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) - } - _otherwise -> Nothing - -textToMinIdsVariant :: Text -> Maybe (MinIds 'TxOutVariantAddress) -textToMinIdsVariant txt = - case Text.split (== ':') txt of - [tminTxInId, tminTxOutId, tminMaTxOutId] -> - Just $ - MinIds - { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) - , minTxOutId = readMaybe (Text.unpack tminTxOutId) - , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) - } - _otherwise -> Nothing - -minJust :: (Ord a) => Maybe a -> Maybe a -> Maybe a -minJust Nothing y = y -minJust x Nothing = x -minJust (Just x) (Just y) = Just (min x y) - --------------------------------------------------------------------------------- --- CompleteMinId --------------------------------------------------------------------------------- -completeMinId :: - (MonadIO m) => - Maybe TxId -> - MinIdsWrapper -> - ReaderT SqlBackend m MinIdsWrapper -completeMinId mTxId mIdW = case mIdW of - CMinIdsWrapper minIds -> CMinIdsWrapper <$> completeMinIdCore mTxId minIds - VMinIdsWrapper minIds -> VMinIdsWrapper <$> completeMinIdVariant mTxId minIds - -completeMinIdCore :: MonadIO m => Maybe TxId -> MinIds 'TxOutCore -> ReaderT SqlBackend m (MinIds 'TxOutCore) -completeMinIdCore mTxId minIds = do - case mTxId of - Nothing -> pure mempty - Just txId -> do - mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId - mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) C.TxOutTxId txId - mMaTxOutId <- case mTxOutId of - Nothing -> pure Nothing - Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) C.MaTxOutTxOutId txOutId - pure $ - MinIds - { minTxInId = mTxInId - , minTxOutId = mTxOutId - , minMaTxOutId = mMaTxOutId - } - -completeMinIdVariant :: MonadIO m => Maybe TxId -> MinIds 'TxOutVariantAddress -> ReaderT SqlBackend m (MinIds 'TxOutVariantAddress) -completeMinIdVariant mTxId minIds = do - case mTxId of - Nothing -> pure mempty - Just txId -> do - mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId - mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) V.TxOutTxId txId - mMaTxOutId <- case mTxOutId of - Nothing -> pure Nothing - Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) V.MaTxOutTxOutId txOutId - pure $ - MinIds - { minTxInId = mTxInId - , minTxOutId = mTxOutId - , minMaTxOutId = mMaTxOutId - } - -whenNothingQueryMinRefId :: - forall m record field. - (MonadIO m, PersistEntity record, PersistField field) => - Maybe (Key record) -> - EntityField record field -> - field -> - ReaderT SqlBackend m (Maybe (Key record)) -whenNothingQueryMinRefId mKey efield field = do - case mKey of - Just k -> pure $ Just k - Nothing -> queryMinRefId efield field +-- import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..), TxOutTableType (..)) +-- import Cardano.Db.Schema.Core +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Cardano.Prelude +-- import qualified Data.Text as Text +-- import Database.Persist.Sql (PersistEntity, PersistField, SqlBackend, fromSqlKey, toSqlKey) + +-- data MinIds (a :: TxOutTableType) = MinIds +-- { minTxInId :: Maybe TxInId +-- , minTxOutId :: Maybe (TxOutIdFor a) +-- , minMaTxOutId :: Maybe (MaTxOutIdFor a) +-- } + +-- instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (MaTxOutIdFor a)) => Monoid (MinIds a) where +-- mempty = MinIds Nothing Nothing Nothing + +-- instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (MaTxOutIdFor a)) => Semigroup (MinIds a) where +-- mn1 <> mn2 = +-- MinIds +-- { minTxInId = minJust (minTxInId mn1) (minTxInId mn2) +-- , minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2) +-- , minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2) +-- } + +-- data MinIdsWrapper +-- = CMinIdsWrapper (MinIds 'TxOutCore) +-- | VMinIdsWrapper (MinIds 'TxOutVariantAddress) + +-- instance Monoid MinIdsWrapper where +-- mempty = CMinIdsWrapper mempty -- or VMinIdsWrapper mempty, depending on your preference + +-- instance Semigroup MinIdsWrapper where +-- (CMinIdsWrapper a) <> (CMinIdsWrapper b) = CMinIdsWrapper (a <> b) +-- (VMinIdsWrapper a) <> (VMinIdsWrapper b) = VMinIdsWrapper (a <> b) +-- _ <> b = b -- If types don't match, return the second argument which is a no-op + +-- minIdsToText :: MinIdsWrapper -> Text +-- minIdsToText (CMinIdsWrapper minIds) = minIdsCoreToText minIds +-- minIdsToText (VMinIdsWrapper minIds) = minIdsVariantToText minIds + +-- textToMinIds :: TxOutTableType -> Text -> Maybe MinIdsWrapper +-- textToMinIds txOutTableType txt = +-- case txOutTableType of +-- TxOutCore -> CMinIdsWrapper <$> textToMinIdsCore txt +-- TxOutVariantAddress -> VMinIdsWrapper <$> textToMinIdsVariant txt + +-- minIdsCoreToText :: MinIds 'TxOutCore -> Text +-- minIdsCoreToText minIds = +-- Text.intercalate +-- ":" +-- [ maybe "" (Text.pack . show . fromSqlKey) $ minTxInId minIds +-- , maybe "" (Text.pack . show . fromSqlKey) $ minTxOutId minIds +-- , maybe "" (Text.pack . show . fromSqlKey) $ minMaTxOutId minIds +-- ] + +-- minIdsVariantToText :: MinIds 'TxOutVariantAddress -> Text +-- minIdsVariantToText minIds = +-- Text.intercalate +-- ":" +-- [ maybe "" (Text.pack . show . fromSqlKey) $ minTxInId minIds +-- , maybe "" (Text.pack . show) $ minTxOutId minIds +-- , maybe "" (Text.pack . show . fromSqlKey) $ minMaTxOutId minIds +-- ] + +-- textToMinIdsCore :: Text -> Maybe (MinIds 'TxOutCore) +-- textToMinIdsCore txt = +-- case Text.split (== ':') txt of +-- [tminTxInId, tminTxOutId, tminMaTxOutId] -> +-- Just $ +-- MinIds +-- { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) +-- , minTxOutId = toSqlKey <$> readMaybe (Text.unpack tminTxOutId) +-- , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) +-- } +-- _otherwise -> Nothing + +-- textToMinIdsVariant :: Text -> Maybe (MinIds 'TxOutVariantAddress) +-- textToMinIdsVariant txt = +-- case Text.split (== ':') txt of +-- [tminTxInId, tminTxOutId, tminMaTxOutId] -> +-- Just $ +-- MinIds +-- { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) +-- , minTxOutId = readMaybe (Text.unpack tminTxOutId) +-- , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) +-- } +-- _otherwise -> Nothing + +-- minJust :: (Ord a) => Maybe a -> Maybe a -> Maybe a +-- minJust Nothing y = y +-- minJust x Nothing = x +-- minJust (Just x) (Just y) = Just (min x y) + +-- -------------------------------------------------------------------------------- +-- -- CompleteMinId +-- -------------------------------------------------------------------------------- +-- completeMinId :: +-- (MonadIO m) => +-- Maybe TxId -> +-- MinIdsWrapper -> +-- ReaderT SqlBackend m MinIdsWrapper +-- completeMinId mTxId mIdW = case mIdW of +-- CMinIdsWrapper minIds -> CMinIdsWrapper <$> completeMinIdCore mTxId minIds +-- VMinIdsWrapper minIds -> VMinIdsWrapper <$> completeMinIdVariant mTxId minIds + +-- completeMinIdCore :: MonadIO m => Maybe TxId -> MinIds 'TxOutCore -> ReaderT SqlBackend m (MinIds 'TxOutCore) +-- completeMinIdCore mTxId minIds = do +-- case mTxId of +-- Nothing -> pure mempty +-- Just txId -> do +-- mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId +-- mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) C.TxOutTxId txId +-- mMaTxOutId <- case mTxOutId of +-- Nothing -> pure Nothing +-- Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) C.MaTxOutTxOutId txOutId +-- pure $ +-- MinIds +-- { minTxInId = mTxInId +-- , minTxOutId = mTxOutId +-- , minMaTxOutId = mMaTxOutId +-- } + +-- completeMinIdVariant :: MonadIO m => Maybe TxId -> MinIds 'TxOutVariantAddress -> ReaderT SqlBackend m (MinIds 'TxOutVariantAddress) +-- completeMinIdVariant mTxId minIds = do +-- case mTxId of +-- Nothing -> pure mempty +-- Just txId -> do +-- mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId +-- mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) V.TxOutTxId txId +-- mMaTxOutId <- case mTxOutId of +-- Nothing -> pure Nothing +-- Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) V.MaTxOutTxOutId txOutId +-- pure $ +-- MinIds +-- { minTxInId = mTxInId +-- , minTxOutId = mTxOutId +-- , minMaTxOutId = mMaTxOutId +-- } + +-- whenNothingQueryMinRefId :: +-- forall m record field. +-- (MonadIO m, PersistEntity record, PersistField field) => +-- Maybe (Key record) -> +-- EntityField record field -> +-- field -> +-- ReaderT SqlBackend m (Maybe (Key record)) +-- whenNothingQueryMinRefId mKey efield field = do +-- case mKey of +-- Just k -> pure $ Just k +-- Nothing -> queryMinRefId efield field diff --git a/cardano-db/src/Cardano/Db/Operations/Query.hs b/cardano-db/src/Cardano/Db/Operations/Query.hs index 904ed1646..adddc8c43 100644 --- a/cardano-db/src/Cardano/Db/Operations/Query.hs +++ b/cardano-db/src/Cardano/Db/Operations/Query.hs @@ -5,165 +5,166 @@ {-# LANGUAGE TypeApplications #-} module Cardano.Db.Operations.Query ( - LookupFail (..), - -- queries used by db-sync - queryBlockCount, - queryBlockCountAfterBlockNo, - queryBlockHashBlockNo, - queryBlockNo, - queryBlockNoAndEpoch, - queryNearestBlockSlotNo, - queryBlockHash, - queryReverseIndexBlockId, - queryMinIdsAfterReverseIndex, - queryBlockTxCount, - queryBlockId, - queryCalcEpochEntry, - queryCurrentEpochNo, - queryNormalEpochRewardCount, - queryGenesis, - queryLatestBlock, - queryLatestPoints, - queryLatestEpochNo, - queryLatestBlockId, - queryLatestSlotNo, - queryMeta, - queryCountSlotNosGreaterThan, - queryCountSlotNo, - queryScript, - queryDatum, - queryRedeemerData, - querySlotHash, - queryMultiAssetId, - queryTxCount, - queryTxId, - queryEpochFromNum, - queryEpochStakeCount, - queryForEpochId, - queryLatestEpoch, - queryMinRefId, - queryMinRefIdNullable, - queryMaxRefId, - existsPoolHashId, - existsPoolMetadataRefId, - existsVotingAnchorId, - queryAdaPotsId, - queryBlockHeight, - queryAllExtraMigrations, - queryMinMaxEpochStake, - queryGovActionProposalId, - queryDrepHashAlwaysAbstain, - queryDrepHashAlwaysNoConfidence, - queryCommitteeHash, - queryProposalConstitution, - queryProposalCommittee, - queryPoolHashId, - queryStakeAddress, - queryStakeRefPtr, - queryPoolUpdateByBlock, - -- queries used in smash - queryOffChainPoolData, - queryPoolRegister, - queryRetiredPools, - queryUsedTicker, - queryReservedTicker, - queryReservedTickers, - queryDelistedPools, - queryOffChainPoolFetchError, - existsDelistedPool, - -- queries used in tools - queryDepositUpToBlockNo, - queryEpochEntry, - queryFeesUpToBlockNo, - queryFeesUpToSlotNo, - queryLatestCachedEpochNo, - queryLatestBlockNo, - querySlotNosGreaterThan, - querySlotNos, - querySlotUtcTime, - queryWithdrawalsUpToBlockNo, - queryAdaPots, - -- queries used only in tests - queryRewardCount, - queryRewardRestCount, - queryTxInCount, - queryEpochCount, - queryCostModel, - queryTxInRedeemer, - queryTxInFailedTx, - queryInvalidTx, - queryDeregistrationScript, - queryDelegationScript, - queryWithdrawalScript, - queryStakeAddressScript, - querySchemaVersion, - queryPreviousSlotNo, - queryMinBlock, - -- utils - listToMaybe, -) where - -import Cardano.Db.Error -import Cardano.Db.Operations.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda) -import Cardano.Db.Schema.BaseSchema -import Cardano.Db.Types -import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..)) -import Cardano.Ledger.Credential (Ptr (..)) -import Cardano.Slotting.Slot (SlotNo (..)) -import Control.Monad.Extra (join, whenJust) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT) -import Data.ByteString.Char8 (ByteString) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.Ratio (numerator) -import Data.Text (Text, unpack) -import Data.Time.Clock (UTCTime (..)) -import Data.Tuple.Extra (uncurry3) -import Data.Word (Word64) -import Database.Esqueleto.Experimental ( - Entity (..), - PersistEntity, - PersistField, - SqlBackend, - Value (Value, unValue), - asc, - count, - countRows, - desc, - entityKey, - entityVal, - from, - in_, - innerJoin, - isNothing, - just, - leftJoin, - limit, - max_, - min_, - on, - orderBy, - persistIdField, - select, - selectOne, - sum_, - table, - val, - valList, - where_, - (&&.), - (<.), - (<=.), - (==.), - (>.), - (>=.), - (?.), - (^.), - (||.), - type (:&) ((:&)), - ) -import Database.Persist.Class.PersistQuery (selectList) -import Database.Persist.Types (SelectOpt (Asc)) + ) where + +-- LookupFail (..), +-- -- queries used by db-sync +-- queryBlockCount, +-- queryBlockCountAfterBlockNo, +-- queryBlockHashBlockNo, +-- queryBlockNo, +-- queryBlockNoAndEpoch, +-- queryNearestBlockSlotNo, +-- queryBlockHash, +-- queryReverseIndexBlockId, +-- queryMinIdsAfterReverseIndex, +-- queryBlockTxCount, +-- queryBlockId, +-- queryCalcEpochEntry, +-- queryCurrentEpochNo, +-- queryNormalEpochRewardCount, +-- queryGenesis, +-- queryLatestBlock, +-- queryLatestPoints, +-- queryLatestEpochNo, +-- queryLatestBlockId, +-- queryLatestSlotNo, +-- queryMeta, +-- queryCountSlotNosGreaterThan, +-- queryCountSlotNo, +-- queryScript, +-- queryDatum, +-- queryRedeemerData, +-- querySlotHash, +-- queryMultiAssetId, +-- queryTxCount, +-- queryTxId, +-- queryEpochFromNum, +-- queryEpochStakeCount, +-- queryForEpochId, +-- queryLatestEpoch, +-- queryMinRefId, +-- queryMinRefIdNullable, +-- queryMaxRefId, +-- existsPoolHashId, +-- existsPoolMetadataRefId, +-- existsVotingAnchorId, +-- queryAdaPotsId, +-- queryBlockHeight, +-- queryAllExtraMigrations, +-- queryMinMaxEpochStake, +-- queryGovActionProposalId, +-- queryDrepHashAlwaysAbstain, +-- queryDrepHashAlwaysNoConfidence, +-- queryCommitteeHash, +-- queryProposalConstitution, +-- queryProposalCommittee, +-- queryPoolHashId, +-- queryStakeAddress, +-- queryStakeRefPtr, +-- queryPoolUpdateByBlock, +-- -- queries used in smash +-- queryOffChainPoolData, +-- queryPoolRegister, +-- queryRetiredPools, +-- queryUsedTicker, +-- queryReservedTicker, +-- queryReservedTickers, +-- queryDelistedPools, +-- queryOffChainPoolFetchError, +-- existsDelistedPool, +-- -- queries used in tools +-- queryDepositUpToBlockNo, +-- queryEpochEntry, +-- queryFeesUpToBlockNo, +-- queryFeesUpToSlotNo, +-- queryLatestCachedEpochNo, +-- queryLatestBlockNo, +-- querySlotNosGreaterThan, +-- querySlotNos, +-- querySlotUtcTime, +-- queryWithdrawalsUpToBlockNo, +-- queryAdaPots, +-- -- queries used only in tests +-- queryRewardCount, +-- queryRewardRestCount, +-- queryTxInCount, +-- queryEpochCount, +-- queryCostModel, +-- queryTxInRedeemer, +-- queryTxInFailedTx, +-- queryInvalidTx, +-- queryDeregistrationScript, +-- queryDelegationScript, +-- queryWithdrawalScript, +-- queryStakeAddressScript, +-- querySchemaVersion, +-- queryPreviousSlotNo, +-- queryMinBlock, +-- utils +-- listToMaybe, + +-- import Cardano.Db.Error +-- import Cardano.Db.Operations.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda) +-- import Cardano.Db.Schema.Core +-- import Cardano.Db.Types +-- import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..)) +-- import Cardano.Ledger.Credential (Ptr (..)) +-- import Cardano.Slotting.Slot (SlotNo (..)) +-- import Control.Monad.Extra (join, whenJust) +-- import Control.Monad.IO.Class (MonadIO) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import Data.ByteString.Char8 (ByteString) +-- import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +-- import Data.Ratio (numerator) +-- import Data.Text (Text, unpack) +-- import Data.Time.Clock (UTCTime (..)) +-- import Data.Tuple.Extra (uncurry3) +-- import Data.Word (Word64) +-- import Database.Esqueleto.Experimental ( +-- Entity (..), +-- PersistEntity, +-- PersistField, +-- SqlBackend, +-- Value (Value, unValue), +-- asc, +-- count, +-- countRows, +-- desc, +-- entityKey, +-- entityVal, +-- from, +-- in_, +-- innerJoin, +-- isNothing, +-- just, +-- leftJoin, +-- limit, +-- max_, +-- min_, +-- on, +-- orderBy, +-- persistIdField, +-- select, +-- selectOne, +-- sum_, +-- table, +-- val, +-- valList, +-- where_, +-- (&&.), +-- (<.), +-- (<=.), +-- (==.), +-- (>.), +-- (>=.), +-- (?.), +-- (^.), +-- (||.), +-- type (:&) ((:&)), +-- ) +-- import Database.Persist.Class.PersistQuery (selectList) +-- import Database.Persist.Types (SelectOpt (Asc)) {- HLINT ignore "Redundant ^." -} {- HLINT ignore "Fuse on/on" -} @@ -177,163 +178,163 @@ import Database.Persist.Types (SelectOpt (Asc)) -- does. -- | Count the number of blocks in the Block table. -queryBlockCount :: MonadIO m => ReaderT SqlBackend m Word -queryBlockCount = do - res <- select $ do - _blk <- from $ table @Block - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --- | Count the number of blocks in the Block table after a 'BlockNo'. -queryBlockCountAfterBlockNo :: MonadIO m => Word64 -> Bool -> ReaderT SqlBackend m Word -queryBlockCountAfterBlockNo blockNo queryEq = do - res <- select $ do - blk <- from $ table @Block - where_ - ( if queryEq - then blk ^. BlockBlockNo >=. just (val (fromIntegral blockNo)) - else blk ^. BlockBlockNo >. just (val (fromIntegral blockNo)) - ) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --- | Get the 'BlockNo' associated with the given hash. -queryBlockHashBlockNo :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail (Maybe Word64)) -queryBlockHashBlockNo hash = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockHash ==. val hash) - pure $ blk ^. BlockBlockNo - pure $ maybeToEither (DbLookupBlockHash hash) unValue (listToMaybe res) - -queryBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe BlockId) -queryBlockNo blkNo = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockBlockNo ==. just (val blkNo)) - pure (blk ^. BlockId) - pure $ fmap unValue (listToMaybe res) - -queryBlockNoAndEpoch :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe (BlockId, Word64)) -queryBlockNoAndEpoch blkNo = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockBlockNo ==. just (val blkNo)) - pure (blk ^. BlockId, blk ^. BlockEpochNo) - pure $ convertBlockQuery (listToMaybe res) +-- queryBlockCount :: MonadIO m => ReaderT SqlBackend m Word +-- queryBlockCount = do +-- res <- select $ do +-- _blk <- from $ table @Block +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- -- | Count the number of blocks in the Block table after a 'BlockNo'. +-- queryBlockCountAfterBlockNo :: MonadIO m => Word64 -> Bool -> ReaderT SqlBackend m Word +-- queryBlockCountAfterBlockNo blockNo queryEq = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ +-- ( if queryEq +-- then blk ^. BlockBlockNo >=. just (val (fromIntegral blockNo)) +-- else blk ^. BlockBlockNo >. just (val (fromIntegral blockNo)) +-- ) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- -- | Get the 'BlockNo' associated with the given hash. +-- queryBlockHashBlockNo :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail (Maybe Word64)) +-- queryBlockHashBlockNo hash = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockHash ==. val hash) +-- pure $ blk ^. BlockBlockNo +-- pure $ maybeToEither (DbLookupBlockHash hash) unValue (listToMaybe res) + +-- queryBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe BlockId) +-- queryBlockNo blkNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockBlockNo ==. just (val blkNo)) +-- pure (blk ^. BlockId) +-- pure $ fmap unValue (listToMaybe res) + +-- queryBlockNoAndEpoch :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe (BlockId, Word64)) +-- queryBlockNoAndEpoch blkNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockBlockNo ==. just (val blkNo)) +-- pure (blk ^. BlockId, blk ^. BlockEpochNo) +-- pure $ convertBlockQuery (listToMaybe res) -- | Retrieves the nearest block with a slot number equal to or greater than the given slot number. -queryNearestBlockSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe (BlockId, Word64)) -queryNearestBlockSlotNo slotNo = do - res <- select $ do - blk <- from $ table @Block - where_ (isNothing (blk ^. BlockSlotNo) ||. blk ^. BlockSlotNo >=. just (val slotNo)) - orderBy [asc (blk ^. BlockSlotNo)] - limit 1 - pure (blk ^. BlockId, blk ^. BlockBlockNo) - pure $ convertBlockQuery (listToMaybe res) - -queryBlockHash :: MonadIO m => Block -> ReaderT SqlBackend m (Maybe (BlockId, Word64)) -queryBlockHash hash = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockHash ==. val (blockHash hash)) - pure (blk ^. BlockId, blk ^. BlockEpochNo) - pure $ convertBlockQuery (listToMaybe res) - -queryMinBlock :: MonadIO m => ReaderT SqlBackend m (Maybe (BlockId, Word64)) -queryMinBlock = do - res <- select $ do - blk <- from $ table @Block - orderBy [asc (blk ^. BlockId)] - limit 1 - pure (blk ^. BlockId, blk ^. BlockBlockNo) - pure $ convertBlockQuery (listToMaybe res) - -convertBlockQuery :: Maybe (Value (Key Block), Value (Maybe Word64)) -> Maybe (BlockId, Word64) -convertBlockQuery mr = - case mr of - Nothing -> Nothing - Just (_, Value Nothing) -> Nothing -- Should never happen. - Just (Value blkid, Value (Just epoch)) -> Just (blkid, epoch) - -queryReverseIndexBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m [Maybe Text] -queryReverseIndexBlockId blockId = do - res <- select $ do - (blk :& ridx) <- - from - $ table @Block - `leftJoin` table @ReverseIndex - `on` (\(blk :& ridx) -> just (blk ^. BlockId) ==. ridx ?. ReverseIndexBlockId) - where_ (blk ^. BlockId >=. val blockId) - orderBy [asc (blk ^. BlockId)] - pure $ ridx ?. ReverseIndexMinIds - pure $ fmap unValue res - -queryMinIdsAfterReverseIndex :: MonadIO m => ReverseIndexId -> ReaderT SqlBackend m [Text] -queryMinIdsAfterReverseIndex rollbackId = do - res <- select $ do - rl <- from $ table @ReverseIndex - where_ (rl ^. ReverseIndexId >=. val rollbackId) - orderBy [desc (rl ^. ReverseIndexId)] - pure $ rl ^. ReverseIndexMinIds - pure $ fmap unValue res - --- | Get the number of transactions in the specified block. -queryBlockTxCount :: MonadIO m => BlockId -> ReaderT SqlBackend m Word64 -queryBlockTxCount blkId = do - res <- select $ do - tx <- from $ table @Tx - where_ (tx ^. TxBlockId ==. val blkId) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --- | Get the 'BlockId' associated with the given hash. -queryBlockId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail BlockId) -queryBlockId hash = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockHash ==. val hash) - pure $ blk ^. BlockId - pure $ maybeToEither (DbLookupBlockHash hash) unValue (listToMaybe res) - --- | 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 Epoch entry for the last epoch. -queryCalcEpochEntry :: MonadIO m => Word64 -> ReaderT SqlBackend m Epoch -queryCalcEpochEntry epochNum = do - blockResult <- select $ do - block <- from $ table @Block - where_ (block ^. BlockEpochNo ==. just (val epochNum)) - pure (countRows, min_ (block ^. BlockTime), max_ (block ^. BlockTime)) - queryTxWithBlocks epochNum blockResult - --- | Get the PostgreSQL row index (EpochId) that matches the given epoch number. -queryForEpochId :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe EpochId) -queryForEpochId epochNum = do - res <- selectOne $ do - epoch <- from $ table @Epoch - where_ (epoch ^. EpochNo ==. val epochNum) - pure (epoch ^. EpochId) - pure $ unValue <$> res - --- | Get an epoch given it's number. -queryEpochFromNum :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe Epoch) -queryEpochFromNum epochNum = do - res <- selectOne $ do - epoch <- from $ table @Epoch - where_ (epoch ^. EpochNo ==. val epochNum) - pure epoch - pure $ entityVal <$> res - --- | Get the most recent epoch in the Epoch DB table. -queryLatestEpoch :: MonadIO m => ReaderT SqlBackend m (Maybe Epoch) -queryLatestEpoch = do - res <- selectOne $ do - epoch <- from $ table @Epoch - orderBy [desc (epoch ^. EpochNo)] - pure epoch - pure $ entityVal <$> res +-- queryNearestBlockSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe (BlockId, Word64)) +-- queryNearestBlockSlotNo slotNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isNothing (blk ^. BlockSlotNo) ||. blk ^. BlockSlotNo >=. just (val slotNo)) +-- orderBy [asc (blk ^. BlockSlotNo)] +-- limit 1 +-- pure (blk ^. BlockId, blk ^. BlockBlockNo) +-- pure $ convertBlockQuery (listToMaybe res) + +-- queryBlockHash :: MonadIO m => Block -> ReaderT SqlBackend m (Maybe (BlockId, Word64)) +-- queryBlockHash hash = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockHash ==. val (blockHash hash)) +-- pure (blk ^. BlockId, blk ^. BlockEpochNo) +-- pure $ convertBlockQuery (listToMaybe res) + +-- queryMinBlock :: MonadIO m => ReaderT SqlBackend m (Maybe (BlockId, Word64)) +-- queryMinBlock = do +-- res <- select $ do +-- blk <- from $ table @Block +-- orderBy [asc (blk ^. BlockId)] +-- limit 1 +-- pure (blk ^. BlockId, blk ^. BlockBlockNo) +-- pure $ convertBlockQuery (listToMaybe res) + +-- convertBlockQuery :: Maybe (Value (Key Block), Value (Maybe Word64)) -> Maybe (BlockId, Word64) +-- convertBlockQuery mr = +-- case mr of +-- Nothing -> Nothing +-- Just (_, Value Nothing) -> Nothing -- Should never happen. +-- Just (Value blkid, Value (Just epoch)) -> Just (blkid, epoch) + +-- queryReverseIndexBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m [Maybe Text] +-- queryReverseIndexBlockId blockId = do +-- res <- select $ do +-- (blk :& ridx) <- +-- from +-- $ table @Block +-- `leftJoin` table @ReverseIndex +-- `on` (\(blk :& ridx) -> just (blk ^. BlockId) ==. ridx ?. ReverseIndexBlockId) +-- where_ (blk ^. BlockId >=. val blockId) +-- orderBy [asc (blk ^. BlockId)] +-- pure $ ridx ?. ReverseIndexMinIds +-- pure $ fmap unValue res + +-- queryMinIdsAfterReverseIndex :: MonadIO m => ReverseIndexId -> ReaderT SqlBackend m [Text] +-- queryMinIdsAfterReverseIndex rollbackId = do +-- res <- select $ do +-- rl <- from $ table @ReverseIndex +-- where_ (rl ^. ReverseIndexId >=. val rollbackId) +-- orderBy [desc (rl ^. ReverseIndexId)] +-- pure $ rl ^. ReverseIndexMinIds +-- pure $ fmap unValue res + +-- -- | Get the number of transactions in the specified block. +-- queryBlockTxCount :: MonadIO m => BlockId -> ReaderT SqlBackend m Word64 +-- queryBlockTxCount blkId = do +-- res <- select $ do +-- tx <- from $ table @Tx +-- where_ (tx ^. TxBlockId ==. val blkId) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- -- | Get the 'BlockId' associated with the given hash. +-- queryBlockId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail BlockId) +-- queryBlockId hash = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockHash ==. val hash) +-- pure $ blk ^. BlockId +-- pure $ maybeToEither (DbLookupBlockHash hash) unValue (listToMaybe res) + +-- -- | 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 Epoch entry for the last epoch. +-- queryCalcEpochEntry :: MonadIO m => Word64 -> ReaderT SqlBackend m Epoch +-- queryCalcEpochEntry epochNum = do +-- blockResult <- select $ do +-- block <- from $ table @Block +-- where_ (block ^. BlockEpochNo ==. just (val epochNum)) +-- pure (countRows, min_ (block ^. BlockTime), max_ (block ^. BlockTime)) +-- queryTxWithBlocks epochNum blockResult + +-- -- | Get the PostgreSQL row index (EpochId) that matches the given epoch number. +-- queryForEpochId :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe EpochId) +-- queryForEpochId epochNum = do +-- res <- selectOne $ do +-- epoch <- from $ table @Epoch +-- where_ (epoch ^. EpochNo ==. val epochNum) +-- pure (epoch ^. EpochId) +-- pure $ unValue <$> res + +-- -- | Get an epoch given it's number. +-- queryEpochFromNum :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe Epoch) +-- queryEpochFromNum epochNum = do +-- res <- selectOne $ do +-- epoch <- from $ table @Epoch +-- where_ (epoch ^. EpochNo ==. val epochNum) +-- pure epoch +-- pure $ entityVal <$> res + +-- -- | Get the most recent epoch in the Epoch DB table. +-- queryLatestEpoch :: MonadIO m => ReaderT SqlBackend m (Maybe Epoch) +-- queryLatestEpoch = do +-- res <- selectOne $ do +-- epoch <- from $ table @Epoch +-- orderBy [desc (epoch ^. EpochNo)] +-- pure epoch +-- pure $ entityVal <$> res -- | Count the number of epochs in Epoch table. queryEpochCount :: MonadIO m => ReaderT SqlBackend m Word @@ -419,15 +420,15 @@ queryNormalEpochRewardCount epochNum = do pure countRows pure $ maybe 0 unValue (listToMaybe res) -queryGenesis :: MonadIO m => ReaderT SqlBackend m (Either LookupFail BlockId) -queryGenesis = do - res <- select $ do - blk <- from (table @Block) - where_ (isNothing (blk ^. BlockPreviousId)) - pure $ blk ^. BlockId - case res of - [blk] -> pure $ Right (unValue blk) - _ -> pure $ Left DBMultipleGenesis +-- queryGenesis :: MonadIO m => ReaderT SqlBackend m (Either LookupFail BlockId) +-- queryGenesis = do +-- res <- select $ do +-- blk <- from (table @Block) +-- where_ (isNothing (blk ^. BlockPreviousId)) +-- pure $ blk ^. BlockId +-- case res of +-- [blk] -> pure $ Right (unValue blk) +-- _ -> pure $ Left DBMultipleGenesis -- | Get the latest block. queryLatestBlock :: MonadIO m => ReaderT SqlBackend m (Maybe Block) @@ -483,14 +484,14 @@ queryLatestSlotNo = do {-# INLINEABLE queryMeta #-} --- | Get the network metadata. -queryMeta :: MonadIO m => ReaderT SqlBackend m (Either LookupFail Meta) -queryMeta = do - res <- select . from $ table @Meta - pure $ case res of - [] -> Left DbMetaEmpty - [m] -> Right $ entityVal m - _ -> Left DbMetaMultipleRows +-- -- | Get the network metadata. +-- queryMeta :: MonadIO m => ReaderT SqlBackend m (Either LookupFail Meta) +-- queryMeta = do +-- res <- select . from $ table @Meta +-- pure $ case res of +-- [] -> Left DbMetaEmpty +-- [m] -> Right $ entityVal m +-- _ -> Left DbMetaMultipleRows queryScript :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe ScriptId) queryScript hsh = do @@ -558,13 +559,13 @@ queryTxCount = do pure $ maybe 0 unValue (listToMaybe res) -- -- | Get the 'TxId' associated with the given hash. -queryTxId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail TxId) -queryTxId hash = do - res <- select $ do - tx <- from $ table @Tx - where_ (tx ^. TxHash ==. val hash) - pure (tx ^. TxId) - pure $ maybeToEither (DbLookupTxHash hash) unValue (listToMaybe res) +-- queryTxId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail TxId) +-- queryTxId hash = do +-- res <- select $ do +-- tx <- from $ table @Tx +-- where_ (tx ^. TxHash ==. val hash) +-- pure (tx ^. TxId) +-- pure $ maybeToEither (DbLookupTxHash hash) unValue (listToMaybe res) queryEpochStakeCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 queryEpochStakeCount epoch = do @@ -651,14 +652,6 @@ existsVotingAnchorId vaId = do pure (votingAnchor ^. VotingAnchorId) pure $ not (null res) -queryAdaPotsId :: MonadIO m => BlockId -> ReaderT SqlBackend m (Maybe (Entity AdaPots)) -queryAdaPotsId blkId = do - res <- select $ do - adaPots <- from $ table @AdaPots - where_ (adaPots ^. AdaPotsBlockId ==. val blkId) - pure adaPots - pure $ listToMaybe res - -- | Get the current block height. queryBlockHeight :: MonadIO m => ReaderT SqlBackend m (Maybe Word64) queryBlockHeight = do @@ -691,14 +684,14 @@ queryMinMaxEpochStake = do pure (es ^. EpochStakeEpochNo) pure (unValue <$> listToMaybe minEpoch, unValue <$> listToMaybe maxEpoch) -queryGovActionProposalId :: MonadIO m => TxId -> Word64 -> ReaderT SqlBackend m (Either LookupFail GovActionProposalId) -queryGovActionProposalId txId index = do - res <- select $ do - ga <- from $ table @GovActionProposal - where_ (ga ^. GovActionProposalTxId ==. val txId) - where_ (ga ^. GovActionProposalIndex ==. val index) - pure ga - pure $ maybeToEither (DbLookupGovActionPair txId index) entityKey (listToMaybe res) +-- queryGovActionProposalId :: MonadIO m => TxId -> Word64 -> ReaderT SqlBackend m (Either LookupFail GovActionProposalId) +-- queryGovActionProposalId txId index = do +-- res <- select $ do +-- ga <- from $ table @GovActionProposal +-- where_ (ga ^. GovActionProposalTxId ==. val txId) +-- where_ (ga ^. GovActionProposalIndex ==. val index) +-- pure ga +-- pure $ maybeToEither (DbLookupGovActionPair txId index) entityKey (listToMaybe res) queryDrepHashAlwaysAbstain :: MonadIO m => ReaderT SqlBackend m (Maybe DrepHashId) queryDrepHashAlwaysAbstain = do @@ -758,17 +751,17 @@ queryPoolHashId hash = do pure (phash ^. PoolHashId) pure $ unValue <$> listToMaybe res -queryStakeAddress :: - MonadIO m => - ByteString -> - (ByteString -> Text) -> - ReaderT SqlBackend m (Either LookupFail StakeAddressId) -queryStakeAddress addr toText = do - res <- select $ do - saddr <- from $ table @StakeAddress - where_ (saddr ^. StakeAddressHashRaw ==. val addr) - pure (saddr ^. StakeAddressId) - pure $ maybeToEither (DbLookupMessage $ "StakeAddress " <> toText addr) unValue (listToMaybe res) +-- queryStakeAddress :: +-- MonadIO m => +-- ByteString -> +-- (ByteString -> Text) -> +-- ReaderT SqlBackend m (Either LookupFail StakeAddressId) +-- queryStakeAddress addr toText = do +-- res <- select $ do +-- saddr <- from $ table @StakeAddress +-- where_ (saddr ^. StakeAddressHashRaw ==. val addr) +-- pure (saddr ^. StakeAddressId) +-- pure $ maybeToEither (DbLookupMessage $ "StakeAddress " <> toText addr) unValue (listToMaybe res) queryStakeRefPtr :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddressId) queryStakeRefPtr (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do @@ -955,8 +948,8 @@ queryOffChainPoolFetchError hash (Just fromTime) = do ^. PoolHashHashRaw ==. val hash &&. offChainPoolFetchError - ^. OffChainPoolFetchErrorFetchTime - >=. val fromTime + ^. OffChainPoolFetchErrorFetchTime + >=. val fromTime ) orderBy [desc (offChainPoolFetchError ^. OffChainPoolFetchErrorFetchTime)] limit 10 @@ -990,13 +983,13 @@ queryDepositUpToBlockNo blkNo = do pure $ sum_ (tx ^. TxDeposit) pure $ unValueSumAda (listToMaybe res) -queryEpochEntry :: MonadIO m => Word64 -> ReaderT SqlBackend m (Either LookupFail Epoch) -queryEpochEntry epochNum = do - res <- select $ do - epoch <- from $ table @Epoch - where_ (epoch ^. EpochNo ==. val epochNum) - pure epoch - pure $ maybeToEither (DbLookupEpochNo epochNum) entityVal (listToMaybe res) +-- queryEpochEntry :: MonadIO m => Word64 -> ReaderT SqlBackend m (Either LookupFail Epoch) +-- queryEpochEntry epochNum = do +-- res <- select $ do +-- epoch <- from $ table @Epoch +-- where_ (epoch ^. EpochNo ==. val epochNum) +-- pure epoch +-- pure $ maybeToEither (DbLookupEpochNo epochNum) entityVal (listToMaybe res) -- | Get the fees paid in all block from genesis up to and including the specified block. queryFeesUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada @@ -1067,15 +1060,15 @@ querySlotNos = do pure (blk ^. BlockSlotNo) pure $ mapMaybe (fmap SlotNo . unValue) res --- | Calculate the slot time (as UTCTime) for a given slot number. --- This will fail if the slot is empty. -querySlotUtcTime :: MonadIO m => Word64 -> ReaderT SqlBackend m (Either LookupFail UTCTime) -querySlotUtcTime slotNo = do - le <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockSlotNo ==. just (val slotNo)) - pure (blk ^. BlockTime) - pure $ maybe (Left $ DbLookupSlotNo slotNo) (Right . unValue) (listToMaybe le) +-- -- | Calculate the slot time (as UTCTime) for a given slot number. +-- -- This will fail if the slot is empty. +-- querySlotUtcTime :: MonadIO m => Word64 -> ReaderT SqlBackend m (Either LookupFail UTCTime) +-- querySlotUtcTime slotNo = do +-- le <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockSlotNo ==. just (val slotNo)) +-- pure (blk ^. BlockTime) +-- pure $ maybe (Left $ DbLookupSlotNo slotNo) (Right . unValue) (listToMaybe le) queryWithdrawalsUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada queryWithdrawalsUpToBlockNo blkNo = do diff --git a/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs b/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs index 64da0a70f..c24f4f243 100644 --- a/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs +++ b/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs @@ -5,33 +5,34 @@ module Cardano.Db.Operations.QueryHelper where -import Cardano.Db.Schema.BaseSchema -import Cardano.Db.Types -import Data.Fixed (Micro) -import Data.Time.Clock (UTCTime) -import Data.Word (Word64) -import Database.Esqueleto.Experimental ( - Entity (..), - PersistField, - SqlExpr, - Value (unValue), - ValueList, - from, - in_, - isNothing, - not_, - subList_select, - table, - unSqlBackendKey, - val, - where_, - (<=.), - (^.), - ) +-- import Cardano.Db.Schema.Core +-- import Cardano.Db.Types +-- import Data.Fixed (Micro) +-- import Data.Time.Clock (UTCTime) +-- import Data.Word (Word64) +-- import Database.Esqueleto.Experimental ( +-- Entity (..), +-- PersistField, +-- SqlExpr, +-- Value (unValue), +-- ValueList, +-- from, +-- in_, +-- isNothing, +-- not_, +-- subList_select, +-- table, +-- unSqlBackendKey, +-- val, +-- where_, +-- (<=.), +-- (^.), Key, +-- ) +-- import Cardano.Db.Schema.Ids (BlockId (..), TxId (..), TxInId) --- Filter out 'Nothing' from a 'Maybe a'. -isJust :: PersistField a => SqlExpr (Value (Maybe a)) -> SqlExpr (Value Bool) -isJust = not_ . isNothing +-- -- Filter out 'Nothing' from a 'Maybe a'. +-- isJust :: PersistField a => SqlExpr (Value (Maybe a)) -> SqlExpr (Value Bool) +-- isJust = not_ . isNothing -- every tx made before or at the snapshot time txLessEqual :: BlockId -> SqlExpr (ValueList TxId) @@ -49,42 +50,42 @@ txLessEqual blkid = where_ $ blk ^. BlockId <=. val blkid pure $ blk ^. BlockId -maybeToEither :: e -> (a -> b) -> Maybe a -> Either e b -maybeToEither e f = maybe (Left e) (Right . f) +-- maybeToEither :: e -> (a -> b) -> Maybe a -> Either e b +-- maybeToEither e f = maybe (Left e) (Right . f) --- | Get the UTxO set after the specified 'BlockNo' has been applied to the chain. --- Unfortunately the 'sum_' operation above returns a 'PersistRational' so we need --- to un-wibble it. -unValueSumAda :: Maybe (Value (Maybe Micro)) -> Ada -unValueSumAda mvm = - case fmap unValue mvm of - Just (Just x) -> lovelaceToAda x - _otherwise -> Ada 0 +-- -- | Get the UTxO set after the specified 'BlockNo' has been applied to the chain. +-- -- Unfortunately the 'sum_' operation above returns a 'PersistRational' so we need +-- -- to un-wibble it. +-- unValueSumAda :: Maybe (Value (Maybe Micro)) -> Ada +-- unValueSumAda mvm = +-- case fmap unValue mvm of +-- Just (Just x) -> lovelaceToAda x +-- _otherwise -> Ada 0 -entityPair :: Entity a -> (Key a, a) -entityPair e = - (entityKey e, entityVal e) +-- entityPair :: Entity a -> (Key a, a) +-- entityPair e = +-- (entityKey e, entityVal e) -unBlockId :: BlockId -> Word64 -unBlockId = fromIntegral . unSqlBackendKey . unBlockKey +-- unBlockId :: BlockId -> Word64 +-- unBlockId = fromIntegral . unSqlBackendKey . unBlockKey -unTxId :: TxId -> Word64 -unTxId = fromIntegral . unSqlBackendKey . unTxKey +-- unTxId :: TxId -> Word64 +-- unTxId = fromIntegral . unSqlBackendKey . unTxKey -unTxInId :: TxInId -> Word64 -unTxInId = fromIntegral . unSqlBackendKey . unTxInKey +-- unTxInId :: TxInId -> Word64 +-- unTxInId = fromIntegral . unSqlBackendKey . unTxInKey -defaultUTCTime :: UTCTime -defaultUTCTime = read "2000-01-01 00:00:00.000000 UTC" +-- defaultUTCTime :: UTCTime +-- defaultUTCTime = read "2000-01-01 00:00:00.000000 UTC" -unValue2 :: (Value a, Value b) -> (a, b) -unValue2 (a, b) = (unValue a, unValue b) +-- unValue2 :: (Value a, Value b) -> (a, b) +-- unValue2 (a, b) = (unValue a, unValue b) -unValue3 :: (Value a, Value b, Value c) -> (a, b, c) -unValue3 (a, b, c) = (unValue a, unValue b, unValue c) +-- unValue3 :: (Value a, Value b, Value c) -> (a, b, c) +-- unValue3 (a, b, c) = (unValue a, unValue b, unValue c) -unValue4 :: (Value a, Value b, Value c, Value d) -> (a, b, c, d) -unValue4 (a, b, c, d) = (unValue a, unValue b, unValue c, unValue d) +-- unValue4 :: (Value a, Value b, Value c, Value d) -> (a, b, c, d) +-- unValue4 (a, b, c, d) = (unValue a, unValue b, unValue c, unValue d) -unValue5 :: (Value a, Value b, Value c, Value d, Value e) -> (a, b, c, d, e) -unValue5 (a, b, c, d, e) = (unValue a, unValue b, unValue c, unValue d, unValue e) +-- unValue5 :: (Value a, Value b, Value c, Value d, Value e) -> (a, b, c, d, e) +-- unValue5 (a, b, c, d, e) = (unValue a, unValue b, unValue c, unValue d, unValue e) diff --git a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs index f17328aa4..35de32c81 100644 --- a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutDelete.hs @@ -5,35 +5,34 @@ module Cardano.Db.Operations.TxOut.TxOutDelete where -import Cardano.Db.Operations.Types (TxOutTableType (..)) -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.Prelude (Int64) -import Control.Monad.Extra (whenJust) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT) -import Database.Persist.Class.PersistQuery (deleteWhere) -import Database.Persist.Sql ( - Filter, - SqlBackend, - deleteWhereCount, - (>=.), - ) +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Cardano.Prelude (Int64) +-- import Control.Monad.Extra (whenJust) +-- import Control.Monad.IO.Class (MonadIO) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import Database.Persist.Class.PersistQuery (deleteWhere) +-- import Database.Persist.Sql ( +-- Filter, +-- SqlBackend, +-- deleteWhereCount, +-- (>=.), +-- ) -------------------------------------------------------------------------------- -- Delete -------------------------------------------------------------------------------- -deleteCoreTxOutTablesAfterTxId :: MonadIO m => Maybe C.TxOutId -> Maybe C.MaTxOutId -> ReaderT SqlBackend m () -deleteCoreTxOutTablesAfterTxId mtxOutId mmaTxOutId = do - whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [C.MaTxOutId >=. maTxOutId] - whenJust mtxOutId $ \txOutId -> deleteWhere [C.TxOutId >=. txOutId] +-- deleteCoreTxOutTablesAfterTxId :: MonadIO m => Maybe C.TxOutId -> Maybe C.MaTxOutId -> ReaderT SqlBackend m () +-- deleteCoreTxOutTablesAfterTxId mtxOutId mmaTxOutId = do +-- whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [C.MaTxOutId >=. maTxOutId] +-- whenJust mtxOutId $ \txOutId -> deleteWhere [C.TxOutId >=. txOutId] -deleteVariantTxOutTablesAfterTxId :: MonadIO m => Maybe V.TxOutId -> Maybe V.MaTxOutId -> ReaderT SqlBackend m () -deleteVariantTxOutTablesAfterTxId mtxOutId mmaTxOutId = do - whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [V.MaTxOutId >=. maTxOutId] - whenJust mtxOutId $ \txOutId -> deleteWhere [V.TxOutId >=. txOutId] +-- deleteVariantTxOutTablesAfterTxId :: MonadIO m => Maybe V.TxOutId -> Maybe V.MaTxOutId -> ReaderT SqlBackend m () +-- deleteVariantTxOutTablesAfterTxId mtxOutId mmaTxOutId = do +-- whenJust mmaTxOutId $ \maTxOutId -> deleteWhere [V.MaTxOutId >=. maTxOutId] +-- whenJust mtxOutId $ \txOutId -> deleteWhere [V.TxOutId >=. txOutId] -deleteTxOut :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m Int64 -deleteTxOut = \case - TxOutCore -> deleteWhereCount ([] :: [Filter C.TxOut]) - TxOutVariantAddress -> deleteWhereCount ([] :: [Filter V.TxOut]) +-- deleteTxOut :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m Int64 +-- deleteTxOut = \case +-- TxOutCore -> deleteWhereCount ([] :: [Filter C.TxOut]) +-- TxOutVariantAddress -> deleteWhereCount ([] :: [Filter V.TxOut]) diff --git a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs index b00e93085..472c406bd 100644 --- a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutInsert.hs @@ -7,96 +7,23 @@ module Cardano.Db.Operations.TxOut.TxOutInsert where -import Cardano.Db.Operations.Insert (insertMany', insertUnchecked) -import Cardano.Db.Operations.Types (CollateralTxOutIdW (..), CollateralTxOutW (..), MaTxOutIdW (..), MaTxOutW (..), TxOutIdW (..), TxOutW (..)) -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import Database.Persist.Sql ( - SqlBackend, - ) - --------------------------------------------------------------------------------- --- insertManyTxOut - Insert a list of TxOut into the database. --------------------------------------------------------------------------------- -insertManyTxOut :: - (MonadBaseControl IO m, MonadIO m) => - Bool -> - [TxOutW] -> - ReaderT SqlBackend m [TxOutIdW] -insertManyTxOut disInOut txOutWs = do - if disInOut - then pure [] - else case txOutWs of - [] -> pure [] - txOuts@(txOutW : _) -> - case txOutW of - CTxOutW _ -> do - vals <- insertMany' "insertManyTxOutC" (map extractCoreTxOut txOuts) - pure $ map CTxOutIdW vals - VTxOutW _ _ -> do - vals <- insertMany' "insertManyTxOutV" (map extractVariantTxOut txOuts) - pure $ map VTxOutIdW vals - where - extractCoreTxOut :: TxOutW -> C.TxOut - extractCoreTxOut (CTxOutW txOut) = txOut - extractCoreTxOut (VTxOutW _ _) = error "Unexpected VTxOutW in CoreTxOut list" - - extractVariantTxOut :: TxOutW -> V.TxOut - extractVariantTxOut (VTxOutW txOut _) = txOut - extractVariantTxOut (CTxOutW _) = error "Unexpected CTxOutW in VariantTxOut list" - --------------------------------------------------------------------------------- --- insertTxOut - Insert a TxOut into the database. --------------------------------------------------------------------------------- -insertTxOut :: (MonadBaseControl IO m, MonadIO m) => TxOutW -> ReaderT SqlBackend m TxOutIdW -insertTxOut txOutW = do - case txOutW of - CTxOutW txOut -> do - val <- insertUnchecked "insertTxOutC" txOut - pure $ CTxOutIdW val - VTxOutW txOut _ -> do - val <- insertUnchecked "insertTxOutV" txOut - pure $ VTxOutIdW val - --------------------------------------------------------------------------------- --- insertAddress - Insert a Address into the database. --------------------------------------------------------------------------------- -insertAddress :: (MonadBaseControl IO m, MonadIO m) => V.Address -> ReaderT SqlBackend m V.AddressId -insertAddress = insertUnchecked "insertAddress" - --------------------------------------------------------------------------------- --- insertManyMaTxOut - Insert a list of MultiAsset TxOut into the database. --------------------------------------------------------------------------------- -insertManyMaTxOut :: (MonadBaseControl IO m, MonadIO m) => [MaTxOutW] -> ReaderT SqlBackend m [MaTxOutIdW] -insertManyMaTxOut maTxOutWs = do - case maTxOutWs of - [] -> pure [] - maTxOuts@(maTxOutW : _) -> - case maTxOutW of - CMaTxOutW _ -> do - vals <- insertMany' "Many Variant MaTxOut" (map extractCoreMaTxOut maTxOuts) - pure $ map CMaTxOutIdW vals - VMaTxOutW _ -> do - vals <- insertMany' "Many Variant MaTxOut" (map extractVariantMaTxOut maTxOuts) - pure $ map VMaTxOutIdW vals - where - extractCoreMaTxOut :: MaTxOutW -> C.MaTxOut - extractCoreMaTxOut (CMaTxOutW maTxOut) = maTxOut - extractCoreMaTxOut (VMaTxOutW _) = error "Unexpected VMaTxOutW in CoreMaTxOut list" - - extractVariantMaTxOut :: MaTxOutW -> V.MaTxOut - extractVariantMaTxOut (VMaTxOutW maTxOut) = maTxOut - extractVariantMaTxOut (CMaTxOutW _) = error "Unexpected CMaTxOutW in VariantMaTxOut list" - -insertCollateralTxOut :: (MonadBaseControl IO m, MonadIO m) => CollateralTxOutW -> ReaderT SqlBackend m CollateralTxOutIdW -insertCollateralTxOut collateralTxOutW = - case collateralTxOutW of - CCollateralTxOutW txOut -> do - val <- insertUnchecked "CollateralTxOut" txOut - pure $ CCollateralTxOutIdW val - VCollateralTxOutW txOut -> do - val <- insertUnchecked "CollateralTxOut" txOut - pure $ VCollateralTxOutIdW val +-- import Cardano.Db.Operations.Insert (insertMany', insertUnchecked) +-- import Cardano.Db.Operations.Types (CollateralTxOutIdW (..), CollateralTxOutW (..), MaTxOutIdW (..), MaTxOutW (..), TxOutIdW (..), TxOutW (..)) +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Control.Monad.IO.Class (MonadIO) +-- import Control.Monad.Trans.Control (MonadBaseControl) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import Database.Persist.Sql ( +-- SqlBackend, +-- ) + +-- insertCollateralTxOut :: (MonadBaseControl IO m, MonadIO m) => CollateralTxOutW -> ReaderT SqlBackend m CollateralTxOutIdW +-- insertCollateralTxOut collateralTxOutW = +-- case collateralTxOutW of +-- CCollateralTxOutW txOut -> do +-- val <- insertUnchecked "CollateralTxOut" txOut +-- pure $ CCollateralTxOutIdW val +-- VCollateralTxOutW txOut -> do +-- val <- insertUnchecked "CollateralTxOut" txOut +-- pure $ VCollateralTxOutIdW val diff --git a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs index c6af125ef..6554a2dc8 100644 --- a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs @@ -13,560 +13,534 @@ module Cardano.Db.Operations.TxOut.TxOutQuery where -import Cardano.Db.Error (LookupFail (..)) -import Cardano.Db.Operations.QueryHelper (isJust, maybeToEither, txLessEqual, unValue2, unValue3, unValueSumAda) -import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTableType (..), TxOutW (..), UtxoQueryResult (..)) -import Cardano.Db.Schema.BaseSchema -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.Db.Types (Ada, DbLovelace (..)) -import Cardano.Prelude (Bifunctor (second), ByteString, ReaderT, Text, Word64, listToMaybe, mapMaybe) -import Control.Monad.IO.Class (MonadIO) -import Database.Esqueleto.Experimental ( - Entity (..), - SqlBackend, - SqlExpr, - SqlQuery, - Value (..), - countRows, - from, - in_, - innerJoin, - isNothing, - just, - leftJoin, - notExists, - on, - select, - sum_, - table, - val, - where_, - (&&.), - (==.), - (>.), - (?.), - (^.), - (||.), - type (:&) ((:&)), - ) - -{- HLINT ignore "Fuse on/on" -} -{- HLINT ignore "Redundant ^." -} - --- Some Queries can accept TxOutTableType as a parameter, whilst others that return a TxOut related value can't --- as they wiil either deal with Core or Variant TxOut/Address types. --- These types also need to be handled at the call site. - --------------------------------------------------------------------------------- --- queryTxOutValue --------------------------------------------------------------------------------- - --- | Like 'queryTxId' but also return the 'TxOutIdValue' of the transaction output. -queryTxOutValue :: - MonadIO m => - TxOutTableType -> - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) -queryTxOutValue txOutTableType hashIndex = - case txOutTableType of - TxOutCore -> queryTxOutValue' @'TxOutCore hashIndex - TxOutVariantAddress -> queryTxOutValue' @'TxOutVariantAddress hashIndex - where - queryTxOutValue' :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) - queryTxOutValue' (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) - where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. txOutTxIdField @a, txOut ^. txOutValueField @a) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - --------------------------------------------------------------------------------- --- queryTxOutId --------------------------------------------------------------------------------- - --- | Like 'queryTxId' but also return the 'TxOutId' of the transaction output. -queryTxOutId :: - MonadIO m => - TxOutTableType -> - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW)) -queryTxOutId txOutTableType hashIndex = - case txOutTableType of - TxOutCore -> wrapTxOutId CTxOutIdW (queryTxOutId' @'TxOutCore hashIndex) - TxOutVariantAddress -> wrapTxOutId VTxOutIdW (queryTxOutId' @'TxOutVariantAddress hashIndex) - where - wrapTxOutId constructor = fmap (fmap (second constructor)) - - queryTxOutId' :: - forall a m. - (TxOutFields a, MonadIO m) => - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdFor a)) - queryTxOutId' (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) - where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - --------------------------------------------------------------------------------- --- queryTxOutIdValue --------------------------------------------------------------------------------- - --- | Like 'queryTxOutId' but also return the 'TxOutIdValue' -queryTxOutIdValue :: - (MonadIO m) => - TxOutTableType -> - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) -queryTxOutIdValue getTxOutTableType hashIndex = do - case getTxOutTableType of - TxOutCore -> wrapTxOutId CTxOutIdW (queryTxOutIdValue' @'TxOutCore hashIndex) - TxOutVariantAddress -> wrapTxOutId VTxOutIdW (queryTxOutIdValue' @'TxOutVariantAddress hashIndex) - where - wrapTxOutId constructor = - fmap (fmap (\(txId, txOutId, lovelace) -> (txId, constructor txOutId, lovelace))) - - queryTxOutIdValue' :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdFor a, DbLovelace)) - queryTxOutIdValue' (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) - where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a, txOut ^. txOutValueField @a) - pure $ maybeToEither (DbLookupTxHash hash) unValue3 (listToMaybe res) - --------------------------------------------------------------------------------- --- queryTxOutIdValue --------------------------------------------------------------------------------- - --- | Give a (tx hash, index) pair, return the TxOut Credentials. -queryTxOutCredentials :: - MonadIO m => - TxOutTableType -> - (ByteString, Word64) -> - ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) -queryTxOutCredentials txOutTableType (hash, index) = - case txOutTableType of - TxOutCore -> queryTxOutCredentialsCore (hash, index) - TxOutVariantAddress -> queryTxOutCredentialsVariant (hash, index) - -queryTxOutCredentialsCore :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) -queryTxOutCredentialsCore (hash, index) = do - res <- select $ do - (tx :& txOut) <- - from - $ table @Tx - `innerJoin` table @C.TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. C.TxOutTxId) - where_ (txOut ^. C.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) - pure (txOut ^. C.TxOutPaymentCred, txOut ^. C.TxOutAddressHasScript) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - -queryTxOutCredentialsVariant :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) -queryTxOutCredentialsVariant (hash, index) = do - res <- select $ do - (tx :& txOut :& address) <- - from - $ ( table @Tx - `innerJoin` table @V.TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. V.TxOutTxId) - ) - `innerJoin` table @V.Address - `on` (\((_ :& txOut) :& address) -> txOut ^. V.TxOutAddressId ==. address ^. V.AddressId) - where_ (txOut ^. V.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) - pure (address ^. V.AddressPaymentCred, address ^. V.AddressHasScript) - pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) - --------------------------------------------------------------------------------- --- ADDRESS QUERIES --------------------------------------------------------------------------------- -queryAddressId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe V.AddressId) -queryAddressId addrRaw = do - res <- select $ do - addr <- from $ table @V.Address - where_ (addr ^. V.AddressRaw ==. val addrRaw) - pure (addr ^. V.AddressId) - pure $ unValue <$> listToMaybe res - --------------------------------------------------------------------------------- --- queryTotalSupply --------------------------------------------------------------------------------- - --- | Get the current total supply of Lovelace. This only returns the on-chain supply which --- does not include staking rewards that have not yet been withdrawn. Before wihdrawal --- rewards are part of the ledger state and hence not on chain. -queryTotalSupply :: - (MonadIO m) => - TxOutTableType -> - ReaderT SqlBackend m Ada -queryTotalSupply txOutTableType = - case txOutTableType of - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Ada - query = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - txOutUnspentP @a txOut - pure $ sum_ (txOut ^. txOutValueField @a) - pure $ unValueSumAda (listToMaybe res) - --------------------------------------------------------------------------------- --- queryGenesisSupply --------------------------------------------------------------------------------- - --- | Return the total Genesis coin supply. -queryGenesisSupply :: - (MonadIO m) => - TxOutTableType -> - ReaderT SqlBackend m Ada -queryGenesisSupply txOutTableType = - case txOutTableType of - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Ada - query = do - res <- select $ do - (_tx :& txOut :& blk) <- - from - $ table @Tx - `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) - `innerJoin` table @Block - `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (isNothing $ blk ^. BlockPreviousId) - pure $ sum_ (txOut ^. txOutValueField @a) - pure $ unValueSumAda (listToMaybe res) - --- A predicate that filters out spent 'TxOut' entries. -{-# INLINEABLE txOutUnspentP #-} -txOutUnspentP :: forall a. TxOutFields a => SqlExpr (Entity (TxOutTable a)) -> SqlQuery () -txOutUnspentP txOut = - where_ . notExists $ - from (table @TxIn) >>= \txIn -> - where_ - ( txOut - ^. txOutTxIdField @a - ==. txIn - ^. TxInTxOutId - &&. txOut - ^. txOutIndexField @a - ==. txIn - ^. TxInTxOutIndex - ) - --------------------------------------------------------------------------------- --- queryShelleyGenesisSupply --------------------------------------------------------------------------------- - --- | Return the total Shelley Genesis coin supply. The Shelley Genesis Block --- is the unique which has a non-null PreviousId, but has null Epoch. -queryShelleyGenesisSupply :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m Ada -queryShelleyGenesisSupply txOutTableType = - case txOutTableType of - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Ada - query = do - res <- select $ do - (txOut :& _tx :& blk) <- - from - $ table @(TxOutTable a) - `innerJoin` table @Tx - `on` (\(txOut :& tx) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) - `innerJoin` table @Block - `on` (\(_txOut :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (isJust $ blk ^. BlockPreviousId) - where_ (isNothing $ blk ^. BlockEpochNo) - pure $ sum_ (txOut ^. txOutValueField @a) - pure $ unValueSumAda (listToMaybe res) - --------------------------------------------------------------------------------- --- Testing or validating. Queries below are not used in production --------------------------------------------------------------------------------- - --------------------------------------------------------------------------------- --- queryUtxoAtBlockNo --------------------------------------------------------------------------------- -queryUtxoAtBlockNo :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [UtxoQueryResult] -queryUtxoAtBlockNo txOutTableType blkNo = do - eblkId <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockBlockNo ==. just (val blkNo)) - pure (blk ^. BlockId) - maybe (pure []) (queryUtxoAtBlockId txOutTableType . unValue) (listToMaybe eblkId) - --------------------------------------------------------------------------------- --- queryUtxoAtSlotNo --------------------------------------------------------------------------------- -queryUtxoAtSlotNo :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [UtxoQueryResult] -queryUtxoAtSlotNo txOutTableType slotNo = do - eblkId <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockSlotNo ==. just (val slotNo)) - pure (blk ^. BlockId) - maybe (pure []) (queryUtxoAtBlockId txOutTableType . unValue) (listToMaybe eblkId) - --------------------------------------------------------------------------------- --- queryUtxoAtBlockId --------------------------------------------------------------------------------- -queryUtxoAtBlockId :: MonadIO m => TxOutTableType -> BlockId -> ReaderT SqlBackend m [UtxoQueryResult] -queryUtxoAtBlockId txOutTableType blkid = - case txOutTableType of - TxOutCore -> queryUtxoAtBlockIdCore blkid - TxOutVariantAddress -> queryUtxoAtBlockIdVariant blkid - -queryUtxoAtBlockIdCore :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQueryResult] -queryUtxoAtBlockIdCore blkid = do - outputs <- select $ do - (txout :& _txin :& _tx1 :& blk :& tx2) <- - from - $ table @C.TxOut - `leftJoin` table @TxIn - `on` ( \(txout :& txin) -> - (just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) - &&. (just (txout ^. C.TxOutIndex) ==. txin ?. TxInTxOutIndex) - ) - `leftJoin` table @Tx - `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) - `leftJoin` table @Block - `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) - `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) - - where_ $ - (txout ^. C.TxOutTxId `in_` txLessEqual blkid) - &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - pure (txout, txout ^. C.TxOutAddress, tx2 ?. TxHash) - pure $ mapMaybe convertCore outputs - -queryUtxoAtBlockIdVariant :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQueryResult] -queryUtxoAtBlockIdVariant blkid = do - outputs <- select $ do - (txout :& _txin :& _tx1 :& blk :& tx2 :& address) <- - from - $ table @V.TxOut - `leftJoin` table @TxIn - `on` ( \(txout :& txin) -> - (just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) - &&. (just (txout ^. V.TxOutIndex) ==. txin ?. TxInTxOutIndex) - ) - `leftJoin` table @Tx - `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) - `leftJoin` table @Block - `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) - `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) - `innerJoin` table @V.Address - `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) - - where_ $ - (txout ^. V.TxOutTxId `in_` txLessEqual blkid) - &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - pure (txout, address, tx2 ?. TxHash) - pure $ mapMaybe convertVariant outputs - -convertCore :: (Entity C.TxOut, Value Text, Value (Maybe ByteString)) -> Maybe UtxoQueryResult -convertCore (out, Value address, Value (Just hash')) = - Just $ - UtxoQueryResult - { utxoTxOutW = CTxOutW $ entityVal out - , utxoAddress = address - , utxoTxHash = hash' - } -convertCore _ = Nothing - -convertVariant :: (Entity V.TxOut, Entity V.Address, Value (Maybe ByteString)) -> Maybe UtxoQueryResult -convertVariant (out, address, Value (Just hash')) = - Just $ - UtxoQueryResult - { utxoTxOutW = VTxOutW (entityVal out) (Just (entityVal address)) - , utxoAddress = V.addressAddress $ entityVal address - , utxoTxHash = hash' - } -convertVariant _ = Nothing - --------------------------------------------------------------------------------- --- queryAddressBalanceAtSlot --------------------------------------------------------------------------------- -queryAddressBalanceAtSlot :: MonadIO m => TxOutTableType -> Text -> Word64 -> ReaderT SqlBackend m Ada -queryAddressBalanceAtSlot txOutTableType addr slotNo = do - eblkId <- select $ do - blk <- from (table @Block) - where_ (blk ^. BlockSlotNo ==. just (val slotNo)) - pure (blk ^. BlockId) - maybe (pure 0) (queryAddressBalanceAtBlockId . unValue) (listToMaybe eblkId) - where - queryAddressBalanceAtBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m Ada - queryAddressBalanceAtBlockId blkid = do - -- tx1 refers to the tx of the input spending this output (if it is ever spent) - -- tx2 refers to the tx of the output - case txOutTableType of - TxOutCore -> do - res <- select $ do - (txout :& _ :& _ :& blk :& _) <- - from - $ table @C.TxOut - `leftJoin` table @TxIn - `on` (\(txout :& txin) -> just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) - `leftJoin` table @Tx - `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) - `leftJoin` table @Block - `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) - `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) - where_ $ - (txout ^. C.TxOutTxId `in_` txLessEqual blkid) - &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - where_ (txout ^. C.TxOutAddress ==. val addr) - pure $ sum_ (txout ^. C.TxOutValue) - pure $ unValueSumAda (listToMaybe res) - TxOutVariantAddress -> do - res <- select $ do - (txout :& _ :& _ :& blk :& _ :& address) <- - from - $ table @V.TxOut - `leftJoin` table @TxIn - `on` (\(txout :& txin) -> just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) - `leftJoin` table @Tx - `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) - `leftJoin` table @Block - `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) - `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) - `innerJoin` table @V.Address - `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) - where_ $ - (txout ^. V.TxOutTxId `in_` txLessEqual blkid) - &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) - where_ (address ^. V.AddressAddress ==. val addr) - pure $ sum_ (txout ^. V.TxOutValue) - pure $ unValueSumAda (listToMaybe res) - --------------------------------------------------------------------------------- --- queryScriptOutputs --------------------------------------------------------------------------------- -queryScriptOutputs :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m [TxOutW] -queryScriptOutputs txOutTableType = - case txOutTableType of - TxOutCore -> fmap (map CTxOutW) queryScriptOutputsCore - TxOutVariantAddress -> queryScriptOutputsVariant - -queryScriptOutputsCore :: MonadIO m => ReaderT SqlBackend m [C.TxOut] -queryScriptOutputsCore = do - res <- select $ do - tx_out <- from $ table @C.TxOut - where_ (tx_out ^. C.TxOutAddressHasScript ==. val True) - pure tx_out - pure $ entityVal <$> res - -queryScriptOutputsVariant :: MonadIO m => ReaderT SqlBackend m [TxOutW] -queryScriptOutputsVariant = do - res <- select $ do - address <- from $ table @V.Address - tx_out <- from $ table @V.TxOut - where_ (address ^. V.AddressHasScript ==. val True) - where_ (tx_out ^. V.TxOutAddressId ==. address ^. V.AddressId) - pure (tx_out, address) - pure $ map (uncurry combineToWrapper) res - where - combineToWrapper :: Entity V.TxOut -> Entity V.Address -> TxOutW - combineToWrapper txOut address = - VTxOutW (entityVal txOut) (Just (entityVal address)) - --------------------------------------------------------------------------------- --- queryAddressOutputs --------------------------------------------------------------------------------- -queryAddressOutputs :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m DbLovelace -queryAddressOutputs txOutTableType addr = do - res <- case txOutTableType of - TxOutCore -> select $ do - txout <- from $ table @C.TxOut - where_ (txout ^. C.TxOutAddress ==. val addr) - pure $ sum_ (txout ^. C.TxOutValue) - TxOutVariantAddress -> select $ do - address <- from $ table @V.Address - txout <- from $ table @V.TxOut - where_ (address ^. V.AddressAddress ==. val addr) - where_ (txout ^. V.TxOutAddressId ==. address ^. V.AddressId) - pure $ sum_ (txout ^. V.TxOutValue) - pure $ convert (listToMaybe res) - where - convert v = case unValue <$> v of - Just (Just x) -> x - _otherwise -> DbLovelace 0 - --------------------------------------------------------------------------------- --- Helper Functions --------------------------------------------------------------------------------- - --- | Count the number of transaction outputs in the TxOut table. -queryTxOutCount :: - MonadIO m => - TxOutTableType -> - ReaderT SqlBackend m Word -queryTxOutCount txOutTableType = do - case txOutTableType of - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Word - query = do - res <- select $ from (table @(TxOutTable a)) >> pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryTxOutUnspentCount :: - MonadIO m => - TxOutTableType -> - ReaderT SqlBackend m Word64 -queryTxOutUnspentCount txOutTableType = - case txOutTableType of - TxOutCore -> query @'TxOutCore - TxOutVariantAddress -> query @'TxOutVariantAddress - where - query :: - forall (a :: TxOutTableType) m. - (MonadIO m, TxOutFields a) => - ReaderT SqlBackend m Word64 - query = do - res <- select $ do - txOut <- from $ table @(TxOutTable a) - txOutUnspentP @a txOut - pure countRows - pure $ maybe 0 unValue (listToMaybe res) +-- import Cardano.Db.Error (LookupFail (..)) +-- import Cardano.Db.Operations.QueryHelper (isJust, maybeToEither, txLessEqual, unValue2, unValue3, unValueSumAda) +-- import Cardano.Db.Operations.Types (TxOutFields (..), TxOutIdW (..), TxOutTableType (..), TxOutW (..), UtxoQueryResult (..)) +-- import Cardano.Db.Schema.Core +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Cardano.Db.Types (Ada, DbLovelace (..)) +-- import Cardano.Prelude (Bifunctor (second), ByteString, ReaderT, Text, Word64, listToMaybe, mapMaybe) +-- import Control.Monad.IO.Class (MonadIO) +-- import Database.Esqueleto.Experimental ( +-- Entity (..), +-- SqlBackend, +-- SqlExpr, +-- SqlQuery, +-- Value (..), +-- countRows, +-- from, +-- in_, +-- innerJoin, +-- isNothing, +-- just, +-- leftJoin, +-- notExists, +-- on, +-- select, +-- sum_, +-- table, +-- val, +-- where_, +-- (&&.), +-- (==.), +-- (>.), +-- (?.), +-- (^.), +-- (||.), +-- type (:&) ((:&)), +-- ) + +-- {- HLINT ignore "Fuse on/on" -} +-- {- HLINT ignore "Redundant ^." -} + +-- -- Some Queries can accept TxOutTableType as a parameter, whilst others that return a TxOut related value can't +-- -- as they wiil either deal with Core or Variant TxOut/Address types. +-- -- These types also need to be handled at the call site. + +-- -------------------------------------------------------------------------------- +-- -- queryTxOutValue +-- -------------------------------------------------------------------------------- + +-- -- | Like 'queryTxId' but also return the 'TxOutIdValue' of the transaction output. +-- -------------------------------------------------------------------------------- +-- -- queryTxOutId +-- -------------------------------------------------------------------------------- + +-- -- | Like 'queryTxId' but also return the 'TxOutId' of the transaction output. +-- queryTxOutId :: +-- MonadIO m => +-- TxOutTableType -> +-- (ByteString, Word64) -> +-- ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW)) +-- queryTxOutId txOutTableType hashIndex = +-- case txOutTableType of +-- TxOutCore -> wrapTxOutId CTxOutIdW (queryTxOutId' @'TxOutCore hashIndex) +-- TxOutVariantAddress -> wrapTxOutId VTxOutIdW (queryTxOutId' @'TxOutVariantAddress hashIndex) +-- where +-- wrapTxOutId constructor = fmap (fmap (second constructor)) + +-- queryTxOutId' :: +-- forall a m. +-- (TxOutFields a, MonadIO m) => +-- (ByteString, Word64) -> +-- ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdFor a)) +-- queryTxOutId' (hash, index) = do +-- res <- select $ do +-- (tx :& txOut) <- +-- from +-- $ table @Tx +-- `innerJoin` table @(TxOutTable a) +-- `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) +-- where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) +-- pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a) +-- pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryTxOutIdValue +-- -- -------------------------------------------------------------------------------- + +-- -- | Like 'queryTxOutId' but also return the 'TxOutIdValue' +-- queryTxOutIdValue :: +-- (MonadIO m) => +-- TxOutTableType -> +-- (ByteString, Word64) -> +-- ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) +-- queryTxOutIdValue getTxOutTableType hashIndex = do +-- case getTxOutTableType of +-- TxOutCore -> wrapTxOutId CTxOutIdW (queryTxOutIdValue' @'TxOutCore hashIndex) +-- TxOutVariantAddress -> wrapTxOutId VTxOutIdW (queryTxOutIdValue' @'TxOutVariantAddress hashIndex) +-- where +-- wrapTxOutId constructor = +-- fmap (fmap (\(txId, txOutId, lovelace) -> (txId, constructor txOutId, lovelace))) + +-- queryTxOutIdValue' :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- (ByteString, Word64) -> +-- ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdFor a, DbLovelace)) +-- queryTxOutIdValue' (hash, index) = do +-- res <- select $ do +-- (tx :& txOut) <- +-- from +-- $ table @Tx +-- `innerJoin` table @(TxOutTable a) +-- `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) +-- where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) +-- pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a, txOut ^. txOutValueField @a) +-- pure $ maybeToEither (DbLookupTxHash hash) unValue3 (listToMaybe res) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryTxOutIdValue +-- -- -------------------------------------------------------------------------------- + +-- -- | Give a (tx hash, index) pair, return the TxOut Credentials. +-- queryTxOutCredentials :: +-- MonadIO m => +-- TxOutTableType -> +-- (ByteString, Word64) -> +-- ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +-- queryTxOutCredentials txOutTableType (hash, index) = +-- case txOutTableType of +-- TxOutCore -> queryTxOutCredentialsCore (hash, index) +-- TxOutVariantAddress -> queryTxOutCredentialsVariant (hash, index) + +-- queryTxOutCredentialsCore :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +-- queryTxOutCredentialsCore (hash, index) = do +-- res <- select $ do +-- (tx :& txOut) <- +-- from +-- $ table @Tx +-- `innerJoin` table @C.TxOut +-- `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. C.TxOutTxId) +-- where_ (txOut ^. C.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) +-- pure (txOut ^. C.TxOutPaymentCred, txOut ^. C.TxOutAddressHasScript) +-- pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +-- queryTxOutCredentialsVariant :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +-- queryTxOutCredentialsVariant (hash, index) = do +-- res <- select $ do +-- (tx :& txOut :& address) <- +-- from +-- $ ( table @Tx +-- `innerJoin` table @V.TxOut +-- `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. V.TxOutTxId) +-- ) +-- `innerJoin` table @V.Address +-- `on` (\((_ :& txOut) :& address) -> txOut ^. V.TxOutAddressId ==. address ^. V.AddressId) +-- where_ (txOut ^. V.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) +-- pure (address ^. V.AddressPaymentCred, address ^. V.AddressHasScript) +-- pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) + +-- -- -------------------------------------------------------------------------------- +-- -- -- ADDRESS QUERIES +-- -- -------------------------------------------------------------------------------- +-- queryAddressId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe V.AddressId) +-- queryAddressId addrRaw = do +-- res <- select $ do +-- addr <- from $ table @V.Address +-- where_ (addr ^. V.AddressRaw ==. val addrRaw) +-- pure (addr ^. V.AddressId) +-- pure $ unValue <$> listToMaybe res + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryTotalSupply +-- -- -------------------------------------------------------------------------------- + +-- -- | Get the current total supply of Lovelace. This only returns the on-chain supply which +-- -- does not include staking rewards that have not yet been withdrawn. Before wihdrawal +-- -- rewards are part of the ledger state and hence not on chain. +-- queryTotalSupply :: +-- (MonadIO m) => +-- TxOutTableType -> +-- ReaderT SqlBackend m Ada +-- queryTotalSupply txOutTableType = +-- case txOutTableType of +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Ada +-- query = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- txOutUnspentP @a txOut +-- pure $ sum_ (txOut ^. txOutValueField @a) +-- pure $ unValueSumAda (listToMaybe res) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryGenesisSupply +-- -- -------------------------------------------------------------------------------- + +-- -- | Return the total Genesis coin supply. +-- queryGenesisSupply :: +-- (MonadIO m) => +-- TxOutTableType -> +-- ReaderT SqlBackend m Ada +-- queryGenesisSupply txOutTableType = +-- case txOutTableType of +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Ada +-- query = do +-- res <- select $ do +-- (_tx :& txOut :& blk) <- +-- from +-- $ table @Tx +-- `innerJoin` table @(TxOutTable a) +-- `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) +-- `innerJoin` table @Block +-- `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (isNothing $ blk ^. BlockPreviousId) +-- pure $ sum_ (txOut ^. txOutValueField @a) +-- pure $ unValueSumAda (listToMaybe res) + +-- -- A predicate that filters out spent 'TxOut' entries. +-- {-# INLINEABLE txOutUnspentP #-} +-- txOutUnspentP :: forall a. TxOutFields a => SqlExpr (Entity (TxOutTable a)) -> SqlQuery () +-- txOutUnspentP txOut = +-- where_ . notExists $ +-- from (table @TxIn) >>= \txIn -> +-- where_ +-- ( txOut +-- ^. txOutTxIdField @a +-- ==. txIn +-- ^. TxInTxOutId +-- &&. txOut +-- ^. txOutIndexField @a +-- ==. txIn +-- ^. TxInTxOutIndex +-- ) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryShelleyGenesisSupply +-- -- -------------------------------------------------------------------------------- + +-- -- | Return the total Shelley Genesis coin supply. The Shelley Genesis Block +-- -- is the unique which has a non-null PreviousId, but has null Epoch. +-- queryShelleyGenesisSupply :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m Ada +-- queryShelleyGenesisSupply txOutTableType = +-- case txOutTableType of +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Ada +-- query = do +-- res <- select $ do +-- (txOut :& _tx :& blk) <- +-- from +-- $ table @(TxOutTable a) +-- `innerJoin` table @Tx +-- `on` (\(txOut :& tx) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) +-- `innerJoin` table @Block +-- `on` (\(_txOut :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (isJust $ blk ^. BlockPreviousId) +-- where_ (isNothing $ blk ^. BlockEpochNo) +-- pure $ sum_ (txOut ^. txOutValueField @a) +-- pure $ unValueSumAda (listToMaybe res) + +-- -- -------------------------------------------------------------------------------- +-- -- -- Testing or validating. Queries below are not used in production +-- -- -------------------------------------------------------------------------------- + +-- -------------------------------------------------------------------------------- +-- -- queryUtxoAtBlockNo +-- -------------------------------------------------------------------------------- +-- queryUtxoAtBlockNo :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [UtxoQueryResult] +-- queryUtxoAtBlockNo txOutTableType blkNo = do +-- eblkId <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockBlockNo ==. just (val blkNo)) +-- pure (blk ^. BlockId) +-- maybe (pure []) (queryUtxoAtBlockId txOutTableType . unValue) (listToMaybe eblkId) + +-- -------------------------------------------------------------------------------- +-- -- queryUtxoAtSlotNo +-- -------------------------------------------------------------------------------- +-- queryUtxoAtSlotNo :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [UtxoQueryResult] +-- queryUtxoAtSlotNo txOutTableType slotNo = do +-- eblkId <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockSlotNo ==. just (val slotNo)) +-- pure (blk ^. BlockId) +-- maybe (pure []) (queryUtxoAtBlockId txOutTableType . unValue) (listToMaybe eblkId) + +-- -------------------------------------------------------------------------------- +-- -- queryUtxoAtBlockId +-- -------------------------------------------------------------------------------- +-- queryUtxoAtBlockId :: MonadIO m => TxOutTableType -> BlockId -> ReaderT SqlBackend m [UtxoQueryResult] +-- queryUtxoAtBlockId txOutTableType blkid = +-- case txOutTableType of +-- TxOutCore -> queryUtxoAtBlockIdCore blkid +-- TxOutVariantAddress -> queryUtxoAtBlockIdVariant blkid + +-- queryUtxoAtBlockIdCore :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQueryResult] +-- queryUtxoAtBlockIdCore blkid = do +-- outputs <- select $ do +-- (txout :& _txin :& _tx1 :& blk :& tx2) <- +-- from +-- $ table @C.TxOut +-- `leftJoin` table @TxIn +-- `on` ( \(txout :& txin) -> +-- (just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) +-- &&. (just (txout ^. C.TxOutIndex) ==. txin ?. TxInTxOutIndex) +-- ) +-- `leftJoin` table @Tx +-- `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) +-- `leftJoin` table @Block +-- `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) +-- `leftJoin` table @Tx +-- `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) + +-- where_ $ +-- (txout ^. C.TxOutTxId `in_` txLessEqual blkid) +-- &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) +-- pure (txout, txout ^. C.TxOutAddress, tx2 ?. TxHash) +-- pure $ mapMaybe convertCore outputs + +-- queryUtxoAtBlockIdVariant :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQueryResult] +-- queryUtxoAtBlockIdVariant blkid = do +-- outputs <- select $ do +-- (txout :& _txin :& _tx1 :& blk :& tx2 :& address) <- +-- from +-- $ table @V.TxOut +-- `leftJoin` table @TxIn +-- `on` ( \(txout :& txin) -> +-- (just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) +-- &&. (just (txout ^. V.TxOutIndex) ==. txin ?. TxInTxOutIndex) +-- ) +-- `leftJoin` table @Tx +-- `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) +-- `leftJoin` table @Block +-- `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) +-- `leftJoin` table @Tx +-- `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) +-- `innerJoin` table @V.Address +-- `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) + +-- where_ $ +-- (txout ^. V.TxOutTxId `in_` txLessEqual blkid) +-- &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) +-- pure (txout, address, tx2 ?. TxHash) +-- pure $ mapMaybe convertVariant outputs + +-- convertCore :: (Entity C.TxOut, Value Text, Value (Maybe ByteString)) -> Maybe UtxoQueryResult +-- convertCore (out, Value address, Value (Just hash')) = +-- Just $ +-- UtxoQueryResult +-- { utxoTxOutW = CTxOutW $ entityVal out +-- , utxoAddress = address +-- , utxoTxHash = hash' +-- } +-- convertCore _ = Nothing + +-- convertVariant :: (Entity V.TxOut, Entity V.Address, Value (Maybe ByteString)) -> Maybe UtxoQueryResult +-- convertVariant (out, address, Value (Just hash')) = +-- Just $ +-- UtxoQueryResult +-- { utxoTxOutW = VTxOutW (entityVal out) (Just (entityVal address)) +-- , utxoAddress = V.addressAddress $ entityVal address +-- , utxoTxHash = hash' +-- } +-- convertVariant _ = Nothing + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryAddressBalanceAtSlot +-- -- -------------------------------------------------------------------------------- +-- queryAddressBalanceAtSlot :: MonadIO m => TxOutTableType -> Text -> Word64 -> ReaderT SqlBackend m Ada +-- queryAddressBalanceAtSlot txOutTableType addr slotNo = do +-- eblkId <- select $ do +-- blk <- from (table @Block) +-- where_ (blk ^. BlockSlotNo ==. just (val slotNo)) +-- pure (blk ^. BlockId) +-- maybe (pure 0) (queryAddressBalanceAtBlockId . unValue) (listToMaybe eblkId) +-- where +-- queryAddressBalanceAtBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m Ada +-- queryAddressBalanceAtBlockId blkid = do +-- -- tx1 refers to the tx of the input spending this output (if it is ever spent) +-- -- tx2 refers to the tx of the output +-- case txOutTableType of +-- TxOutCore -> do +-- res <- select $ do +-- (txout :& _ :& _ :& blk :& _) <- +-- from +-- $ table @C.TxOut +-- `leftJoin` table @TxIn +-- `on` (\(txout :& txin) -> just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) +-- `leftJoin` table @Tx +-- `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) +-- `leftJoin` table @Block +-- `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) +-- `leftJoin` table @Tx +-- `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) +-- where_ $ +-- (txout ^. C.TxOutTxId `in_` txLessEqual blkid) +-- &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) +-- where_ (txout ^. C.TxOutAddress ==. val addr) +-- pure $ sum_ (txout ^. C.TxOutValue) +-- pure $ unValueSumAda (listToMaybe res) +-- TxOutVariantAddress -> do +-- res <- select $ do +-- (txout :& _ :& _ :& blk :& _ :& address) <- +-- from +-- $ table @V.TxOut +-- `leftJoin` table @TxIn +-- `on` (\(txout :& txin) -> just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) +-- `leftJoin` table @Tx +-- `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) +-- `leftJoin` table @Block +-- `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) +-- `leftJoin` table @Tx +-- `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) +-- `innerJoin` table @V.Address +-- `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) +-- where_ $ +-- (txout ^. V.TxOutTxId `in_` txLessEqual blkid) +-- &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) +-- where_ (address ^. V.AddressAddress ==. val addr) +-- pure $ sum_ (txout ^. V.TxOutValue) +-- pure $ unValueSumAda (listToMaybe res) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryScriptOutputs +-- -- -------------------------------------------------------------------------------- +-- queryScriptOutputs :: MonadIO m => TxOutTableType -> ReaderT SqlBackend m [TxOutW] +-- queryScriptOutputs txOutTableType = +-- case txOutTableType of +-- TxOutCore -> fmap (map CTxOutW) queryScriptOutputsCore +-- TxOutVariantAddress -> queryScriptOutputsVariant + +-- queryScriptOutputsCore :: MonadIO m => ReaderT SqlBackend m [C.TxOut] +-- queryScriptOutputsCore = do +-- res <- select $ do +-- tx_out <- from $ table @C.TxOut +-- where_ (tx_out ^. C.TxOutAddressHasScript ==. val True) +-- pure tx_out +-- pure $ entityVal <$> res + +-- queryScriptOutputsVariant :: MonadIO m => ReaderT SqlBackend m [TxOutW] +-- queryScriptOutputsVariant = do +-- res <- select $ do +-- address <- from $ table @V.Address +-- tx_out <- from $ table @V.TxOut +-- where_ (address ^. V.AddressHasScript ==. val True) +-- where_ (tx_out ^. V.TxOutAddressId ==. address ^. V.AddressId) +-- pure (tx_out, address) +-- pure $ map (uncurry combineToWrapper) res +-- where +-- combineToWrapper :: Entity V.TxOut -> Entity V.Address -> TxOutW +-- combineToWrapper txOut address = +-- VTxOutW (entityVal txOut) (Just (entityVal address)) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryAddressOutputs +-- -- -------------------------------------------------------------------------------- +-- queryAddressOutputs :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m DbLovelace +-- queryAddressOutputs txOutTableType addr = do +-- res <- case txOutTableType of +-- TxOutCore -> select $ do +-- txout <- from $ table @C.TxOut +-- where_ (txout ^. C.TxOutAddress ==. val addr) +-- pure $ sum_ (txout ^. C.TxOutValue) +-- TxOutVariantAddress -> select $ do +-- address <- from $ table @V.Address +-- txout <- from $ table @V.TxOut +-- where_ (address ^. V.AddressAddress ==. val addr) +-- where_ (txout ^. V.TxOutAddressId ==. address ^. V.AddressId) +-- pure $ sum_ (txout ^. V.TxOutValue) +-- pure $ convert (listToMaybe res) +-- where +-- convert v = case unValue <$> v of +-- Just (Just x) -> x +-- _otherwise -> DbLovelace 0 + +-- -- -------------------------------------------------------------------------------- +-- -- -- Helper Functions +-- -- -------------------------------------------------------------------------------- + +-- -- | Count the number of transaction outputs in the TxOut table. +-- queryTxOutCount :: +-- MonadIO m => +-- TxOutTableType -> +-- ReaderT SqlBackend m Word +-- queryTxOutCount txOutTableType = do +-- case txOutTableType of +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Word +-- query = do +-- res <- select $ from (table @(TxOutTable a)) >> pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryTxOutUnspentCount :: +-- MonadIO m => +-- TxOutTableType -> +-- ReaderT SqlBackend m Word64 +-- queryTxOutUnspentCount txOutTableType = +-- case txOutTableType of +-- TxOutCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutTableType) m. +-- (MonadIO m, TxOutFields a) => +-- ReaderT SqlBackend m Word64 +-- query = do +-- res <- select $ do +-- txOut <- from $ table @(TxOutTable a) +-- txOutUnspentP @a txOut +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) diff --git a/cardano-db/src/Cardano/Db/Operations/Types.hs b/cardano-db/src/Cardano/Db/Operations/Types.hs index 21d818870..33aadb7dd 100644 --- a/cardano-db/src/Cardano/Db/Operations/Types.hs +++ b/cardano-db/src/Cardano/Db/Operations/Types.hs @@ -8,208 +8,208 @@ module Cardano.Db.Operations.Types where -import Cardano.Db.Schema.BaseSchema -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.Db.Types (DbLovelace (..), DbWord64) -import Cardano.Prelude (ByteString, Text, Word64, mapMaybe) -import Data.Kind (Type) -import Database.Esqueleto.Experimental (PersistEntity (..)) -import Database.Persist.Sql (PersistField) - -data TxOutTableType = TxOutCore | TxOutVariantAddress - deriving (Eq, Show) - --------------------------------------------------------------------------------- --- TxOut --------------------------------------------------------------------------------- - --- | A wrapper for TxOut that allows us to handle both Core and Variant TxOuts -data TxOutW - = CTxOutW !C.TxOut - | VTxOutW !V.TxOut !(Maybe V.Address) - --- | A wrapper for TxOutId -data TxOutIdW - = CTxOutIdW !C.TxOutId - | VTxOutIdW !V.TxOutId - deriving (Show) - --- TxOut fields for a given TxOutTableType -class (PersistEntity (TxOutTable a), PersistField (TxOutIdFor a)) => TxOutFields (a :: TxOutTableType) where - type TxOutTable a :: Type - type TxOutIdFor a :: Type - txOutIdField :: EntityField (TxOutTable a) (TxOutIdFor a) - txOutTxIdField :: EntityField (TxOutTable a) TxId - txOutIndexField :: EntityField (TxOutTable a) Word64 - txOutValueField :: EntityField (TxOutTable a) DbLovelace - txOutDataHashField :: EntityField (TxOutTable a) (Maybe ByteString) - txOutInlineDatumIdField :: EntityField (TxOutTable a) (Maybe DatumId) - txOutReferenceScriptIdField :: EntityField (TxOutTable a) (Maybe ScriptId) - txOutConsumedByTxIdField :: EntityField (TxOutTable a) (Maybe TxId) - --- TxOutCore fields -instance TxOutFields 'TxOutCore where - type TxOutTable 'TxOutCore = C.TxOut - type TxOutIdFor 'TxOutCore = C.TxOutId - txOutTxIdField = C.TxOutTxId - txOutIndexField = C.TxOutIndex - txOutValueField = C.TxOutValue - txOutIdField = C.TxOutId - txOutDataHashField = C.TxOutDataHash - txOutInlineDatumIdField = C.TxOutInlineDatumId - txOutReferenceScriptIdField = C.TxOutReferenceScriptId - txOutConsumedByTxIdField = C.TxOutConsumedByTxId - --- TxOutVariantAddress fields -instance TxOutFields 'TxOutVariantAddress where - type TxOutTable 'TxOutVariantAddress = V.TxOut - type TxOutIdFor 'TxOutVariantAddress = V.TxOutId - txOutTxIdField = V.TxOutTxId - txOutIndexField = V.TxOutIndex - txOutValueField = V.TxOutValue - txOutIdField = V.TxOutId - txOutDataHashField = V.TxOutDataHash - txOutInlineDatumIdField = V.TxOutInlineDatumId - txOutReferenceScriptIdField = V.TxOutReferenceScriptId - txOutConsumedByTxIdField = V.TxOutConsumedByTxId - --------------------------------------------------------------------------------- --- Address --- related fields for TxOutVariantAddress only --------------------------------------------------------------------------------- -class AddressFields (a :: TxOutTableType) where - type AddressTable a :: Type - type AddressIdFor a :: Type - addressField :: EntityField (AddressTable a) Text - addressRawField :: EntityField (AddressTable a) ByteString - addressHasScriptField :: EntityField (AddressTable a) Bool - addressPaymentCredField :: EntityField (AddressTable a) (Maybe ByteString) - addressStakeAddressIdField :: EntityField (AddressTable a) (Maybe StakeAddressId) - addressIdField :: EntityField (AddressTable a) (AddressIdFor a) - --- TxOutVariant fields -instance AddressFields 'TxOutVariantAddress where - type AddressTable 'TxOutVariantAddress = V.Address - type AddressIdFor 'TxOutVariantAddress = V.AddressId - addressField = V.AddressAddress - addressRawField = V.AddressRaw - addressHasScriptField = V.AddressHasScript - addressPaymentCredField = V.AddressPaymentCred - addressStakeAddressIdField = V.AddressStakeAddressId - addressIdField = V.AddressId - --------------------------------------------------------------------------------- --- MaTxOut --------------------------------------------------------------------------------- - --- | A wrapper for MaTxOut -data MaTxOutW - = CMaTxOutW !C.MaTxOut - | VMaTxOutW !V.MaTxOut - deriving (Show) - --- | A wrapper for MaTxOutId -data MaTxOutIdW - = CMaTxOutIdW !C.MaTxOutId - | VMaTxOutIdW !V.MaTxOutId - deriving (Show) - --- MaTxOut fields for a given TxOutTableType -class (PersistEntity (MaTxOutTable a)) => MaTxOutFields (a :: TxOutTableType) where - type MaTxOutTable a :: Type - type MaTxOutIdFor a :: Type - maTxOutTxOutIdField :: EntityField (MaTxOutTable a) (TxOutIdFor a) - maTxOutIdentField :: EntityField (MaTxOutTable a) MultiAssetId - maTxOutQuantityField :: EntityField (MaTxOutTable a) DbWord64 - --- TxOutCore fields -instance MaTxOutFields 'TxOutCore where - type MaTxOutTable 'TxOutCore = C.MaTxOut - type MaTxOutIdFor 'TxOutCore = C.MaTxOutId - maTxOutTxOutIdField = C.MaTxOutTxOutId - maTxOutIdentField = C.MaTxOutIdent - maTxOutQuantityField = C.MaTxOutQuantity - --- TxOutVariantAddress fields -instance MaTxOutFields 'TxOutVariantAddress where - type MaTxOutTable 'TxOutVariantAddress = V.MaTxOut - type MaTxOutIdFor 'TxOutVariantAddress = V.MaTxOutId - maTxOutTxOutIdField = V.MaTxOutTxOutId - maTxOutIdentField = V.MaTxOutIdent - maTxOutQuantityField = V.MaTxOutQuantity - --- | UtxoQueryResult which has utxoAddress that can come from Core or Variant TxOut -data UtxoQueryResult = UtxoQueryResult - { utxoTxOutW :: TxOutW - , utxoAddress :: Text - , utxoTxHash :: ByteString - } - --------------------------------------------------------------------------------- --- CollateralTxOut fields for a given TxOutTableType --------------------------------------------------------------------------------- -data CollateralTxOutW - = CCollateralTxOutW !C.CollateralTxOut - | VCollateralTxOutW !V.CollateralTxOut - deriving (Show) - --- | A wrapper for TxOutId -data CollateralTxOutIdW - = CCollateralTxOutIdW !C.CollateralTxOutId - | VCollateralTxOutIdW !V.CollateralTxOutId - deriving (Show) - -class (PersistEntity (CollateralTxOutTable a)) => CollateralTxOutFields (a :: TxOutTableType) where - type CollateralTxOutTable a :: Type - type CollateralTxOutIdFor a :: Type - collateralTxOutIdField :: EntityField (CollateralTxOutTable a) (CollateralTxOutIdFor a) - collateralTxOutTxIdField :: EntityField (TxOutTable a) TxId - collateralTxOutIndexField :: EntityField (TxOutTable a) DbWord64 - collateralTxOutAddressField :: EntityField (TxOutTable a) Text - collateralTxOutAddressHasScriptField :: EntityField (TxOutTable a) Bool - --------------------------------------------------------------------------------- --- Helper functions --------------------------------------------------------------------------------- -extractCoreTxOut :: TxOutW -> C.TxOut -extractCoreTxOut (CTxOutW txOut) = txOut --- this will never error as we can only have either CoreTxOut or VariantTxOut -extractCoreTxOut (VTxOutW _ _) = error "Unexpected VTxOut in CoreTxOut list" - -extractVariantTxOut :: TxOutW -> V.TxOut -extractVariantTxOut (VTxOutW txOut _) = txOut --- this will never error as we can only have either CoreTxOut or VariantTxOut -extractVariantTxOut (CTxOutW _) = error "Unexpected CTxOut in VariantTxOut list" - -convertTxOutIdCore :: [TxOutIdW] -> [C.TxOutId] -convertTxOutIdCore = mapMaybe unwrapCore - where - unwrapCore (CTxOutIdW txOutid) = Just txOutid - unwrapCore _ = Nothing - -convertTxOutIdVariant :: [TxOutIdW] -> [V.TxOutId] -convertTxOutIdVariant = mapMaybe unwrapVariant - where - unwrapVariant (VTxOutIdW txOutid) = Just txOutid - unwrapVariant _ = Nothing - -convertMaTxOutIdCore :: [MaTxOutIdW] -> [C.MaTxOutId] -convertMaTxOutIdCore = mapMaybe unwrapCore - where - unwrapCore (CMaTxOutIdW maTxOutId) = Just maTxOutId - unwrapCore _ = Nothing - -convertMaTxOutIdVariant :: [MaTxOutIdW] -> [V.MaTxOutId] -convertMaTxOutIdVariant = mapMaybe unwrapVariant - where - unwrapVariant (VMaTxOutIdW maTxOutId) = Just maTxOutId - unwrapVariant _ = Nothing - -isTxOutCore :: TxOutTableType -> Bool -isTxOutCore TxOutCore = True -isTxOutCore TxOutVariantAddress = False - -isTxOutVariantAddress :: TxOutTableType -> Bool -isTxOutVariantAddress TxOutVariantAddress = True -isTxOutVariantAddress TxOutCore = False +-- import Cardano.Db.Schema.Core +-- import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +-- import qualified Cardano.Db.Schema.Variants.TxOutCore as C +-- import Cardano.Db.Types (DbLovelace (..), DbWord64) +-- import Cardano.Prelude (ByteString, Text, Word64, mapMaybe) +-- import Data.Kind (Type) +-- import Database.Esqueleto.Experimental (PersistEntity (..)) +-- import Database.Persist.Sql (PersistField) + +-- data TxOutTableType = TxOutCore | TxOutVariantAddress +-- deriving (Eq, Show) + +-- -------------------------------------------------------------------------------- +-- -- TxOut +-- -------------------------------------------------------------------------------- + +-- -- | A wrapper for TxOut that allows us to handle both Core and Variant TxOuts +-- data TxOutW +-- = CTxOutW !C.TxOut +-- | VTxOutW !V.TxOut !(Maybe V.Address) + +-- -- | A wrapper for TxOutId +-- data TxOutIdW +-- = CTxOutIdW !C.TxOutId +-- | VTxOutIdW !V.TxOutId +-- deriving (Show) + +-- -- TxOut fields for a given TxOutTableType +-- class (PersistEntity (TxOutTable a), PersistField (TxOutIdFor a)) => TxOutFields (a :: TxOutTableType) where +-- type TxOutTable a :: Type +-- type TxOutIdFor a :: Type +-- txOutIdField :: EntityField (TxOutTable a) (TxOutIdFor a) +-- txOutTxIdField :: EntityField (TxOutTable a) TxId +-- txOutIndexField :: EntityField (TxOutTable a) Word64 +-- txOutValueField :: EntityField (TxOutTable a) DbLovelace +-- txOutDataHashField :: EntityField (TxOutTable a) (Maybe ByteString) +-- txOutInlineDatumIdField :: EntityField (TxOutTable a) (Maybe DatumId) +-- txOutReferenceScriptIdField :: EntityField (TxOutTable a) (Maybe ScriptId) +-- txOutConsumedByTxIdField :: EntityField (TxOutTable a) (Maybe TxId) + +-- -- TxOutCore fields +-- instance TxOutFields 'TxOutCore where +-- type TxOutTable 'TxOutCore = C.TxOut +-- type TxOutIdFor 'TxOutCore = C.TxOutId +-- txOutTxIdField = C.TxOutTxId +-- txOutIndexField = C.TxOutIndex +-- txOutValueField = C.TxOutValue +-- txOutIdField = C.TxOutId +-- txOutDataHashField = C.TxOutDataHash +-- txOutInlineDatumIdField = C.TxOutInlineDatumId +-- txOutReferenceScriptIdField = C.TxOutReferenceScriptId +-- txOutConsumedByTxIdField = C.TxOutConsumedByTxId + +-- -- TxOutVariantAddress fields +-- instance TxOutFields 'TxOutVariantAddress where +-- type TxOutTable 'TxOutVariantAddress = V.TxOut +-- type TxOutIdFor 'TxOutVariantAddress = V.TxOutId +-- txOutTxIdField = V.TxOutTxId +-- txOutIndexField = V.TxOutIndex +-- txOutValueField = V.TxOutValue +-- txOutIdField = V.TxOutId +-- txOutDataHashField = V.TxOutDataHash +-- txOutInlineDatumIdField = V.TxOutInlineDatumId +-- txOutReferenceScriptIdField = V.TxOutReferenceScriptId +-- txOutConsumedByTxIdField = V.TxOutConsumedByTxId + +-- -------------------------------------------------------------------------------- +-- -- Address +-- -- related fields for TxOutVariantAddress only +-- -------------------------------------------------------------------------------- +-- class AddressFields (a :: TxOutTableType) where +-- type AddressTable a :: Type +-- type AddressIdFor a :: Type +-- addressField :: EntityField (AddressTable a) Text +-- addressRawField :: EntityField (AddressTable a) ByteString +-- addressHasScriptField :: EntityField (AddressTable a) Bool +-- addressPaymentCredField :: EntityField (AddressTable a) (Maybe ByteString) +-- addressStakeAddressIdField :: EntityField (AddressTable a) (Maybe StakeAddressId) +-- addressIdField :: EntityField (AddressTable a) (AddressIdFor a) + +-- -- TxOutVariant fields +-- instance AddressFields 'TxOutVariantAddress where +-- type AddressTable 'TxOutVariantAddress = V.Address +-- type AddressIdFor 'TxOutVariantAddress = V.AddressId +-- addressField = V.AddressAddress +-- addressRawField = V.AddressRaw +-- addressHasScriptField = V.AddressHasScript +-- addressPaymentCredField = V.AddressPaymentCred +-- addressStakeAddressIdField = V.AddressStakeAddressId +-- addressIdField = V.AddressId + +-- -------------------------------------------------------------------------------- +-- -- MaTxOut +-- -------------------------------------------------------------------------------- + +-- -- | A wrapper for MaTxOut +-- data MaTxOutW +-- = CMaTxOutW !C.MaTxOut +-- | VMaTxOutW !V.MaTxOut +-- deriving (Show) + +-- -- | A wrapper for MaTxOutId +-- data MaTxOutIdW +-- = CMaTxOutIdW !C.MaTxOutId +-- | VMaTxOutIdW !V.MaTxOutId +-- deriving (Show) + +-- -- MaTxOut fields for a given TxOutTableType +-- class (PersistEntity (MaTxOutTable a)) => MaTxOutFields (a :: TxOutTableType) where +-- type MaTxOutTable a :: Type +-- type MaTxOutIdFor a :: Type +-- maTxOutTxOutIdField :: EntityField (MaTxOutTable a) (TxOutIdFor a) +-- maTxOutIdentField :: EntityField (MaTxOutTable a) MultiAssetId +-- maTxOutQuantityField :: EntityField (MaTxOutTable a) DbWord64 + +-- -- TxOutCore fields +-- instance MaTxOutFields 'TxOutCore where +-- type MaTxOutTable 'TxOutCore = C.MaTxOut +-- type MaTxOutIdFor 'TxOutCore = C.MaTxOutId +-- maTxOutTxOutIdField = C.MaTxOutTxOutId +-- maTxOutIdentField = C.MaTxOutIdent +-- maTxOutQuantityField = C.MaTxOutQuantity + +-- -- TxOutVariantAddress fields +-- instance MaTxOutFields 'TxOutVariantAddress where +-- type MaTxOutTable 'TxOutVariantAddress = V.MaTxOut +-- type MaTxOutIdFor 'TxOutVariantAddress = V.MaTxOutId +-- maTxOutTxOutIdField = V.MaTxOutTxOutId +-- maTxOutIdentField = V.MaTxOutIdent +-- maTxOutQuantityField = V.MaTxOutQuantity + +-- -- | UtxoQueryResult which has utxoAddress that can come from Core or Variant TxOut +-- data UtxoQueryResult = UtxoQueryResult +-- { utxoTxOutW :: TxOutW +-- , utxoAddress :: Text +-- , utxoTxHash :: ByteString +-- } + +-- -------------------------------------------------------------------------------- +-- -- CollateralTxOut fields for a given TxOutTableType +-- -------------------------------------------------------------------------------- +-- data CollateralTxOutW +-- = CCollateralTxOutW !C.CollateralTxOut +-- | VCollateralTxOutW !V.CollateralTxOut +-- deriving (Show) + +-- -- | A wrapper for TxOutId +-- data CollateralTxOutIdW +-- = CCollateralTxOutIdW !C.CollateralTxOutId +-- | VCollateralTxOutIdW !V.CollateralTxOutId +-- deriving (Show) + +-- class (PersistEntity (CollateralTxOutTable a)) => CollateralTxOutFields (a :: TxOutTableType) where +-- type CollateralTxOutTable a :: Type +-- type CollateralTxOutIdFor a :: Type +-- collateralTxOutIdField :: EntityField (CollateralTxOutTable a) (CollateralTxOutIdFor a) +-- collateralTxOutTxIdField :: EntityField (TxOutTable a) TxId +-- collateralTxOutIndexField :: EntityField (TxOutTable a) DbWord64 +-- collateralTxOutAddressField :: EntityField (TxOutTable a) Text +-- collateralTxOutAddressHasScriptField :: EntityField (TxOutTable a) Bool + +-- -------------------------------------------------------------------------------- +-- -- Helper functions +-- -------------------------------------------------------------------------------- +-- extractCoreTxOut :: TxOutW -> C.TxOut +-- extractCoreTxOut (CTxOutW txOut) = txOut +-- -- this will never error as we can only have either CoreTxOut or VariantTxOut +-- extractCoreTxOut (VTxOutW _ _) = error "Unexpected VTxOut in CoreTxOut list" + +-- extractVariantTxOut :: TxOutW -> V.TxOut +-- extractVariantTxOut (VTxOutW txOut _) = txOut +-- -- this will never error as we can only have either CoreTxOut or VariantTxOut +-- extractVariantTxOut (CTxOutW _) = error "Unexpected CTxOut in VariantTxOut list" + +-- convertTxOutIdCore :: [TxOutIdW] -> [C.TxOutId] +-- convertTxOutIdCore = mapMaybe unwrapCore +-- where +-- unwrapCore (CTxOutIdW txOutid) = Just txOutid +-- unwrapCore _ = Nothing + +-- convertTxOutIdVariant :: [TxOutIdW] -> [V.TxOutId] +-- convertTxOutIdVariant = mapMaybe unwrapVariant +-- where +-- unwrapVariant (VTxOutIdW txOutid) = Just txOutid +-- unwrapVariant _ = Nothing + +-- convertMaTxOutIdCore :: [MaTxOutIdW] -> [C.MaTxOutId] +-- convertMaTxOutIdCore = mapMaybe unwrapCore +-- where +-- unwrapCore (CMaTxOutIdW maTxOutId) = Just maTxOutId +-- unwrapCore _ = Nothing + +-- convertMaTxOutIdVariant :: [MaTxOutIdW] -> [V.MaTxOutId] +-- convertMaTxOutIdVariant = mapMaybe unwrapVariant +-- where +-- unwrapVariant (VMaTxOutIdW maTxOutId) = Just maTxOutId +-- unwrapVariant _ = Nothing + +-- isTxOutCore :: TxOutTableType -> Bool +-- isTxOutCore TxOutCore = True +-- isTxOutCore TxOutVariantAddress = False + +-- isTxOutVariantAddress :: TxOutTableType -> Bool +-- isTxOutVariantAddress TxOutVariantAddress = True +-- isTxOutVariantAddress TxOutCore = False diff --git a/cardano-db/src/Cardano/Db/PGConfig.hs b/cardano-db/src/Cardano/Db/PGConfig.hs index eb1052375..8ae2f715c 100644 --- a/cardano-db/src/Cardano/Db/PGConfig.hs +++ b/cardano-db/src/Cardano/Db/PGConfig.hs @@ -13,15 +13,21 @@ module Cardano.Db.PGConfig ( readPGPassFileEnv, readPGPassFile, readPGPassFileExit, - toConnectionString, + toConnectionSetting, ) where +import Cardano.Prelude (decodeUtf8) import Control.Exception (IOException) import qualified Control.Exception as Exception +import Control.Monad.Extra (unless) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.Text as Text -import Database.Persist.Postgresql (ConnectionString) +import qualified Data.Text.Read as Text (decimal) +import Data.Word (Word16) +import qualified Hasql.Connection.Setting as HsqlSet +import qualified Hasql.Connection.Setting.Connection as HsqlSetC +import qualified Hasql.Connection.Setting.Connection.Param as HsqlSetP import System.Environment (lookupEnv, setEnv) import System.Posix.User (getEffectiveUserName) @@ -31,38 +37,50 @@ data PGPassSource | PGPassCached PGConfig deriving (Show) --- | PGConfig as specified by https://www.postgresql.org/docs/11/libpq-pgpass.html --- However, this module expects the config data to be on the first line. +-- | Preconstructed connection string according to . data PGConfig = PGConfig - { pgcHost :: ByteString - , pgcPort :: ByteString - , pgcDbname :: ByteString - , pgcUser :: ByteString - , pgcPassword :: ByteString + { pgcHost :: Text.Text + , pgcPort :: Text.Text + , pgcDbname :: Text.Text + , pgcUser :: Text.Text + , pgcPassword :: Text.Text } deriving (Show) newtype PGPassFile = PGPassFile FilePath -toConnectionString :: PGConfig -> ConnectionString -toConnectionString pgc = - BS.concat - [ "host=" - , pgcHost pgc - , " " - , "port=" - , pgcPort pgc - , " " - , "user=" - , pgcUser pgc - , " " - , "dbname=" - , pgcDbname pgc - , " " - , "password=" - , pgcPassword pgc - ] +-- | Convert PGConfig to Hasql connection settings, or return an error message. +toConnectionSetting :: PGConfig -> Either String HsqlSet.Setting +toConnectionSetting pgc = do + -- Convert the port from Text to Word16 + portWord16 <- textToWord16 (pgcPort pgc) + -- Build the connection settings + pure $ HsqlSet.connection (HsqlSetC.params [host, port portWord16, user, dbname, password]) + where + host = HsqlSetP.host (pgcHost pgc) + port = HsqlSetP.port + user = HsqlSetP.user (pgcUser pgc) + dbname = HsqlSetP.dbname (pgcDbname pgc) + password = HsqlSetP.password (pgcPassword pgc) + +-- | Convert a Text port to Word16, or return an error message. +textToWord16 :: Text.Text -> Either String Word16 +textToWord16 portText = + case Text.decimal portText of + Left err -> + Left $ "Invalid port: '" <> Text.unpack portText <> "'. " <> err + Right (portInt, remainder) -> do + -- Check for leftover characters (e.g., "123abc" is invalid) + unless (Text.null remainder) $ + Left $ + "Invalid port: '" <> Text.unpack portText <> "'. Contains non-numeric characters." + -- Check if the port is within the valid Word16 range (0-65535) + unless (portInt >= (0 :: Integer) && portInt <= 65535) $ + Left $ + "Invalid port: '" <> Text.unpack portText <> "'. Port must be between 0 and 65535." + -- Convert to Word16 + Right (fromIntegral portInt) readPGPassDefault :: IO (Either PGPassError PGConfig) readPGPassDefault = readPGPass PGPassDefaultEnv @@ -94,24 +112,32 @@ readPGPassFile (PGPassFile fpath) = do extract bs = case BS.lines bs of (b : _) -> parsePGConfig b - _ -> pure $ Left (FailedToParsePGPassConfig bs) + _otherwise -> pure $ Left (FailedToParsePGPassConfig bs) parsePGConfig :: ByteString -> IO (Either PGPassError PGConfig) parsePGConfig bs = case BS.split ':' bs of - [h, pt, d, u, pwd] -> replaceUser (PGConfig h pt d u pwd) - _ -> pure $ Left (FailedToParsePGPassConfig bs) + [h, pt, d, u, pwd] -> + replaceUser + ( PGConfig + (decodeUtf8 h) + (decodeUtf8 pt) + (decodeUtf8 d) + (decodeUtf8 u) + (decodeUtf8 pwd) + ) + _otherwise -> pure $ Left (FailedToParsePGPassConfig bs) where replaceUser :: PGConfig -> IO (Either PGPassError PGConfig) replaceUser pgc - | pgcUser pgc /= "*" = pure $ Right pgc + | pgcUser pgc /= Text.pack "*" = pure $ Right pgc | otherwise = do euser <- Exception.try getEffectiveUserName case euser of Left (err :: IOException) -> pure $ Left (UserFailed err) Right user -> - pure $ Right (pgc {pgcUser = BS.pack user}) + pure $ Right (pgc {pgcUser = Text.pack user}) -- | Read 'PGPassFile' into 'PGConfig'. -- If it fails it will raise an error. diff --git a/cardano-db/src/Cardano/Db/Run.hs b/cardano-db/src/Cardano/Db/Run.hs index 0aabb07d0..a81714871 100644 --- a/cardano-db/src/Cardano/Db/Run.hs +++ b/cardano-db/src/Cardano/Db/Run.hs @@ -2,19 +2,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Cardano.Db.Run ( - getBackendGhci, - ghciDebugQuery, runDbHandleLogger, runDbIohkLogging, runDbIohkNoLogging, runDbNoLogging, runDbNoLoggingEnv, - runDbStdoutLogging, runIohkLogging, - transactionCommit, - runWithConnectionLogging, runWithConnectionNoLogging, -- * Connection Pool variants @@ -29,8 +26,7 @@ import Cardano.BM.Data.LogItem ( ) import Cardano.BM.Data.Severity (Severity (..)) import Cardano.BM.Trace (Trace) -import Cardano.Db.Error (runOrThrowIODb) -import Cardano.Db.PGConfig +import Cardano.Prelude (ReaderT (..), bracket, lift, runExceptT, throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger ( LogLevel (..), @@ -38,95 +34,115 @@ import Control.Monad.Logger ( LoggingT, NoLoggingT, defaultLogStr, - defaultOutput, runLoggingT, runNoLoggingT, - runStdoutLoggingT, ) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Resource (MonadUnliftIO) import Control.Tracer (traceWith) import qualified Data.ByteString.Char8 as BS -import Data.Pool (Pool) +import Data.Pool (Pool, withResource) import Data.Text (Text) import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy.Builder as LazyText -import qualified Data.Text.Lazy.IO as LazyText -import Database.Esqueleto.Experimental (SqlQuery) -import Database.Esqueleto.Internal.Internal ( - Mode (SELECT), - SqlSelect, - initialIdentState, - toRawSql, - ) -import Database.Persist.Postgresql ( - ConnectionString, - SqlBackend, - openSimpleConn, - withPostgresqlConn, - ) -import Database.Persist.Sql ( - IsolationLevel (..), - runSqlConnWithIsolation, - runSqlPoolWithIsolation, - transactionSaveWithIsolation, - ) -import Database.PostgreSQL.Simple (connectPostgreSQL) +import qualified Hasql.Connection as HsqlCon +import qualified Hasql.Connection.Setting as HsqlConS import Language.Haskell.TH.Syntax (Loc) -import System.IO (Handle, stdout) +import System.IO (Handle) import System.Log.FastLogger (LogStr, fromLogStr) +import Cardano.Db.Error (DbError, runOrThrowIO) +import qualified Cardano.Db.PGConfig as PGC +import qualified Cardano.Db.Types as DB + -- | Run a DB action logging via the provided Handle. -runDbHandleLogger :: Handle -> PGPassSource -> ReaderT SqlBackend (LoggingT IO) a -> IO a -runDbHandleLogger logHandle source dbAction = do - pgconfig <- runOrThrowIODb (readPGPass source) - runHandleLoggerT - . withPostgresqlConn (toConnectionString pgconfig) - $ \backend -> - -- The 'runSqlConnWithIsolation' function starts a transaction, runs the 'dbAction' - -- and then commits the transaction. - runSqlConnWithIsolation dbAction backend Serializable +runDbHandleLogger :: Handle -> PGC.PGPassSource -> DB.DbAction (LoggingT IO) a -> IO a +runDbHandleLogger logHandle source action = do + pgconfig <- runOrThrowIO (PGC.readPGPass source) + connSetting <- case PGC.toConnectionSetting pgconfig of + Left err -> throwIO $ userError err + Right setting -> pure setting + + bracket + (acquireConnection [connSetting]) + HsqlCon.release + ( \connection -> do + let dbEnv = DB.DbEnv connection True Nothing -- No tracer needed + runHandleLoggerT $ + runReaderT (runExceptT (DB.runDbAction action)) dbEnv >>= \case + Left err -> liftIO $ throwIO err + Right result -> pure result + ) where runHandleLoggerT :: LoggingT m a -> m a - runHandleLoggerT action = - runLoggingT action logOut + runHandleLoggerT actn = + runLoggingT actn logOut logOut :: Loc -> LogSource -> LogLevel -> LogStr -> IO () logOut loc src level msg = BS.hPutStrLn logHandle . fromLogStr $ defaultLogStr loc src level msg -runWithConnectionLogging :: - ConnectionString -> Trace IO Text -> ReaderT SqlBackend (LoggingT IO) a -> IO a -runWithConnectionLogging dbConnString tracer dbAction = do - runIohkLogging tracer - . withPostgresqlConn dbConnString - $ \backend -> - runSqlConnWithIsolation dbAction backend Serializable - runWithConnectionNoLogging :: - PGPassSource -> ReaderT SqlBackend (NoLoggingT IO) a -> IO a -runWithConnectionNoLogging source dbAction = do - pgconfig <- runOrThrowIODb (readPGPass source) - runNoLoggingT - . withPostgresqlConn (toConnectionString pgconfig) - $ \backend -> - runSqlConnWithIsolation dbAction backend Serializable + PGC.PGPassSource -> DB.DbAction (NoLoggingT IO) a -> IO a +runWithConnectionNoLogging source action = do + pgConfig <- runOrThrowIO (PGC.readPGPass source) + connSetting <- case PGC.toConnectionSetting pgConfig of + Left err -> throwIO $ userError err + Right setting -> pure setting + + bracket + (acquireConnection [connSetting]) + HsqlCon.release + ( \connection -> do + let dbEnv = DB.DbEnv connection False Nothing + runNoLoggingT $ + runReaderT (runExceptT (DB.runDbAction action)) dbEnv >>= \case + Left err -> liftIO $ throwIO err + Right result -> pure result + ) -- | Run a DB action logging via iohk-monitoring-framework. -runDbIohkLogging :: MonadUnliftIO m => SqlBackend -> Trace IO Text -> ReaderT SqlBackend (LoggingT m) b -> m b -runDbIohkLogging backend tracer dbAction = do - runIohkLogging tracer $ runSqlConnWithIsolation dbAction backend Serializable - --- | Run a DB action using a Pool via iohk-monitoring-framework. -runPoolDbIohkLogging :: MonadUnliftIO m => Pool SqlBackend -> Trace IO Text -> ReaderT SqlBackend (LoggingT m) b -> m b -runPoolDbIohkLogging backend tracer dbAction = do - runIohkLogging tracer $ runSqlPoolWithIsolation dbAction backend Serializable - --- | Run a DB action logging via iohk-monitoring-framework. -runDbIohkNoLogging :: MonadUnliftIO m => SqlBackend -> ReaderT SqlBackend (NoLoggingT m) a -> m a -runDbIohkNoLogging backend action = do - runNoLoggingT $ runSqlConnWithIsolation action backend Serializable +runDbIohkLogging :: + MonadUnliftIO m => + Trace IO Text -> + DB.DbEnv -> + DB.DbAction m a -> + m (Either DbError a) +runDbIohkLogging tracer dbEnv action = + runIohkLogging tracer $ + lift $ + runReaderT (runExceptT (DB.runDbAction action)) dbEnv + +-- | Run a DB action using a Pool with iohk-monitoring-framework logging. +-- This function now expects a Pool of Hasql.Connection instead of SqlBackend +runPoolDbIohkLogging :: + MonadIO m => + Pool HsqlCon.Connection -> + Trace IO Text -> + DB.DbAction (LoggingT m) a -> + m a +runPoolDbIohkLogging connPool tracer action = do + -- Use withResource from Data.Pool which works with MonadIO + conn <- liftIO $ withResource connPool pure + + let dbEnv = DB.DbEnv conn True (Just tracer) + result <- + runIohkLogging tracer $ + runReaderT (runExceptT (DB.runDbAction action)) dbEnv + case result of + Left err -> liftIO $ throwIO err + Right val -> pure val + +-- | Run a DB action with no logging. +runDbIohkNoLogging :: + MonadIO m => + HsqlCon.Connection -> + DB.DbAction (NoLoggingT m) a -> + m a +runDbIohkNoLogging conn action = do + let dbEnv = DB.DbEnv conn False Nothing + result <- runNoLoggingT $ runReaderT (runExceptT (DB.runDbAction action)) dbEnv + case result of + Left err -> liftIO $ throwIO err + Right val -> pure val runIohkLogging :: Trace IO Text -> LoggingT m a -> m a runIohkLogging tracer action = @@ -153,48 +169,35 @@ runIohkLogging tracer action = -- | Run a DB action without any logging, mainly for tests. runDbNoLoggingEnv :: - (MonadBaseControl IO m, MonadUnliftIO m) => - ReaderT SqlBackend (NoLoggingT m) a -> + MonadIO m => + DB.DbAction m a -> m a -runDbNoLoggingEnv = runDbNoLogging PGPassDefaultEnv +runDbNoLoggingEnv = runDbNoLogging PGC.PGPassDefaultEnv runDbNoLogging :: - (MonadBaseControl IO m, MonadUnliftIO m) => - PGPassSource -> - ReaderT SqlBackend (NoLoggingT m) a -> + MonadIO m => + PGC.PGPassSource -> + DB.DbAction m a -> m a runDbNoLogging source action = do - pgconfig <- liftIO $ runOrThrowIODb (readPGPass source) - runNoLoggingT - . withPostgresqlConn (toConnectionString pgconfig) - $ \backend -> - runSqlConnWithIsolation action backend Serializable - --- | Run a DB action with stdout logging. Mainly for debugging. -runDbStdoutLogging :: PGPassSource -> ReaderT SqlBackend (LoggingT IO) b -> IO b -runDbStdoutLogging source action = do - pgconfig <- runOrThrowIODb (readPGPass source) - runStdoutLoggingT - . withPostgresqlConn (toConnectionString pgconfig) - $ \backend -> - runSqlConnWithIsolation action backend Serializable - -getBackendGhci :: IO SqlBackend -getBackendGhci = do - pgconfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) - connection <- connectPostgreSQL (toConnectionString pgconfig) - openSimpleConn (defaultOutput stdout) connection - -ghciDebugQuery :: SqlSelect a r => SqlQuery a -> IO () -ghciDebugQuery query = do - pgconfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) - runStdoutLoggingT - . withPostgresqlConn (toConnectionString pgconfig) - $ \backend -> do - let (sql, params) = toRawSql SELECT (backend, initialIdentState) query - liftIO $ do - LazyText.putStr $ LazyText.toLazyText sql - print params - -transactionCommit :: MonadIO m => ReaderT SqlBackend m () -transactionCommit = transactionSaveWithIsolation Serializable + pgconfig <- liftIO $ runOrThrowIO (PGC.readPGPass source) + connSetting <- liftIO $ case PGC.toConnectionSetting pgconfig of + Left err -> error err -- or use a more appropriate error handling + Right setting -> pure setting + + connection <- liftIO $ acquireConnection [connSetting] + let dbEnv = DB.DbEnv connection False Nothing + + result <- runReaderT (runExceptT (DB.runDbAction action)) dbEnv + liftIO $ HsqlCon.release connection + + case result of + Left err -> error (show err) -- or use a more appropriate error handling + Right val -> pure val + +acquireConnection :: MonadIO m => [HsqlConS.Setting] -> m HsqlCon.Connection +acquireConnection settings = liftIO $ do + result <- HsqlCon.acquire settings + case result of + Left err -> throwIO $ userError $ "Connection error: " <> show err + Right conn -> pure conn diff --git a/cardano-db/src/Cardano/Db/Schema/BaseSchema.hs b/cardano-db/src/Cardano/Db/Schema/BaseSchema.hs deleted file mode 100644 index 51b939650..000000000 --- a/cardano-db/src/Cardano/Db/Schema/BaseSchema.hs +++ /dev/null @@ -1,1432 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Cardano.Db.Schema.BaseSchema where - -import Cardano.Db.Schema.Orphans () -import Cardano.Db.Schema.Types ( - PoolUrl, - ) -import Cardano.Db.Types ( - AnchorType, - DbInt65, - DbLovelace, - DbWord64, - GovActionType, - RewardSource, - ScriptPurpose, - ScriptType, - SyncState, - Vote, - VoteUrl, - VoterRole, - ) -import Data.ByteString.Char8 (ByteString) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.WideWord.Word128 (Word128) -import Data.Word (Word16, Word64) -import Database.Persist.Class (Unique) -import Database.Persist.Documentation (deriveShowFields, document, (#), (--^)) -import Database.Persist.EntityDef.Internal (EntityDef (..)) - --- Do not use explicit imports from this module as the imports can change --- from version to version due to changes to the TH code in Persistent. -import Database.Persist.TH - --- In the schema definition we need to match Haskell types with with the --- custom type defined in PostgreSQL (via 'DOMAIN' statements). For the --- time being the Haskell types will be simple Haskell types like --- 'ByteString' and 'Word64'. - --- We use camelCase here in the Haskell schema definition and 'persistLowerCase' --- specifies that all the table and column names are converted to lower snake case. - -share - [ mkPersist sqlSettings - , mkMigrate "migrateBaseCardanoDb" - , mkEntityDefList "entityDefs" - , deriveShowFields - ] - [persistLowerCase| - - -- Schema versioning has three stages to best allow handling of schema migrations. - -- Stage 1: Set up PostgreSQL data types (using SQL 'DOMAIN' statements). - -- Stage 2: Persistent generated migrations. - -- Stage 3: Set up 'VIEW' tables (for use by other languages and applications). - -- This table should have a single row. - SchemaVersion - stageOne Int - stageTwo Int - stageThree Int - deriving Eq - - PoolHash - hashRaw ByteString sqltype=hash28type - view Text - UniquePoolHash hashRaw - - SlotLeader - hash ByteString sqltype=hash28type - poolHashId PoolHashId Maybe noreference -- This will be non-null when a block is mined by a pool. - description Text -- Description of the Slots leader. - UniqueSlotLeader hash - - -- Each table has autogenerated primary key named 'id', the Haskell type - -- of which is (for instance for this table) 'BlockId'. This specific - -- primary key Haskell type can be used in a type-safe way in the rest - -- of the schema definition. - -- All NULL-able fields other than 'epochNo' are NULL for EBBs, whereas 'epochNo' is - -- only NULL for the genesis block. - Block - hash ByteString sqltype=hash32type - epochNo Word64 Maybe sqltype=word31type - slotNo Word64 Maybe sqltype=word63type - epochSlotNo Word64 Maybe sqltype=word31type - blockNo Word64 Maybe sqltype=word31type - previousId BlockId Maybe noreference - slotLeaderId SlotLeaderId noreference - size Word64 sqltype=word31type - time UTCTime sqltype=timestamp - txCount Word64 - protoMajor Word16 sqltype=word31type - protoMinor Word16 sqltype=word31type - -- Shelley specific - vrfKey Text Maybe - opCert ByteString Maybe sqltype=hash32type - opCertCounter Word64 Maybe sqltype=word63type - UniqueBlock hash - - Tx - hash ByteString sqltype=hash32type - blockId BlockId noreference -- This type is the primary key for the 'block' table. - blockIndex Word64 sqltype=word31type -- The index of this transaction within the block. - outSum DbLovelace sqltype=lovelace - fee DbLovelace sqltype=lovelace - deposit Int64 Maybe -- Needs to allow negaitve values. - size Word64 sqltype=word31type - - -- New for Allega - invalidBefore DbWord64 Maybe sqltype=word64type - invalidHereafter DbWord64 Maybe sqltype=word64type - - -- New for Alonzo - validContract Bool -- False if the contract is invalid, True otherwise. - scriptSize Word64 sqltype=word31type - UniqueTx hash - - -- New for Conway - treasuryDonation DbLovelace sqltype=lovelace default=0 - - TxCbor - txId TxId noreference - bytes ByteString sqltype=bytea - - ReverseIndex - blockId BlockId noreference - minIds Text - - StakeAddress -- Can be an address of a script hash - hashRaw ByteString sqltype=addr29type - view Text - scriptHash ByteString Maybe sqltype=hash28type - UniqueStakeAddress hashRaw - - TxIn - txInId TxId noreference -- The transaction where this is used as an input. - txOutId TxId noreference -- The transaction where this was created as an output. - txOutIndex Word64 sqltype=txindex - redeemerId RedeemerId Maybe noreference - deriving Show - - CollateralTxIn - txInId TxId noreference -- The transaction where this is used as an input. - txOutId TxId noreference -- The transaction where this was created as an output. - txOutIndex Word64 sqltype=txindex - - ReferenceTxIn - txInId TxId noreference -- The transaction where this is used as an input. - txOutId TxId noreference -- The transaction where this was created as an output. - txOutIndex Word64 sqltype=txindex - - -- A table containing metadata about the chain. There will probably only ever be one - -- row in this table. - Meta - startTime UTCTime sqltype=timestamp - networkName Text - version Text - UniqueMeta startTime - - -- The Epoch table is an aggregation of data in the 'Block' table, but is kept in this form - -- because having it as a 'VIEW' is incredibly slow and inefficient. - - -- The 'outsum' type in the PostgreSQL world is 'bigint >= 0' so it will error out if an - -- overflow (sum of tx outputs in an epoch) is detected. 'maxBound :: Int` is big enough to - -- hold 204 times the total Lovelace distribution. The chance of that much being transacted - -- in a single epoch is relatively low. - Epoch - outSum Word128 sqltype=word128type - fees DbLovelace sqltype=lovelace - txCount Word64 sqltype=word31type - blkCount Word64 sqltype=word31type - no Word64 sqltype=word31type - startTime UTCTime sqltype=timestamp - endTime UTCTime sqltype=timestamp - UniqueEpoch no - deriving Eq Show - - -- A table with all the different types of total balances. - -- This is only populated for the Shelley and later eras, and only on epoch boundaries. - -- The treasury and rewards fields will be correct for the whole epoch, but all other - -- fields change block by block. - AdaPots - slotNo Word64 sqltype=word63type - epochNo Word64 sqltype=word31type - treasury DbLovelace sqltype=lovelace - reserves DbLovelace sqltype=lovelace - rewards DbLovelace sqltype=lovelace - utxo DbLovelace sqltype=lovelace - depositsStake DbLovelace sqltype=lovelace - depositsDrep DbLovelace sqltype=lovelace - depositsProposal DbLovelace sqltype=lovelace - fees DbLovelace sqltype=lovelace - blockId BlockId noreference - deriving Eq - - PoolMetadataRef - poolId PoolHashId noreference - url PoolUrl sqltype=varchar - hash ByteString sqltype=hash32type - registeredTxId TxId noreference -- Only used for rollback. - - PoolUpdate - hashId PoolHashId noreference - certIndex Word16 - vrfKeyHash ByteString sqltype=hash32type - pledge DbLovelace sqltype=lovelace - rewardAddrId StakeAddressId noreference - activeEpochNo Word64 - metaId PoolMetadataRefId Maybe noreference - margin Double -- sqltype=percentage???? - fixedCost DbLovelace sqltype=lovelace - deposit DbLovelace Maybe sqltype=lovelace - registeredTxId TxId noreference -- Slot number in which the pool was registered. - - -- A Pool can have more than one owner, so we have a PoolOwner table. - PoolOwner - addrId StakeAddressId noreference - poolUpdateId PoolUpdateId noreference - - PoolRetire - hashId PoolHashId noreference - certIndex Word16 - announcedTxId TxId noreference -- Slot number in which the pool announced it was retiring. - retiringEpoch Word64 sqltype=word31type -- Epoch number in which the pool will retire. - - PoolRelay - updateId PoolUpdateId noreference - ipv4 Text Maybe - ipv6 Text Maybe - dnsName Text Maybe - dnsSrvName Text Maybe - port Word16 Maybe - - StakeRegistration - addrId StakeAddressId noreference - certIndex Word16 - epochNo Word64 sqltype=word31type - deposit DbLovelace Maybe sqltype=lovelace - txId TxId noreference - - -- When was a staking key/script deregistered - StakeDeregistration - addrId StakeAddressId noreference - certIndex Word16 - epochNo Word64 sqltype=word31type - txId TxId noreference - redeemerId RedeemerId Maybe noreference - - Delegation - addrId StakeAddressId noreference - certIndex Word16 - poolHashId PoolHashId noreference - activeEpochNo Word64 - txId TxId noreference - slotNo Word64 sqltype=word63type - redeemerId RedeemerId Maybe noreference - - TxMetadata - key DbWord64 sqltype=word64type - json Text Maybe sqltype=jsonb - bytes ByteString sqltype=bytea - txId TxId noreference - - -- ----------------------------------------------------------------------------------------------- - -- Reward, Stake and Treasury need to be obtained from the ledger state. - - -- The reward for each stake address and. This is not a balance, but a reward amount and the - -- epoch in which the reward was earned. - -- This table should never get rolled back. - Reward - addrId StakeAddressId noreference - type RewardSource sqltype=rewardtype - amount DbLovelace sqltype=lovelace - earnedEpoch Word64 generated="((CASE WHEN (type='refund') then spendable_epoch else (CASE WHEN spendable_epoch >= 2 then spendable_epoch-2 else 0 end) end) STORED)" - spendableEpoch Word64 - poolId PoolHashId noreference - -- Here used to lie a unique constraint which would slow down inserts when in syncing mode - -- Now the constraint is set manually inside of `applyAndInsertBlockMaybe` once the tip of - -- the chain has been reached. - deriving Show - - RewardRest - addrId StakeAddressId noreference - type RewardSource sqltype=rewardtype - amount DbLovelace sqltype=lovelace - earnedEpoch Word64 generated="(CASE WHEN spendable_epoch >= 1 then spendable_epoch-1 else 0 end)" - spendableEpoch Word64 - deriving Show - - Withdrawal - addrId StakeAddressId noreference - amount DbLovelace sqltype=lovelace - redeemerId RedeemerId Maybe noreference - txId TxId noreference - - -- This table should never get rolled back. - EpochStake - addrId StakeAddressId noreference - poolId PoolHashId noreference - amount DbLovelace sqltype=lovelace - epochNo Word64 sqltype=word31type - -- similar scenario as in Reward the constraint that was here is now set manually in - -- `applyAndInsertBlockMaybe` at a more optimal time. - - EpochStakeProgress - epochNo Word64 sqltype=word31type - completed Bool - UniqueEpochStakeProgress epochNo - - Treasury - addrId StakeAddressId noreference - certIndex Word16 - amount DbInt65 sqltype=int65type - txId TxId noreference - - Reserve - addrId StakeAddressId noreference - certIndex Word16 - amount DbInt65 sqltype=int65type - txId TxId noreference - - PotTransfer - certIndex Word16 - treasury DbInt65 sqltype=int65type - reserves DbInt65 sqltype=int65type - txId TxId noreference - - EpochSyncTime - no Word64 - seconds Word64 sqltype=word63type - state SyncState sqltype=syncstatetype - UniqueEpochSyncTime no - - -- ----------------------------------------------------------------------------------------------- - -- Multi Asset related tables. - - MultiAsset - policy ByteString sqltype=hash28type - name ByteString sqltype=asset32type - fingerprint Text - UniqueMultiAsset policy name - - MaTxMint - ident MultiAssetId noreference - quantity DbInt65 sqltype=int65type - txId TxId noreference - - -- Unit step is in picosends, and `maxBound :: Int64` picoseconds is over 100 days, so using - -- Word64/word63type is safe here. Similarly, `maxBound :: Int64` if unit step would be an - -- *enormous* amount a memory which would cost a fortune. - Redeemer - txId TxId noreference - unitMem Word64 sqltype=word63type - unitSteps Word64 sqltype=word63type - fee DbLovelace Maybe sqltype=lovelace - purpose ScriptPurpose sqltype=scriptpurposetype - index Word64 sqltype=word31type - scriptHash ByteString Maybe sqltype=hash28type - redeemerDataId RedeemerDataId noreference - - Script - txId TxId noreference - hash ByteString sqltype=hash28type - type ScriptType sqltype=scripttype - json Text Maybe sqltype=jsonb - bytes ByteString Maybe sqltype=bytea - serialisedSize Word64 Maybe sqltype=word31type - UniqueScript hash - - Datum - hash ByteString sqltype=hash32type - txId TxId noreference - value Text Maybe sqltype=jsonb - bytes ByteString sqltype=bytea - UniqueDatum hash - - RedeemerData - hash ByteString sqltype=hash32type - txId TxId noreference - value Text Maybe sqltype=jsonb - bytes ByteString sqltype=bytea - UniqueRedeemerData hash - - ExtraKeyWitness - hash ByteString sqltype=hash28type - txId TxId noreference - - ParamProposal - epochNo Word64 Maybe sqltype=word31type - key ByteString Maybe sqltype=hash28type - minFeeA DbWord64 Maybe sqltype=word64type - minFeeB DbWord64 Maybe sqltype=word64type - maxBlockSize DbWord64 Maybe sqltype=word64type - maxTxSize DbWord64 Maybe sqltype=word64type - maxBhSize DbWord64 Maybe sqltype=word64type - keyDeposit DbLovelace Maybe sqltype=lovelace - poolDeposit DbLovelace Maybe sqltype=lovelace - maxEpoch DbWord64 Maybe sqltype=word64type - optimalPoolCount DbWord64 Maybe sqltype=word64type - influence Double Maybe -- sqltype=rational - monetaryExpandRate Double Maybe -- sqltype=interval - treasuryGrowthRate Double Maybe -- sqltype=interval - decentralisation Double Maybe -- sqltype=interval - entropy ByteString Maybe sqltype=hash32type - protocolMajor Word16 Maybe sqltype=word31type - protocolMinor Word16 Maybe sqltype=word31type - minUtxoValue DbLovelace Maybe sqltype=lovelace - minPoolCost DbLovelace Maybe sqltype=lovelace - - coinsPerUtxoSize DbLovelace Maybe sqltype=lovelace - costModelId CostModelId Maybe noreference - priceMem Double Maybe -- sqltype=rational - priceStep Double Maybe -- sqltype=rational - maxTxExMem DbWord64 Maybe sqltype=word64type - maxTxExSteps DbWord64 Maybe sqltype=word64type - maxBlockExMem DbWord64 Maybe sqltype=word64type - maxBlockExSteps DbWord64 Maybe sqltype=word64type - maxValSize DbWord64 Maybe sqltype=word64type - collateralPercent Word16 Maybe sqltype=word31type - maxCollateralInputs Word16 Maybe sqltype=word31type - - pvtMotionNoConfidence Double Maybe -- sqltype=rational - pvtCommitteeNormal Double Maybe -- sqltype=rational - pvtCommitteeNoConfidence Double Maybe -- sqltype=rational - pvtHardForkInitiation Double Maybe -- sqltype=rational - pvtppSecurityGroup Double Maybe -- sqltype=rational - dvtMotionNoConfidence Double Maybe -- sqltype=rational - dvtCommitteeNormal Double Maybe -- sqltype=rational - dvtCommitteeNoConfidence Double Maybe -- sqltype=rational - dvtUpdateToConstitution Double Maybe -- sqltype=rational - dvtHardForkInitiation Double Maybe -- sqltype=rational - dvtPPNetworkGroup Double Maybe -- sqltype=rational - dvtPPEconomicGroup Double Maybe -- sqltype=rational - dvtPPTechnicalGroup Double Maybe -- sqltype=rational - dvtPPGovGroup Double Maybe -- sqltype=rational - dvtTreasuryWithdrawal Double Maybe -- sqltype=rational - - committeeMinSize DbWord64 Maybe sqltype=word64type - committeeMaxTermLength DbWord64 Maybe sqltype=word64type - govActionLifetime DbWord64 Maybe sqltype=word64type - govActionDeposit DbWord64 Maybe sqltype=word64type - drepDeposit DbWord64 Maybe sqltype=word64type - drepActivity DbWord64 Maybe sqltype=word64type - minFeeRefScriptCostPerByte Double Maybe -- sqltype=rational - - registeredTxId TxId noreference - - EpochParam - epochNo Word64 sqltype=word31type - minFeeA Word64 sqltype=word31type - minFeeB Word64 sqltype=word31type - maxBlockSize Word64 sqltype=word31type - maxTxSize Word64 sqltype=word31type - maxBhSize Word64 sqltype=word31type - keyDeposit DbLovelace sqltype=lovelace - poolDeposit DbLovelace sqltype=lovelace - maxEpoch Word64 sqltype=word31type - optimalPoolCount Word64 sqltype=word31type - influence Double -- sqltype=rational - monetaryExpandRate Double -- sqltype=interval - treasuryGrowthRate Double -- sqltype=interval - decentralisation Double -- sqltype=interval - extraEntropy ByteString Maybe sqltype=hash32type - protocolMajor Word16 sqltype=word31type - protocolMinor Word16 sqltype=word31type - minUtxoValue DbLovelace sqltype=lovelace - minPoolCost DbLovelace sqltype=lovelace - - nonce ByteString Maybe sqltype=hash32type - - coinsPerUtxoSize DbLovelace Maybe sqltype=lovelace - costModelId CostModelId Maybe noreference - priceMem Double Maybe -- sqltype=rational - priceStep Double Maybe -- sqltype=rational - maxTxExMem DbWord64 Maybe sqltype=word64type - maxTxExSteps DbWord64 Maybe sqltype=word64type - maxBlockExMem DbWord64 Maybe sqltype=word64type - maxBlockExSteps DbWord64 Maybe sqltype=word64type - maxValSize DbWord64 Maybe sqltype=word64type - collateralPercent Word16 Maybe sqltype=word31type - maxCollateralInputs Word16 Maybe sqltype=word31type - - pvtMotionNoConfidence Double Maybe -- sqltype=rational - pvtCommitteeNormal Double Maybe -- sqltype=rational - pvtCommitteeNoConfidence Double Maybe -- sqltype=rational - pvtHardForkInitiation Double Maybe -- sqltype=rational - pvtppSecurityGroup Double Maybe -- sqltype=rational - dvtMotionNoConfidence Double Maybe -- sqltype=rational - dvtCommitteeNormal Double Maybe -- sqltype=rational - dvtCommitteeNoConfidence Double Maybe -- sqltype=rational - dvtUpdateToConstitution Double Maybe -- sqltype=rational - dvtHardForkInitiation Double Maybe -- sqltype=rational - dvtPPNetworkGroup Double Maybe -- sqltype=rational - dvtPPEconomicGroup Double Maybe -- sqltype=rational - dvtPPTechnicalGroup Double Maybe -- sqltype=rational - dvtPPGovGroup Double Maybe -- sqltype=rational - dvtTreasuryWithdrawal Double Maybe -- sqltype=rational - - committeeMinSize DbWord64 Maybe sqltype=word64type - committeeMaxTermLength DbWord64 Maybe sqltype=word64type - govActionLifetime DbWord64 Maybe sqltype=word64type - govActionDeposit DbWord64 Maybe sqltype=word64type - drepDeposit DbWord64 Maybe sqltype=word64type - drepActivity DbWord64 Maybe sqltype=word64type - minFeeRefScriptCostPerByte Double Maybe -- sqltype=rational - - blockId BlockId noreference -- The first block where these parameters are valid. - - CostModel - hash ByteString sqltype=hash32type - costs Text sqltype=jsonb - UniqueCostModel hash - - PoolStat - poolHashId PoolHashId noreference - epochNo Word64 sqltype=word31type - numberOfBlocks DbWord64 sqltype=word64type - numberOfDelegators DbWord64 sqltype=word64type - stake DbWord64 sqltype=word64type - votingPower DbWord64 Maybe sqltype=word64type - - ExtraMigrations - token Text - description Text Maybe - - DrepHash - raw ByteString Maybe sqltype=hash28type - view Text - hasScript Bool - UniqueDrepHash raw hasScript !force - - CommitteeHash - raw ByteString sqltype=hash28type - hasScript Bool - UniqueCommitteeHash raw hasScript - - DelegationVote - addrId StakeAddressId noreference - certIndex Word16 - drepHashId DrepHashId noreference - txId TxId noreference - redeemerId RedeemerId Maybe noreference - - CommitteeRegistration - txId TxId noreference - certIndex Word16 - coldKeyId CommitteeHashId noreference - hotKeyId CommitteeHashId noreference - - CommitteeDeRegistration - txId TxId noreference - certIndex Word16 - coldKeyId CommitteeHashId noreference - votingAnchorId VotingAnchorId Maybe noreference - - DrepRegistration - txId TxId noreference - certIndex Word16 - deposit Int64 Maybe - votingAnchorId VotingAnchorId Maybe noreference - drepHashId DrepHashId noreference - - VotingAnchor - blockId BlockId noreference - dataHash ByteString - url VoteUrl sqltype=varchar - type AnchorType sqltype=anchorType - UniqueVotingAnchor dataHash url type - - GovActionProposal - txId TxId noreference - index Word64 - prevGovActionProposal GovActionProposalId Maybe noreference - deposit DbLovelace sqltype=lovelace - returnAddress StakeAddressId noreference - expiration Word64 Maybe sqltype=word31type - votingAnchorId VotingAnchorId Maybe noreference - type GovActionType sqltype=govactiontype - description Text sqltype=jsonb - paramProposal ParamProposalId Maybe noreference - ratifiedEpoch Word64 Maybe sqltype=word31type - enactedEpoch Word64 Maybe sqltype=word31type - droppedEpoch Word64 Maybe sqltype=word31type - expiredEpoch Word64 Maybe sqltype=word31type - - TreasuryWithdrawal - govActionProposalId GovActionProposalId noreference - stakeAddressId StakeAddressId noreference - amount DbLovelace sqltype=lovelace - - Committee - govActionProposalId GovActionProposalId Maybe noreference - quorumNumerator Word64 - quorumDenominator Word64 - - CommitteeMember - committeeId CommitteeId OnDeleteCascade -- here intentionally we use foreign keys - committeeHashId CommitteeHashId noreference - expirationEpoch Word64 sqltype=word31type - - Constitution - govActionProposalId GovActionProposalId Maybe noreference - votingAnchorId VotingAnchorId noreference - scriptHash ByteString Maybe sqltype=hash28type - - VotingProcedure -- GovVote - txId TxId noreference - index Word16 - govActionProposalId GovActionProposalId noreference - voterRole VoterRole sqltype=voterrole - committeeVoter CommitteeHashId Maybe noreference - drepVoter DrepHashId Maybe noreference - poolVoter PoolHashId Maybe noreference - vote Vote sqltype=vote - votingAnchorId VotingAnchorId Maybe noreference - invalid EventInfoId Maybe noreference - - DrepDistr - hashId DrepHashId noreference - amount Word64 - epochNo Word64 sqltype=word31type - activeUntil Word64 Maybe sqltype=word31type - UniqueDrepDistr hashId epochNo - - EpochState - committeeId CommitteeId Maybe noreference - noConfidenceId GovActionProposalId Maybe noreference - constitutionId ConstitutionId Maybe noreference - epochNo Word64 sqltype=word31type - - EventInfo - txId TxId Maybe noreference - epoch Word64 sqltype=word31type - type Text - explanation Text Maybe - - -- ----------------------------------------------------------------------------------------------- - -- OffChain (ie not on the blockchain) data. - - OffChainPoolData - poolId PoolHashId noreference - tickerName Text - hash ByteString sqltype=hash32type - json Text sqltype=jsonb - bytes ByteString sqltype=bytea - pmrId PoolMetadataRefId noreference - UniqueOffChainPoolData poolId pmrId - deriving Show - - -- The pool metadata fetch error. We duplicate the poolId for easy access. - -- TODO(KS): Debatable whether we need to persist this between migrations! - - OffChainPoolFetchError - poolId PoolHashId noreference - fetchTime UTCTime sqltype=timestamp - pmrId PoolMetadataRefId noreference - fetchError Text - retryCount Word sqltype=word31type - UniqueOffChainPoolFetchError poolId fetchTime retryCount - deriving Show - - OffChainVoteData - votingAnchorId VotingAnchorId noreference - hash ByteString - language Text - comment Text Maybe - json Text sqltype=jsonb - bytes ByteString sqltype=bytea - warning Text Maybe - isValid Bool Maybe - UniqueOffChainVoteData votingAnchorId hash - deriving Show - - OffChainVoteGovActionData - offChainVoteDataId OffChainVoteDataId noreference - title Text - abstract Text - motivation Text - rationale Text - - OffChainVoteDrepData - offChainVoteDataId OffChainVoteDataId noreference - paymentAddress Text Maybe - givenName Text - objectives Text Maybe - motivations Text Maybe - qualifications Text Maybe - imageUrl Text Maybe - imageHash Text Maybe - - OffChainVoteAuthor - offChainVoteDataId OffChainVoteDataId noreference - name Text Maybe - witnessAlgorithm Text - publicKey Text - signature Text - warning Text Maybe - - OffChainVoteReference - offChainVoteDataId OffChainVoteDataId noreference - label Text - uri Text - hashDigest Text Maybe - hashAlgorithm Text Maybe - - OffChainVoteExternalUpdate - offChainVoteDataId OffChainVoteDataId noreference - title Text - uri Text - - OffChainVoteFetchError - votingAnchorId VotingAnchorId noreference - fetchError Text - fetchTime UTCTime sqltype=timestamp - retryCount Word sqltype=word31type - UniqueOffChainVoteFetchError votingAnchorId retryCount - deriving Show - - -------------------------------------------------------------------------- - -- A table containing a managed list of reserved ticker names. - -- For now they are grouped under the specific hash of the pool. - ReservedPoolTicker - name Text - poolHash ByteString sqltype=hash28type - UniqueReservedPoolTicker name - - -- A table containing delisted pools. - DelistedPool - hashRaw ByteString sqltype=hash28type - UniqueDelistedPool hashRaw - - |] - -deriving instance Eq (Unique EpochSyncTime) - -schemaDocs :: [EntityDef] -schemaDocs = - document entityDefs $ do - SchemaVersion --^ do - "The version of the database schema. Schema versioning is split into three stages as detailed\ - \ below. This table should only ever have a single row." - SchemaVersionStageOne # "Set up PostgreSQL data types (using SQL 'DOMAIN' statements)." - SchemaVersionStageTwo # "Persistent generated migrations." - SchemaVersionStageThree # "Set up database views, indices etc." - - PoolHash --^ do - "A table for every unique pool key hash.\ - \ The existance of an entry doesn't mean the pool is registered or in fact that is was ever registered." - PoolHashHashRaw # "The raw bytes of the pool hash." - PoolHashView # "The Bech32 encoding of the pool hash." - - SlotLeader --^ do - "Every unique slot leader (ie an entity that mines a block). It could be a pool or a leader defined in genesis." - SlotLeaderHash # "The hash of of the block producer identifier." - SlotLeaderPoolHashId # "If the slot leader is a pool, an index into the `PoolHash` table." - SlotLeaderDescription # "An auto-generated description of the slot leader." - - Block --^ do - "A table for blocks on the chain." - BlockHash # "The hash identifier of the block." - BlockEpochNo # "The epoch number." - BlockSlotNo # "The slot number." - BlockEpochSlotNo # "The slot number within an epoch (resets to zero at the start of each epoch)." - BlockBlockNo # "The block number." - BlockPreviousId # "The Block table index of the previous block." - BlockSlotLeaderId # "The SlotLeader table index of the creator of this block." - BlockSize # "The block size (in bytes). Note, this size value is not expected to be the same as the sum of the tx sizes due to the fact that txs being stored in segwit format and oddities in the CBOR encoding." - BlockTime # "The block time (UTCTime)." - BlockTxCount # "The number of transactions in this block." - BlockProtoMajor # "The block's major protocol number." - BlockProtoMinor # "The block's major protocol number." - -- Shelley specific - BlockVrfKey # "The VRF key of the creator of this block." - BlockOpCert # "The hash of the operational certificate of the block producer." - BlockOpCertCounter # "The value of the counter used to produce the operational certificate." - - Tx --^ do - "A table for transactions within a block on the chain." - TxHash # "The hash identifier of the transaction." - TxBlockId # "The Block table index of the block that contains this transaction." - TxBlockIndex # "The index of this transaction with the block (zero based)." - TxOutSum # "The sum of the transaction outputs (in Lovelace)." - TxFee # "The fees paid for this transaction." - TxDeposit # "Deposit (or deposit refund) in this transaction. Deposits are positive, refunds negative." - TxSize # "The size of the transaction in bytes." - TxInvalidBefore # "Transaction in invalid before this slot number." - TxInvalidHereafter # "Transaction in invalid at or after this slot number." - TxValidContract # "False if the contract is invalid. True if the contract is valid or there is no contract." - TxScriptSize # "The sum of the script sizes (in bytes) of scripts in the transaction." - - TxCbor --^ do - "A table holding raw CBOR encoded transactions." - TxCborTxId # "The Tx table index of the transaction encoded in this table." - TxCborBytes # "CBOR encoded transaction." - - ReverseIndex --^ do - "A table for reverse indexes for the minimum input output and multi asset output related with\ - \ this block. New in v13.1" - ReverseIndexBlockId # "The Block table index related with these indexes" - ReverseIndexMinIds # "The Reverse indexes associated with this block, as Text separated by :" - - StakeAddress --^ do - "A table of unique stake addresses. Can be an actual address or a script hash. \ - \ The existance of an entry doesn't mean the address is registered or in fact that is was ever registered." - StakeAddressHashRaw # "The raw bytes of the stake address hash." - StakeAddressView # "The Bech32 encoded version of the stake address." - StakeAddressScriptHash # "The script hash, in case this address is locked by a script." - - TxIn --^ do - "A table for transaction inputs." - TxInTxInId # "The Tx table index of the transaction that contains this transaction input." - TxInTxOutId # "The Tx table index of the transaction that contains the referenced transaction output." - TxInTxOutIndex # "The index within the transaction outputs." - TxInRedeemerId # "The Redeemer table index which is used to validate this input." - - CollateralTxIn --^ do - "A table for transaction collateral inputs." - CollateralTxInTxInId # "The Tx table index of the transaction that contains this transaction input" - CollateralTxInTxOutId # "The Tx table index of the transaction that contains the referenced transaction output." - CollateralTxInTxOutIndex # "The index within the transaction outputs." - - ReferenceTxIn --^ do - "A table for reference transaction inputs. New in v13." - ReferenceTxInTxInId # "The Tx table index of the transaction that contains this transaction input" - ReferenceTxInTxOutId # "The Tx table index of the transaction that contains the referenced output." - ReferenceTxInTxOutIndex # "The index within the transaction outputs." - - Meta --^ do - "A table containing metadata about the chain. There will probably only ever be one row in this table." - MetaStartTime # "The start time of the network." - MetaNetworkName # "The network name." - - Epoch --^ do - "Aggregation of data within an epoch." - EpochOutSum # "The sum of the transaction output values (in Lovelace) in this epoch." - EpochFees # "The sum of the fees (in Lovelace) in this epoch." - EpochTxCount # "The number of transactions in this epoch." - EpochBlkCount # "The number of blocks in this epoch." - EpochNo # "The epoch number." - EpochStartTime # "The epoch start time." - EpochEndTime # "The epoch end time." - - AdaPots --^ do - "A table with all the different types of total balances (Shelley only).\n\ - \The treasury and rewards fields will be correct for the whole epoch, but all other \ - \fields change block by block." - AdaPotsSlotNo # "The slot number where this AdaPots snapshot was taken." - AdaPotsEpochNo # "The epoch number where this AdaPots snapshot was taken." - AdaPotsTreasury # "The amount (in Lovelace) in the treasury pot." - AdaPotsReserves # "The amount (in Lovelace) in the reserves pot." - AdaPotsRewards # "The amount (in Lovelace) in the rewards pot." - AdaPotsUtxo # "The amount (in Lovelace) in the UTxO set." - AdaPotsDepositsStake # "The amount (in Lovelace) in the obligation pot coming from stake key and pool deposits. Renamed from deposits in 13.3." - AdaPotsDepositsDrep # "The amount (in Lovelace) in the obligation pot coming from drep registrations deposits. New in 13.3." - AdaPotsDepositsProposal # "The amount (in Lovelace) in the obligation pot coming from governance proposal deposits. New in 13.3." - AdaPotsFees # "The amount (in Lovelace) in the fee pot." - AdaPotsBlockId # "The Block table index of the block for which this snapshot was taken." - - PoolMetadataRef --^ do - "An on-chain reference to off-chain pool metadata." - PoolMetadataRefPoolId # "The PoolHash table index of the pool for this reference." - PoolMetadataRefUrl # "The URL for the location of the off-chain data." - PoolMetadataRefHash # "The expected hash for the off-chain data." - PoolMetadataRefRegisteredTxId # "The Tx table index of the transaction in which provided this metadata reference." - - PoolUpdate --^ do - "An on-chain pool update." - PoolUpdateHashId # "The PoolHash table index of the pool this update refers to." - PoolUpdateCertIndex # "The index of this pool update within the certificates of this transaction." - PoolUpdateVrfKeyHash # "The hash of the pool's VRF key." - PoolUpdatePledge # "The amount (in Lovelace) the pool owner pledges to the pool." - PoolUpdateRewardAddrId # "The StakeAddress table index of this pool's rewards address. New in v13: Replaced reward_addr." - PoolUpdateActiveEpochNo # "The epoch number where this update becomes active." - PoolUpdateMetaId # "The PoolMetadataRef table index this pool update refers to." - PoolUpdateMargin # "The margin (as a percentage) this pool charges." - PoolUpdateFixedCost # "The fixed per epoch fee (in ADA) this pool charges." - PoolUpdateDeposit # "The deposit payed for this pool update. Null for reregistrations." - PoolUpdateRegisteredTxId # "The Tx table index of the transaction in which provided this pool update." - - PoolOwner --^ do - "A table containing pool owners." - PoolOwnerAddrId # "The StakeAddress table index for the pool owner's stake address." - PoolOwnerPoolUpdateId # "The PoolUpdate table index for the pool. New in v13." - - PoolRetire --^ do - "A table containing information about pools retiring." - PoolRetireHashId # "The PoolHash table index of the pool this retirement refers to." - PoolRetireCertIndex # "The index of this pool retirement within the certificates of this transaction." - PoolRetireAnnouncedTxId # "The Tx table index of the transaction where this pool retirement was announced." - PoolRetireRetiringEpoch # "The epoch where this pool retires." - - PoolRelay --^ do - PoolRelayUpdateId # "The PoolUpdate table index this PoolRelay entry refers to." - PoolRelayIpv4 # "The IPv4 address of the relay (NULLable)." - PoolRelayIpv6 # "The IPv6 address of the relay (NULLable)." - PoolRelayDnsName # "The DNS name of the relay (NULLable)." - PoolRelayDnsSrvName # "The DNS service name of the relay (NULLable)." - PoolRelayPort # "The port number of relay (NULLable)." - - StakeRegistration --^ do - "A table containing stake address registrations." - StakeRegistrationAddrId # "The StakeAddress table index for the stake address." - StakeRegistrationCertIndex # "The index of this stake registration within the certificates of this transaction." - StakeRegistrationEpochNo # "The epoch in which the registration took place." - StakeRegistrationTxId # "The Tx table index of the transaction where this stake address was registered." - - StakeDeregistration --^ do - "A table containing stake address deregistrations." - StakeDeregistrationAddrId # "The StakeAddress table index for the stake address." - StakeDeregistrationCertIndex # "The index of this stake deregistration within the certificates of this transaction." - StakeDeregistrationEpochNo # "The epoch in which the deregistration took place." - StakeDeregistrationTxId # "The Tx table index of the transaction where this stake address was deregistered." - StakeDeregistrationRedeemerId # "The Redeemer table index that is related with this certificate." - - Delegation --^ do - "A table containing delegations from a stake address to a stake pool." - DelegationAddrId # "The StakeAddress table index for the stake address." - DelegationCertIndex # "The index of this delegation within the certificates of this transaction." - DelegationPoolHashId # "The PoolHash table index for the pool being delegated to." - DelegationActiveEpochNo # "The epoch number where this delegation becomes active." - DelegationTxId # "The Tx table index of the transaction that contained this delegation." - DelegationSlotNo # "The slot number of the block that contained this delegation." - DelegationRedeemerId # "The Redeemer table index that is related with this certificate." - - TxMetadata --^ do - "A table for metadata attached to a transaction." - TxMetadataKey # "The metadata key (a Word64/unsigned 64 bit number)." - TxMetadataJson # "The JSON payload if it can be decoded as JSON." - TxMetadataBytes # "The raw bytes of the payload." - TxMetadataTxId # "The Tx table index of the transaction where this metadata was included." - - Reward --^ do - "A table for earned staking rewards. After 13.2 release it includes only 3 types of rewards: member, leader and refund, \ - \ since the other 2 types have moved to a separate table instant_reward.\ - \ The rewards are inserted incrementally and\ - \ this procedure is finalised when the spendable epoch comes. Before the epoch comes, some entries\ - \ may be missing. The `reward.id` field has been removed and it only appears on docs due to a bug." - RewardAddrId # "The StakeAddress table index for the stake address that earned the reward." - RewardType # "The type of the rewards" - RewardAmount # "The reward amount (in Lovelace)." - RewardEarnedEpoch - # "The epoch in which the reward was earned. For `pool` and `leader` rewards spendable in epoch `N`, this will be\ - \ `N - 2`, `refund` N." - RewardSpendableEpoch # "The epoch in which the reward is actually distributed and can be spent." - RewardPoolId - # "The PoolHash table index for the pool the stake address was delegated to when\ - \ the reward is earned or for the pool that there is a deposit refund." - - RewardRest --^ do - "A table for rewards which are not correlated to a pool. It includes 3 types of rewards: reserves, treasury and proposal_refund.\ - \ Instant rewards are depredated after Conway.\ - \ The `reward.id` field has been removed and it only appears on docs due to a bug.\ - \ New in 13.2" - RewardRestAddrId # "The StakeAddress table index for the stake address that earned the reward." - RewardRestType # "The type of the rewards." - RewardRestAmount # "The reward amount (in Lovelace)." - RewardRestEarnedEpoch - # "The epoch in which the reward was earned. For rewards spendable in epoch `N`, this will be\ - \ `N - 1`." - RewardRestSpendableEpoch # "The epoch in which the reward is actually distributed and can be spent." - - Withdrawal --^ do - "A table for withdrawals from a reward account." - WithdrawalAddrId # "The StakeAddress table index for the stake address for which the withdrawal is for." - WithdrawalAmount # "The withdrawal amount (in Lovelace)." - WithdrawalTxId # "The Tx table index for the transaction that contains this withdrawal." - WithdrawalRedeemerId # "The Redeemer table index that is related with this withdrawal." - - EpochStake --^ do - "A table containing the epoch stake distribution for each epoch. This is inserted incrementally in the first blocks of the previous epoch.\ - \ The stake distribution is extracted from the `set` snapshot of the ledger. See Shelley specs Sec. 11.2 for more details." - EpochStakeAddrId # "The StakeAddress table index for the stake address for this EpochStake entry." - EpochStakePoolId # "The PoolHash table index for the pool this entry is delegated to." - EpochStakeAmount # "The amount (in Lovelace) being staked." - EpochStakeEpochNo # "The epoch number." - - EpochStakeProgress --^ do - "A table which shows when the epoch_stake for an epoch is complete" - EpochStakeProgressEpochNo # "The related epoch" - EpochStakeProgressCompleted # "True if completed. If not completed the entry won't exist or more rarely be False." - - Treasury --^ do - "A table for payments from the treasury to a StakeAddress. Note: Before protocol version 5.0\ - \ (Alonzo) if more than one payment was made to a stake address in a single epoch, only the\ - \ last payment was kept and earlier ones removed. For protocol version 5.0 and later, they\ - \ are summed and produce a single reward with type `treasury`." - TreasuryAddrId # "The StakeAddress table index for the stake address for this Treasury entry." - TreasuryCertIndex # "The index of this payment certificate within the certificates of this transaction." - TreasuryAmount # "The payment amount (in Lovelace)." - TreasuryTxId # "The Tx table index for the transaction that contains this payment." - - Reserve --^ do - "A table for payments from the reserves to a StakeAddress. Note: Before protocol version 5.0\ - \ (Alonzo) if more than one payment was made to a stake address in a single epoch, only the\ - \ last payment was kept and earlier ones removed. For protocol version 5.0 and later, they\ - \ are summed and produce a single reward with type `reserves`" - ReserveAddrId # "The StakeAddress table index for the stake address for this Treasury entry." - ReserveCertIndex # "The index of this payment certificate within the certificates of this transaction." - ReserveAmount # "The payment amount (in Lovelace)." - ReserveTxId # "The Tx table index for the transaction that contains this payment." - - PotTransfer --^ do - "A table containing transfers between the reserves pot and the treasury pot." - PotTransferCertIndex # "The index of this transfer certificate within the certificates of this transaction." - PotTransferTreasury # "The amount (in Lovelace) the treasury balance changes by." - PotTransferReserves # "The amount (in Lovelace) the reserves balance changes by." - PotTransferTxId # "The Tx table index for the transaction that contains this transfer." - - EpochSyncTime --^ do - "A table containing the time required to fully sync an epoch." - EpochSyncTimeNo # "The epoch number for this sync time." - EpochSyncTimeSeconds - # "The time (in seconds) required to sync this epoch (may be NULL for an epoch\ - \ that was already partially synced when `db-sync` was started)." - EpochSyncTimeState # "The sync state when the sync time is recorded (either 'lagging' or 'following')." - - MultiAsset --^ do - "A table containing all the unique policy/name pairs along with a CIP14 asset fingerprint" - MultiAssetPolicy # "The MultiAsset policy hash." - MultiAssetName # "The MultiAsset name." - MultiAssetFingerprint # "The CIP14 fingerprint for the MultiAsset." - - MaTxMint --^ do - "A table containing Multi-Asset mint events." - MaTxMintIdent # "The MultiAsset table index specifying the asset." - MaTxMintQuantity # "The amount of the Multi Asset to mint (can be negative to \"burn\" assets)." - MaTxMintTxId # "The Tx table index for the transaction that contains this minting event." - - Redeemer --^ do - "A table containing redeemers. A redeemer is provided for all items that are validated by a script." - RedeemerTxId # "The Tx table index that contains this redeemer." - RedeemerUnitMem # "The budget in Memory to run a script." - RedeemerUnitSteps # "The budget in Cpu steps to run a script." - RedeemerFee - # "The budget in fees to run a script. The fees depend on the ExUnits and the current prices.\ - \ Is null when --disable-ledger is enabled. New in v13: became nullable." - RedeemerPurpose # "What kind pf validation this redeemer is used for. It can be one of 'spend', 'mint', 'cert', 'reward', `voting`, `proposing`" - RedeemerIndex # "The index of the redeemer pointer in the transaction." - RedeemerScriptHash # "The script hash this redeemer is used for." - RedeemerRedeemerDataId # "The data related to this redeemer. New in v13: renamed from datum_id." - - Script --^ do - "A table containing scripts available, found in witnesses, inlined in outputs (reference outputs) or auxdata of transactions." - ScriptTxId # "The Tx table index for the transaction where this script first became available." - ScriptHash # "The Hash of the Script." - ScriptType # "The type of the script. This is currenttly either 'timelock' or 'plutus'." - ScriptJson # "JSON representation of the timelock script, null for other script types" - ScriptBytes # "CBOR encoded plutus script data, null for other script types" - ScriptSerialisedSize # "The size of the CBOR serialised script, if it is a Plutus script." - - Datum --^ do - "A table containing Plutus Datum, found in witnesses or inlined in outputs" - DatumHash # "The Hash of the Datum" - DatumTxId # "The Tx table index for the transaction where this script first became available." - DatumValue # "The actual data in JSON format (detailed schema)" - DatumBytes # "The actual data in CBOR format" - - RedeemerData --^ do - "A table containing Plutus Redeemer Data. These are always referenced by at least one redeemer. New in v13: split from datum table." - RedeemerDataHash # "The Hash of the Plutus Data" - RedeemerDataTxId # "The Tx table index for the transaction where this script first became available." - RedeemerDataValue # "The actual data in JSON format (detailed schema)" - RedeemerDataBytes # "The actual data in CBOR format" - - ExtraKeyWitness --^ do - "A table containing transaction extra key witness hashes." - ExtraKeyWitnessHash # "The hash of the witness." - ExtraKeyWitnessTxId # "The id of the tx this witness belongs to." - - ParamProposal --^ do - "A table containing block chain parameter change proposals." - ParamProposalEpochNo - # "The epoch for which this parameter proposal in intended to become active.\ - \ Changed in 13.2-Conway to nullable is always null in Conway era." - ParamProposalKey - # "The hash of the crypto key used to sign this proposal.\ - \ Changed in 13.2-Conway to nullable is always null in Conway era." - ParamProposalMinFeeA # "The 'a' parameter to calculate the minimum transaction fee." - ParamProposalMinFeeB # "The 'b' parameter to calculate the minimum transaction fee." - ParamProposalMaxBlockSize # "The maximum block size (in bytes)." - ParamProposalMaxTxSize # "The maximum transaction size (in bytes)." - ParamProposalMaxBhSize # "The maximum block header size (in bytes)." - ParamProposalKeyDeposit # "The amount (in Lovelace) require for a deposit to register a StakeAddress." - ParamProposalPoolDeposit # "The amount (in Lovelace) require for a deposit to register a stake pool." - ParamProposalMaxEpoch # "The maximum number of epochs in the future that a pool retirement is allowed to be scheduled for." - ParamProposalOptimalPoolCount # "The optimal number of stake pools." - ParamProposalInfluence # "The influence of the pledge on a stake pool's probability on minting a block." - ParamProposalMonetaryExpandRate # "The monetary expansion rate." - ParamProposalTreasuryGrowthRate # "The treasury growth rate." - ParamProposalDecentralisation # "The decentralisation parameter (1 fully centralised, 0 fully decentralised)." - ParamProposalEntropy # "The 32 byte string of extra random-ness to be added into the protocol's entropy pool." - ParamProposalProtocolMajor # "The protocol major number." - ParamProposalProtocolMinor # "The protocol minor number." - ParamProposalMinUtxoValue # "The minimum value of a UTxO entry." - ParamProposalMinPoolCost # "The minimum pool cost." - ParamProposalCoinsPerUtxoSize # "For Alonzo this is the cost per UTxO word. For Babbage and later per UTxO byte. New in v13: Renamed from coins_per_utxo_word." - ParamProposalCostModelId # "The CostModel table index for the proposal." - ParamProposalPriceMem # "The per word cost of script memory usage." - ParamProposalPriceStep # "The cost of script execution step usage." - ParamProposalMaxTxExMem # "The maximum number of execution memory allowed to be used in a single transaction." - ParamProposalMaxTxExSteps # "The maximum number of execution steps allowed to be used in a single transaction." - ParamProposalMaxBlockExMem # "The maximum number of execution memory allowed to be used in a single block." - ParamProposalMaxBlockExSteps # "The maximum number of execution steps allowed to be used in a single block." - ParamProposalMaxValSize # "The maximum Val size." - ParamProposalCollateralPercent # "The percentage of the txfee which must be provided as collateral when including non-native scripts." - ParamProposalMaxCollateralInputs # "The maximum number of collateral inputs allowed in a transaction." - ParamProposalRegisteredTxId # "The Tx table index for the transaction that contains this parameter proposal." - ParamProposalPvtMotionNoConfidence # "Pool Voting threshold for motion of no-confidence. New in 13.2-Conway." - ParamProposalPvtCommitteeNormal # "Pool Voting threshold for new committee/threshold (normal state). New in 13.2-Conway." - ParamProposalPvtCommitteeNoConfidence # "Pool Voting threshold for new committee/threshold (state of no-confidence). New in 13.2-Conway." - ParamProposalPvtHardForkInitiation # "Pool Voting threshold for hard-fork initiation. New in 13.2-Conway." - ParamProposalDvtMotionNoConfidence # "DRep Vote threshold for motion of no-confidence. New in 13.2-Conway." - ParamProposalDvtCommitteeNormal # "DRep Vote threshold for new committee/threshold (normal state). New in 13.2-Conway." - ParamProposalDvtCommitteeNoConfidence # "DRep Vote threshold for new committee/threshold (state of no-confidence). New in 13.2-Conway." - ParamProposalDvtUpdateToConstitution # "DRep Vote threshold for update to the Constitution. New in 13.2-Conway." - ParamProposalDvtHardForkInitiation # "DRep Vote threshold for hard-fork initiation. New in 13.2-Conway." - ParamProposalDvtPPNetworkGroup # "DRep Vote threshold for protocol parameter changes, network group. New in 13.2-Conway." - ParamProposalDvtPPEconomicGroup # "DRep Vote threshold for protocol parameter changes, economic group. New in 13.2-Conway." - ParamProposalDvtPPTechnicalGroup # "DRep Vote threshold for protocol parameter changes, technical group. New in 13.2-Conway." - ParamProposalDvtPPGovGroup # "DRep Vote threshold for protocol parameter changes, governance group. New in 13.2-Conway." - ParamProposalDvtTreasuryWithdrawal # "DRep Vote threshold for treasury withdrawal. New in 13.2-Conway." - ParamProposalCommitteeMinSize # "Minimal constitutional committee size. New in 13.2-Conway." - ParamProposalCommitteeMaxTermLength # "Constitutional committee term limits. New in 13.2-Conway." - ParamProposalGovActionLifetime # "Governance action expiration. New in 13.2-Conway." - ParamProposalGovActionDeposit # "Governance action deposit. New in 13.2-Conway." - ParamProposalDrepDeposit # "DRep deposit amount. New in 13.2-Conway." - ParamProposalDrepActivity # "DRep activity period. New in 13.2-Conway." - - EpochParam --^ do - "The accepted protocol parameters for an epoch." - EpochParamEpochNo # "The first epoch for which these parameters are valid." - EpochParamMinFeeA # "The 'a' parameter to calculate the minimum transaction fee." - EpochParamMinFeeB # "The 'b' parameter to calculate the minimum transaction fee." - EpochParamMaxBlockSize # "The maximum block size (in bytes)." - EpochParamMaxTxSize # "The maximum transaction size (in bytes)." - EpochParamMaxBhSize # "The maximum block header size (in bytes)." - EpochParamKeyDeposit # "The amount (in Lovelace) require for a deposit to register a StakeAddress." - EpochParamPoolDeposit # "The amount (in Lovelace) require for a deposit to register a stake pool." - EpochParamMaxEpoch # "The maximum number of epochs in the future that a pool retirement is allowed to be scheduled for." - EpochParamOptimalPoolCount # "The optimal number of stake pools." - EpochParamInfluence # "The influence of the pledge on a stake pool's probability on minting a block." - EpochParamMonetaryExpandRate # "The monetary expansion rate." - EpochParamTreasuryGrowthRate # "The treasury growth rate." - EpochParamDecentralisation # "The decentralisation parameter (1 fully centralised, 0 fully decentralised)." - EpochParamExtraEntropy # "The 32 byte string of extra random-ness to be added into the protocol's entropy pool. New in v13: renamed from entopy." - EpochParamProtocolMajor # "The protocol major number." - EpochParamProtocolMinor # "The protocol minor number." - EpochParamMinUtxoValue # "The minimum value of a UTxO entry." - EpochParamMinPoolCost # "The minimum pool cost." - EpochParamNonce # "The nonce value for this epoch." - EpochParamCoinsPerUtxoSize # "For Alonzo this is the cost per UTxO word. For Babbage and later per UTxO byte. New in v13: Renamed from coins_per_utxo_word." - EpochParamCostModelId # "The CostModel table index for the params." - EpochParamPriceMem # "The per word cost of script memory usage." - EpochParamPriceStep # "The cost of script execution step usage." - EpochParamMaxTxExMem # "The maximum number of execution memory allowed to be used in a single transaction." - EpochParamMaxTxExSteps # "The maximum number of execution steps allowed to be used in a single transaction." - EpochParamMaxBlockExMem # "The maximum number of execution memory allowed to be used in a single block." - EpochParamMaxBlockExSteps # "The maximum number of execution steps allowed to be used in a single block." - EpochParamMaxValSize # "The maximum Val size." - EpochParamCollateralPercent # "The percentage of the txfee which must be provided as collateral when including non-native scripts." - EpochParamMaxCollateralInputs # "The maximum number of collateral inputs allowed in a transaction." - EpochParamBlockId # "The Block table index for the first block where these parameters are valid." - EpochParamPvtMotionNoConfidence # "Pool Voting threshold for motion of no-confidence. New in 13.2-Conway." - EpochParamPvtCommitteeNormal # "Pool Voting threshold for new committee/threshold (normal state). New in 13.2-Conway." - EpochParamPvtCommitteeNoConfidence # "Pool Voting threshold for new committee/threshold (state of no-confidence). New in 13.2-Conway." - EpochParamPvtHardForkInitiation # "Pool Voting threshold for hard-fork initiation. New in 13.2-Conway." - EpochParamDvtMotionNoConfidence # "DRep Vote threshold for motion of no-confidence. New in 13.2-Conway." - EpochParamDvtCommitteeNormal # "DRep Vote threshold for new committee/threshold (normal state). New in 13.2-Conway." - EpochParamDvtCommitteeNoConfidence # "DRep Vote threshold for new committee/threshold (state of no-confidence). New in 13.2-Conway." - EpochParamDvtUpdateToConstitution # "DRep Vote threshold for update to the Constitution. New in 13.2-Conway." - EpochParamDvtHardForkInitiation # "DRep Vote threshold for hard-fork initiation. New in 13.2-Conway." - EpochParamDvtPPNetworkGroup # "DRep Vote threshold for protocol parameter changes, network group. New in 13.2-Conway." - EpochParamDvtPPEconomicGroup # "DRep Vote threshold for protocol parameter changes, economic group. New in 13.2-Conway." - EpochParamDvtPPTechnicalGroup # "DRep Vote threshold for protocol parameter changes, technical group. New in 13.2-Conway." - EpochParamDvtPPGovGroup # "DRep Vote threshold for protocol parameter changes, governance group. New in 13.2-Conway." - EpochParamDvtTreasuryWithdrawal # "DRep Vote threshold for treasury withdrawal. New in 13.2-Conway." - EpochParamCommitteeMinSize # "Minimal constitutional committee size. New in 13.2-Conway." - EpochParamCommitteeMaxTermLength # "Constitutional committee term limits. New in 13.2-Conway." - EpochParamGovActionLifetime # "Governance action expiration. New in 13.2-Conway." - EpochParamGovActionDeposit # "Governance action deposit. New in 13.2-Conway." - EpochParamDrepDeposit # "DRep deposit amount. New in 13.2-Conway." - EpochParamDrepActivity # "DRep activity period. New in 13.2-Conway." - - CostModel --^ do - "CostModel for EpochParam and ParamProposal." - CostModelHash # "The hash of cost model. It ensures uniqueness of entries. New in v13." - CostModelCosts # "The actual costs formatted as json." - - PoolStat --^ do - "Stats per pool and per epoch." - PoolStatPoolHashId # "The pool_hash_id reference." - PoolStatEpochNo # "The epoch number." - PoolStatNumberOfBlocks # "Number of blocks created on the previous epoch." - PoolStatNumberOfDelegators # "Number of delegators in the mark snapshot." - PoolStatStake # "Total stake in the mark snapshot." - PoolStatVotingPower # "Voting power of the SPO." - - EpochState --^ do - "Table with governance (and in the future other) stats per epoch." - EpochStateCommitteeId # "The reference to the current committee." - EpochStateNoConfidenceId # "The reference to the current gov_action_proposal of no confidence. TODO: This remains NULL." - EpochStateConstitutionId # "The reference to the current constitution. Should never be null." - EpochStateEpochNo # "The epoch in question." - - ExtraMigrations --^ do - "Extra optional migrations. New in 13.2." - ExtraMigrationsDescription # "A description of the migration" - - DrepHash --^ do - "A table for every unique drep key hash.\ - \ The existance of an entry doesn't mean the DRep is registered.\ - \ New in 13.2-Conway." - DrepHashRaw # "The raw bytes of the DRep." - DrepHashView # "The human readable encoding of the Drep." - DrepHashHasScript # "Flag which shows if this DRep credentials are a script hash" - - CommitteeHash --^ do - "A table for all committee credentials hot or cold" - CommitteeHashRaw # "The key or script hash" - CommitteeHashHasScript # "Flag which shows if this credential is a script hash" - - DelegationVote --^ do - "A table containing delegations from a stake address to a stake pool. New in 13.2-Conway." - DelegationVoteAddrId # "The StakeAddress table index for the stake address." - DelegationVoteCertIndex # "The index of this delegation within the certificates of this transaction." - DelegationVoteDrepHashId # "The DrepHash table index for the pool being delegated to." - DelegationVoteTxId # "The Tx table index of the transaction that contained this delegation." - DelegationVoteRedeemerId # "The Redeemer table index that is related with this certificate. TODO: can vote redeemers index these delegations?" - - CommitteeRegistration --^ do - "A table for every committee hot key registration. New in 13.2-Conway." - CommitteeRegistrationTxId # "The Tx table index of the tx that includes this certificate." - CommitteeRegistrationCertIndex # "The index of this registration within the certificates of this transaction." - CommitteeRegistrationColdKeyId # "The reference to the registered cold key hash id" - CommitteeRegistrationHotKeyId # "The reference to the registered hot key hash id" - - CommitteeDeRegistration --^ do - "A table for every committee key de-registration. New in 13.2-Conway." - CommitteeDeRegistrationTxId # "The Tx table index of the tx that includes this certificate." - CommitteeDeRegistrationCertIndex # "The index of this deregistration within the certificates of this transaction." - CommitteeDeRegistrationColdKeyId # "The reference to the the deregistered cold key hash id" - CommitteeDeRegistrationVotingAnchorId # "The Voting anchor reference id" - - DrepRegistration --^ do - "A table for DRep registrations, deregistrations or updates. Registration have positive deposit values, deregistrations have negative and\ - \ updates have null. Based on this distinction, for a specific DRep, getting the latest entry gives its registration state. New in 13.2-Conway." - DrepRegistrationTxId # "The Tx table index of the tx that includes this certificate." - DrepRegistrationCertIndex # "The index of this registration within the certificates of this transaction." - DrepRegistrationDeposit # "The deposits payed if this is an initial registration." - DrepRegistrationDrepHashId # "The Drep hash index of this registration." - - VotingAnchor --^ do - "A table for every Anchor that appears on Governance Actions. These are pointers to offchain metadata. \ - \ The tuple of url and hash is unique. New in 13.2-Conway." - VotingAnchorBlockId # "The Block table index of the tx that includes this anchor. This only exists to facilitate rollbacks" - VotingAnchorDataHash # "A hash of the contents of the metadata URL" - VotingAnchorUrl # "A URL to a JSON payload of metadata" - VotingAnchorType # "The type of the anchor. It can be gov_action, drep, other, vote, committee_dereg, constitution" - - GovActionProposal --^ do - "A table for proposed GovActionProposal, aka ProposalProcedure, GovAction or GovProposal.\ - \ This table may be referenced\ - \ by TreasuryWithdrawal or NewCommittee. New in 13.2-Conway." - GovActionProposalTxId # "The Tx table index of the tx that includes this certificate." - GovActionProposalIndex # "The index of this proposal procedure within its transaction." - GovActionProposalPrevGovActionProposal # "The previous related GovActionProposal. This is null for " - GovActionProposalDeposit # "The deposit amount payed for this proposal." - GovActionProposalReturnAddress # "The StakeAddress index of the reward address to receive the deposit when it is repaid." - GovActionProposalVotingAnchorId # "The Anchor table index related to this proposal." - GovActionProposalType # "Can be one of ParameterChange, HardForkInitiation, TreasuryWithdrawals, NoConfidence, NewCommittee, NewConstitution, InfoAction" - GovActionProposalDescription # "A Text describing the content of this GovActionProposal in a readable way." - GovActionProposalParamProposal # "If this is a param proposal action, this has the index of the param_proposal table." - GovActionProposalRatifiedEpoch # "If not null, then this proposal has been ratified at the specfied epoch." - GovActionProposalEnactedEpoch # "If not null, then this proposal has been enacted at the specfied epoch." - GovActionProposalExpiredEpoch # "If not null, then this proposal has been expired at the specfied epoch." - GovActionProposalDroppedEpoch - # "If not null, then this proposal has been dropped at the specfied epoch. A proposal is dropped when it's \ - \expired or enacted or when one of its dependencies is expired." - GovActionProposalExpiration # "Shows the epoch at which this governance action will expire." - - TreasuryWithdrawal --^ do - "A table for all treasury withdrawals proposed on a GovActionProposal. New in 13.2-Conway." - TreasuryWithdrawalGovActionProposalId - # "The GovActionProposal table index for this withdrawal.\ - \Multiple TreasuryWithdrawal may reference the same GovActionProposal." - TreasuryWithdrawalStakeAddressId # "The address that benefits from this withdrawal." - TreasuryWithdrawalAmount # "The amount for this withdrawl." - - Committee --^ do - "A table for new committee proposed on a GovActionProposal. New in 13.2-Conway." - CommitteeGovActionProposalId # "The GovActionProposal table index for this new committee. This can be null for genesis committees." - CommitteeQuorumNumerator # "The proposed quorum nominator." - CommitteeQuorumDenominator # "The proposed quorum denominator." - - CommitteeMember --^ do - "A table for members of the committee. A committee can have multiple members. New in 13.3-Conway." - CommitteeMemberCommitteeId # "The reference to the committee" - CommitteeMemberCommitteeHashId # "The reference to the committee hash" - CommitteeMemberExpirationEpoch # "The epoch this member expires" - - Constitution --^ do - "A table for constitution attached to a GovActionProposal. New in 13.2-Conway." - ConstitutionGovActionProposalId # "The GovActionProposal table index for this constitution." - ConstitutionVotingAnchorId # "The ConstitutionVotingAnchor table index for this constitution." - ConstitutionScriptHash # "The Script Hash. It's associated script may not be already inserted in the script table." - - VotingProcedure --^ do - "A table for voting procedures, aka GovVote. A Vote can be Yes No or Abstain. New in 13.2-Conway." - VotingProcedureTxId # "The Tx table index of the tx that includes this VotingProcedure." - VotingProcedureIndex # "The index of this VotingProcedure within this transaction." - VotingProcedureGovActionProposalId # "The index of the GovActionProposal that this vote targets." - VotingProcedureVoterRole # "The role of the voter. Can be one of ConstitutionalCommittee, DRep, SPO." - VotingProcedureCommitteeVoter # "A reference to the hot key committee hash entry that voted" - VotingProcedureDrepVoter # "A reference to the drep hash entry that voted" - VotingProcedurePoolVoter # "A reference to the pool hash entry that voted" - VotingProcedureVote # "The Vote. Can be one of Yes, No, Abstain." - VotingProcedureVotingAnchorId # "The VotingAnchor table index associated with this VotingProcedure." - VotingProcedureInvalid # "TODO: This is currently not implemented and always stays null. Not null if the vote is invalid." - - OffChainVoteData --^ do - "The table with the offchain metadata related to Vote Anchors. It accepts metadata in a more lenient way than what's\ - \ decribed in CIP-100. New in 13.2-Conway." - OffChainVoteDataVotingAnchorId # "The VotingAnchor table index this offchain data refers." - OffChainVoteDataHash # "The hash of the offchain data." - OffChainVoteDataLanguage # "The langauge described in the context of the metadata. Described in CIP-100. New in 13.3-Conway." - OffChainVoteDataJson # "The payload as JSON." - OffChainVoteDataBytes # "The raw bytes of the payload." - OffChainVoteDataWarning # "A warning that occured while validating the metadata." - OffChainVoteDataIsValid - # "False if the data is found invalid. db-sync leaves this field null \ - \since it normally populates off_chain_vote_fetch_error for invalid data. \ - \It can be used manually to mark some metadata invalid by clients." - - OffChainVoteGovActionData --^ do - "The table with offchain metadata for Governance Actions. Implementes CIP-108. New in 13.3-Conway." - OffChainVoteGovActionDataOffChainVoteDataId # "The vote metadata table index this offchain data belongs to." - OffChainVoteGovActionDataTitle # "The title" - OffChainVoteGovActionDataAbstract # "The abstract" - OffChainVoteGovActionDataMotivation # "The motivation" - OffChainVoteGovActionDataRationale # "The rationale" - - OffChainVoteDrepData --^ do - "The table with offchain metadata for Drep Registrations. Implementes CIP-119. New in 13.3-Conway." - OffChainVoteDrepDataOffChainVoteDataId # "The vote metadata table index this offchain data belongs to." - OffChainVoteDrepDataPaymentAddress # "The payment address" - OffChainVoteDrepDataGivenName # "The name. This is the only mandatory field" - OffChainVoteDrepDataObjectives # "The objectives" - OffChainVoteDrepDataMotivations # "The motivations" - OffChainVoteDrepDataQualifications # "The qualifications" - - OffChainVoteAuthor --^ do - "The table with offchain metadata authors, as decribed in CIP-100. New in 13.3-Conway." - OffChainVoteAuthorOffChainVoteDataId # "The OffChainVoteData table index this offchain data refers." - OffChainVoteAuthorName # "The name of the author." - OffChainVoteAuthorWitnessAlgorithm # "The witness algorithm used by the author." - OffChainVoteAuthorPublicKey # "The public key used by the author." - OffChainVoteAuthorSignature # "The signature of the author." - OffChainVoteAuthorWarning # "A warning related to verifying this metadata." - - OffChainVoteReference --^ do - "The table with offchain metadata references, as decribed in CIP-100. New in 13.3-Conway." - OffChainVoteReferenceOffChainVoteDataId # "The OffChainVoteData table index this entry refers." - OffChainVoteReferenceLabel # "The label of this vote reference." - OffChainVoteReferenceUri # "The uri of this vote reference." - OffChainVoteReferenceHashDigest - # "The hash digest of this vote reference, as described in CIP-108. \ - \This only appears for governance action metadata." - OffChainVoteReferenceHashAlgorithm - # "The hash algorithm of this vote reference, as described in CIP-108. \ - \This only appears for governance action metadata." - - OffChainVoteExternalUpdate --^ do - "The table with offchain metadata external updates, as decribed in CIP-100. New in 13.3-Conway." - OffChainVoteExternalUpdateOffChainVoteDataId # "The OffChainVoteData table index this entry refers." - OffChainVoteExternalUpdateTitle # "The title of this external update." - OffChainVoteExternalUpdateUri # "The uri of this external update." - - OffChainVoteFetchError --^ do - "Errors while fetching or validating offchain Voting Anchor metadata. New in 13.2-Conway." - OffChainVoteFetchErrorVotingAnchorId # "The VotingAnchor table index this offchain fetch error refers." - OffChainVoteFetchErrorFetchError # "The text of the error." - OffChainVoteFetchErrorRetryCount # "The number of retries." - - DrepDistr --^ do - "The table for the distribution of voting power per DRep per. Currently this has a single entry per DRep\ - \ and doesn't show every delegator. This may change. New in 13.2-Conway." - DrepDistrHashId # "The DrepHash table index that this distribution entry has information about." - DrepDistrAmount # "The total amount of voting power this DRep is delegated." - DrepDistrEpochNo # "The epoch no this distribution is about." - DrepDistrActiveUntil # "The epoch until which this drep is active. TODO: This currently remains null always. " - - OffChainPoolData --^ do - "The pool offchain (ie not on chain) for a stake pool." - OffChainPoolDataPoolId # "The PoolHash table index for the pool this offchain data refers." - OffChainPoolDataTickerName # "The pool's ticker name (as many as 5 characters)." - OffChainPoolDataHash # "The hash of the offchain data." - OffChainPoolDataJson # "The payload as JSON." - OffChainPoolDataBytes # "The raw bytes of the payload." - OffChainPoolDataPmrId # "The PoolMetadataRef table index for this offchain data." - - OffChainPoolFetchError --^ do - "A table containing pool offchain data fetch errors." - OffChainPoolFetchErrorPoolId # "The PoolHash table index for the pool this offchain fetch error refers." - OffChainPoolFetchErrorFetchTime # "The UTC time stamp of the error." - OffChainPoolFetchErrorPmrId # "The PoolMetadataRef table index for this offchain data." - OffChainPoolFetchErrorFetchError # "The text of the error." - OffChainPoolFetchErrorRetryCount # "The number of retries." - - ReservedPoolTicker --^ do - "A table containing a managed list of reserved ticker names." - ReservedPoolTickerName # "The ticker name." - ReservedPoolTickerPoolHash # "The hash of the pool that owns this ticker." - - DelistedPool --^ do - "A table containing pools that have been delisted." - DelistedPoolHashRaw # "The pool hash" diff --git a/cardano-db/src/Cardano/Db/Schema/Core.hs b/cardano-db/src/Cardano/Db/Schema/Core.hs new file mode 100644 index 000000000..31929817b --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core.hs @@ -0,0 +1,17 @@ +module Cardano.Db.Schema.Core ( + module Cardano.Db.Schema.Core.Base, + module Cardano.Db.Schema.Core.EpochAndProtocol, + module Cardano.Db.Schema.Core.GovernanceAndVoting, + module Cardano.Db.Schema.Core.MultiAsset, + module Cardano.Db.Schema.Core.OffChain, + module Cardano.Db.Schema.Core.Pool, + module Cardano.Db.Schema.Core.StakeDeligation, +) where + +import Cardano.Db.Schema.Core.Base +import Cardano.Db.Schema.Core.EpochAndProtocol +import Cardano.Db.Schema.Core.GovernanceAndVoting +import Cardano.Db.Schema.Core.MultiAsset +import Cardano.Db.Schema.Core.OffChain +import Cardano.Db.Schema.Core.Pool +import Cardano.Db.Schema.Core.StakeDeligation diff --git a/cardano-db/src/Cardano/Db/Schema/Core/Base.hs b/cardano-db/src/Cardano/Db/Schema/Core/Base.hs new file mode 100644 index 000000000..f04ddf3eb --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/Base.hs @@ -0,0 +1,947 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Schema.Core.Base where + +import Contravariant.Extras (contrazip4) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import Hasql.Decoders as D +import Hasql.Encoders as E + +-- import Cardano.Db.Schema.Orphans () + +import Cardano.Db.Schema.Ids +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types ( + DbLovelace (..), + DbWord64 (..), + ScriptPurpose, + ScriptType, + dbLovelaceDecoder, + dbLovelaceEncoder, + maybeDbWord64Decoder, + maybeDbWord64Encoder, + scriptPurposeDecoder, + scriptPurposeEncoder, + scriptTypeDecoder, + scriptTypeEncoder, + ) + +-- We use camelCase here in the Haskell schema definition and 'persistLowerCase' +-- specifies that all the table and column names are converted to lower snake case. + +-- All NULL-able fields other than 'epochNo' are NULL for EBBs, whereas 'epochNo' is +-- only NULL for the genesis block. + +----------------------------------------------------------------------------------------------------------------------------------- +-- BASE TABLES +-- These tables store fundamental blockchain data, such as blocks, transactions, and UTXOs. +----------------------------------------------------------------------------------------------------------------------------------- + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: block +-- Description: Stores information about individual blocks in the blockchain, including their hash, size, +-- and the transactions they contain. +----------------------------------------------------------------------------------------------------------------------------------- +data Block = Block + { blockHash :: !ByteString -- sqltype=hash32type + , blockEpochNo :: !(Maybe Word64) -- sqltype=word31type + , blockSlotNo :: !(Maybe Word64) -- sqltype=word63type + , blockEpochSlotNo :: !(Maybe Word64) -- sqltype=word31type + , blockBlockNo :: !(Maybe Word64) -- sqltype=word31type + , blockPreviousId :: !(Maybe Int) -- noreference + , blockSlotLeaderId :: !SlotLeaderId -- noreference + , blockSize :: !Word64 -- sqltype=word31type + , blockTime :: !UTCTime -- sqltype=timestamp + , blockTxCount :: !Word64 + , blockProtoMajor :: !Word16 -- sqltype=word31type + , blockProtoMinor :: !Word16 -- sqltype=word31type + -- Shelley specific + , blockVrfKey :: !(Maybe Text) + , blockOpCert :: !(Maybe ByteString) -- sqltype=hash32type + , blockOpCertCounter :: !(Maybe Word64) -- sqltype=hash63type + } + deriving (Eq, Show, Generic) + +type instance Key Block = BlockId +instance DbInfo Block where + uniqueFields _ = ["hash"] + +entityBlockDecoder :: D.Row (Entity Block) +entityBlockDecoder = + Entity + <$> idDecoder BlockId + <*> blockDecoder + +blockDecoder :: D.Row Block +blockDecoder = + Block + <$> D.column (D.nonNullable D.bytea) -- blockHash + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- blockEpochNo + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- blockSlotNo + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- blockEpochSlotNo + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- blockBlockNo + <*> D.column (D.nullable $ fromIntegral <$> D.int4) -- blockPreviousId + <*> idDecoder SlotLeaderId -- blockSlotLeaderId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- blockSize + <*> D.column (D.nonNullable D.timestamptz) -- blockTime + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- blockTxCount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- blockProtoMajor + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- blockProtoMinor + <*> D.column (D.nullable D.text) -- blockVrfKey + <*> D.column (D.nullable D.bytea) -- blockOpCert + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- blockOpCertCounter + +entityBlockEncoder :: E.Params (Entity Block) +entityBlockEncoder = + mconcat + [ entityKey >$< idEncoder getBlockId + , entityVal >$< blockEncoder + ] + +blockEncoder :: E.Params Block +blockEncoder = + mconcat + [ blockEpochNo >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , blockSlotNo >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , blockEpochSlotNo >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , blockBlockNo >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , blockPreviousId >$< E.param (E.nullable $ fromIntegral >$< E.int4) + , blockSlotLeaderId >$< idEncoder getSlotLeaderId + , blockSize >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , blockTime >$< E.param (E.nonNullable E.timestamptz) + , blockTxCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , blockProtoMajor >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , blockProtoMinor >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , blockVrfKey >$< E.param (E.nullable E.text) + , blockOpCert >$< E.param (E.nullable E.bytea) + , blockOpCertCounter >$< E.param (E.nullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: tx +-- Description: Contains data related to transactions, such as transaction ID, inputs, outputs, and metadata +data Tx = Tx + { txHash :: !ByteString -- sqltype=hash32type + , txBlockId :: !BlockId -- noreference -- This type is the primary key for the 'block' table. + , txBlockIndex :: !Word64 -- sqltype=word31type -- The index of this transaction within the block. + , txOutSum :: !DbLovelace -- sqltype=lovelace + , txFee :: !DbLovelace -- sqltype=lovelace + , txDeposit :: !(Maybe Int64) -- Needs to allow negaitve values. + , txSize :: !Word64 -- sqltype=word31type + -- New for Allega + , txInvalidBefore :: !(Maybe DbWord64) -- sqltype=word64type + , txInvalidHereafter :: !(Maybe DbWord64) -- sqltype=word64type + -- New for Alonzo + , txValidContract :: !Bool -- False if the contract is invalid, True otherwise. + , txScriptSize :: !Word64 -- sqltype=word31type + -- New for Conway + , txTreasuryDonation :: !DbLovelace -- sqltype=lovelace default=0 + } + deriving (Show, Eq, Generic) + +type instance Key Tx = TxId +instance DbInfo Tx where + uniqueFields _ = ["hash"] + +entityTxDecoder :: D.Row (Entity Tx) +entityTxDecoder = + Entity + <$> idDecoder TxId + <*> txDecoder + +txDecoder :: D.Row Tx +txDecoder = + Tx + <$> D.column (D.nonNullable D.bytea) -- txHash + <*> idDecoder BlockId -- txBlockId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- txBlockIndex + <*> dbLovelaceDecoder -- txOutSum + <*> dbLovelaceDecoder -- txFee + <*> D.column (D.nullable D.int8) -- txDeposit + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- txSize + <*> maybeDbWord64Decoder -- txInvalidBefore + <*> maybeDbWord64Decoder -- txInvalidHereafter + <*> D.column (D.nonNullable D.bool) -- txValidContract + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- txScriptSize + <*> dbLovelaceDecoder -- txTreasuryDonation + +entityTxEncoder :: E.Params (Entity Tx) +entityTxEncoder = + mconcat + [ entityKey >$< idEncoder getTxId + , entityVal >$< txEncoder + ] + +txEncoder :: E.Params Tx +txEncoder = + mconcat + [ txHash >$< E.param (E.nonNullable E.bytea) + , txBlockId >$< idEncoder getBlockId + , txBlockIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , txOutSum >$< dbLovelaceEncoder + , txFee >$< dbLovelaceEncoder + , txDeposit >$< E.param (E.nullable E.int8) + , txSize >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , txInvalidBefore >$< maybeDbWord64Encoder + , txInvalidHereafter >$< maybeDbWord64Encoder + , txValidContract >$< E.param (E.nonNullable E.bool) + , txScriptSize >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , txTreasuryDonation >$< dbLovelaceEncoder + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: txmetadata +-- Description: Contains metadata associated with transactions, such as metadata ID, key, and date. +----------------------------------------------------------------------------------------------------------------------------------- +data TxMetadata = TxMetadata + { txMetadataKey :: !DbWord64 -- sqltype=word64type + , txMetadataJson :: !(Maybe Text) -- sqltype=jsonb + , txMetadataBytes :: !ByteString -- sqltype=bytea + , txMetadataTxId :: !TxId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key TxMetadata = TxMetadataId +instance DbInfo TxMetadata + +entityTxMetadataDecoder :: D.Row (Entity TxMetadata) +entityTxMetadataDecoder = + Entity + <$> idDecoder TxMetadataId + <*> txMetadataDecoder + +txMetadataDecoder :: D.Row TxMetadata +txMetadataDecoder = + TxMetadata + <$> D.column (D.nonNullable $ DbWord64 . fromIntegral <$> D.int8) -- txMetadataKey + <*> D.column (D.nullable D.text) -- txMetadataJson + <*> D.column (D.nonNullable D.bytea) -- txMetadataBytes + <*> idDecoder TxId -- txMetadataTxId + +entityTxMetadataEncoder :: E.Params (Entity TxMetadata) +entityTxMetadataEncoder = + mconcat + [ entityKey >$< idEncoder getTxMetadataId + , entityVal >$< txMetadataEncoder + ] + +txMetadataEncoder :: E.Params TxMetadata +txMetadataEncoder = + mconcat + [ txMetadataKey >$< E.param (E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + , txMetadataJson >$< E.param (E.nullable E.text) + , txMetadataBytes >$< E.param (E.nonNullable E.bytea) + , txMetadataTxId >$< idEncoder getTxId + ] + +txMetadataBulkEncoder :: E.Params ([DbWord64], [Maybe Text], [ByteString], [TxId]) +txMetadataBulkEncoder = + contrazip4 + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + (bulkEncoder $ E.nullable E.text) + (bulkEncoder $ E.nonNullable E.bytea) + (bulkEncoder $ E.nonNullable $ getTxId >$< E.int8) + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: txin +-- Description: Represents the input side of a transaction, linking to previous transaction outputs being spent +----------------------------------------------------------------------------------------------------------------------------------- +data TxIn = TxIn + { txInTxInId :: !TxId -- The transaction where this is used as an input. + , txInTxOutId :: !TxId -- The transaction where this was created as an output. + , txInTxOutIndex :: !Word64 -- sqltype=txindex + , txInRedeemerId :: !(Maybe RedeemerId) + } + deriving (Show, Eq, Generic) + +type instance Key TxIn = TxInId +instance DbInfo TxIn + +entityTxInDecoder :: D.Row (Entity TxIn) +entityTxInDecoder = + Entity + <$> idDecoder TxInId + <*> txInDecoder + +txInDecoder :: D.Row TxIn +txInDecoder = + TxIn + <$> idDecoder TxId -- txInTxInId + <*> idDecoder TxId -- txInTxOutId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- txInTxOutIndex + <*> maybeIdDecoder RedeemerId -- txInRedeemerId + +entityTxInEncoder :: E.Params (Entity TxIn) +entityTxInEncoder = + mconcat + [ entityKey >$< idEncoder getTxInId + , entityVal >$< txInEncoder + ] + +txInEncoder :: E.Params TxIn +txInEncoder = + mconcat + [ txInTxInId >$< idEncoder getTxId + , txInTxOutId >$< idEncoder getTxId + , txInTxOutIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , txInRedeemerId >$< maybeIdEncoder getRedeemerId + ] + +encodeTxInBulk :: E.Params ([TxId], [TxId], [Word64], [Maybe RedeemerId]) +encodeTxInBulk = + contrazip4 + (bulkEncoder $ E.nonNullable $ getTxId >$< E.int8) + (bulkEncoder $ E.nonNullable $ getTxId >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + (bulkEncoder $ E.nullable $ getRedeemerId >$< E.int8) + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: collateral_txin +-- Description: Represents the input side of a transaction, linking to previous transaction outputs being spent +----------------------------------------------------------------------------------------------------------------------------------- +data CollateralTxIn = CollateralTxIn + { collateralTxInTxInId :: !TxId -- noreference -- The transaction where this is used as an input. + , collateralTxInTxOutId :: !TxId -- noreference -- The transaction where this was created as an output. + , collateralTxInTxOutIndex :: !Word64 -- sqltype=txindex + } + deriving (Show, Eq, Generic) + +type instance Key CollateralTxIn = CollateralTxInId +instance DbInfo CollateralTxIn + +entityCollateralTxInDecoder :: D.Row (Entity CollateralTxIn) +entityCollateralTxInDecoder = + Entity + <$> idDecoder CollateralTxInId + <*> collateralTxInDecoder + +collateralTxInDecoder :: D.Row CollateralTxIn +collateralTxInDecoder = + CollateralTxIn + <$> idDecoder TxId -- collateralTxInTxInId + <*> idDecoder TxId -- collateralTxInTxOutId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- collateralTxInTxOutIndex + +entityCollateralTxInEncoder :: E.Params (Entity CollateralTxIn) +entityCollateralTxInEncoder = + mconcat + [ entityKey >$< idEncoder getCollateralTxInId + , entityVal >$< collateralTxInEncoder + ] + +collateralTxInEncoder :: E.Params CollateralTxIn +collateralTxInEncoder = + mconcat + [ collateralTxInTxInId >$< idEncoder getTxId + , collateralTxInTxOutId >$< idEncoder getTxId + , collateralTxInTxOutIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: reference_txin +-- Description: Represents the input side of a transaction, linking to previous transaction outputs being spent +----------------------------------------------------------------------------------------------------------------------------------- +data ReferenceTxIn = ReferenceTxIn + { referenceTxInTxInId :: !TxId -- noreference -- The transaction where this is used as an input. + , referenceTxInTxOutId :: !TxId -- noreference -- The transaction where this was created as an output. + , referenceTxInTxOutIndex :: !Word64 -- sqltype=txindex + } + deriving (Show, Eq, Generic) + +type instance Key ReferenceTxIn = ReferenceTxInId +instance DbInfo ReferenceTxIn + +entityReferenceTxInDecoder :: D.Row (Entity ReferenceTxIn) +entityReferenceTxInDecoder = + Entity + <$> idDecoder ReferenceTxInId + <*> referenceTxInDecoder + +referenceTxInDecoder :: D.Row ReferenceTxIn +referenceTxInDecoder = + ReferenceTxIn + <$> idDecoder TxId -- referenceTxInTxInId + <*> idDecoder TxId -- referenceTxInTxOutId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- referenceTxInTxOutIndex + +entityReferenceTxInEncoder :: E.Params (Entity ReferenceTxIn) +entityReferenceTxInEncoder = + mconcat + [ entityKey >$< idEncoder getReferenceTxInId + , entityVal >$< referenceTxInEncoder + ] + +referenceTxInEncoder :: E.Params ReferenceTxIn +referenceTxInEncoder = + mconcat + [ referenceTxInTxInId >$< idEncoder getTxId + , referenceTxInTxOutId >$< idEncoder getTxId + , referenceTxInTxOutIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: reverse_index +-- Description: Provides a reverse lookup mechanism for transaction inputs, allowing efficient querying of the origin of funds. +----------------------------------------------------------------------------------------------------------------------------------- +data ReverseIndex = ReverseIndex + { reverseIndexBlockId :: !BlockId -- noreference + , reverseIndexMinIds :: !Text + } + deriving (Show, Eq, Generic) + +type instance Key ReverseIndex = ReverseIndexId +instance DbInfo ReverseIndex + +entityReverseIndexDecoder :: D.Row (Entity ReverseIndex) +entityReverseIndexDecoder = + Entity + <$> idDecoder ReverseIndexId + <*> reverseIndexDecoder + +reverseIndexDecoder :: D.Row ReverseIndex +reverseIndexDecoder = + ReverseIndex + <$> idDecoder BlockId -- reverseIndexBlockId + <*> D.column (D.nonNullable D.text) -- reverseIndexMinIds + +entityReverseIndexEncoder :: E.Params (Entity ReverseIndex) +entityReverseIndexEncoder = + mconcat + [ entityKey >$< idEncoder getReverseIndexId + , entityVal >$< reverseIndexEncoder + ] + +reverseIndexEncoder :: E.Params ReverseIndex +reverseIndexEncoder = + mconcat + [ reverseIndexBlockId >$< idEncoder getBlockId + , reverseIndexMinIds >$< E.param (E.nonNullable E.text) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: txcbor +-- Description: Stores the raw CBOR (Concise Binary Object Representation) encoding of transactions, useful for validation +-- and serialization purposes. +----------------------------------------------------------------------------------------------------------------------------------- +data TxCbor = TxCbor + { txCborTxId :: !TxId -- noreference + , txCborBytes :: !ByteString -- sqltype=bytea + } + deriving (Show, Eq, Generic) + +type instance Key TxCbor = TxCborId +instance DbInfo TxCbor + +entityTxCborDecoder :: D.Row (Entity TxCbor) +entityTxCborDecoder = + Entity + <$> idDecoder TxCborId + <*> txCborDecoder + +txCborDecoder :: D.Row TxCbor +txCborDecoder = + TxCbor + <$> idDecoder TxId -- txCborTxId + <*> D.column (D.nonNullable D.bytea) -- txCborBytes + +entityTxCborEncoder :: E.Params (Entity TxCbor) +entityTxCborEncoder = + mconcat + [ entityKey >$< idEncoder getTxCborId + , entityVal >$< txCborEncoder + ] + +txCborEncoder :: E.Params TxCbor +txCborEncoder = + mconcat + [ txCborTxId >$< idEncoder getTxId + , txCborBytes >$< E.param (E.nonNullable E.bytea) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: datum +-- Description: Contains the data associated with a transaction output, which can be used as input for a script. +----------------------------------------------------------------------------------------------------------------------------------- +data Datum = Datum + { datumHash :: !ByteString -- sqltype=hash32type + , datumTxId :: !TxId -- noreference + , datumValue :: !(Maybe Text) -- sqltype=jsonb + , datumBytes :: !ByteString -- sqltype=bytea + } + deriving (Eq, Show, Generic) + +type instance Key Datum = DatumId +instance DbInfo Datum where + uniqueFields _ = ["hash"] + +entityDatumDecoder :: D.Row (Entity Datum) +entityDatumDecoder = + Entity + <$> idDecoder DatumId + <*> datumDecoder + +datumDecoder :: D.Row Datum +datumDecoder = + Datum + <$> D.column (D.nonNullable D.bytea) -- datumHash + <*> idDecoder TxId -- datumTxId + <*> D.column (D.nullable D.text) -- datumValue + <*> D.column (D.nonNullable D.bytea) -- datumBytes + +entityDatumEncoder :: E.Params (Entity Datum) +entityDatumEncoder = + mconcat + [ entityKey >$< idEncoder getDatumId + , entityVal >$< datumEncoder + ] + +datumEncoder :: E.Params Datum +datumEncoder = + mconcat + [ datumHash >$< E.param (E.nonNullable E.bytea) + , datumTxId >$< idEncoder getTxId + , datumValue >$< E.param (E.nullable E.text) + , datumBytes >$< E.param (E.nonNullable E.bytea) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: script +-- Description: Contains the script associated with a transaction output, which can be used as input for a script. +----------------------------------------------------------------------------------------------------------------------------------- +data Script = Script + { scriptTxId :: !TxId -- noreference + , scriptHash :: !ByteString -- sqltype=hash28type + , scriptType :: !ScriptType -- sqltype=scripttype + , scriptJson :: !(Maybe Text) -- sqltype=jsonb + , scriptBytes :: !(Maybe ByteString) -- sqltype=bytea + , scriptSerialisedSize :: !(Maybe Word64) -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key Script = ScriptId +instance DbInfo Script where + uniqueFields _ = ["hash"] + +entityScriptDecoder :: D.Row (Entity Script) +entityScriptDecoder = + Entity + <$> idDecoder ScriptId + <*> scriptDecoder + +scriptDecoder :: D.Row Script +scriptDecoder = + Script + <$> idDecoder TxId -- scriptTxId + <*> D.column (D.nonNullable D.bytea) -- scriptHash + <*> D.column (D.nonNullable scriptTypeDecoder) -- scriptType + <*> D.column (D.nullable D.text) -- scriptJson + <*> D.column (D.nullable D.bytea) -- scriptBytes + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- scriptSerialisedSize + +entityScriptEncoder :: E.Params (Entity Script) +entityScriptEncoder = + mconcat + [ entityKey >$< idEncoder getScriptId + , entityVal >$< scriptEncoder + ] + +scriptEncoder :: E.Params Script +scriptEncoder = + mconcat + [ scriptTxId >$< idEncoder getTxId + , scriptHash >$< E.param (E.nonNullable E.bytea) + , scriptType >$< E.param (E.nonNullable scriptTypeEncoder) + , scriptJson >$< E.param (E.nullable E.text) + , scriptBytes >$< E.param (E.nullable E.bytea) + , scriptSerialisedSize >$< E.param (E.nullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: redeemer +-- Description: Holds the redeemer data used to satisfy script conditions during transaction processing. +----------------------------------------------------------------------------------------------------------------------------------- + +-- Unit step is in picosends, and `maxBound :: !Int64` picoseconds is over 100 days, so using +-- Word64/word63type is safe here. Similarly, `maxBound :: !Int64` if unit step would be an + +-- * enormous* amount a memory which would cost a fortune. + +data Redeemer = Redeemer + { redeemerTxId :: !TxId -- noreference + , redeemerUnitMem :: !Word64 -- sqltype=word63type + , redeemerUnitSteps :: !Word64 -- sqltype=word63type + , redeemerFee :: !(Maybe DbLovelace) -- sqltype=lovelace + , redeemerPurpose :: !ScriptPurpose -- sqltype=scriptpurposetype + , redeemerIndex :: !Word64 -- sqltype=word31type + , redeemerScriptHash :: !(Maybe ByteString) -- sqltype=hash28type + , redeemerRedeemerDataId :: !RedeemerDataId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key Redeemer = RedeemerId +instance DbInfo Redeemer + +entityRedeemerDecoder :: D.Row (Entity Redeemer) +entityRedeemerDecoder = + Entity + <$> idDecoder RedeemerId + <*> redeemerDecoder + +redeemerDecoder :: D.Row Redeemer +redeemerDecoder = + Redeemer + <$> idDecoder TxId -- redeemerTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- redeemerUnitMem + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- redeemerUnitSteps + <*> D.column (D.nullable $ DbLovelace . fromIntegral <$> D.int8) -- redeemerFee + <*> D.column (D.nonNullable scriptPurposeDecoder) -- redeemerPurpose + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- redeemerIndex + <*> D.column (D.nullable D.bytea) -- redeemerScriptHash + <*> idDecoder RedeemerDataId -- redeemerRedeemerDataId + +entityRedeemerEncoder :: E.Params (Entity Redeemer) +entityRedeemerEncoder = + mconcat + [ entityKey >$< idEncoder getRedeemerId + , entityVal >$< redeemerEncoder + ] + +redeemerEncoder :: E.Params Redeemer +redeemerEncoder = + mconcat + [ redeemerTxId >$< idEncoder getTxId + , redeemerUnitMem >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , redeemerUnitSteps >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , redeemerFee >$< E.param (E.nullable $ fromIntegral . unDbLovelace >$< E.int8) + , redeemerPurpose >$< E.param (E.nonNullable scriptPurposeEncoder) + , redeemerIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , redeemerScriptHash >$< E.param (E.nullable E.bytea) + , redeemerRedeemerDataId >$< idEncoder getRedeemerDataId + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: redeemer_data +-- Description: Additional details about the redeemer, including its type and any associated metadata. +----------------------------------------------------------------------------------------------------------------------------------- +data RedeemerData = RedeemerData + { redeemerDataHash :: !ByteString -- sqltype=hash32type + , redeemerDataTxId :: !TxId -- noreference + , redeemerDataValue :: !(Maybe Text) -- sqltype=jsonb + , redeemerDataBytes :: !ByteString -- sqltype=bytea + } + deriving (Eq, Show, Generic) + +type instance Key RedeemerData = RedeemerDataId +instance DbInfo RedeemerData where + uniqueFields _ = ["hash"] + +entityRedeemerDataDecoder :: D.Row (Entity RedeemerData) +entityRedeemerDataDecoder = + Entity + <$> idDecoder RedeemerDataId + <*> redeemerDataDecoder + +redeemerDataDecoder :: D.Row RedeemerData +redeemerDataDecoder = + RedeemerData + <$> D.column (D.nonNullable D.bytea) -- redeemerDataHash + <*> idDecoder TxId -- redeemerDataTxId + <*> D.column (D.nullable D.text) -- redeemerDataValue + <*> D.column (D.nonNullable D.bytea) -- redeemerDataBytes + +entityRedeemerDataEncoder :: E.Params (Entity RedeemerData) +entityRedeemerDataEncoder = + mconcat + [ entityKey >$< idEncoder getRedeemerDataId + , entityVal >$< redeemerDataEncoder + ] + +redeemerDataEncoder :: E.Params RedeemerData +redeemerDataEncoder = + mconcat + [ redeemerDataHash >$< E.param (E.nonNullable E.bytea) + , redeemerDataTxId >$< idEncoder getTxId + , redeemerDataValue >$< E.param (E.nullable E.text) + , redeemerDataBytes >$< E.param (E.nonNullable E.bytea) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: extra_key_witness +-- Description: Contains additional key witnesses for transactions, which are used to validate the transaction's signature. +----------------------------------------------------------------------------------------------------------------------------------- +data ExtraKeyWitness = ExtraKeyWitness + { extraKeyWitnessHash :: !ByteString -- sqltype=hash28type + , extraKeyWitnessTxId :: !TxId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key ExtraKeyWitness = ExtraKeyWitnessId +instance DbInfo ExtraKeyWitness + +entityExtraKeyWitnessDecoder :: D.Row (Entity ExtraKeyWitness) +entityExtraKeyWitnessDecoder = + Entity + <$> idDecoder ExtraKeyWitnessId + <*> extraKeyWitnessDecoder + +extraKeyWitnessDecoder :: D.Row ExtraKeyWitness +extraKeyWitnessDecoder = + ExtraKeyWitness + <$> D.column (D.nonNullable D.bytea) -- extraKeyWitnessHash + <*> idDecoder TxId -- extraKeyWitnessTxId + +entityExtraKeyWitnessEncoder :: E.Params (Entity ExtraKeyWitness) +entityExtraKeyWitnessEncoder = + mconcat + [ entityKey >$< idEncoder getExtraKeyWitnessId + , entityVal >$< extraKeyWitnessEncoder + ] + +extraKeyWitnessEncoder :: E.Params ExtraKeyWitness +extraKeyWitnessEncoder = + mconcat + [ extraKeyWitnessHash >$< E.param (E.nonNullable E.bytea) + , extraKeyWitnessTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: slot_leader +-- Description:Contains information about the slot leader for a given block, including the slot leader's ID, hash, and description. +----------------------------------------------------------------------------------------------------------------------------------- + +data SlotLeader = SlotLeader + { slotLeaderHash :: !ByteString -- sqltype=hash28type + , slotLeaderPoolHashId :: !(Maybe Int) -- This will be non-null when a block is mined by a pool + , slotLeaderDescription :: !Text -- Description of the Slots leader + } + deriving (Eq, Show, Generic) + +type instance Key SlotLeader = SlotLeaderId +instance DbInfo SlotLeader where + uniqueFields _ = ["hash"] + +entitySlotLeaderDecoder :: D.Row (Entity SlotLeader) +entitySlotLeaderDecoder = + Entity + <$> idDecoder SlotLeaderId + <*> slotLeaderDecoder + +slotLeaderDecoder :: D.Row SlotLeader +slotLeaderDecoder = + SlotLeader + <$> D.column (D.nonNullable D.bytea) -- slotLeaderHash + <*> D.column (D.nullable $ fromIntegral <$> D.int4) -- slotLeaderPoolHashId + <*> D.column (D.nonNullable D.text) -- slotLeaderDescription + +entitySlotLeaderEncoder :: E.Params (Entity SlotLeader) +entitySlotLeaderEncoder = + mconcat + [ entityKey >$< idEncoder getSlotLeaderId + , entityVal >$< slotLeaderEncoder + ] + +slotLeaderEncoder :: E.Params SlotLeader +slotLeaderEncoder = + mconcat + [ slotLeaderHash >$< E.param (E.nonNullable E.bytea) + , slotLeaderPoolHashId >$< E.param (E.nullable $ fromIntegral >$< E.int4) + , slotLeaderDescription >$< E.param (E.nonNullable E.text) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- SYSTEM +-- These tables are used for database maintenance, versioning, and migrations. +----------------------------------------------------------------------------------------------------------------------------------- + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: schema_version +-- Description: A table for schema versioning. +----------------------------------------------------------------------------------------------------------------------------------- +-- Schema versioning has three stages to best allow handling of schema migrations. +-- Stage 1: Set up PostgreSQL data types (using SQL 'DOMAIN' statements). +-- Stage 2: Persistent generated migrations. +-- Stage 3: Set up 'VIEW' tables (for use by other languages and applications). +-- This table should have a single row. +data SchemaVersion = SchemaVersion + { schemaVersionStageOne :: !Int + , schemaVersionStageTwo :: !Int + , schemaVersionStageThree :: !Int + } + deriving (Eq, Show, Generic) + +type instance Key SchemaVersion = SchemaVersionId +instance DbInfo SchemaVersion + +entitySchemaVersionDecoder :: D.Row (Entity SchemaVersion) +entitySchemaVersionDecoder = + Entity + <$> idDecoder SchemaVersionId + <*> schemaVersionDecoder + +schemaVersionDecoder :: D.Row SchemaVersion +schemaVersionDecoder = + SchemaVersion + <$> D.column (D.nonNullable $ fromIntegral <$> D.int4) -- schemaVersionStageOne + <*> D.column (D.nonNullable $ fromIntegral <$> D.int4) -- schemaVersionStageTwo + <*> D.column (D.nonNullable $ fromIntegral <$> D.int4) -- schemaVersionStageThree + +entitySchemaVersionEncoder :: E.Params (Entity SchemaVersion) +entitySchemaVersionEncoder = + mconcat + [ entityKey >$< idEncoder getSchemaVersionId + , entityVal >$< schemaVersionEncoder + ] + +schemaVersionEncoder :: E.Params SchemaVersion +schemaVersionEncoder = + mconcat + [ schemaVersionStageOne >$< E.param (E.nonNullable $ fromIntegral >$< E.int4) + , schemaVersionStageTwo >$< E.param (E.nonNullable $ fromIntegral >$< E.int4) + , schemaVersionStageThree >$< E.param (E.nonNullable $ fromIntegral >$< E.int4) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: meta +-- Description: A table containing metadata about the chain. There will probably only ever be one value in this table +----------------------------------------------------------------------------------------------------------------------------------- +data Meta = Meta + { metaStartTime :: !UTCTime -- sqltype=timestamp + , metaNetworkName :: !Text + , metaVersion :: !Text + } + deriving (Show, Eq, Generic) + +type instance Key Meta = MetaId +instance DbInfo Meta where + uniqueFields _ = ["start_time"] + +entityMetaDecoder :: D.Row (Entity Meta) +entityMetaDecoder = + Entity + <$> idDecoder MetaId + <*> metaDecoder + +metaDecoder :: D.Row Meta +metaDecoder = + Meta + <$> D.column (D.nonNullable D.timestamptz) -- metaStartTime + <*> D.column (D.nonNullable D.text) -- metaNetworkName + <*> D.column (D.nonNullable D.text) -- metaVersion + +entityMetaEncoder :: E.Params (Entity Meta) +entityMetaEncoder = + mconcat + [ entityKey >$< idEncoder getMetaId + , entityVal >$< metaEncoder + ] + +metaEncoder :: E.Params Meta +metaEncoder = + mconcat + [ metaStartTime >$< E.param (E.nonNullable E.timestamptz) + , metaNetworkName >$< E.param (E.nonNullable E.text) + , metaVersion >$< E.param (E.nonNullable E.text) + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: migration +-- Description: A table containing information about migrations. +----------------------------------------------------------------------------------------------------------------------------------- +data Withdrawal = Withdrawal + { withdrawalAddrId :: !StakeAddressId + , withdrawalAmount :: !DbLovelace + , withdrawalRedeemerId :: !(Maybe RedeemerId) + , withdrawalTxId :: !TxId + } + deriving (Eq, Show, Generic) + +type instance Key Withdrawal = WithdrawalId +instance DbInfo Withdrawal + +entityWithdrawalDecoder :: D.Row (Entity Withdrawal) +entityWithdrawalDecoder = + Entity + <$> idDecoder WithdrawalId + <*> withdrawalDecoder + +withdrawalDecoder :: D.Row Withdrawal +withdrawalDecoder = + Withdrawal + <$> idDecoder StakeAddressId -- withdrawalAddrId + <*> dbLovelaceDecoder -- withdrawalAmount + <*> maybeIdDecoder RedeemerId -- withdrawalRedeemerId + <*> idDecoder TxId -- withdrawalTxId + +entityWithdrawalEncoder :: E.Params (Entity Withdrawal) +entityWithdrawalEncoder = + mconcat + [ entityKey >$< idEncoder getWithdrawalId + , entityVal >$< withdrawalEncoder + ] + +withdrawalEncoder :: E.Params Withdrawal +withdrawalEncoder = + mconcat + [ withdrawalAddrId >$< idEncoder getStakeAddressId + , withdrawalAmount >$< dbLovelaceEncoder + , withdrawalRedeemerId >$< maybeIdEncoder getRedeemerId + , withdrawalTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: extra_migrations +-- Description: = A table containing information about extra migrations. +----------------------------------------------------------------------------------------------------------------------------------- +data ExtraMigrations = ExtraMigrations + { extraMigrationsToken :: !Text + , extraMigrationsDescription :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key ExtraMigrations = ExtraMigrationsId +instance DbInfo ExtraMigrations + +entityExtraMigrationsDecoder :: D.Row (Entity ExtraMigrations) +entityExtraMigrationsDecoder = + Entity + <$> idDecoder ExtraMigrationsId + <*> extraMigrationsDecoder + +extraMigrationsDecoder :: D.Row ExtraMigrations +extraMigrationsDecoder = + ExtraMigrations + <$> D.column (D.nonNullable D.text) -- extraMigrationsToken + <*> D.column (D.nullable D.text) -- extraMigrationsDescription + +entityExtraMigrationsEncoder :: E.Params (Entity ExtraMigrations) +entityExtraMigrationsEncoder = + mconcat + [ entityKey >$< idEncoder getExtraMigrationsId + , entityVal >$< extraMigrationsEncoder + ] + +extraMigrationsEncoder :: E.Params ExtraMigrations +extraMigrationsEncoder = + mconcat + [ extraMigrationsToken >$< E.param (E.nonNullable E.text) + , extraMigrationsDescription >$< E.param (E.nullable E.text) + ] diff --git a/cardano-db/src/Cardano/Db/Schema/Core/EpochAndProtocol.hs b/cardano-db/src/Cardano/Db/Schema/Core/EpochAndProtocol.hs new file mode 100644 index 000000000..9b1f3693c --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/EpochAndProtocol.hs @@ -0,0 +1,652 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Schema.Core.EpochAndProtocol where + +import Cardano.Db.Schema.Ids +import Cardano.Db.Schema.Orphans () +import Cardano.Db.Types ( + DbInt65, + DbLovelace (..), + DbWord64, + SyncState, + dbInt65Decoder, + dbInt65Encoder, + dbLovelaceDecoder, + dbLovelaceEncoder, + maybeDbWord64Decoder, + maybeDbWord64Encoder, + syncStateDecoder, + syncStateEncoder, + word128Decoder, + word128Encoder, + ) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.WideWord.Word128 (Word128) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) + +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Contravariant.Extras (contrazip4) +import Hasql.Decoders as D +import Hasql.Encoders as E + +----------------------------------------------------------------------------------------------------------------------------------- +-- EPOCH AND PROTOCOL PARAMETER +-- These tables store fundamental blockchain data, such as blocks, transactions, and UTXOs. +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: epoch +-- Description: The Epoch table is an aggregation of data in the 'Block' table, but is kept in this form +-- because having it as a 'VIEW' is incredibly slow and inefficient. +-- The 'outsum' type in the PostgreSQL world is 'bigint >= 0' so it will error out if an +-- overflow (sum of tx outputs in an epoch) is detected. 'maxBound :: !Int` is big enough to +-- hold 204 times the total Lovelace distribution. The chance of that much being transacted +-- in a single epoch is relatively low. +data Epoch = Epoch + { epochOutSum :: !Word128 -- sqltype=word128type + , epochFees :: !DbLovelace -- sqltype=lovelace + , epochTxCount :: !Word64 -- sqltype=word31type + , epochBlkCount :: !Word64 -- sqltype=word31type + , epochNo :: !Word64 -- sqltype=word31type + , epochStartTime :: !UTCTime -- sqltype=timestamp + , epochEndTime :: !UTCTime -- sqltype=timestamp + } + deriving (Eq, Show, Generic) + +type instance Key Epoch = EpochId +instance DbInfo Epoch where + uniqueFields _ = ["no"] + +entityEpochDecoder :: D.Row (Entity Epoch) +entityEpochDecoder = + Entity + <$> idDecoder EpochId + <*> epochDecoder + +epochDecoder :: D.Row Epoch +epochDecoder = + Epoch + <$> D.column (D.nonNullable word128Decoder) -- epochOutSum + <*> dbLovelaceDecoder -- epochFees + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochTxCount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochBlkCount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochNo + <*> D.column (D.nonNullable D.timestamptz) -- epochStartTime + <*> D.column (D.nonNullable D.timestamptz) -- epochEndTime + +entityEpochEncoder :: E.Params (Entity Epoch) +entityEpochEncoder = + mconcat + [ entityKey >$< idEncoder getEpochId + , entityVal >$< epochEncoder + ] + +epochEncoder :: E.Params Epoch +epochEncoder = + mconcat + [ epochOutSum >$< E.param (E.nonNullable word128Encoder) + , epochFees >$< dbLovelaceEncoder + , epochTxCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochBlkCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochStartTime >$< E.param (E.nonNullable E.timestamptz) + , epochEndTime >$< E.param (E.nonNullable E.timestamptz) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: epochparam +-- Description: Stores parameters relevant to each epoch, such as the number of slots per epoch or the block size limit. +data EpochParam = EpochParam + { epochParamEpochNo :: !Word64 -- sqltype=word31type + , epochParamMinFeeA :: !Word64 -- sqltype=word31type + , epochParamMinFeeB :: !Word64 -- sqltype=word31type + , epochParamMaxBlockSize :: !Word64 -- sqltype=word31type + , epochParamMaxTxSize :: !Word64 -- sqltype=word31type + , epochParamMaxBhSize :: !Word64 -- sqltype=word31type + , epochParamKeyDeposit :: !DbLovelace -- sqltype=lovelace + , epochParamPoolDeposit :: !DbLovelace -- sqltype=lovelace + , epochParamMaxEpoch :: !Word64 -- sqltype=word31type + , epochParamOptimalPoolCount :: !Word64 -- sqltype=word31type + , epochParamInfluence :: !Double + , epochParamMonetaryExpandRate :: !Double + , epochParamTreasuryGrowthRate :: !Double + , epochParamDecentralisation :: !Double + , epochParamProtocolMajor :: !Word16 -- sqltype=word31type + , epochParamProtocolMinor :: !Word16 -- sqltype=word31type + , epochParamMinUtxoValue :: !DbLovelace -- sqltype=lovelace + , epochParamMinPoolCost :: !DbLovelace -- sqltype=lovelace + , epochParamNonce :: !(Maybe ByteString) -- sqltype=hash32type + , epochParamCoinsPerUtxoSize :: !(Maybe DbLovelace) -- sqltype=lovelace + , epochParamCostModelId :: !(Maybe CostModelId) -- noreference + , epochParamPriceMem :: !(Maybe Double) + , epochParamPriceStep :: !(Maybe Double) + , epochParamMaxTxExMem :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamMaxTxExSteps :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamMaxBlockExMem :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamMaxBlockExSteps :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamMaxValSize :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamCollateralPercent :: !(Maybe Word16) -- sqltype=word31type + , epochParamMaxCollateralInputs :: !(Maybe Word16) -- sqltype=word31type + , epochParamBlockId :: !BlockId -- noreference -- The first block where these parameters are valid. + , epochParamExtraEntropy :: !(Maybe ByteString) -- sqltype=hash32type + , epochParamPvtMotionNoConfidence :: !(Maybe Double) + , epochParamPvtCommitteeNormal :: !(Maybe Double) + , epochParamPvtCommitteeNoConfidence :: !(Maybe Double) + , epochParamPvtHardForkInitiation :: !(Maybe Double) + , epochParamPvtppSecurityGroup :: !(Maybe Double) + , epochParamDvtMotionNoConfidence :: !(Maybe Double) + , epochParamDvtCommitteeNormal :: !(Maybe Double) + , epochParamDvtCommitteeNoConfidence :: !(Maybe Double) + , epochParamDvtUpdateToConstitution :: !(Maybe Double) + , epochParamDvtHardForkInitiation :: !(Maybe Double) + , epochParamDvtPPNetworkGroup :: !(Maybe Double) + , epochParamDvtPPEconomicGroup :: !(Maybe Double) + , epochParamDvtPPTechnicalGroup :: !(Maybe Double) + , epochParamDvtPPGovGroup :: !(Maybe Double) + , epochParamDvtTreasuryWithdrawal :: !(Maybe Double) + , epochParamCommitteeMinSize :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamCommitteeMaxTermLength :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamGovActionLifetime :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamGovActionDeposit :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamDrepDeposit :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamDrepActivity :: !(Maybe DbWord64) -- sqltype=word64type + , epochParamMinFeeRefScriptCostPerByte :: !(Maybe Double) + } + deriving (Eq, Show, Generic) + +type instance Key EpochParam = EpochParamId +instance DbInfo EpochParam + +entityEpochParamDecoder :: D.Row (Entity EpochParam) +entityEpochParamDecoder = + Entity + <$> idDecoder EpochParamId + <*> epochParamDecoder + +epochParamDecoder :: D.Row EpochParam +epochParamDecoder = + EpochParam + <$> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamEpochNo + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamMinFeeA + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamMinFeeB + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamMaxBlockSize + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamMaxTxSize + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamMaxBhSize + <*> dbLovelaceDecoder -- epochParamKeyDeposit + <*> dbLovelaceDecoder -- epochParamPoolDeposit + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamMaxEpoch + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochParamOptimalPoolCount + <*> D.column (D.nonNullable D.float8) -- epochParamInfluence + <*> D.column (D.nonNullable D.float8) -- epochParamMonetaryExpandRate + <*> D.column (D.nonNullable D.float8) -- epochParamTreasuryGrowthRate + <*> D.column (D.nonNullable D.float8) -- epochParamDecentralisation + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- epochParamProtocolMajor + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- epochParamProtocolMinor + <*> dbLovelaceDecoder -- epochParamMinUtxoValue + <*> dbLovelaceDecoder -- epochParamMinPoolCost + <*> D.column (D.nullable D.bytea) -- epochParamNonce + <*> D.column (D.nullable $ DbLovelace . fromIntegral <$> D.int8) -- epochParamCoinsPerUtxoSize + <*> maybeIdDecoder CostModelId -- epochParamCostModelId + <*> D.column (D.nullable D.float8) -- epochParamPriceMem + <*> D.column (D.nullable D.float8) -- epochParamPriceStep + <*> maybeDbWord64Decoder -- epochParamMaxTxExMem + <*> maybeDbWord64Decoder -- epochParamMaxTxExSteps + <*> maybeDbWord64Decoder -- epochParamMaxBlockExMem + <*> maybeDbWord64Decoder -- epochParamMaxBlockExSteps + <*> maybeDbWord64Decoder -- epochParamMaxValSize + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- epochParamCollateralPercent + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- epochParamMaxCollateralInputs + <*> idDecoder BlockId -- epochParamBlockId + <*> D.column (D.nullable D.bytea) -- epochParamExtraEntropy + <*> D.column (D.nullable D.float8) -- epochParamPvtMotionNoConfidence + <*> D.column (D.nullable D.float8) -- epochParamPvtCommitteeNormal + <*> D.column (D.nullable D.float8) -- epochParamPvtCommitteeNoConfidence + <*> D.column (D.nullable D.float8) -- epochParamPvtHardForkInitiation + <*> D.column (D.nullable D.float8) -- epochParamPvtppSecurityGroup + <*> D.column (D.nullable D.float8) -- epochParamDvtMotionNoConfidence + <*> D.column (D.nullable D.float8) -- epochParamDvtCommitteeNormal + <*> D.column (D.nullable D.float8) -- epochParamDvtCommitteeNoConfidence + <*> D.column (D.nullable D.float8) -- epochParamDvtUpdateToConstitution + <*> D.column (D.nullable D.float8) -- epochParamDvtHardForkInitiation + <*> D.column (D.nullable D.float8) -- epochParamDvtPPNetworkGroup + <*> D.column (D.nullable D.float8) -- epochParamDvtPPEconomicGroup + <*> D.column (D.nullable D.float8) -- epochParamDvtPPTechnicalGroup + <*> D.column (D.nullable D.float8) -- epochParamDvtPPGovGroup + <*> D.column (D.nullable D.float8) -- epochParamDvtTreasuryWithdrawal + <*> maybeDbWord64Decoder -- epochParamCommitteeMinSize + <*> maybeDbWord64Decoder -- epochParamCommitteeMaxTermLength + <*> maybeDbWord64Decoder -- epochParamGovActionLifetime + <*> maybeDbWord64Decoder -- epochParamGovActionDeposit + <*> maybeDbWord64Decoder -- epochParamDrepDeposit + <*> maybeDbWord64Decoder -- epochParamDrepActivity + <*> D.column (D.nullable D.float8) -- epochParamMinFeeRefScriptCostPerByte + +entityEpochParamEncoder :: E.Params (Entity EpochParam) +entityEpochParamEncoder = + mconcat + [ entityKey >$< idEncoder getEpochParamId + , entityVal >$< epochParamEncoder + ] + +epochParamEncoder :: E.Params EpochParam +epochParamEncoder = + mconcat + [ epochParamEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamMinFeeA >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamMinFeeB >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamMaxBlockSize >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamMaxTxSize >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamMaxBhSize >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamKeyDeposit >$< dbLovelaceEncoder + , epochParamPoolDeposit >$< dbLovelaceEncoder + , epochParamMaxEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamOptimalPoolCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochParamInfluence >$< E.param (E.nonNullable E.float8) + , epochParamMonetaryExpandRate >$< E.param (E.nonNullable E.float8) + , epochParamTreasuryGrowthRate >$< E.param (E.nonNullable E.float8) + , epochParamDecentralisation >$< E.param (E.nonNullable E.float8) + , epochParamProtocolMajor >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , epochParamProtocolMinor >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , epochParamMinUtxoValue >$< dbLovelaceEncoder + , epochParamMinPoolCost >$< dbLovelaceEncoder + , epochParamNonce >$< E.param (E.nullable E.bytea) + , epochParamCoinsPerUtxoSize >$< E.param (E.nullable $ fromIntegral . unDbLovelace >$< E.int8) + , epochParamCostModelId >$< maybeIdEncoder getCostModelId + , epochParamPriceMem >$< E.param (E.nullable E.float8) + , epochParamPriceStep >$< E.param (E.nullable E.float8) + , epochParamMaxTxExMem >$< maybeDbWord64Encoder + , epochParamMaxTxExSteps >$< maybeDbWord64Encoder + , epochParamMaxBlockExMem >$< maybeDbWord64Encoder + , epochParamMaxBlockExSteps >$< maybeDbWord64Encoder + , epochParamMaxValSize >$< maybeDbWord64Encoder + , epochParamCollateralPercent >$< E.param (E.nullable $ fromIntegral >$< E.int2) + , epochParamMaxCollateralInputs >$< E.param (E.nullable $ fromIntegral >$< E.int2) + , epochParamBlockId >$< idEncoder getBlockId + , epochParamExtraEntropy >$< E.param (E.nullable E.bytea) + , epochParamPvtMotionNoConfidence >$< E.param (E.nullable E.float8) + , epochParamPvtCommitteeNormal >$< E.param (E.nullable E.float8) + , epochParamPvtCommitteeNoConfidence >$< E.param (E.nullable E.float8) + , epochParamPvtHardForkInitiation >$< E.param (E.nullable E.float8) + , epochParamPvtppSecurityGroup >$< E.param (E.nullable E.float8) + , epochParamDvtMotionNoConfidence >$< E.param (E.nullable E.float8) + , epochParamDvtCommitteeNormal >$< E.param (E.nullable E.float8) + , epochParamDvtCommitteeNoConfidence >$< E.param (E.nullable E.float8) + , epochParamDvtUpdateToConstitution >$< E.param (E.nullable E.float8) + , epochParamDvtHardForkInitiation >$< E.param (E.nullable E.float8) + , epochParamDvtPPNetworkGroup >$< E.param (E.nullable E.float8) + , epochParamDvtPPEconomicGroup >$< E.param (E.nullable E.float8) + , epochParamDvtPPTechnicalGroup >$< E.param (E.nullable E.float8) + , epochParamDvtPPGovGroup >$< E.param (E.nullable E.float8) + , epochParamDvtTreasuryWithdrawal >$< E.param (E.nullable E.float8) + , epochParamCommitteeMinSize >$< maybeDbWord64Encoder + , epochParamCommitteeMaxTermLength >$< maybeDbWord64Encoder + , epochParamGovActionLifetime >$< maybeDbWord64Encoder + , epochParamGovActionDeposit >$< maybeDbWord64Encoder + , epochParamDrepDeposit >$< maybeDbWord64Encoder + , epochParamDrepActivity >$< maybeDbWord64Encoder + , epochParamMinFeeRefScriptCostPerByte >$< E.param (E.nullable E.float8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: epochstate +-- Description: Contains the state of the blockchain at the end of each epoch, including the committee, constitution, and no-confidence votes. +data EpochState = EpochState + { epochStateCommitteeId :: !(Maybe CommitteeId) -- noreference + , epochStateNoConfidenceId :: !(Maybe GovActionProposalId) -- noreference + , epochStateConstitutionId :: !(Maybe ConstitutionId) -- noreference + , epochStateEpochNo :: !Word64 -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key EpochState = EpochStateId +instance DbInfo EpochState + +entityEpochStateDecoder :: D.Row (Entity EpochState) +entityEpochStateDecoder = + Entity + <$> idDecoder EpochStateId + <*> epochStateDecoder + +epochStateDecoder :: D.Row EpochState +epochStateDecoder = + EpochState + <$> maybeIdDecoder CommitteeId -- epochStateCommitteeId + <*> maybeIdDecoder GovActionProposalId -- epochStateNoConfidenceId + <*> maybeIdDecoder ConstitutionId -- epochStateConstitutionId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochStateEpochNo + +entityEpochStateEncoder :: E.Params (Entity EpochState) +entityEpochStateEncoder = + mconcat + [ entityKey >$< idEncoder getEpochStateId + , entityVal >$< epochStateEncoder + ] + +epochStateEncoder :: E.Params EpochState +epochStateEncoder = + mconcat + [ epochStateCommitteeId >$< maybeIdEncoder getCommitteeId + , epochStateNoConfidenceId >$< maybeIdEncoder getGovActionProposalId + , epochStateConstitutionId >$< maybeIdEncoder getConstitutionId + , epochStateEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +epochStateBulkEncoder :: E.Params ([Maybe CommitteeId], [Maybe GovActionProposalId], [Maybe ConstitutionId], [Word64]) +epochStateBulkEncoder = + contrazip4 + (bulkEncoder $ E.nullable $ getCommitteeId >$< E.int8) + (bulkEncoder $ E.nullable $ getGovActionProposalId >$< E.int8) + (bulkEncoder $ E.nullable $ getConstitutionId >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: epochsync_time +-- Description: Tracks synchronization times for epochs, ensuring nodes are in consensus regarding the current state. +data EpochSyncTime = EpochSyncTime + { epochSyncTimeNo :: !Word64 -- sqltype=word31type + , epochSyncTimeSeconds :: !Word64 -- sqltype=word63type + , epochSyncTimeState :: !SyncState -- sqltype=syncstatetype + } + deriving (Show, Eq, Generic) + +type instance Key EpochSyncTime = EpochSyncTimeId +instance DbInfo EpochSyncTime where + uniqueFields _ = ["no"] + +entityEpochSyncTimeDecoder :: D.Row (Entity EpochSyncTime) +entityEpochSyncTimeDecoder = + Entity + <$> idDecoder EpochSyncTimeId + <*> epochSyncTimeDecoder + +epochSyncTimeDecoder :: D.Row EpochSyncTime +epochSyncTimeDecoder = + EpochSyncTime + <$> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochSyncTimeNo + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochSyncTimeSeconds + <*> D.column (D.nonNullable syncStateDecoder) -- epochSyncTimeState + +entityEpochSyncTimeEncoder :: E.Params (Entity EpochSyncTime) +entityEpochSyncTimeEncoder = + mconcat + [ entityKey >$< idEncoder getEpochSyncTimeId + , entityVal >$< epochSyncTimeEncoder + ] + +epochSyncTimeEncoder :: E.Params EpochSyncTime +epochSyncTimeEncoder = + mconcat + [ epochSyncTimeNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochSyncTimeSeconds >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochSyncTimeState >$< E.param (E.nonNullable syncStateEncoder) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: ada_pots +-- Description: A table with all the different types of total balances. +-- This is only populated for the Shelley and later eras, and only on epoch boundaries. +-- The treasury and rewards fields will be correct for the whole epoch, but all other +-- fields change block by block. +data AdaPots = AdaPots + { adaPotsSlotNo :: !Word64 -- sqltype=word63type + , adaPotsEpochNo :: !Word64 -- sqltype=word31type + , adaPotsTreasury :: !DbLovelace -- sqltype=lovelace + , adaPotsReserves :: !DbLovelace -- sqltype=lovelace + , adaPotsRewards :: !DbLovelace -- sqltype=lovelace + , adaPotsUtxo :: !DbLovelace -- sqltype=lovelace + , adaPotsDepositsStake :: !DbLovelace -- sqltype=lovelace + , adaPotsFees :: !DbLovelace -- sqltype=lovelace + , adaPotsBlockId :: !BlockId -- noreference + , adaPotsDepositsDrep :: !DbLovelace -- sqltype=lovelace + , adaPotsDepositsProposal :: !DbLovelace -- sqltype=lovelace + } + deriving (Show, Eq, Generic) + +type instance Key AdaPots = AdaPotsId +instance DbInfo AdaPots + +entityAdaPotsDecoder :: D.Row (Entity AdaPots) +entityAdaPotsDecoder = + Entity + <$> idDecoder AdaPotsId + <*> adaPotsDecoder + +adaPotsDecoder :: D.Row AdaPots +adaPotsDecoder = + AdaPots + <$> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- adaPotsSlotNo + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- adaPotsEpochNo + <*> dbLovelaceDecoder -- adaPotsTreasury + <*> dbLovelaceDecoder -- adaPotsReserves + <*> dbLovelaceDecoder -- adaPotsRewards + <*> dbLovelaceDecoder -- adaPotsUtxo + <*> dbLovelaceDecoder -- adaPotsDepositsStake + <*> dbLovelaceDecoder -- adaPotsFees + <*> idDecoder BlockId -- adaPotsBlockId + <*> dbLovelaceDecoder -- adaPotsDepositsDrep + <*> dbLovelaceDecoder -- adaPotsDepositsProposal + +entityAdaPotsEncoder :: E.Params (Entity AdaPots) +entityAdaPotsEncoder = + mconcat + [ entityKey >$< idEncoder getAdaPotsId + , entityVal >$< adaPotsEncoder + ] + +adaPotsEncoder :: E.Params AdaPots +adaPotsEncoder = + mconcat + [ adaPotsSlotNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , adaPotsEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , adaPotsTreasury >$< dbLovelaceEncoder + , adaPotsReserves >$< dbLovelaceEncoder + , adaPotsRewards >$< dbLovelaceEncoder + , adaPotsUtxo >$< dbLovelaceEncoder + , adaPotsDepositsStake >$< dbLovelaceEncoder + , adaPotsFees >$< dbLovelaceEncoder + , adaPotsBlockId >$< idEncoder getBlockId + , adaPotsDepositsDrep >$< dbLovelaceEncoder + , adaPotsDepositsProposal >$< dbLovelaceEncoder + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pot_transfer +-- Description: Records transfers between different pots (e.g., from the rewards pot to the treasury pot). +data PotTransfer = PotTransfer + { potTransferCertIndex :: !Word16 + , potTransferTreasury :: !DbInt65 -- sqltype=int65type + , potTransferReserves :: !DbInt65 -- sqltype=int65type + , potTransferTxId :: !TxId -- noreference + } + deriving (Show, Eq, Generic) + +instance DbInfo PotTransfer +type instance Key PotTransfer = PotTransferId + +entityPotTransferDecoder :: D.Row (Entity PotTransfer) +entityPotTransferDecoder = + Entity + <$> idDecoder PotTransferId + <*> potTransferDecoder + +potTransferDecoder :: D.Row PotTransfer +potTransferDecoder = + PotTransfer + <$> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- potTransferCertIndex + <*> D.column (D.nonNullable dbInt65Decoder) -- potTransferTreasury + <*> D.column (D.nonNullable dbInt65Decoder) -- potTransferReserves + <*> idDecoder TxId -- potTransferTxId + +entityPotTransferEncoder :: E.Params (Entity PotTransfer) +entityPotTransferEncoder = + mconcat + [ entityKey >$< idEncoder getPotTransferId + , entityVal >$< potTransferEncoder + ] + +potTransferEncoder :: E.Params PotTransfer +potTransferEncoder = + mconcat + [ potTransferCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , potTransferTreasury >$< E.param (E.nonNullable dbInt65Encoder) + , potTransferReserves >$< E.param (E.nonNullable dbInt65Encoder) + , potTransferTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: treasury +-- Description: Holds funds allocated to the treasury, which can be used for network upgrades or other community initiatives. +data Treasury = Treasury + { treasuryAddrId :: !StakeAddressId -- noreference + , treasuryCertIndex :: !Word16 + , treasuryAmount :: !DbInt65 -- sqltype=int65type + , treasuryTxId :: !TxId -- noreference + } + deriving (Show, Eq, Generic) + +instance DbInfo Treasury +type instance Key Treasury = TreasuryId + +entityTreasuryDecoder :: D.Row (Entity Treasury) +entityTreasuryDecoder = + Entity + <$> idDecoder TreasuryId + <*> treasuryDecoder + +treasuryDecoder :: D.Row Treasury +treasuryDecoder = + Treasury + <$> idDecoder StakeAddressId -- treasuryAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- treasuryCertIndex + <*> D.column (D.nonNullable dbInt65Decoder) -- treasuryAmount + <*> idDecoder TxId -- treasuryTxId + +entityTreasuryEncoder :: E.Params (Entity Treasury) +entityTreasuryEncoder = + mconcat + [ entityKey >$< idEncoder getTreasuryId + , entityVal >$< treasuryEncoder + ] + +treasuryEncoder :: E.Params Treasury +treasuryEncoder = + mconcat + [ treasuryAddrId >$< idEncoder getStakeAddressId + , treasuryCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , treasuryAmount >$< E.param (E.nonNullable dbInt65Encoder) + , treasuryTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: reserve +-- Description: Stores reserves set aside by the protocol to stabilize the cryptocurrency's value or fund future activities. +data Reserve = Reserve + { reserveAddrId :: !StakeAddressId -- noreference + , reserveCertIndex :: !Word16 + , reserveAmount :: !DbInt65 -- sqltype=int65type + , reserveTxId :: !TxId -- noreference + } + deriving (Show, Eq, Generic) + +type instance Key Reserve = ReserveId +instance DbInfo Reserve + +entityReserveDecoder :: D.Row (Entity Reserve) +entityReserveDecoder = + Entity + <$> idDecoder ReserveId + <*> reserveDecoder + +reserveDecoder :: D.Row Reserve +reserveDecoder = + Reserve + <$> idDecoder StakeAddressId -- reserveAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- reserveCertIndex + <*> D.column (D.nonNullable dbInt65Decoder) -- reserveAmount + <*> idDecoder TxId -- reserveTxId + +entityReserveEncoder :: E.Params (Entity Reserve) +entityReserveEncoder = + mconcat + [ entityKey >$< idEncoder getReserveId + , entityVal >$< reserveEncoder + ] + +reserveEncoder :: E.Params Reserve +reserveEncoder = + mconcat + [ reserveAddrId >$< idEncoder getStakeAddressId + , reserveCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , reserveAmount >$< E.param (E.nonNullable dbInt65Encoder) + , reserveTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: cost_model +-- Description: Defines the cost model used for estimating transaction fees, ensuring efficient resource allocation on the network. +data CostModel = CostModel + { costModelCosts :: !Text -- sqltype=jsonb + , costModelHash :: !ByteString -- sqltype=hash32type + } + deriving (Eq, Show, Generic) + +type instance Key CostModel = CostModelId +instance DbInfo CostModel where + uniqueFields _ = ["hash"] + +entityCostModelDecoder :: D.Row (Entity CostModel) +entityCostModelDecoder = + Entity + <$> idDecoder CostModelId + <*> costModelDecoder + +costModelDecoder :: D.Row CostModel +costModelDecoder = + CostModel + <$> D.column (D.nonNullable D.text) -- costModelCosts + <*> D.column (D.nonNullable D.bytea) -- costModelHash + +entityCostModelEncoder :: E.Params (Entity CostModel) +entityCostModelEncoder = + mconcat + [ entityKey >$< idEncoder getCostModelId + , entityVal >$< costModelEncoder + ] + +costModelEncoder :: E.Params CostModel +costModelEncoder = + mconcat + [ costModelCosts >$< E.param (E.nonNullable E.text) + , costModelHash >$< E.param (E.nonNullable E.bytea) + ] diff --git a/cardano-db/src/Cardano/Db/Schema/Core/GovernanceAndVoting.hs b/cardano-db/src/Cardano/Db/Schema/Core/GovernanceAndVoting.hs new file mode 100644 index 000000000..8b5d51ceb --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/GovernanceAndVoting.hs @@ -0,0 +1,965 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Schema.Core.GovernanceAndVoting where + +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant +import Data.Int (Int64) +import Data.Text (Text) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import Hasql.Decoders as D +import Hasql.Encoders as E + +import Cardano.Db.Schema.Ids +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types ( + AnchorType, + DbLovelace, + DbWord64, + GovActionType, + Vote, + VoteUrl, + VoterRole, + anchorTypeDecoder, + anchorTypeEncoder, + dbLovelaceDecoder, + dbLovelaceEncoder, + govActionTypeDecoder, + govActionTypeEncoder, + maybeDbLovelaceDecoder, + maybeDbLovelaceEncoder, + maybeDbWord64Decoder, + maybeDbWord64Encoder, + voteDecoder, + voteEncoder, + voteUrlDecoder, + voteUrlEncoder, + voterRoleDecoder, + voterRoleEncoder, + ) + +----------------------------------------------------------------------------------------------------------------------------------- +-- GOVERNANCE AND VOTING +-- These tables manage governance-related data, including DReps, committees, and voting procedures. +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: drep_hash +-- Description: Stores hashes of DRep (Decentralized Reputation) records, which are used in governance processes. +data DrepHash = DrepHash + { drepHashRaw :: !(Maybe ByteString) -- sqltype=hash28type + , drepHashView :: !Text + , drepHashHasScript :: !Bool + } + deriving (Eq, Show, Generic) + +type instance Key DrepHash = DrepHashId +instance DbInfo DrepHash where + uniqueFields _ = ["raw", "has_script"] + +entityDrepHashDecoder :: D.Row (Entity DrepHash) +entityDrepHashDecoder = + Entity + <$> idDecoder DrepHashId -- entityKey + <*> drepHashDecoder -- entityVal + +drepHashDecoder :: D.Row DrepHash +drepHashDecoder = + DrepHash + <$> D.column (D.nullable D.bytea) -- drepHashRaw + <*> D.column (D.nonNullable D.text) -- drepHashView + <*> D.column (D.nonNullable D.bool) -- drepHashHasScript + +entityDrepHashEncoder :: E.Params (Entity DrepHash) +entityDrepHashEncoder = + mconcat + [ entityKey >$< idEncoder getDrepHashId + , entityVal >$< drepHashEncoder + ] + +drepHashEncoder :: E.Params DrepHash +drepHashEncoder = + mconcat + [ drepHashRaw >$< E.param (E.nullable E.bytea) + , drepHashView >$< E.param (E.nonNullable E.text) + , drepHashHasScript >$< E.param (E.nonNullable E.bool) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: drep_registration +-- Description: Contains details about the registration of DReps, including their public keys and other identifying information. +data DrepRegistration = DrepRegistration + { drepRegistrationTxId :: !TxId -- noreference + , drepRegistrationCertIndex :: !Word16 + , drepRegistrationDeposit :: !(Maybe Int64) + , drepRegistrationDrepHashId :: !DrepHashId -- noreference + , drepRegistrationVotingAnchorId :: !(Maybe VotingAnchorId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key DrepRegistration = DrepRegistrationId +instance DbInfo DrepRegistration + +entityDrepRegistrationDecoder :: D.Row (Entity DrepRegistration) +entityDrepRegistrationDecoder = + Entity + <$> idDecoder DrepRegistrationId -- entityKey + <*> drepRegistrationDecoder -- entityVal + +drepRegistrationDecoder :: D.Row DrepRegistration +drepRegistrationDecoder = + DrepRegistration + <$> idDecoder TxId -- drepRegistrationTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- drepRegistrationCertIndex + <*> D.column (D.nullable D.int8) -- drepRegistrationDeposit + <*> idDecoder DrepHashId -- drepRegistrationDrepHashId + <*> maybeIdDecoder VotingAnchorId -- drepRegistrationVotingAnchorId + +entityDrepRegistrationEncoder :: E.Params (Entity DrepRegistration) +entityDrepRegistrationEncoder = + mconcat + [ entityKey >$< idEncoder getDrepRegistrationId + , entityVal >$< drepRegistrationEncoder + ] + +drepRegistrationEncoder :: E.Params DrepRegistration +drepRegistrationEncoder = + mconcat + [ drepRegistrationCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , drepRegistrationDeposit >$< E.param (E.nullable E.int8) + , drepRegistrationDrepHashId >$< idEncoder getDrepHashId + , drepRegistrationVotingAnchorId >$< maybeIdEncoder getVotingAnchorId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: drep_distr +-- Description: Contains information about the distribution of DRep tokens, including the amount distributed and the epoch in which the distribution occurred. +data DrepDistr = DrepDistr + { drepDistrHashId :: !DrepHashId -- noreference + , drepDistrAmount :: !Word64 + , drepDistrEpochNo :: !Word64 -- sqltype=word31type + , drepDistrActiveUntil :: !(Maybe Word64) -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key DrepDistr = DrepDistrId +instance DbInfo DrepDistr where + uniqueFields _ = ["hash_id", "epoch_no"] + +entityDrepDistrDecoder :: D.Row (Entity DrepDistr) +entityDrepDistrDecoder = + Entity + <$> idDecoder DrepDistrId -- entityKey + <*> drepDistrDecoder -- entityVal + +drepDistrDecoder :: D.Row DrepDistr +drepDistrDecoder = + DrepDistr + <$> idDecoder DrepHashId -- drepDistrHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- drepDistrAmount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- drepDistrEpochNo + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- drepDistrActiveUntil + +entityDrepDistrEncoder :: E.Params (Entity DrepDistr) +entityDrepDistrEncoder = + mconcat + [ entityKey >$< idEncoder getDrepDistrId + , entityVal >$< drepDistrEncoder + ] + +drepDistrEncoder :: E.Params DrepDistr +drepDistrEncoder = + mconcat + [ drepDistrHashId >$< idEncoder getDrepHashId + , drepDistrAmount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , drepDistrEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , drepDistrActiveUntil >$< E.param (E.nullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: delegation_vote +-- Description: Tracks votes cast by stakeholders to delegate their voting rights to other entities within the governance framework. +data DelegationVote = DelegationVote + { delegationVoteAddrId :: !StakeAddressId -- noreference + , delegationVoteCertIndex :: !Word16 + , delegationVoteDrepHashId :: !DrepHashId -- noreference + , delegationVoteTxId :: !TxId -- noreference + , delegationVoteRedeemerId :: !(Maybe RedeemerId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key DelegationVote = DelegationVoteId +instance DbInfo DelegationVote + +entityDelegationVoteDecoder :: D.Row (Entity DelegationVote) +entityDelegationVoteDecoder = + Entity + <$> idDecoder DelegationVoteId -- entityKey + <*> delegationVoteDecoder -- entityVal + +delegationVoteDecoder :: D.Row DelegationVote +delegationVoteDecoder = + DelegationVote + <$> idDecoder StakeAddressId -- delegationVoteAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- delegationVoteCertIndex + <*> idDecoder DrepHashId -- delegationVoteDrepHashId + <*> idDecoder TxId -- delegationVoteTxId + <*> maybeIdDecoder RedeemerId -- delegationVoteRedeemerId + +entityDelegationVoteEncoder :: E.Params (Entity DelegationVote) +entityDelegationVoteEncoder = + mconcat + [ entityKey >$< idEncoder getDelegationVoteId + , entityVal >$< delegationVoteEncoder + ] + +delegationVoteEncoder :: E.Params DelegationVote +delegationVoteEncoder = + mconcat + [ delegationVoteAddrId >$< idEncoder getStakeAddressId + , delegationVoteCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , delegationVoteDrepHashId >$< idEncoder getDrepHashId + , delegationVoteTxId >$< idEncoder getTxId + , delegationVoteRedeemerId >$< maybeIdEncoder getRedeemerId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: gov_action_proposal +-- Description: Contains proposals for governance actions, including the type of action, the amount of the deposit, and the expiration date. +data GovActionProposal = GovActionProposal + { govActionProposalTxId :: !TxId -- noreference + , govActionProposalIndex :: !Word64 + , govActionProposalPrevGovActionProposal :: !(Maybe GovActionProposalId) -- noreference + , govActionProposalDeposit :: !DbLovelace -- sqltype=lovelace + , govActionProposalReturnAddress :: !StakeAddressId -- noreference + , govActionProposalExpiration :: !(Maybe Word64) -- sqltype=word31type + , govActionProposalVotingAnchorId :: !(Maybe VotingAnchorId) -- noreference + , govActionProposalType :: !GovActionType -- sqltype=govactiontype + , govActionProposalDescription :: !Text -- sqltype=jsonb + , govActionProposalParamProposal :: !(Maybe ParamProposalId) -- noreference + , govActionProposalRatifiedEpoch :: !(Maybe Word64) -- sqltype=word31type + , govActionProposalEnactedEpoch :: !(Maybe Word64) -- sqltype=word31type + , govActionProposalDroppedEpoch :: !(Maybe Word64) -- sqltype=word31type + , govActionProposalExpiredEpoch :: !(Maybe Word64) -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key GovActionProposal = GovActionProposalId +instance DbInfo GovActionProposal + +entityGovActionProposalDecoder :: D.Row (Entity GovActionProposal) +entityGovActionProposalDecoder = + Entity + <$> idDecoder GovActionProposalId -- entityKey + <*> govActionProposalDecoder -- entityVal + +govActionProposalDecoder :: D.Row GovActionProposal +govActionProposalDecoder = + GovActionProposal + <$> idDecoder TxId -- govActionProposalTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- govActionProposalIndex + <*> maybeIdDecoder GovActionProposalId -- govActionProposalPrevGovActionProposal + <*> dbLovelaceDecoder -- govActionProposalDeposit + <*> idDecoder StakeAddressId -- govActionProposalReturnAddress + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- govActionProposalExpiration + <*> maybeIdDecoder VotingAnchorId -- govActionProposalVotingAnchorId + <*> D.column (D.nonNullable govActionTypeDecoder) -- govActionProposalType + <*> D.column (D.nonNullable D.text) -- govActionProposalDescription + <*> maybeIdDecoder ParamProposalId -- govActionProposalParamProposal + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- govActionProposalRatifiedEpoch + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- govActionProposalEnactedEpoch + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- govActionProposalDroppedEpoch + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- govActionProposalExpiredEpoch + +entityGovActionProposalEncoder :: E.Params (Entity GovActionProposal) +entityGovActionProposalEncoder = + mconcat + [ entityKey >$< idEncoder getGovActionProposalId + , entityVal >$< govActionProposalEncoder + ] + +govActionProposalEncoder :: E.Params GovActionProposal +govActionProposalEncoder = + mconcat + [ govActionProposalTxId >$< idEncoder getTxId + , govActionProposalIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , govActionProposalPrevGovActionProposal >$< maybeIdEncoder getGovActionProposalId + , govActionProposalDeposit >$< dbLovelaceEncoder + , govActionProposalReturnAddress >$< idEncoder getStakeAddressId + , govActionProposalExpiration >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , govActionProposalVotingAnchorId >$< maybeIdEncoder getVotingAnchorId + , govActionProposalType >$< E.param (E.nonNullable govActionTypeEncoder) + , govActionProposalDescription >$< E.param (E.nonNullable E.text) + , govActionProposalParamProposal >$< maybeIdEncoder getParamProposalId + , govActionProposalRatifiedEpoch >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , govActionProposalEnactedEpoch >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , govActionProposalDroppedEpoch >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , govActionProposalExpiredEpoch >$< E.param (E.nullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: voting_procedure +-- Description: Defines the procedures and rules governing the voting process, including quorum requirements and tallying mechanisms. +data VotingProcedure = VotingProcedure + { votingProcedureTxId :: !TxId -- noreference + , votingProcedureIndex :: !Word16 + , votingProcedureGovActionProposalId :: !GovActionProposalId -- noreference + , votingProcedureVoterRole :: !VoterRole -- sqltype=voterrole + , votingProcedureDrepVoter :: !(Maybe DrepHashId) -- noreference + , votingProcedurePoolVoter :: !(Maybe PoolHashId) -- noreference + , votingProcedureVote :: !Vote -- sqltype=vote + , votingProcedureVotingAnchorId :: !(Maybe VotingAnchorId) -- noreference + , votingProcedureCommitteeVoter :: !(Maybe CommitteeHashId) -- noreference + , votingProcedureInvalid :: !(Maybe EventInfoId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key VotingProcedure = VotingProcedureId +instance DbInfo VotingProcedure + +entityVotingProcedureDecoder :: D.Row (Entity VotingProcedure) +entityVotingProcedureDecoder = + Entity + <$> idDecoder VotingProcedureId -- entityKey + <*> votingProcedureDecoder -- entityVal + +votingProcedureDecoder :: D.Row VotingProcedure +votingProcedureDecoder = + VotingProcedure + <$> idDecoder TxId -- votingProcedureTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- votingProcedureIndex + <*> idDecoder GovActionProposalId -- votingProcedureGovActionProposalId + <*> D.column (D.nonNullable voterRoleDecoder) -- votingProcedureVoterRole + <*> maybeIdDecoder DrepHashId -- votingProcedureDrepVoter + <*> maybeIdDecoder PoolHashId -- votingProcedurePoolVoter + <*> D.column (D.nonNullable voteDecoder) -- votingProcedureVote + <*> maybeIdDecoder VotingAnchorId -- votingProcedureVotingAnchorId + <*> maybeIdDecoder CommitteeHashId -- votingProcedureCommitteeVoter + <*> maybeIdDecoder EventInfoId -- votingProcedureInvalid + +entityVotingProcedureEncoder :: E.Params (Entity VotingProcedure) +entityVotingProcedureEncoder = + mconcat + [ entityKey >$< idEncoder getVotingProcedureId + , entityVal >$< votingProcedureEncoder + ] + +votingProcedureEncoder :: E.Params VotingProcedure +votingProcedureEncoder = + mconcat + [ votingProcedureTxId >$< idEncoder getTxId + , votingProcedureIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , votingProcedureGovActionProposalId >$< idEncoder getGovActionProposalId + , votingProcedureVoterRole >$< E.param (E.nonNullable voterRoleEncoder) + , votingProcedureDrepVoter >$< maybeIdEncoder getDrepHashId + , votingProcedurePoolVoter >$< maybeIdEncoder getPoolHashId + , votingProcedureVote >$< E.param (E.nonNullable voteEncoder) + , votingProcedureVotingAnchorId >$< maybeIdEncoder getVotingAnchorId + , votingProcedureCommitteeVoter >$< maybeIdEncoder getCommitteeHashId + , votingProcedureInvalid >$< maybeIdEncoder getEventInfoId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: voting_anchor +-- Description: Acts as an anchor point for votes, ensuring they are securely recorded and linked to specific proposals. +data VotingAnchor = VotingAnchor + { votingAnchorUrl :: !VoteUrl -- sqltype=varchar + , votingAnchorDataHash :: !ByteString + , votingAnchorType :: !AnchorType -- sqltype=anchorType + , votingAnchorBlockId :: !BlockId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key VotingAnchor = VotingAnchorId +instance DbInfo VotingAnchor where + uniqueFields _ = ["data_hash", "url", "type"] + +entityVotingAnchorDecoder :: D.Row (Entity VotingAnchor) +entityVotingAnchorDecoder = + Entity + <$> idDecoder VotingAnchorId + <*> votingAnchorDecoder + +votingAnchorDecoder :: D.Row VotingAnchor +votingAnchorDecoder = + VotingAnchor + <$> D.column (D.nonNullable voteUrlDecoder) -- votingAnchorUrl + <*> D.column (D.nonNullable D.bytea) -- votingAnchorDataHash + <*> D.column (D.nonNullable anchorTypeDecoder) -- votingAnchorType + <*> idDecoder BlockId -- votingAnchorBlockId + +entityVotingAnchorEncoder :: E.Params (Entity VotingAnchor) +entityVotingAnchorEncoder = + mconcat + [ entityKey >$< idEncoder getVotingAnchorId + , entityVal >$< votingAnchorEncoder + ] + +votingAnchorEncoder :: E.Params VotingAnchor +votingAnchorEncoder = + mconcat + [ votingAnchorUrl >$< E.param (E.nonNullable voteUrlEncoder) + , votingAnchorDataHash >$< E.param (E.nonNullable E.bytea) + , votingAnchorType >$< E.param (E.nonNullable anchorTypeEncoder) + , votingAnchorBlockId >$< idEncoder getBlockId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: constitution +-- Description: Holds the on-chain constitution, which defines the rules and principles of the blockchain's governance system. +data Constitution = Constitution + { constitutionGovActionProposalId :: !(Maybe GovActionProposalId) -- noreference + , constitutionVotingAnchorId :: !VotingAnchorId -- noreference + , constitutionScriptHash :: !(Maybe ByteString) -- sqltype=hash28type + } + deriving (Eq, Show, Generic) + +type instance Key Constitution = ConstitutionId +instance DbInfo Constitution + +entityConstitutionDecoder :: D.Row (Entity Constitution) +entityConstitutionDecoder = + Entity + <$> idDecoder ConstitutionId -- entityKey + <*> constitutionDecoder -- entityVal + +constitutionDecoder :: D.Row Constitution +constitutionDecoder = + Constitution + <$> maybeIdDecoder GovActionProposalId -- constitutionGovActionProposalId + <*> idDecoder VotingAnchorId -- constitutionVotingAnchorId + <*> D.column (D.nullable D.bytea) -- constitutionScriptHash + +entityConstitutionEncoder :: E.Params (Entity Constitution) +entityConstitutionEncoder = + mconcat + [ entityKey >$< idEncoder getConstitutionId + , entityVal >$< constitutionEncoder + ] + +constitutionEncoder :: E.Params Constitution +constitutionEncoder = + mconcat + [ constitutionGovActionProposalId >$< maybeIdEncoder getGovActionProposalId + , constitutionVotingAnchorId >$< idEncoder getVotingAnchorId + , constitutionScriptHash >$< E.param (E.nullable E.bytea) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: committee +-- Description: Contains information about the committee, including the quorum requirements and the proposal being considered. +data Committee = Committee + { committeeGovActionProposalId :: !(Maybe GovActionProposalId) -- noreference + , committeeQuorumNumerator :: !Word64 + , committeeQuorumDenominator :: !Word64 + } + deriving (Eq, Show, Generic) + +type instance Key Committee = CommitteeId +instance DbInfo Committee + +entityCommitteeDecoder :: D.Row (Entity Committee) +entityCommitteeDecoder = + Entity + <$> idDecoder CommitteeId -- entityKey + <*> committeeDecoder -- entityVal + +committeeDecoder :: D.Row Committee +committeeDecoder = + Committee + <$> maybeIdDecoder GovActionProposalId -- committeeGovActionProposalId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- committeeQuorumNumerator + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- committeeQuorumDenominator + +entityCommitteeEncoder :: E.Params (Entity Committee) +entityCommitteeEncoder = + mconcat + [ entityKey >$< idEncoder getCommitteeId + , entityVal >$< committeeEncoder + ] + +committeeEncoder :: E.Params Committee +committeeEncoder = + mconcat + [ committeeGovActionProposalId >$< maybeIdEncoder getGovActionProposalId + , committeeQuorumNumerator >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , committeeQuorumDenominator >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: committee_hash +-- Description: Stores hashes of committee records, which are used in governance processes. +data CommitteeHash = CommitteeHash + { committeeHashRaw :: !ByteString -- sqltype=hash28type + , committeeHashHasScript :: !Bool + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeHash = CommitteeHashId +instance DbInfo CommitteeHash where + uniqueFields _ = ["raw", "has_script"] + +entityCommitteeHashDecoder :: D.Row (Entity CommitteeHash) +entityCommitteeHashDecoder = + Entity + <$> idDecoder CommitteeHashId -- entityKey + <*> committeeHashDecoder -- entityVal + +committeeHashDecoder :: D.Row CommitteeHash +committeeHashDecoder = + CommitteeHash + <$> D.column (D.nonNullable D.bytea) -- committeeHashRaw + <*> D.column (D.nonNullable D.bool) -- committeeHashHasScript + +entityCommitteeHashEncoder :: E.Params (Entity CommitteeHash) +entityCommitteeHashEncoder = + mconcat + [ entityKey >$< idEncoder getCommitteeHashId + , entityVal >$< committeeHashEncoder + ] + +committeeHashEncoder :: E.Params CommitteeHash +committeeHashEncoder = + mconcat + [ committeeHashRaw >$< E.param (E.nonNullable E.bytea) + , committeeHashHasScript >$< E.param (E.nonNullable E.bool) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: committeemember +-- Description: Contains information about committee members. +data CommitteeMember = CommitteeMember + { committeeMemberCommitteeId :: !CommitteeId -- OnDeleteCascade -- here intentionally we use foreign keys + , committeeMemberCommitteeHashId :: !CommitteeHashId -- noreference + , committeeMemberExpirationEpoch :: !Word64 -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeMember = CommitteeMemberId +instance DbInfo CommitteeMember + +entityCommitteeMemberDecoder :: D.Row (Entity CommitteeMember) +entityCommitteeMemberDecoder = + Entity + <$> idDecoder CommitteeMemberId -- entityKey + <*> committeeMemberDecoder -- entityVal + +committeeMemberDecoder :: D.Row CommitteeMember +committeeMemberDecoder = + CommitteeMember + <$> idDecoder CommitteeId -- committeeMemberCommitteeId + <*> idDecoder CommitteeHashId -- committeeMemberCommitteeHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- committeeMemberExpirationEpoch + +entityCommitteeMemberEncoder :: E.Params (Entity CommitteeMember) +entityCommitteeMemberEncoder = + mconcat + [ entityKey >$< idEncoder getCommitteeMemberId + , entityVal >$< committeeMemberEncoder + ] + +committeeMemberEncoder :: E.Params CommitteeMember +committeeMemberEncoder = + mconcat + [ committeeMemberCommitteeId >$< idEncoder getCommitteeId + , committeeMemberCommitteeHashId >$< idEncoder getCommitteeHashId + , committeeMemberExpirationEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: committeeregistration +-- Description: Contains information about the registration of committee members, including their public keys and other identifying information. +data CommitteeRegistration = CommitteeRegistration + { committeeRegistrationTxId :: !TxId -- noreference + , committeeRegistrationCertIndex :: !Word16 + , committeeRegistrationColdKeyId :: !CommitteeHashId -- noreference + , committeeRegistrationHotKeyId :: !CommitteeHashId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeRegistration = CommitteeRegistrationId +instance DbInfo CommitteeRegistration + +entityCommitteeRegistrationDecoder :: D.Row (Entity CommitteeRegistration) +entityCommitteeRegistrationDecoder = + Entity + <$> idDecoder CommitteeRegistrationId -- entityKey + <*> committeeRegistrationDecoder -- entityVal + +committeeRegistrationDecoder :: D.Row CommitteeRegistration +committeeRegistrationDecoder = + CommitteeRegistration + <$> idDecoder TxId -- committeeRegistrationTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- committeeRegistrationCertIndex + <*> idDecoder CommitteeHashId -- committeeRegistrationColdKeyId + <*> idDecoder CommitteeHashId -- committeeRegistrationHotKeyId + +entityCommitteeRegistrationEncoder :: E.Params (Entity CommitteeRegistration) +entityCommitteeRegistrationEncoder = + mconcat + [ entityKey >$< idEncoder getCommitteeRegistrationId + , entityVal >$< committeeRegistrationEncoder + ] + +committeeRegistrationEncoder :: E.Params CommitteeRegistration +committeeRegistrationEncoder = + mconcat + [ committeeRegistrationTxId >$< idEncoder getTxId + , committeeRegistrationCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , committeeRegistrationColdKeyId >$< idEncoder getCommitteeHashId + , committeeRegistrationHotKeyId >$< idEncoder getCommitteeHashId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: committeede_registration +-- Description: Contains information about the deregistration of committee members, including their public keys and other identifying information. +data CommitteeDeRegistration = CommitteeDeRegistration + { committeeDeRegistration_TxId :: !TxId -- noreference + , committeeDeRegistration_CertIndex :: !Word16 + , committeeDeRegistration_VotingAnchorId :: !(Maybe VotingAnchorId) -- noreference + , committeeDeRegistration_ColdKeyId :: !CommitteeHashId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeDeRegistration = CommitteeDeRegistrationId +instance DbInfo CommitteeDeRegistration + +entityCommitteeDeRegistrationDecoder :: D.Row (Entity CommitteeDeRegistration) +entityCommitteeDeRegistrationDecoder = + Entity + <$> idDecoder CommitteeDeRegistrationId -- entityKey + <*> committeeDeRegistrationDecoder -- entityVal + +committeeDeRegistrationDecoder :: D.Row CommitteeDeRegistration +committeeDeRegistrationDecoder = + CommitteeDeRegistration + <$> idDecoder TxId -- committeeDeRegistration_TxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- committeeDeRegistration_CertIndex + <*> maybeIdDecoder VotingAnchorId -- committeeDeRegistration_VotingAnchorId + <*> idDecoder CommitteeHashId -- committeeDeRegistration_ColdKeyId + +entityCommitteeDeRegistrationEncoder :: E.Params (Entity CommitteeDeRegistration) +entityCommitteeDeRegistrationEncoder = + mconcat + [ entityKey >$< idEncoder getCommitteeDeRegistrationId + , entityVal >$< committeeDeRegistrationEncoder + ] + +committeeDeRegistrationEncoder :: E.Params CommitteeDeRegistration +committeeDeRegistrationEncoder = + mconcat + [ committeeDeRegistration_TxId >$< idEncoder getTxId + , committeeDeRegistration_CertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , committeeDeRegistration_VotingAnchorId >$< maybeIdEncoder getVotingAnchorId + , committeeDeRegistration_ColdKeyId >$< idEncoder getCommitteeHashId + ] + +-- | +-- Table Name: param_proposal +-- Description: Contains proposals for changes to the protocol parameters, including the proposed values and the expiration date. +data ParamProposal = ParamProposal + { paramProposalEpochNo :: !(Maybe Word64) -- sqltype=word31type + , paramProposalKey :: !(Maybe ByteString) -- sqltype=hash28type + , paramProposalMinFeeA :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMinFeeB :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxBlockSize :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxTxSize :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxBhSize :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalKeyDeposit :: !(Maybe DbLovelace) -- sqltype=lovelace + , paramProposalPoolDeposit :: !(Maybe DbLovelace) -- sqltype=lovelace + , paramProposalMaxEpoch :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalOptimalPoolCount :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalInfluence :: !(Maybe Double) + , paramProposalMonetaryExpandRate :: !(Maybe Double) + , paramProposalTreasuryGrowthRate :: !(Maybe Double) + , paramProposalDecentralisation :: !(Maybe Double) + , paramProposalEntropy :: !(Maybe ByteString) -- sqltype=hash32type + , paramProposalProtocolMajor :: !(Maybe Word16) -- sqltype=word31type + , paramProposalProtocolMinor :: !(Maybe Word16) -- sqltype=word31type + , paramProposalMinUtxoValue :: !(Maybe DbLovelace) -- sqltype=lovelace + , paramProposalMinPoolCost :: !(Maybe DbLovelace) -- sqltype=lovelace + , paramProposalCostModelId :: !(Maybe CostModelId) -- noreference + , paramProposalPriceMem :: !(Maybe Double) + , paramProposalPriceStep :: !(Maybe Double) + , paramProposalMaxTxExMem :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxTxExSteps :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxBlockExMem :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxBlockExSteps :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMaxValSize :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalCollateralPercent :: !(Maybe Word16) -- sqltype=word31type + , paramProposalMaxCollateralInputs :: !(Maybe Word16) -- sqltype=word31type + , paramProposalRegisteredTxId :: !TxId -- noreference + , paramProposalCoinsPerUtxoSize :: !(Maybe DbLovelace) -- sqltype=lovelace + , paramProposalPvtMotionNoConfidence :: !(Maybe Double) + , paramProposalPvtCommitteeNormal :: !(Maybe Double) + , paramProposalPvtCommitteeNoConfidence :: !(Maybe Double) + , paramProposalPvtHardForkInitiation :: !(Maybe Double) + , paramProposalPvtppSecurityGroup :: !(Maybe Double) + , paramProposalDvtMotionNoConfidence :: !(Maybe Double) + , paramProposalDvtCommitteeNormal :: !(Maybe Double) + , paramProposalDvtCommitteeNoConfidence :: !(Maybe Double) + , paramProposalDvtUpdateToConstitution :: !(Maybe Double) + , paramProposalDvtHardForkInitiation :: !(Maybe Double) + , paramProposalDvtPPNetworkGroup :: !(Maybe Double) + , paramProposalDvtPPEconomicGroup :: !(Maybe Double) + , paramProposalDvtPPTechnicalGroup :: !(Maybe Double) + , paramProposalDvtPPGovGroup :: !(Maybe Double) + , paramProposalDvtTreasuryWithdrawal :: !(Maybe Double) + , paramProposalCommitteeMinSize :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalCommitteeMaxTermLength :: !(Maybe DbWord64) -- + , paramProposalGovActionLifetime :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalGovActionDeposit :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalDrepDeposit :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalDrepActivity :: !(Maybe DbWord64) -- sqltype=word64type + , paramProposalMinFeeRefScriptCostPerByte :: !(Maybe Double) + } + deriving (Show, Eq, Generic) + +type instance Key ParamProposal = ParamProposalId +instance DbInfo ParamProposal + +entityParamProposalDecoder :: D.Row (Entity ParamProposal) +entityParamProposalDecoder = + Entity + <$> idDecoder ParamProposalId -- entityKey + <*> paramProposalDecoder -- entityVal + +paramProposalDecoder :: D.Row ParamProposal +paramProposalDecoder = + ParamProposal + <$> D.column (D.nullable $ fromIntegral <$> D.int8) -- paramProposalEpochNo + <*> D.column (D.nullable D.bytea) -- paramProposalKey + <*> maybeDbWord64Decoder -- paramProposalMinFeeA + <*> maybeDbWord64Decoder -- paramProposalMinFeeB + <*> maybeDbWord64Decoder -- paramProposalMaxBlockSize + <*> maybeDbWord64Decoder -- paramProposalMaxTxSize + <*> maybeDbWord64Decoder -- paramProposalMaxBhSize + <*> maybeDbLovelaceDecoder -- paramProposalKeyDeposit + <*> maybeDbLovelaceDecoder -- paramProposalPoolDeposit + <*> maybeDbWord64Decoder -- paramProposalMaxEpoch + <*> maybeDbWord64Decoder -- paramProposalOptimalPoolCount + <*> D.column (D.nullable D.float8) -- paramProposalInfluence + <*> D.column (D.nullable D.float8) -- paramProposalMonetaryExpandRate + <*> D.column (D.nullable D.float8) -- paramProposalTreasuryGrowthRate + <*> D.column (D.nullable D.float8) -- paramProposalDecentralisation + <*> D.column (D.nullable D.bytea) -- paramProposalEntropy + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- paramProposalProtocolMajor + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- paramProposalProtocolMinor + <*> maybeDbLovelaceDecoder -- paramProposalMinUtxoValue + <*> maybeDbLovelaceDecoder -- paramProposalMinPoolCost + <*> maybeIdDecoder CostModelId -- paramProposalCostModelId + <*> D.column (D.nullable D.float8) -- paramProposalPriceMem + <*> D.column (D.nullable D.float8) -- paramProposalPriceStep + <*> maybeDbWord64Decoder -- paramProposalMaxTxExMem + <*> maybeDbWord64Decoder -- paramProposalMaxTxExSteps + <*> maybeDbWord64Decoder -- paramProposalMaxBlockExMem + <*> maybeDbWord64Decoder -- paramProposalMaxBlockExSteps + <*> maybeDbWord64Decoder -- paramProposalMaxValSize + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- paramProposalCollateralPercent + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- paramProposalMaxCollateralInputs + <*> idDecoder TxId -- paramProposalRegisteredTxId + <*> maybeDbLovelaceDecoder -- paramProposalCoinsPerUtxoSize + <*> D.column (D.nullable D.float8) -- paramProposalPvtMotionNoConfidence + <*> D.column (D.nullable D.float8) -- paramProposalPvtCommitteeNormal + <*> D.column (D.nullable D.float8) -- paramProposalPvtCommitteeNoConfidence + <*> D.column (D.nullable D.float8) -- paramProposalPvtHardForkInitiation + <*> D.column (D.nullable D.float8) -- paramProposalPvtppSecurityGroup + <*> D.column (D.nullable D.float8) -- paramProposalDvtMotionNoConfidence + <*> D.column (D.nullable D.float8) -- paramProposalDvtCommitteeNormal + <*> D.column (D.nullable D.float8) -- paramProposalDvtCommitteeNoConfidence + <*> D.column (D.nullable D.float8) -- paramProposalDvtUpdateToConstitution + <*> D.column (D.nullable D.float8) -- paramProposalDvtHardForkInitiation + <*> D.column (D.nullable D.float8) -- paramProposalDvtPPNetworkGroup + <*> D.column (D.nullable D.float8) -- paramProposalDvtPPEconomicGroup + <*> D.column (D.nullable D.float8) -- paramProposalDvtPPTechnicalGroup + <*> D.column (D.nullable D.float8) -- paramProposalDvtPPGovGroup + <*> D.column (D.nullable D.float8) -- paramProposalDvtTreasuryWithdrawal + <*> maybeDbWord64Decoder -- paramProposalCommitteeMinSize + <*> maybeDbWord64Decoder -- paramProposalCommitteeMaxTermLength + <*> maybeDbWord64Decoder -- paramProposalGovActionLifetime + <*> maybeDbWord64Decoder -- paramProposalGovActionDeposit + <*> maybeDbWord64Decoder -- paramProposalDrepDeposit + <*> maybeDbWord64Decoder -- paramProposalDrepActivity + <*> D.column (D.nullable D.float8) -- paramProposalMinFeeRefScriptCostPerByte + +entityParamProposalEncoder :: E.Params (Entity ParamProposal) +entityParamProposalEncoder = + mconcat + [ entityKey >$< idEncoder getParamProposalId + , entityVal >$< paramProposalEncoder + ] + +paramProposalEncoder :: E.Params ParamProposal +paramProposalEncoder = + mconcat + [ paramProposalEpochNo >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , paramProposalKey >$< E.param (E.nullable E.bytea) + , paramProposalMinFeeA >$< maybeDbWord64Encoder + , paramProposalMinFeeB >$< maybeDbWord64Encoder + , paramProposalMaxBlockSize >$< maybeDbWord64Encoder + , paramProposalMaxTxSize >$< maybeDbWord64Encoder + , paramProposalMaxBhSize >$< maybeDbWord64Encoder + , paramProposalKeyDeposit >$< maybeDbLovelaceEncoder + , paramProposalPoolDeposit >$< maybeDbLovelaceEncoder + , paramProposalMaxEpoch >$< maybeDbWord64Encoder + , paramProposalOptimalPoolCount >$< maybeDbWord64Encoder + , paramProposalInfluence >$< E.param (E.nullable E.float8) + , paramProposalMonetaryExpandRate >$< E.param (E.nullable E.float8) + , paramProposalTreasuryGrowthRate >$< E.param (E.nullable E.float8) + , paramProposalDecentralisation >$< E.param (E.nullable E.float8) + , paramProposalEntropy >$< E.param (E.nullable E.bytea) + , paramProposalProtocolMajor >$< E.param (E.nullable $ fromIntegral >$< E.int2) + , paramProposalProtocolMinor >$< E.param (E.nullable $ fromIntegral >$< E.int2) + , paramProposalMinUtxoValue >$< maybeDbLovelaceEncoder + , paramProposalCoinsPerUtxoSize >$< maybeDbLovelaceEncoder + , paramProposalCostModelId >$< maybeIdEncoder getCostModelId + , paramProposalPriceMem >$< E.param (E.nullable E.float8) + , paramProposalPriceStep >$< E.param (E.nullable E.float8) + , paramProposalMaxTxExMem >$< maybeDbWord64Encoder + , paramProposalMaxTxExSteps >$< maybeDbWord64Encoder + , paramProposalMaxBlockExMem >$< maybeDbWord64Encoder + , paramProposalMaxBlockExSteps >$< maybeDbWord64Encoder + , paramProposalMaxValSize >$< maybeDbWord64Encoder + , paramProposalCollateralPercent >$< E.param (E.nullable $ fromIntegral >$< E.int2) + , paramProposalMaxCollateralInputs >$< E.param (E.nullable $ fromIntegral >$< E.int2) + , paramProposalRegisteredTxId >$< idEncoder getTxId + , paramProposalMinPoolCost >$< maybeDbLovelaceEncoder + , paramProposalPvtMotionNoConfidence >$< E.param (E.nullable E.float8) + , paramProposalPvtCommitteeNormal >$< E.param (E.nullable E.float8) + , paramProposalPvtCommitteeNoConfidence >$< E.param (E.nullable E.float8) + , paramProposalPvtHardForkInitiation >$< E.param (E.nullable E.float8) + , paramProposalPvtppSecurityGroup >$< E.param (E.nullable E.float8) + , paramProposalDvtMotionNoConfidence >$< E.param (E.nullable E.float8) + , paramProposalDvtCommitteeNormal >$< E.param (E.nullable E.float8) + , paramProposalDvtCommitteeNoConfidence >$< E.param (E.nullable E.float8) + , paramProposalDvtUpdateToConstitution >$< E.param (E.nullable E.float8) + , paramProposalDvtHardForkInitiation >$< E.param (E.nullable E.float8) + , paramProposalDvtPPNetworkGroup >$< E.param (E.nullable E.float8) + , paramProposalDvtPPEconomicGroup >$< E.param (E.nullable E.float8) + , paramProposalDvtPPTechnicalGroup >$< E.param (E.nullable E.float8) + , paramProposalDvtPPGovGroup >$< E.param (E.nullable E.float8) + , paramProposalDvtTreasuryWithdrawal >$< E.param (E.nullable E.float8) + , paramProposalCommitteeMinSize >$< maybeDbWord64Encoder + , paramProposalCommitteeMaxTermLength >$< maybeDbWord64Encoder + , paramProposalGovActionLifetime >$< maybeDbWord64Encoder + , paramProposalGovActionDeposit >$< maybeDbWord64Encoder + , paramProposalDrepDeposit >$< maybeDbWord64Encoder + , paramProposalDrepActivity >$< maybeDbWord64Encoder + , paramProposalMinFeeRefScriptCostPerByte >$< E.param (E.nullable E.float8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: treasury_withdrawal +-- Description: +data TreasuryWithdrawal = TreasuryWithdrawal + { treasuryWithdrawalGovActionProposalId :: !GovActionProposalId -- noreference + , treasuryWithdrawalStakeAddressId :: !StakeAddressId -- noreference + , treasuryWithdrawalAmount :: !DbLovelace -- sqltype=lovelace + } + deriving (Eq, Show, Generic) + +type instance Key TreasuryWithdrawal = TreasuryWithdrawalId +instance DbInfo TreasuryWithdrawal + +entityTreasuryWithdrawalDecoder :: D.Row (Entity TreasuryWithdrawal) +entityTreasuryWithdrawalDecoder = + Entity + <$> idDecoder TreasuryWithdrawalId -- entityKey + <*> treasuryWithdrawalDecoder -- entityVal + +treasuryWithdrawalDecoder :: D.Row TreasuryWithdrawal +treasuryWithdrawalDecoder = + TreasuryWithdrawal + <$> idDecoder GovActionProposalId -- treasuryWithdrawalGovActionProposalId + <*> idDecoder StakeAddressId -- treasuryWithdrawalStakeAddressId + <*> dbLovelaceDecoder -- treasuryWithdrawalAmount + +entityTreasuryWithdrawalEncoder :: E.Params (Entity TreasuryWithdrawal) +entityTreasuryWithdrawalEncoder = + mconcat + [ entityKey >$< idEncoder getTreasuryWithdrawalId + , entityVal >$< treasuryWithdrawalEncoder + ] + +treasuryWithdrawalEncoder :: E.Params TreasuryWithdrawal +treasuryWithdrawalEncoder = + mconcat + [ treasuryWithdrawalGovActionProposalId >$< idEncoder getGovActionProposalId + , treasuryWithdrawalStakeAddressId >$< idEncoder getStakeAddressId + , treasuryWithdrawalAmount >$< dbLovelaceEncoder + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: event_info +-- Description: Contains information about events, including the epoch in which they occurred and the type of event. +data EventInfo = EventInfo + { eventInfoTxId :: !(Maybe TxId) -- noreference + , eventInfoEpoch :: !Word64 -- sqltype=word31type + , eventInfoType :: !Text + , eventInfoExplanation :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key EventInfo = EventInfoId +instance DbInfo EventInfo + +entityEventInfoDecoder :: D.Row (Entity EventInfo) +entityEventInfoDecoder = + Entity + <$> idDecoder EventInfoId -- entityKey + <*> eventInfoDecoder -- entityVal + +eventInfoDecoder :: D.Row EventInfo +eventInfoDecoder = + EventInfo + <$> maybeIdDecoder TxId -- eventInfoTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- eventInfoEpoch + <*> D.column (D.nonNullable D.text) -- eventInfoType + <*> D.column (D.nullable D.text) -- eventInfoExplanation + +entityEventInfoEncoder :: E.Params (Entity EventInfo) +entityEventInfoEncoder = + mconcat + [ entityKey >$< idEncoder getEventInfoId + , entityVal >$< eventInfoEncoder + ] + +eventInfoEncoder :: E.Params EventInfo +eventInfoEncoder = + mconcat + [ eventInfoTxId >$< maybeIdEncoder getTxId + , eventInfoEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , eventInfoType >$< E.param (E.nonNullable E.text) + , eventInfoExplanation >$< E.param (E.nullable E.text) + ] diff --git a/cardano-db/src/Cardano/Db/Schema/Core/MultiAsset.hs b/cardano-db/src/Cardano/Db/Schema/Core/MultiAsset.hs new file mode 100644 index 000000000..acb0cf444 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/MultiAsset.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Schema.Core.MultiAsset where + +import Contravariant.Extras (contrazip3) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant ((>$<)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Hasql.Decoders as D +import Hasql.Encoders as E + +import Cardano.Db.Schema.Ids +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types (DbInt65, dbInt65Decoder, dbInt65Encoder) + +----------------------------------------------------------------------------------------------------------------------------------- +-- MULTI ASSETS +-- These tables manage governance-related data, including DReps, committees, and voting procedures. +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: multi_asset +-- Description: Contains information about multi-assets, including the policy and name of the asset. +data MultiAsset = MultiAsset + { multiAssetPolicy :: !ByteString -- sqltype=hash28type + , multiAssetName :: !ByteString -- sqltype=asset32type + , multiAssetFingerprint :: !Text + } + deriving (Eq, Show, Generic) + +type instance Key MultiAsset = MultiAssetId +instance DbInfo MultiAsset where + uniqueFields _ = ["policy", "name"] + +entityMultiAssetDecoder :: D.Row (Entity MultiAsset) +entityMultiAssetDecoder = + Entity + <$> idDecoder MultiAssetId + <*> multiAssetDecoder + +multiAssetDecoder :: D.Row MultiAsset +multiAssetDecoder = + MultiAsset + <$> D.column (D.nonNullable D.bytea) -- multiAssetPolicy + <*> D.column (D.nonNullable D.bytea) -- multiAssetName + <*> D.column (D.nonNullable D.text) -- multiAssetFingerprint + +entityMultiAssetEncoder :: E.Params (Entity MultiAsset) +entityMultiAssetEncoder = + mconcat + [ entityKey >$< idEncoder getMultiAssetId + , entityVal >$< multiAssetEncoder + ] + +multiAssetEncoder :: E.Params MultiAsset +multiAssetEncoder = + mconcat + [ multiAssetPolicy >$< E.param (E.nonNullable E.bytea) + , multiAssetName >$< E.param (E.nonNullable E.bytea) + , multiAssetFingerprint >$< E.param (E.nonNullable E.text) + ] + +multiAssetInsertEncoder :: E.Params MultiAsset +multiAssetInsertEncoder = + mconcat + [ multiAssetPolicy >$< E.param (E.nonNullable E.bytea) + , multiAssetName >$< E.param (E.nonNullable E.bytea) + , multiAssetFingerprint >$< E.param (E.nonNullable E.text) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: ma_tx_mint +-- Description: Contains information about the minting of multi-assets, including the quantity of the asset and the transaction in which it was minted. +data MaTxMint = MaTxMint + { maTxMintQuantity :: !DbInt65 -- sqltype=int65type + , maTxMintIdent :: !MultiAssetId -- noreference + , maTxMintTxId :: !TxId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key MaTxMint = MaTxMintId +instance DbInfo MaTxMint + +entityMaTxMintDecoder :: D.Row (Entity MaTxMint) +entityMaTxMintDecoder = + Entity + <$> idDecoder MaTxMintId + <*> maTxMintDecoder + +maTxMintDecoder :: D.Row MaTxMint +maTxMintDecoder = + MaTxMint + <$> D.column (D.nonNullable dbInt65Decoder) + <*> idDecoder MultiAssetId + <*> idDecoder TxId + +entityMaTxMintEncoder :: E.Params (Entity MaTxMint) +entityMaTxMintEncoder = + mconcat + [ entityKey >$< idEncoder getMaTxMintId + , entityVal >$< maTxMintEncoder + ] + +maTxMintEncoder :: E.Params MaTxMint +maTxMintEncoder = + mconcat + [ maTxMintQuantity >$< E.param (E.nonNullable dbInt65Encoder) + , maTxMintIdent >$< idEncoder getMultiAssetId + , maTxMintTxId >$< idEncoder getTxId + ] + +maTxMintBulkEncoder :: E.Params ([DbInt65], [MultiAssetId], [TxId]) +maTxMintBulkEncoder = + contrazip3 + (bulkEncoder $ E.nonNullable dbInt65Encoder) + (bulkEncoder $ E.nonNullable $ getMultiAssetId >$< E.int8) + (bulkEncoder $ E.nonNullable $ getTxId >$< E.int8) diff --git a/cardano-db/src/Cardano/Db/Schema/Core/OffChain.hs b/cardano-db/src/Cardano/Db/Schema/Core/OffChain.hs new file mode 100644 index 000000000..1cc7bc431 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/OffChain.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Schema.Core.OffChain where + +import Contravariant.Extras (contrazip3, contrazip5, contrazip6) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import GHC.Generics (Generic) +import Hasql.Decoders as D +import Hasql.Encoders as E + +import Cardano.Db.Schema.Ids +import Cardano.Db.Schema.Orphans () +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) + +----------------------------------------------------------------------------------------------------------------------------------- +-- OFFCHAIN +-- These tables manage off-chain data, including pool and vote data. +---------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_pool_data +-- Description: +data OffChainPoolData = OffChainPoolData + { offChainPoolDataPoolId :: !PoolHashId -- noreference + , offChainPoolDataTickerName :: !Text + , offChainPoolDataHash :: !ByteString -- sqltype=hash32type + , offChainPoolDataJson :: !Text -- sqltype=jsonb + , offChainPoolDataBytes :: !ByteString -- sqltype=bytea + , offChainPoolDataPmrId :: !PoolMetadataRefId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key OffChainPoolData = OffChainPoolDataId +instance DbInfo OffChainPoolData where + uniqueFields _ = ["pool_id", "prm_id"] + +entityOffChainPoolDataDecoder :: D.Row (Entity OffChainPoolData) +entityOffChainPoolDataDecoder = + Entity + <$> idDecoder OffChainPoolDataId + <*> offChainPoolDataDecoder + +offChainPoolDataDecoder :: D.Row OffChainPoolData +offChainPoolDataDecoder = + OffChainPoolData + <$> idDecoder PoolHashId -- offChainPoolDataPoolId + <*> D.column (D.nonNullable D.text) -- offChainPoolDataTickerName + <*> D.column (D.nonNullable D.bytea) -- offChainPoolDataHash + <*> D.column (D.nonNullable D.text) -- offChainPoolDataJson + <*> D.column (D.nonNullable D.bytea) -- offChainPoolDataBytes + <*> idDecoder PoolMetadataRefId -- offChainPoolDataPmrId + +entityOffChainPoolDataEncoder :: E.Params (Entity OffChainPoolData) +entityOffChainPoolDataEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainPoolDataId + , entityVal >$< offChainPoolDataEncoder + ] + +offChainPoolDataEncoder :: E.Params OffChainPoolData +offChainPoolDataEncoder = + mconcat + [ offChainPoolDataPoolId >$< idEncoder getPoolHashId + , offChainPoolDataTickerName >$< E.param (E.nonNullable E.text) + , offChainPoolDataHash >$< E.param (E.nonNullable E.bytea) + , offChainPoolDataJson >$< E.param (E.nonNullable E.text) + , offChainPoolDataBytes >$< E.param (E.nonNullable E.bytea) + , offChainPoolDataPmrId >$< idEncoder getPoolMetadataRefId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_pool_fetch_error +-- Description: + +-- The pool metadata fetch error. We duplicate the poolId for easy access. +-- TODO(KS): Debatable whether we need to persist this between migrations! +data OffChainPoolFetchError = OffChainPoolFetchError + { offChainPoolFetchErrorPoolId :: !PoolHashId -- noreference + , offChainPoolFetchErrorFetchTime :: !UTCTime -- sqltype=timestamp + , offChainPoolFetchErrorPmrId :: !PoolMetadataRefId -- noreference + , offChainPoolFetchErrorFetchError :: !Text + , offChainPoolFetchErrorRetryCount :: !Word -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key OffChainPoolFetchError = OffChainPoolFetchErrorId +instance DbInfo OffChainPoolFetchError where + uniqueFields _ = ["pool_id", "fetch_time", "retry_count"] + +entityOffChainPoolFetchErrorDecoder :: D.Row (Entity OffChainPoolFetchError) +entityOffChainPoolFetchErrorDecoder = + Entity + <$> idDecoder OffChainPoolFetchErrorId + <*> offChainPoolFetchErrorDecoder + +offChainPoolFetchErrorDecoder :: D.Row OffChainPoolFetchError +offChainPoolFetchErrorDecoder = + OffChainPoolFetchError + <$> idDecoder PoolHashId -- offChainPoolFetchErrorPoolId + <*> D.column (D.nonNullable D.timestamptz) -- offChainPoolFetchErrorFetchTime + <*> idDecoder PoolMetadataRefId -- offChainPoolFetchErrorPmrId + <*> D.column (D.nonNullable D.text) -- offChainPoolFetchErrorFetchError + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- offChainPoolFetchErrorRetryCount + +entityOffChainPoolFetchErrorEncoder :: E.Params (Entity OffChainPoolFetchError) +entityOffChainPoolFetchErrorEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainPoolFetchErrorId + , entityVal >$< offChainPoolFetchErrorEncoder + ] + +offChainPoolFetchErrorEncoder :: E.Params OffChainPoolFetchError +offChainPoolFetchErrorEncoder = + mconcat + [ offChainPoolFetchErrorPoolId >$< idEncoder getPoolHashId + , offChainPoolFetchErrorFetchTime >$< E.param (E.nonNullable E.timestamptz) + , offChainPoolFetchErrorPmrId >$< idEncoder getPoolMetadataRefId + , offChainPoolFetchErrorFetchError >$< E.param (E.nonNullable E.text) + , offChainPoolFetchErrorRetryCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_data +-- Description: +data OffChainVoteData = OffChainVoteData + { offChainVoteDataVotingAnchorId :: !VotingAnchorId -- noreference + , offChainVoteDataHash :: !ByteString + , offChainVoteDataLanguage :: !Text + , offChainVoteDataComment :: !(Maybe Text) + , offChainVoteDataJson :: !Text -- sqltype=jsonb + , offChainVoteDataBytes :: !ByteString -- sqltype=bytea + , offChainVoteDataWarning :: !(Maybe Text) + , offChainVoteDataIsValid :: !(Maybe Bool) + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteData = OffChainVoteDataId +instance DbInfo OffChainVoteData where + uniqueFields _ = ["hash", "voting_anchor_id"] + +entityOffChainVoteDataDecoder :: D.Row (Entity OffChainVoteData) +entityOffChainVoteDataDecoder = + Entity + <$> idDecoder OffChainVoteDataId + <*> offChainVoteDataDecoder + +offChainVoteDataDecoder :: D.Row OffChainVoteData +offChainVoteDataDecoder = + OffChainVoteData + <$> idDecoder VotingAnchorId -- offChainVoteDataVotingAnchorId + <*> D.column (D.nonNullable D.bytea) -- offChainVoteDataHash + <*> D.column (D.nonNullable D.text) -- offChainVoteDataLanguage + <*> D.column (D.nullable D.text) -- offChainVoteDataComment + <*> D.column (D.nonNullable D.text) -- offChainVoteDataJson + <*> D.column (D.nonNullable D.bytea) -- offChainVoteDataBytes + <*> D.column (D.nullable D.text) -- offChainVoteDataWarning + <*> D.column (D.nullable D.bool) -- offChainVoteDataIsValid + +entityOffChainVoteDataEncoder :: E.Params (Entity OffChainVoteData) +entityOffChainVoteDataEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteDataId + , entityVal >$< offChainVoteDataEncoder + ] + +offChainVoteDataEncoder :: E.Params OffChainVoteData +offChainVoteDataEncoder = + mconcat + [ offChainVoteDataVotingAnchorId >$< idEncoder getVotingAnchorId + , offChainVoteDataHash >$< E.param (E.nonNullable E.bytea) + , offChainVoteDataLanguage >$< E.param (E.nonNullable E.text) + , offChainVoteDataComment >$< E.param (E.nullable E.text) + , offChainVoteDataJson >$< E.param (E.nonNullable E.text) + , offChainVoteDataBytes >$< E.param (E.nonNullable E.bytea) + , offChainVoteDataWarning >$< E.param (E.nullable E.text) + , offChainVoteDataIsValid >$< E.param (E.nullable E.bool) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_gov_action_data +-- Description: +data OffChainVoteGovActionData = OffChainVoteGovActionData + { offChainVoteGovActionDataOffChainVoteDataId :: !OffChainVoteDataId -- noreference + , offChainVoteGovActionDataTitle :: !Text + , offChainVoteGovActionDataAbstract :: !Text + , offChainVoteGovActionDataMotivation :: !Text + , offChainVoteGovActionDataRationale :: !Text + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteGovActionData = OffChainVoteGovActionDataId +instance DbInfo OffChainVoteGovActionData + +entityOffChainVoteGovActionDataDecoder :: D.Row (Entity OffChainVoteGovActionData) +entityOffChainVoteGovActionDataDecoder = + Entity + <$> idDecoder OffChainVoteGovActionDataId + <*> offChainVoteGovActionDataDecoder + +offChainVoteGovActionDataDecoder :: D.Row OffChainVoteGovActionData +offChainVoteGovActionDataDecoder = + OffChainVoteGovActionData + <$> idDecoder OffChainVoteDataId -- offChainVoteGovActionDataOffChainVoteDataId + <*> D.column (D.nonNullable D.text) -- offChainVoteGovActionDataTitle + <*> D.column (D.nonNullable D.text) -- offChainVoteGovActionDataAbstract + <*> D.column (D.nonNullable D.text) -- offChainVoteGovActionDataMotivation + <*> D.column (D.nonNullable D.text) -- offChainVoteGovActionDataRationale + +entityOffChainVoteGovActionDataEncoder :: E.Params (Entity OffChainVoteGovActionData) +entityOffChainVoteGovActionDataEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteGovActionDataId + , entityVal >$< offChainVoteGovActionDataEncoder + ] + +offChainVoteGovActionDataEncoder :: E.Params OffChainVoteGovActionData +offChainVoteGovActionDataEncoder = + mconcat + [ offChainVoteGovActionDataOffChainVoteDataId >$< idEncoder getOffChainVoteDataId + , offChainVoteGovActionDataTitle >$< E.param (E.nonNullable E.text) + , offChainVoteGovActionDataAbstract >$< E.param (E.nonNullable E.text) + , offChainVoteGovActionDataMotivation >$< E.param (E.nonNullable E.text) + , offChainVoteGovActionDataRationale >$< E.param (E.nonNullable E.text) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_drep_data +-- Description: +data OffChainVoteDrepData = OffChainVoteDrepData + { offChainVoteDrepDataOffChainVoteDataId :: !OffChainVoteDataId -- noreference + , offChainVoteDrepDataPaymentAddress :: !(Maybe Text) + , offChainVoteDrepDataGivenName :: !Text + , offChainVoteDrepDataObjectives :: !(Maybe Text) + , offChainVoteDrepDataMotivations :: !(Maybe Text) + , offChainVoteDrepDataQualifications :: !(Maybe Text) + , offChainVoteDrepDataImageUrl :: !(Maybe Text) + , offChainVoteDrepDataImageHash :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteDrepData = OffChainVoteDrepDataId +instance DbInfo OffChainVoteDrepData + +entityOffChainVoteDrepDataDecoder :: D.Row (Entity OffChainVoteDrepData) +entityOffChainVoteDrepDataDecoder = + Entity + <$> idDecoder OffChainVoteDrepDataId + <*> offChainVoteDrepDataDecoder + +offChainVoteDrepDataDecoder :: D.Row OffChainVoteDrepData +offChainVoteDrepDataDecoder = + OffChainVoteDrepData + <$> idDecoder OffChainVoteDataId -- offChainVoteDrepDataOffChainVoteDataId + <*> D.column (D.nullable D.text) -- offChainVoteDrepDataPaymentAddress + <*> D.column (D.nonNullable D.text) -- offChainVoteDrepDataGivenName + <*> D.column (D.nullable D.text) -- offChainVoteDrepDataObjectives + <*> D.column (D.nullable D.text) -- offChainVoteDrepDataMotivations + <*> D.column (D.nullable D.text) -- offChainVoteDrepDataQualifications + <*> D.column (D.nullable D.text) -- offChainVoteDrepDataImageUrl + <*> D.column (D.nullable D.text) -- offChainVoteDrepDataImageHash + +entityOffChainVoteDrepDataEncoder :: E.Params (Entity OffChainVoteDrepData) +entityOffChainVoteDrepDataEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteDrepDataId + , entityVal >$< offChainVoteDrepDataEncoder + ] + +offChainVoteDrepDataEncoder :: E.Params OffChainVoteDrepData +offChainVoteDrepDataEncoder = + mconcat + [ offChainVoteDrepDataOffChainVoteDataId >$< idEncoder getOffChainVoteDataId + , offChainVoteDrepDataPaymentAddress >$< E.param (E.nullable E.text) + , offChainVoteDrepDataGivenName >$< E.param (E.nonNullable E.text) + , offChainVoteDrepDataObjectives >$< E.param (E.nullable E.text) + , offChainVoteDrepDataMotivations >$< E.param (E.nullable E.text) + , offChainVoteDrepDataQualifications >$< E.param (E.nullable E.text) + , offChainVoteDrepDataImageUrl >$< E.param (E.nullable E.text) + , offChainVoteDrepDataImageHash >$< E.param (E.nullable E.text) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_author +-- Description: +data OffChainVoteAuthor = OffChainVoteAuthor + { offChainVoteAuthorOffChainVoteDataId :: !OffChainVoteDataId -- noreference + , offChainVoteAuthorName :: !(Maybe Text) + , offChainVoteAuthorWitnessAlgorithm :: !Text + , offChainVoteAuthorPublicKey :: !Text + , offChainVoteAuthorSignature :: !Text + , offChainVoteAuthorWarning :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteAuthor = OffChainVoteAuthorId +instance DbInfo OffChainVoteAuthor + +entityOffChainVoteAuthorDecoder :: D.Row (Entity OffChainVoteAuthor) +entityOffChainVoteAuthorDecoder = + Entity + <$> idDecoder OffChainVoteAuthorId + <*> offChainVoteAuthorDecoder + +offChainVoteAuthorDecoder :: D.Row OffChainVoteAuthor +offChainVoteAuthorDecoder = + OffChainVoteAuthor + <$> idDecoder OffChainVoteDataId -- offChainVoteAuthorOffChainVoteDataId + <*> D.column (D.nullable D.text) -- offChainVoteAuthorName + <*> D.column (D.nonNullable D.text) -- offChainVoteAuthorWitnessAlgorithm + <*> D.column (D.nonNullable D.text) -- offChainVoteAuthorPublicKey + <*> D.column (D.nonNullable D.text) -- offChainVoteAuthorSignature + <*> D.column (D.nullable D.text) -- offChainVoteAuthorWarning + +entityOffChainVoteAuthorEncoder :: E.Params (Entity OffChainVoteAuthor) +entityOffChainVoteAuthorEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteAuthorId + , entityVal >$< offChainVoteAuthorEncoder + ] + +offChainVoteAuthorEncoder :: E.Params OffChainVoteAuthor +offChainVoteAuthorEncoder = + mconcat + [ offChainVoteAuthorOffChainVoteDataId >$< idEncoder getOffChainVoteDataId + , offChainVoteAuthorName >$< E.param (E.nullable E.text) + , offChainVoteAuthorWitnessAlgorithm >$< E.param (E.nonNullable E.text) + , offChainVoteAuthorPublicKey >$< E.param (E.nonNullable E.text) + , offChainVoteAuthorSignature >$< E.param (E.nonNullable E.text) + , offChainVoteAuthorWarning >$< E.param (E.nullable E.text) + ] + +offChainVoteAuthorBulkEncoder :: + E.Params ([OffChainVoteDataId], [Maybe Text], [Text], [Text], [Text], [Maybe Text]) +offChainVoteAuthorBulkEncoder = + contrazip6 + (bulkEncoder $ idBulkEncoder getOffChainVoteDataId) + (bulkEncoder $ E.nullable E.text) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nullable E.text) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_reference +-- Description: +data OffChainVoteReference = OffChainVoteReference + { offChainVoteReferenceOffChainVoteDataId :: !OffChainVoteDataId -- noreference + , offChainVoteReferenceLabel :: !Text + , offChainVoteReferenceUri :: !Text + , offChainVoteReferenceHashDigest :: !(Maybe Text) + , offChainVoteReferenceHashAlgorithm :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteReference = OffChainVoteReferenceId +instance DbInfo OffChainVoteReference + +entityOffChainVoteReferenceDecoder :: D.Row (Entity OffChainVoteReference) +entityOffChainVoteReferenceDecoder = + Entity + <$> idDecoder OffChainVoteReferenceId + <*> offChainVoteReferenceDecoder + +offChainVoteReferenceDecoder :: D.Row OffChainVoteReference +offChainVoteReferenceDecoder = + OffChainVoteReference + <$> idDecoder OffChainVoteDataId -- offChainVoteReferenceOffChainVoteDataId + <*> D.column (D.nonNullable D.text) -- offChainVoteReferenceLabel + <*> D.column (D.nonNullable D.text) -- offChainVoteReferenceUri + <*> D.column (D.nullable D.text) -- offChainVoteReferenceHashDigest + <*> D.column (D.nullable D.text) -- offChainVoteReferenceHashAlgorithm + +entityOffChainVoteReferenceEncoder :: E.Params (Entity OffChainVoteReference) +entityOffChainVoteReferenceEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteReferenceId + , entityVal >$< offChainVoteReferenceEncoder + ] + +offChainVoteReferenceEncoder :: E.Params OffChainVoteReference +offChainVoteReferenceEncoder = + mconcat + [ offChainVoteReferenceOffChainVoteDataId >$< idEncoder getOffChainVoteDataId + , offChainVoteReferenceLabel >$< E.param (E.nonNullable E.text) + , offChainVoteReferenceUri >$< E.param (E.nonNullable E.text) + , offChainVoteReferenceHashDigest >$< E.param (E.nullable E.text) + , offChainVoteReferenceHashAlgorithm >$< E.param (E.nullable E.text) + ] + +offChainVoteReferenceBulkEncoder :: E.Params ([OffChainVoteDataId], [Text], [Text], [Maybe Text], [Maybe Text]) +offChainVoteReferenceBulkEncoder = + contrazip5 + (bulkEncoder $ idBulkEncoder getOffChainVoteDataId) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nullable E.text) + (bulkEncoder $ E.nullable E.text) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_external_update +-- Description: +data OffChainVoteExternalUpdate = OffChainVoteExternalUpdate + { offChainVoteExternalUpdateOffChainVoteDataId :: !OffChainVoteDataId -- noreference + , offChainVoteExternalUpdateTitle :: !Text + , offChainVoteExternalUpdateUri :: !Text + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteExternalUpdate = OffChainVoteExternalUpdateId +instance DbInfo OffChainVoteExternalUpdate + +entityOffChainVoteExternalUpdateDecoder :: D.Row (Entity OffChainVoteExternalUpdate) +entityOffChainVoteExternalUpdateDecoder = + Entity + <$> idDecoder OffChainVoteExternalUpdateId + <*> offChainVoteExternalUpdateDecoder + +offChainVoteExternalUpdateDecoder :: D.Row OffChainVoteExternalUpdate +offChainVoteExternalUpdateDecoder = + OffChainVoteExternalUpdate + <$> idDecoder OffChainVoteDataId -- offChainVoteExternalUpdateOffChainVoteDataId + <*> D.column (D.nonNullable D.text) -- offChainVoteExternalUpdateTitle + <*> D.column (D.nonNullable D.text) -- offChainVoteExternalUpdateUri + +entityOffChainVoteExternalUpdateEncoder :: E.Params (Entity OffChainVoteExternalUpdate) +entityOffChainVoteExternalUpdateEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteExternalUpdateId + , entityVal >$< offChainVoteExternalUpdateEncoder + ] + +offChainVoteExternalUpdateEncoder :: E.Params OffChainVoteExternalUpdate +offChainVoteExternalUpdateEncoder = + mconcat + [ offChainVoteExternalUpdateOffChainVoteDataId >$< idEncoder getOffChainVoteDataId + , offChainVoteExternalUpdateTitle >$< E.param (E.nonNullable E.text) + , offChainVoteExternalUpdateUri >$< E.param (E.nonNullable E.text) + ] + +offChainVoteExternalUpdatesEncoder :: E.Params ([OffChainVoteDataId], [Text], [Text]) +offChainVoteExternalUpdatesEncoder = + contrazip3 + (bulkEncoder $ idBulkEncoder getOffChainVoteDataId) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + +offChainVoteExternalUpdatesBulkEncoder :: E.Params ([OffChainVoteDataId], [Text], [Text]) +offChainVoteExternalUpdatesBulkEncoder = + contrazip3 + (bulkEncoder $ idBulkEncoder getOffChainVoteDataId) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: off_chain_vote_fetch_error +-- Description: +data OffChainVoteFetchError = OffChainVoteFetchError + { offChainVoteFetchErrorVotingAnchorId :: !VotingAnchorId -- noreference + , offChainVoteFetchErrorFetchError :: !Text + , offChainVoteFetchErrorFetchTime :: !UTCTime -- sqltype=timestamp + , offChainVoteFetchErrorRetryCount :: !Word -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteFetchError = OffChainVoteFetchErrorId +instance DbInfo OffChainVoteFetchError where + uniqueFields _ = ["voting_anchor_id", "retry_count"] + +entityOffChainVoteFetchErrorDecoder :: D.Row (Entity OffChainVoteFetchError) +entityOffChainVoteFetchErrorDecoder = + Entity + <$> idDecoder OffChainVoteFetchErrorId + <*> offChainVoteFetchErrorDecoder + +offChainVoteFetchErrorDecoder :: D.Row OffChainVoteFetchError +offChainVoteFetchErrorDecoder = + OffChainVoteFetchError + <$> idDecoder VotingAnchorId -- offChainVoteFetchErrorVotingAnchorId + <*> D.column (D.nonNullable D.text) -- offChainVoteFetchErrorFetchError + <*> D.column (D.nonNullable D.timestamptz) -- offChainVoteFetchErrorFetchTime + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- offChainVoteFetchErrorRetryCount + +entityOffChainVoteFetchErrorEncoder :: E.Params (Entity OffChainVoteFetchError) +entityOffChainVoteFetchErrorEncoder = + mconcat + [ entityKey >$< idEncoder getOffChainVoteFetchErrorId + , entityVal >$< offChainVoteFetchErrorEncoder + ] + +offChainVoteFetchErrorEncoder :: E.Params OffChainVoteFetchError +offChainVoteFetchErrorEncoder = + mconcat + [ offChainVoteFetchErrorVotingAnchorId >$< idEncoder getVotingAnchorId + , offChainVoteFetchErrorFetchError >$< E.param (E.nonNullable E.text) + , offChainVoteFetchErrorFetchTime >$< E.param (E.nonNullable E.timestamptz) + , offChainVoteFetchErrorRetryCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] diff --git a/cardano-db/src/Cardano/Db/Schema/Core/Pool.hs b/cardano-db/src/Cardano/Db/Schema/Core/Pool.hs new file mode 100644 index 000000000..3a74c373b --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/Pool.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Schema.Core.Pool where + +import Cardano.Db.Schema.Ids +import Cardano.Db.Schema.Orphans () +import Cardano.Db.Schema.Types ( + PoolUrl (..), + unPoolUrl, + ) +import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) + +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types ( + DbLovelace (..), + DbWord64 (..), + dbLovelaceDecoder, + dbLovelaceEncoder, + ) +import Contravariant.Extras (contrazip6) +import Data.Functor.Contravariant ((>$<)) +import Hasql.Decoders as D +import Hasql.Encoders as E + +----------------------------------------------------------------------------------------------------------------------------------- +-- POOLS +-- These tables manage stake pool-related data, including pool registration, updates, and retirements. +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_hash +-- Description: A table containing information about pool hashes. +data PoolHash = PoolHash + { poolHashHashRaw :: !ByteString -- unique hashRaw sqltype=hash28type + , poolHashView :: !Text + } + deriving (Eq, Show, Generic) + +type instance Key PoolHash = PoolHashId +instance DbInfo PoolHash where + uniqueFields _ = ["hash_raw"] + +entityPoolHashDecoder :: D.Row (Entity PoolHash) +entityPoolHashDecoder = + Entity + <$> idDecoder PoolHashId + <*> poolHashDecoder + +poolHashDecoder :: D.Row PoolHash +poolHashDecoder = + PoolHash + <$> D.column (D.nonNullable D.bytea) -- poolHashHashRaw + <*> D.column (D.nonNullable D.text) -- poolHashView + +entityPoolHashEncoder :: E.Params (Entity PoolHash) +entityPoolHashEncoder = + mconcat + [ entityKey >$< idEncoder getPoolHashId + , entityVal >$< poolHashEncoder + ] + +poolHashEncoder :: E.Params PoolHash +poolHashEncoder = + mconcat + [ poolHashHashRaw >$< E.param (E.nonNullable E.bytea) -- poolHashHashRaw + , poolHashView >$< E.param (E.nonNullable E.text) -- poolHashView + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_stat +-- Description: A table containing information about pool metadata. +data PoolStat = PoolStat + { poolStatPoolHashId :: !PoolHashId -- noreference + , poolStatEpochNo :: !Word64 -- sqltype=word31type + , poolStatNumberOfBlocks :: !DbWord64 -- sqltype=word64type + , poolStatNumberOfDelegators :: !DbWord64 -- sqltype=word64type + , poolStatStake :: !DbWord64 -- sqltype=word64type + , poolStatVotingPower :: !(Maybe DbWord64) -- sqltype=word64type + } + deriving (Eq, Show, Generic) + +type instance Key PoolStat = PoolStatId +instance DbInfo PoolStat + +entityPoolStatDecoder :: D.Row (Entity PoolStat) +entityPoolStatDecoder = + Entity + <$> idDecoder PoolStatId + <*> poolStatDecoder + +poolStatDecoder :: D.Row PoolStat +poolStatDecoder = + PoolStat + <$> idDecoder PoolHashId -- poolStatPoolHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- poolStatEpochNo + <*> D.column (D.nonNullable $ DbWord64 . fromIntegral <$> D.int8) -- poolStatNumberOfBlocks + <*> D.column (D.nonNullable $ DbWord64 . fromIntegral <$> D.int8) -- poolStatNumberOfDelegators + <*> D.column (D.nonNullable $ DbWord64 . fromIntegral <$> D.int8) -- poolStatStake + <*> D.column (D.nullable $ DbWord64 . fromIntegral <$> D.int8) -- poolStatVotingPower + +entityPoolStatEncoder :: E.Params (Entity PoolStat) +entityPoolStatEncoder = + mconcat + [ entityKey >$< idEncoder getPoolStatId + , entityVal >$< poolStatEncoder + ] + +poolStatEncoder :: E.Params PoolStat +poolStatEncoder = + mconcat + [ poolStatPoolHashId >$< idEncoder getPoolHashId + , poolStatEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , poolStatNumberOfBlocks >$< E.param (E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + , poolStatNumberOfDelegators >$< E.param (E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + , poolStatStake >$< E.param (E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + , poolStatVotingPower >$< E.param (E.nullable $ fromIntegral . unDbWord64 >$< E.int8) + ] + +poolStatBulkEncoder :: E.Params ([PoolHashId], [Word64], [DbWord64], [DbWord64], [DbWord64], [Maybe DbWord64]) +poolStatBulkEncoder = + contrazip6 + (bulkEncoder $ E.nonNullable $ getPoolHashId >$< E.int8) -- poolHashId + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int4) -- epoch_no + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.numeric) -- number_of_blocks + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.numeric) -- number_of_delegators + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.numeric) -- stake + (bulkEncoder $ E.nullable $ fromIntegral . unDbWord64 >$< E.numeric) -- voting_power + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_update +-- Description: A table containing information about pool updates. +data PoolUpdate = PoolUpdate + { poolUpdateHashId :: !PoolHashId -- noreference + , poolUpdateCertIndex :: !Word16 + , poolUpdateVrfKeyHash :: !ByteString -- sqltype=hash32type + , poolUpdatePledge :: !DbLovelace -- sqltype=lovelace + , poolUpdateRewardAddrId :: !StakeAddressId -- noreference + , poolUpdateActiveEpochNo :: !Word64 + , poolUpdateMetaId :: !(Maybe PoolMetadataRefId) -- noreference + , poolUpdateMargin :: !Double -- sqltype=percentage???? + , poolUpdateFixedCost :: !DbLovelace -- sqltype=lovelace + , poolUpdateDeposit :: !(Maybe DbLovelace) -- sqltype=lovelace + , poolUpdateRegisteredTxId :: !TxId -- noreference -- Slot number in which the pool was registered. + } + deriving (Eq, Show, Generic) + +type instance Key PoolUpdate = PoolUpdateId +instance DbInfo PoolUpdate + +entityPoolUpdateDecoder :: D.Row (Entity PoolUpdate) +entityPoolUpdateDecoder = + Entity + <$> idDecoder PoolUpdateId + <*> poolUpdateDecoder + +poolUpdateDecoder :: D.Row PoolUpdate +poolUpdateDecoder = + PoolUpdate + <$> idDecoder PoolHashId -- poolUpdateHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- poolUpdateCertIndex (Word16) + <*> D.column (D.nonNullable D.bytea) -- poolUpdateVrfKeyHash + <*> dbLovelaceDecoder -- poolUpdatePledge + <*> idDecoder StakeAddressId -- poolUpdateRewardAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- poolUpdateActiveEpochNo + <*> maybeIdDecoder PoolMetadataRefId -- poolUpdateMetaId + <*> D.column (D.nonNullable D.float8) -- poolUpdateMargin + <*> dbLovelaceDecoder -- poolUpdateFixedCost + <*> D.column (D.nullable $ DbLovelace . fromIntegral <$> D.int8) -- poolUpdateDeposit + <*> idDecoder TxId -- poolUpdateRegisteredTxId + +entityPoolUpdateEncoder :: E.Params (Entity PoolUpdate) +entityPoolUpdateEncoder = + mconcat + [ entityKey >$< idEncoder getPoolUpdateId + , entityVal >$< poolUpdateEncoder + ] + +poolUpdateEncoder :: E.Params PoolUpdate +poolUpdateEncoder = + mconcat + [ poolUpdateHashId >$< idEncoder getPoolHashId + , poolUpdateCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , poolUpdateVrfKeyHash >$< E.param (E.nonNullable E.bytea) + , poolUpdatePledge >$< dbLovelaceEncoder + , poolUpdateRewardAddrId >$< idEncoder getStakeAddressId + , poolUpdateActiveEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , poolUpdateMetaId >$< maybeIdEncoder getPoolMetadataRefId + , poolUpdateMargin >$< E.param (E.nonNullable E.float8) + , poolUpdateFixedCost >$< dbLovelaceEncoder + , poolUpdateDeposit >$< E.param (E.nullable $ fromIntegral . unDbLovelace >$< E.int8) + , poolUpdateRegisteredTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_metadata_ref +-- Description: A table containing references to pool metadata. +data PoolMetadataRef = PoolMetadataRef + { poolMetadataRefPoolId :: !PoolHashId -- noreference + , poolMetadataRefUrl :: !PoolUrl -- sqltype=varchar + , poolMetadataRefHash :: !ByteString -- sqltype=hash32type + , poolMetadataRefRegisteredTxId :: !TxId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key PoolMetadataRef = PoolMetadataRefId +instance DbInfo PoolMetadataRef + +entityPoolMetadataRefDecoder :: D.Row (Entity PoolMetadataRef) +entityPoolMetadataRefDecoder = + Entity + <$> idDecoder PoolMetadataRefId + <*> poolMetadataRefDecoder + +poolMetadataRefDecoder :: D.Row PoolMetadataRef +poolMetadataRefDecoder = + PoolMetadataRef + <$> idDecoder PoolHashId -- poolMetadataRefPoolId + <*> D.column (D.nonNullable (PoolUrl <$> D.text)) -- poolMetadataRefUrl + <*> D.column (D.nonNullable D.bytea) -- poolMetadataRefHash + <*> idDecoder TxId -- poolMetadataRefRegisteredTxId + +entityPoolMetadataRefEncoder :: E.Params (Entity PoolMetadataRef) +entityPoolMetadataRefEncoder = + mconcat + [ entityKey >$< idEncoder getPoolMetadataRefId + , entityVal >$< poolMetadataRefEncoder + ] + +poolMetadataRefEncoder :: E.Params PoolMetadataRef +poolMetadataRefEncoder = + mconcat + [ poolMetadataRefPoolId >$< idEncoder getPoolHashId + , poolMetadataRefUrl >$< E.param (E.nonNullable (unPoolUrl >$< E.text)) + , poolMetadataRefHash >$< E.param (E.nonNullable E.bytea) + , poolMetadataRefRegisteredTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_owner +-- Description: A table containing information about pool owners. +data PoolOwner = PoolOwner + { poolOwnerAddrId :: !StakeAddressId -- noreference + , poolOwnerPoolUpdateId :: !PoolUpdateId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key PoolOwner = PoolOwnerId +instance DbInfo PoolOwner + +entityPoolOwnerDecoder :: D.Row (Entity PoolOwner) +entityPoolOwnerDecoder = + Entity + <$> idDecoder PoolOwnerId + <*> poolOwnerDecoder + +poolOwnerDecoder :: D.Row PoolOwner +poolOwnerDecoder = + PoolOwner + <$> idDecoder StakeAddressId -- poolOwnerAddrId + <*> idDecoder PoolUpdateId -- poolOwnerPoolUpdateId + +entityPoolOwnerEncoder :: E.Params (Entity PoolOwner) +entityPoolOwnerEncoder = + mconcat + [ entityKey >$< idEncoder getPoolOwnerId + , entityVal >$< poolOwnerEncoder + ] + +poolOwnerEncoder :: E.Params PoolOwner +poolOwnerEncoder = + mconcat + [ poolOwnerAddrId >$< idEncoder getStakeAddressId + , poolOwnerPoolUpdateId >$< idEncoder getPoolUpdateId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_retire +-- Description: A table containing information about pool retirements. +data PoolRetire = PoolRetire + { poolRetireHashId :: !PoolHashId -- noreference + , poolRetireCertIndex :: !Word16 + , poolRetireAnnouncedTxId :: !TxId -- noreference -- Slot number in which the pool announced it was retiring. + , poolRetireRetiringEpoch :: !Word64 -- sqltype=word31type -- Epoch number in which the pool will retire. + } + deriving (Eq, Show, Generic) + +type instance Key PoolRetire = PoolRetireId +instance DbInfo PoolRetire + +entityPoolRetireDecoder :: D.Row (Entity PoolRetire) +entityPoolRetireDecoder = + Entity + <$> idDecoder PoolRetireId + <*> poolRetireDecoder + +poolRetireDecoder :: D.Row PoolRetire +poolRetireDecoder = + PoolRetire + <$> idDecoder PoolHashId -- poolRetireHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- poolRetireCertIndex + <*> idDecoder TxId -- poolRetireAnnouncedTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- poolRetireRetiringEpoch + +entityPoolRetireEncoder :: E.Params (Entity PoolRetire) +entityPoolRetireEncoder = + mconcat + [ entityKey >$< idEncoder getPoolRetireId + , entityVal >$< poolRetireEncoder + ] + +poolRetireEncoder :: E.Params PoolRetire +poolRetireEncoder = + mconcat + [ poolRetireHashId >$< idEncoder getPoolHashId + , poolRetireCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , poolRetireAnnouncedTxId >$< idEncoder getTxId + , poolRetireRetiringEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: pool_relay +-- Description: A table containing information about pool relays. + +----------------------------------------------------------------------------------------------------------------------------------- +data PoolRelay = PoolRelay + { poolRelayUpdateId :: !PoolUpdateId -- noreference + , poolRelayIpv4 :: !(Maybe Text) + , poolRelayIpv6 :: !(Maybe Text) + , poolRelayDnsName :: !(Maybe Text) + , poolRelayDnsSrvName :: !(Maybe Text) + , poolRelayPort :: !(Maybe Word16) + } + deriving (Eq, Show, Generic) + +type instance Key PoolRelay = PoolRelayId +instance DbInfo PoolRelay + +entityPoolRelayDecoder :: D.Row (Entity PoolRelay) +entityPoolRelayDecoder = + Entity + <$> idDecoder PoolRelayId + <*> poolRelayDecoder + +poolRelayDecoder :: D.Row PoolRelay +poolRelayDecoder = + PoolRelay + <$> idDecoder PoolUpdateId -- poolRelayUpdateId + <*> D.column (D.nullable D.text) -- poolRelayIpv4 + <*> D.column (D.nullable D.text) -- poolRelayIpv6 + <*> D.column (D.nullable D.text) -- poolRelayDnsName + <*> D.column (D.nullable D.text) -- poolRelayDnsSrvName + <*> D.column (D.nullable $ fromIntegral <$> D.int2) -- poolRelayPort + +entityPoolRelayEncoder :: E.Params (Entity PoolRelay) +entityPoolRelayEncoder = + mconcat + [ entityKey >$< idEncoder getPoolRelayId + , entityVal >$< poolRelayEncoder + ] + +poolRelayEncoder :: E.Params PoolRelay +poolRelayEncoder = + mconcat + [ poolRelayUpdateId >$< idEncoder getPoolUpdateId + , poolRelayIpv4 >$< E.param (E.nullable E.text) + , poolRelayIpv6 >$< E.param (E.nullable E.text) + , poolRelayDnsName >$< E.param (E.nullable E.text) + , poolRelayDnsSrvName >$< E.param (E.nullable E.text) + , poolRelayPort >$< E.param (E.nullable $ fromIntegral >$< E.int2) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: delisted_pool +-- Description: A table containing a managed list of delisted pools. + +----------------------------------------------------------------------------------------------------------------------------------- + +newtype DelistedPool = DelistedPool + { delistedPoolHashRaw :: ByteString -- sqltype=hash28type + } + deriving (Eq, Show, Generic) + +type instance Key DelistedPool = DelistedPoolId +instance DbInfo DelistedPool where + uniqueFields _ = ["hash_raw"] + +entityDelistedPoolDecoder :: D.Row (Entity DelistedPool) +entityDelistedPoolDecoder = + Entity + <$> idDecoder DelistedPoolId + <*> delistedPoolDecoder + +delistedPoolDecoder :: D.Row DelistedPool +delistedPoolDecoder = + DelistedPool + <$> D.column (D.nonNullable D.bytea) -- delistedPoolHashRaw + +entityDelistedPoolEncoder :: E.Params (Entity DelistedPool) +entityDelistedPoolEncoder = + mconcat + [ entityKey >$< idEncoder getDelistedPoolId + , entityVal >$< delistedPoolEncoder + ] + +delistedPoolEncoder :: E.Params DelistedPool +delistedPoolEncoder = delistedPoolHashRaw >$< E.param (E.nonNullable E.bytea) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: resser_pool_ticker +-- Description: A table containing a managed list of reserved ticker names. +-- For now they are grouped under the specific hash of the pool. + +----------------------------------------------------------------------------------------------------------------------------------- +data ReservedPoolTicker = ReservedPoolTicker + { reservedPoolTickerName :: !Text + , reservedPoolTickerPoolHash :: !ByteString -- sqltype=hash28type + } + deriving (Eq, Show, Generic) + +type instance Key ReservedPoolTicker = ReservedPoolTickerId +instance DbInfo ReservedPoolTicker where + uniqueFields _ = ["name"] + +entityReservedPoolTickerDecoder :: D.Row (Entity ReservedPoolTicker) +entityReservedPoolTickerDecoder = + Entity + <$> idDecoder ReservedPoolTickerId + <*> reservedPoolTickerDecoder + +reservedPoolTickerDecoder :: D.Row ReservedPoolTicker +reservedPoolTickerDecoder = + ReservedPoolTicker + <$> D.column (D.nonNullable D.text) -- reservedPoolTickerName + <*> D.column (D.nonNullable D.bytea) -- reservedPoolTickerPoolHash + +entityReservedPoolTickerEncoder :: E.Params (Entity ReservedPoolTicker) +entityReservedPoolTickerEncoder = + mconcat + [ entityKey >$< idEncoder getReservedPoolTickerId + , entityVal >$< reservedPoolTickerEncoder + ] + +reservedPoolTickerEncoder :: E.Params ReservedPoolTicker +reservedPoolTickerEncoder = + mconcat + [ reservedPoolTickerName >$< E.param (E.nonNullable E.text) + , reservedPoolTickerPoolHash >$< E.param (E.nonNullable E.bytea) + ] diff --git a/cardano-db/src/Cardano/Db/Schema/Core/StakeDeligation.hs b/cardano-db/src/Cardano/Db/Schema/Core/StakeDeligation.hs new file mode 100644 index 000000000..0410cc980 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/StakeDeligation.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Schema.Core.StakeDeligation where + +import Contravariant.Extras (contrazip2, contrazip4, contrazip5, contrazip6) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant +import Data.Text (Text) +import Data.Word (Word16, Word64) +import GHC.Generics (Generic) +import Hasql.Decoders as D +import Hasql.Encoders as E + +import Cardano.Db.Schema.Ids +import Cardano.Db.Schema.Orphans () +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types ( + DbLovelace (..), + RewardSource, + dbLovelaceDecoder, + dbLovelaceEncoder, + maybeDbLovelaceDecoder, + maybeDbLovelaceEncoder, + rewardSourceDecoder, + rewardSourceEncoder, + ) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | STAKE DELEGATION +-- | These tables handle stake addresses, delegation, and reward + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: stake_address +-- Description: Contains information about stakeholder addresses. +data StakeAddress = StakeAddress -- Can be an address of a script hash + { stakeAddressHashRaw :: !ByteString -- sqltype=addr29type + , stakeAddressView :: !Text + , stakeAddressScriptHash :: !(Maybe ByteString) -- sqltype=hash28type + } + deriving (Show, Eq, Generic) + +type instance Key StakeAddress = StakeAddressId +instance DbInfo StakeAddress where + uniqueFields _ = ["hash_raw"] + +entityStakeAddressDecoder :: D.Row (Entity StakeAddress) +entityStakeAddressDecoder = + Entity + <$> idDecoder StakeAddressId + <*> stakeAddressDecoder + +stakeAddressDecoder :: D.Row StakeAddress +stakeAddressDecoder = + StakeAddress + <$> D.column (D.nonNullable D.bytea) -- stakeAddressHashRaw + <*> D.column (D.nonNullable D.text) -- stakeAddressView + <*> D.column (D.nullable D.bytea) -- stakeAddressScriptHash + +entityStakeAddressEncoder :: E.Params (Entity StakeAddress) +entityStakeAddressEncoder = + mconcat + [ entityKey >$< idEncoder getStakeAddressId + , entityVal >$< stakeAddressEncoder + ] + +stakeAddressEncoder :: E.Params StakeAddress +stakeAddressEncoder = + mconcat + [ stakeAddressHashRaw >$< E.param (E.nonNullable E.bytea) + , stakeAddressView >$< E.param (E.nonNullable E.text) + , stakeAddressScriptHash >$< E.param (E.nullable E.bytea) + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: stake_registration +-- Description: Contains information about stakeholder registrations. +data StakeRegistration = StakeRegistration + { stakeRegistrationAddrId :: !StakeAddressId -- noreference + , stakeRegistrationCertIndex :: !Word16 + , stakeRegistrationEpochNo :: !Word64 -- sqltype=word31type + , stakeRegistrationDeposit :: !(Maybe DbLovelace) -- sqltype=lovelace + , stakeRegistrationTxId :: !TxId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key StakeRegistration = StakeRegistrationId +instance DbInfo StakeRegistration + +entityStakeRegistrationDecoder :: D.Row (Entity StakeRegistration) +entityStakeRegistrationDecoder = + Entity + <$> idDecoder StakeRegistrationId + <*> stakeRegistrationDecoder + +stakeRegistrationDecoder :: D.Row StakeRegistration +stakeRegistrationDecoder = + StakeRegistration + <$> idDecoder StakeAddressId -- stakeRegistrationAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- stakeRegistrationCertIndex + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- stakeRegistrationEpochNo + <*> maybeDbLovelaceDecoder -- stakeRegistrationDeposit + <*> idDecoder TxId -- stakeRegistrationTxId + +entityStakeRegistrationEncoder :: E.Params (Entity StakeRegistration) +entityStakeRegistrationEncoder = + mconcat + [ entityKey >$< idEncoder getStakeRegistrationId + , entityVal >$< stakeRegistrationEncoder + ] + +stakeRegistrationEncoder :: E.Params StakeRegistration +stakeRegistrationEncoder = + mconcat + [ stakeRegistrationAddrId >$< idEncoder getStakeAddressId + , stakeRegistrationCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , stakeRegistrationEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , stakeRegistrationDeposit >$< maybeDbLovelaceEncoder + , stakeRegistrationTxId >$< idEncoder getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: stake_deregistration +-- Description: Contains information about stakeholder deregistrations. + +----------------------------------------------------------------------------------------------------------------------------------- +data StakeDeregistration = StakeDeregistration + { stakeDeregistrationAddrId :: !StakeAddressId -- noreference + , stakeDeregistrationCertIndex :: !Word16 + , stakeDeregistrationEpochNo :: !Word64 -- sqltype=word31type + , stakeDeregistrationTxId :: !TxId -- noreference + , stakeDeregistrationRedeemerId :: !(Maybe RedeemerId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key StakeDeregistration = StakeDeregistrationId +instance DbInfo StakeDeregistration + +entityStakeDeregistrationDecoder :: D.Row (Entity StakeDeregistration) +entityStakeDeregistrationDecoder = + Entity + <$> idDecoder StakeDeregistrationId + <*> stakeDeregistrationDecoder + +stakeDeregistrationDecoder :: D.Row StakeDeregistration +stakeDeregistrationDecoder = + StakeDeregistration + <$> idDecoder StakeAddressId -- stakeDeregistrationAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- stakeDeregistrationCertIndex + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- stakeDeregistrationEpochNo + <*> idDecoder TxId -- stakeDeregistrationTxId + <*> maybeIdDecoder RedeemerId -- stakeDeregistrationRedeemerId + +entityStakeDeregistrationEncoder :: E.Params (Entity StakeDeregistration) +entityStakeDeregistrationEncoder = + mconcat + [ entityKey >$< idEncoder getStakeDeregistrationId + , entityVal >$< stakeDeregistrationEncoder + ] + +stakeDeregistrationEncoder :: E.Params StakeDeregistration +stakeDeregistrationEncoder = + mconcat + [ stakeDeregistrationAddrId >$< idEncoder getStakeAddressId + , stakeDeregistrationCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , stakeDeregistrationEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , stakeDeregistrationTxId >$< idEncoder getTxId + , stakeDeregistrationRedeemerId >$< maybeIdEncoder getRedeemerId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: delegation +-- Description:Contains information about stakeholder delegations, including the stakeholder's address and the pool to which they are delegating. + +----------------------------------------------------------------------------------------------------------------------------------- +data Delegation = Delegation + { delegationAddrId :: !StakeAddressId -- noreference + , delegationCertIndex :: !Word16 + , delegationPoolHashId :: !PoolHashId -- noreference + , delegationActiveEpochNo :: !Word64 + , delegationTxId :: !TxId -- noreference + , delegationSlotNo :: !Word64 -- sqltype=word63type + , delegationRedeemerId :: !(Maybe RedeemerId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key Delegation = DelegationId +instance DbInfo Delegation + +entityDelegationDecoder :: D.Row (Entity Delegation) +entityDelegationDecoder = + Entity + <$> idDecoder DelegationId + <*> delegationDecoder + +delegationDecoder :: D.Row Delegation +delegationDecoder = + Delegation + <$> idDecoder StakeAddressId -- delegationAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- delegationCertIndex + <*> idDecoder PoolHashId -- delegationPoolHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- delegationActiveEpochNo + <*> idDecoder TxId -- delegationTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- delegationSlotNo + <*> maybeIdDecoder RedeemerId -- delegationRedeemerId + +entityDelegationEncoder :: E.Params (Entity Delegation) +entityDelegationEncoder = + mconcat + [ entityKey >$< idEncoder getDelegationId + , entityVal >$< delegationEncoder + ] + +delegationEncoder :: E.Params Delegation +delegationEncoder = + mconcat + [ delegationAddrId >$< idEncoder getStakeAddressId + , delegationCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , delegationPoolHashId >$< idEncoder getPoolHashId + , delegationActiveEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , delegationTxId >$< idEncoder getTxId + , delegationSlotNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , delegationRedeemerId >$< maybeIdEncoder getRedeemerId + ] + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: reward +-- Description: Reward, Stake and Treasury need to be obtained from the ledger state. +-- The reward for each stake address and. This is not a balance, but a reward amount and the +-- epoch in which the reward was earned. +-- This table should never get rolled back. + +----------------------------------------------------------------------------------------------------------------------------------- +data Reward = Reward + { rewardAddrId :: !StakeAddressId -- noreference + , rewardType :: !RewardSource -- sqltype=rewardtype + , rewardAmount :: !DbLovelace -- sqltype=lovelace + , rewardEarnedEpoch :: !Word64 -- generated="((CASE WHEN (type='refund') then spendable_epoch else (CASE WHEN spendable_epoch >= 2 then spendable_epoch-2 else 0 end) end) STORED)" + , rewardSpendableEpoch :: !Word64 + , rewardPoolId :: !PoolHashId -- noreference + } + deriving (Show, Eq, Generic) + +type instance Key Reward = RewardId +instance DbInfo Reward + +entityRewardDecoder :: D.Row (Entity Reward) +entityRewardDecoder = + Entity + <$> idDecoder RewardId + <*> rewardDecoder + +rewardDecoder :: D.Row Reward +rewardDecoder = + Reward + <$> idDecoder StakeAddressId -- rewardAddrId + <*> D.column (D.nonNullable rewardSourceDecoder) -- rewardType + <*> dbLovelaceDecoder -- rewardAmount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- rewardEarnedEpoch + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- rewardSpendableEpoch + <*> idDecoder PoolHashId -- rewardPoolId + +entityRewardEncoder :: E.Params (Entity Reward) +entityRewardEncoder = + mconcat + [ entityKey >$< idEncoder getRewardId + , entityVal >$< rewardEncoder + ] + +rewardEncoder :: E.Params Reward +rewardEncoder = + mconcat + [ rewardAddrId >$< idEncoder getStakeAddressId + , rewardType >$< E.param (E.nonNullable rewardSourceEncoder) + , rewardAmount >$< dbLovelaceEncoder + , rewardEarnedEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , rewardSpendableEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , rewardPoolId >$< idEncoder getPoolHashId + ] + +rewardBulkEncoder :: E.Params ([StakeAddressId], [RewardSource], [DbLovelace], [Word64], [Word64], [PoolHashId]) +rewardBulkEncoder = + contrazip6 + (bulkEncoder $ idBulkEncoder getStakeAddressId) + (bulkEncoder $ E.nonNullable rewardSourceEncoder) + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbLovelace >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + (bulkEncoder $ idBulkEncoder getPoolHashId) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: reward_rest +-- Description: Contains information about the remaining reward for each stakeholder. + +----------------------------------------------------------------------------------------------------------------------------------- +data RewardRest = RewardRest + { rewardRestAddrId :: !StakeAddressId -- noreference + , rewardRestType :: !RewardSource -- sqltype=rewardtype + , rewardRestAmount :: !DbLovelace -- sqltype=lovelace + , rewardRestEarnedEpoch :: !Word64 -- generated="(CASE WHEN spendable_epoch >= 1 then spendable_epoch-1 else 0 end)" + , rewardRestSpendableEpoch :: !Word64 + } + deriving (Show, Eq, Generic) + +type instance Key RewardRest = RewardRestId +instance DbInfo RewardRest + +entityRewardRestDecoder :: D.Row (Entity RewardRest) +entityRewardRestDecoder = + Entity + <$> idDecoder RewardRestId + <*> rewardRestDecoder + +rewardRestDecoder :: D.Row RewardRest +rewardRestDecoder = + RewardRest + <$> idDecoder StakeAddressId -- rewardRestAddrId + <*> D.column (D.nonNullable rewardSourceDecoder) -- rewardRestType + <*> dbLovelaceDecoder -- rewardRestAmount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- rewardRestEarnedEpoch + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- rewardRestSpendableEpoch + +entityRewardRestEncoder :: E.Params (Entity RewardRest) +entityRewardRestEncoder = + mconcat + [ entityKey >$< idEncoder getRewardRestId + , entityVal >$< rewardRestEncoder + ] + +rewardRestEncoder :: E.Params RewardRest +rewardRestEncoder = + mconcat + [ rewardRestType >$< E.param (E.nonNullable rewardSourceEncoder) + , rewardRestAmount >$< dbLovelaceEncoder + , rewardRestEarnedEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , rewardRestSpendableEpoch >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +rewardRestBulkEncoder :: E.Params ([StakeAddressId], [RewardSource], [DbLovelace], [Word64], [Word64]) +rewardRestBulkEncoder = + contrazip5 + (bulkEncoder $ idBulkEncoder getStakeAddressId) + (bulkEncoder $ E.nonNullable rewardSourceEncoder) + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbLovelace >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: epoch_stake +-- Description: Contains information about the stake of each stakeholder in each epoch. +-- This table should never get rolled back + +----------------------------------------------------------------------------------------------------------------------------------- +data EpochStake = EpochStake + { epochStakeAddrId :: !StakeAddressId -- noreference + , epochStakePoolId :: !PoolHashId -- noreference + , epochStakeAmount :: !DbLovelace -- sqltype=lovelace + , epochStakeEpochNo :: !Word64 -- sqltype=word31type + } + deriving (Show, Eq, Generic) + +-- similar scenario as in Reward the constraint that was here is now set manually in +-- `applyAndInsertBlockMaybe` at a more optimal time. + +type instance Key EpochStake = EpochStakeId +instance DbInfo EpochStake + +entityEpochStakeDecoder :: D.Row (Entity EpochStake) +entityEpochStakeDecoder = + Entity + <$> idDecoder EpochStakeId + <*> epochStakeDecoder + +epochStakeDecoder :: D.Row EpochStake +epochStakeDecoder = + EpochStake + <$> idDecoder StakeAddressId -- epochStakeAddrId + <*> idDecoder PoolHashId -- epochStakePoolId + <*> dbLovelaceDecoder -- epochStakeAmount + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochStakeEpochNo + +entityEpochStakeEncoder :: E.Params (Entity EpochStake) +entityEpochStakeEncoder = + mconcat + [ entityKey >$< idEncoder getEpochStakeId + , entityVal >$< epochStakeEncoder + ] + +epochStakeEncoder :: E.Params EpochStake +epochStakeEncoder = + mconcat + [ epochStakeAddrId >$< idEncoder getStakeAddressId + , epochStakePoolId >$< idEncoder getPoolHashId + , epochStakeAmount >$< dbLovelaceEncoder + , epochStakeEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +epochStakeBulkEncoder :: E.Params ([StakeAddressId], [PoolHashId], [DbLovelace], [Word64]) +epochStakeBulkEncoder = + contrazip4 + (bulkEncoder $ idBulkEncoder getStakeAddressId) + (bulkEncoder $ idBulkEncoder getPoolHashId) + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbLovelace >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Table Name: epoch_stake_progress +-- Description: Contains information about the progress of the epoch stake calculation. + +----------------------------------------------------------------------------------------------------------------------------------- +data EpochStakeProgress = EpochStakeProgress + { epochStakeProgressEpochNo :: !Word64 -- sqltype=word31type + , epochStakeProgressCompleted :: !Bool + } + deriving (Show, Eq, Generic) + +type instance Key EpochStakeProgress = EpochStakeProgressId +instance DbInfo EpochStakeProgress where + uniqueFields _ = ["epoch_no"] + +entityEpochStakeProgressDecoder :: D.Row (Entity EpochStakeProgress) +entityEpochStakeProgressDecoder = + Entity + <$> idDecoder EpochStakeProgressId + <*> epochStakeProgressDecoder + +epochStakeProgressDecoder :: D.Row EpochStakeProgress +epochStakeProgressDecoder = + EpochStakeProgress + <$> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- epochStakeProgressEpochNo + <*> D.column (D.nonNullable D.bool) -- epochStakeProgressCompleted + +entityEpochStakeProgressEncoder :: E.Params (Entity EpochStakeProgress) +entityEpochStakeProgressEncoder = + mconcat + [ entityKey >$< idEncoder getEpochStakeProgressId + , entityVal >$< epochStakeProgressEncoder + ] + +epochStakeProgressEncoder :: E.Params EpochStakeProgress +epochStakeProgressEncoder = + mconcat + [ epochStakeProgressEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , epochStakeProgressCompleted >$< E.param (E.nonNullable E.bool) + ] + +epochStakeProgressBulkEncoder :: E.Params ([Word64], [Bool]) +epochStakeProgressBulkEncoder = + contrazip2 + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + (bulkEncoder $ E.nonNullable E.bool) diff --git a/cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs b/cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs deleted file mode 100644 index 57974fb82..000000000 --- a/cardano-db/src/Cardano/Db/Schema/Core/TxOut.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Cardano.Db.Schema.Core.TxOut where - -import Cardano.Db.Schema.BaseSchema (DatumId, MultiAssetId, ScriptId, StakeAddressId, TxId) -import Cardano.Db.Types (DbLovelace, DbWord64) -import Data.ByteString.Char8 (ByteString) -import Data.Text (Text) -import Data.Word (Word64) -import Database.Persist.Documentation (deriveShowFields, document, (#), (--^)) -import Database.Persist.EntityDef.Internal (EntityDef (..)) -import Database.Persist.TH - -share - [ mkPersist sqlSettings - , mkMigrate "migrateCoreTxOutCardanoDb" - , mkEntityDefList "entityDefsTxOutCore" - , deriveShowFields - ] - [persistLowerCase| ----------------------------------------------- --- Core TxOut ----------------------------------------------- - TxOut - address Text - addressHasScript Bool - dataHash ByteString Maybe sqltype=hash32type - consumedByTxId TxId Maybe noreference - index Word64 sqltype=txindex - inlineDatumId DatumId Maybe noreference - paymentCred ByteString Maybe sqltype=hash28type - referenceScriptId ScriptId Maybe noreference - stakeAddressId StakeAddressId Maybe noreference - txId TxId noreference - value DbLovelace sqltype=lovelace - UniqueTxout txId index -- The (tx_id, index) pair must be unique. - ----------------------------------------------- --- Core CollateralTxOut ----------------------------------------------- - CollateralTxOut - txId TxId noreference -- This type is the primary key for the 'tx' table. - index Word64 sqltype=txindex - address Text - addressHasScript Bool - paymentCred ByteString Maybe sqltype=hash28type - stakeAddressId StakeAddressId Maybe noreference - value DbLovelace sqltype=lovelace - dataHash ByteString Maybe sqltype=hash32type - multiAssetsDescr Text - inlineDatumId DatumId Maybe noreference - referenceScriptId ScriptId Maybe noreference - deriving Show - ----------------------------------------------- --- MultiAsset ----------------------------------------------- - MaTxOut - ident MultiAssetId noreference - quantity DbWord64 sqltype=word64type - txOutId TxOutId noreference - deriving Show - -|] - -schemaDocsTxOutCore :: [EntityDef] -schemaDocsTxOutCore = - document entityDefsTxOutCore $ do - TxOut --^ do - "A table for transaction outputs." - TxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - TxOutAddressHasScript # "Flag which shows if this address is locked by a script." - TxOutConsumedByTxId # "The Tx table index of the transaction that consumes this transaction output. Not populated by default, can be activated via tx-out configs." - TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - TxOutIndex # "The index of this transaction output with the transaction." - TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - TxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - TxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - TxOutValue # "The output value (in Lovelace) of the transaction output." - - TxOutTxId # "The Tx table index of the transaction that contains this transaction output." - - CollateralTxOut --^ do - "A table for transaction collateral outputs. New in v13." - CollateralTxOutTxId # "The Tx table index of the transaction that contains this transaction output." - CollateralTxOutIndex # "The index of this transaction output with the transaction." - CollateralTxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - CollateralTxOutAddressHasScript # "Flag which shows if this address is locked by a script." - CollateralTxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - CollateralTxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - CollateralTxOutValue # "The output value (in Lovelace) of the transaction output." - CollateralTxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - CollateralTxOutMultiAssetsDescr # "This is a description of the multiassets in collateral output. Since the output is not really created, we don't need to add them in separate tables." - CollateralTxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - CollateralTxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - - MaTxOut --^ do - "A table containing Multi-Asset transaction outputs." - MaTxOutIdent # "The MultiAsset table index specifying the asset." - MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." - MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." diff --git a/cardano-db/src/Cardano/Db/Schema/Ids.hs b/cardano-db/src/Cardano/Db/Schema/Ids.hs new file mode 100644 index 000000000..a50925ac6 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Ids.hs @@ -0,0 +1,314 @@ +module Cardano.Db.Schema.Ids where + +import Data.Functor.Contravariant ((>$<)) +import Data.Int (Int64) +import qualified Hasql.Decoders as D +import qualified Hasql.Encoders as E + +----------------------------------------------------------------------------------------------------------------------------------- +-- Helper functions +----------------------------------------------------------------------------------------------------------------------------------- + +-- | +-- Helper function to create a decoder for an id column. +-- The function takes a function that constructs the id type from an Int64. +idDecoder :: (Int64 -> a) -> D.Row a +idDecoder f = D.column (D.nonNullable $ f <$> D.int8) + +maybeIdDecoder :: (Int64 -> a) -> D.Row (Maybe a) +maybeIdDecoder f = D.column (D.nullable $ f <$> D.int8) + +-- | +-- Helper function to create an encoder for an id column. +-- The function takes a function that extracts the Int64 from the id type. +idEncoder :: (a -> Int64) -> E.Params a +idEncoder f = E.param $ E.nonNullable $ f >$< E.int8 + +idBulkEncoder :: (a -> Int64) -> E.NullableOrNot E.Value a +idBulkEncoder f = E.nonNullable $ f >$< E.int8 + +maybeIdEncoder :: (a -> Int64) -> E.Params (Maybe a) +maybeIdEncoder f = E.param $ E.nullable $ f >$< E.int8 + +----------------------------------------------------------------------------------------------------------------------------------- +-- BASE TABLES +----------------------------------------------------------------------------------------------------------------------------------- +newtype BlockId = BlockId {getBlockId :: Int64} + deriving (Eq, Show, Ord) + +newtype TxId = TxId {getTxId :: Int64} + deriving (Eq, Show, Ord) + +newtype TxMetadataId = TxMetadataId {getTxMetadataId :: Int64} + deriving (Eq, Show, Ord) + +newtype TxInId = TxInId {getTxInId :: Int64} + deriving (Eq, Show, Ord) + +newtype CollateralTxInId = CollateralTxInId {getCollateralTxInId :: Int64} + deriving (Eq, Show, Ord) + +newtype AddressId = AddressId {getAddressId :: Int64} + deriving (Eq, Ord, Show) + +newtype ReferenceTxInId = ReferenceTxInId {getReferenceTxInId :: Int64} + deriving (Eq, Show, Ord) + +newtype ReverseIndexId = ReverseIndexId {getReverseIndexId :: Int64} + deriving (Eq, Show, Ord) + +newtype TxCborId = TxCborId {getTxCborId :: Int64} + deriving (Eq, Show, Ord) + +newtype DatumId = DatumId {getDatumId :: Int64} + deriving (Eq, Show, Ord) + +newtype ScriptId = ScriptId {getScriptId :: Int64} + deriving (Eq, Show, Ord) + +newtype RedeemerId = RedeemerId {getRedeemerId :: Int64} + deriving (Eq, Show, Ord) + +newtype RedeemerDataId = RedeemerDataId {getRedeemerDataId :: Int64} + deriving (Eq, Show, Ord) + +newtype ExtraKeyWitnessId = ExtraKeyWitnessId {getExtraKeyWitnessId :: Int64} + deriving (Eq, Show, Ord) + +newtype SlotLeaderId = SlotLeaderId {getSlotLeaderId :: Int64} + deriving (Eq, Show, Ord) + +newtype SchemaVersionId = SchemaVersionId {getSchemaVersionId :: Int64} + deriving (Eq, Show, Ord) + +newtype MetaId = MetaId {getMetaId :: Int64} + deriving (Eq, Show, Ord) + +newtype WithdrawalId = WithdrawalId {getWithdrawalId :: Int64} + deriving (Eq, Show, Ord) + +newtype ExtraMigrationsId = ExtraMigrationsId {getExtraMigrationsId :: Int64} + deriving (Eq, Show, Ord) + +----------------------------------------------------------------------------------------------------------------------------------- +-- VARIANTS +----------------------------------------------------------------------------------------------------------------------------------- + +-- | TxOut variants +newtype TxOutCoreId = TxOutCoreId {getTxOutCoreId :: Int64} + deriving (Eq, Ord, Show) + +newtype TxOutAddressId = TxOutAddressId {getTxOutAddressId :: Int64} + deriving (Eq, Ord, Show) + +newtype TxOutUtxoHdId = TxOutUtxoHdId {getTxOutUtxoHdId :: Int64} + deriving (Eq, Ord, Show) + +newtype TxOutUtxoHdAddressId = TxOutUtxoHdAddressId {getTxOutUtxoHdAddressId :: Int64} + deriving (Eq, Ord, Show) + +-- | CollateralTxOut variants +newtype CollateralTxOutCoreId = CollateralTxOutCoreId {getCollateralTxOutCoreId :: Int64} + deriving (Eq, Ord, Show) + +newtype CollateralTxOutAddressId = CollateralTxOutAddressId {getCollateralTxOutAddressId :: Int64} + deriving (Eq, Ord, Show) + +newtype CollateralTxOutUtxoHdId = CollateralTxOutUtxoHdId {getCollateralTxOutUtxoHdId :: Int64} + deriving (Eq, Ord, Show) + +newtype CollateralTxOutUtxoHdAddressId = CollateralTxOutUtxoHdAddressId {getCollateralTxOutUtxoHdAddressId :: Int64} + deriving (Eq, Ord, Show) + +-- | Multi-asset variants +newtype MaTxOutCoreId = MaTxOutCoreId {getMaTxOutCoreId :: Int64} + deriving (Eq, Ord, Show) + +newtype MaTxOutAddressId = MaTxOutAddressId {getMaTxOutAddressId :: Int64} + deriving (Eq, Ord, Show) + +newtype MaTxOutUtxoHdId = MaTxOutUtxoHdId {getMaTxOutUtxoHdId :: Int64} + deriving (Eq, Ord, Show) + +newtype MaTxOutUtxoHdAddressId = MaTxOutUtxoHdAddressId {getMaTxOutUtxoHdAddressId :: Int64} + deriving (Eq, Ord, Show) + +----------------------------------------------------------------------------------------------------------------------------------- +-- EPOCH AND PROTOCOL PARAMETER +----------------------------------------------------------------------------------------------------------------------------------- +newtype EpochId = EpochId {getEpochId :: Int64} + deriving (Eq, Show, Ord) + +newtype EpochParamId = EpochParamId {getEpochParamId :: Int64} + deriving (Eq, Show, Ord) + +newtype EpochStateId = EpochStateId {getEpochStateId :: Int64} + deriving (Eq, Show, Ord) + +newtype EpochSyncTimeId = EpochSyncTimeId {getEpochSyncTimeId :: Int64} + deriving (Eq, Show, Ord) + +newtype AdaPotsId = AdaPotsId {getAdaPotsId :: Int64} + deriving (Eq, Show, Ord) + +newtype PotTransferId = PotTransferId {getPotTransferId :: Int64} + deriving (Eq, Show, Ord) + +newtype TreasuryId = TreasuryId {getTreasuryId :: Int64} + deriving (Eq, Show, Ord) + +newtype ReserveId = ReserveId {getReserveId :: Int64} + deriving (Eq, Show, Ord) + +newtype CostModelId = CostModelId {getCostModelId :: Int64} + deriving (Eq, Show, Ord) + +----------------------------------------------------------------------------------------------------------------------------------- +-- GOVERNANCE AND VOTING +----------------------------------------------------------------------------------------------------------------------------------- +newtype DrepHashId = DrepHashId {getDrepHashId :: Int64} + deriving (Eq, Show, Ord) + +newtype DrepRegistrationId = DrepRegistrationId {getDrepRegistrationId :: Int64} + deriving (Eq, Show, Ord) + +newtype DrepDistrId = DrepDistrId {getDrepDistrId :: Int64} + deriving (Eq, Show, Ord) + +newtype DelegationVoteId = DelegationVoteId {getDelegationVoteId :: Int64} + deriving (Eq, Show, Ord) + +newtype GovActionProposalId = GovActionProposalId {getGovActionProposalId :: Int64} + deriving (Eq, Show, Ord) + +newtype VotingProcedureId = VotingProcedureId {getVotingProcedureId :: Int64} + deriving (Eq, Show, Ord) + +newtype VotingAnchorId = VotingAnchorId {getVotingAnchorId :: Int64} + deriving (Eq, Show, Ord) + +newtype ConstitutionId = ConstitutionId {getConstitutionId :: Int64} + deriving (Eq, Show, Ord) + +newtype CommitteeId = CommitteeId {getCommitteeId :: Int64} + deriving (Eq, Show, Ord) + +newtype CommitteeHashId = CommitteeHashId {getCommitteeHashId :: Int64} + deriving (Eq, Show, Ord) + +newtype CommitteeMemberId = CommitteeMemberId {getCommitteeMemberId :: Int64} + deriving (Eq, Show, Ord) + +newtype CommitteeRegistrationId = CommitteeRegistrationId {getCommitteeRegistrationId :: Int64} + deriving (Eq, Show, Ord) + +newtype CommitteeDeRegistrationId = CommitteeDeRegistrationId {getCommitteeDeRegistrationId :: Int64} + deriving (Eq, Show, Ord) + +newtype ParamProposalId = ParamProposalId {getParamProposalId :: Int64} + deriving (Eq, Show, Ord) + +newtype TreasuryWithdrawalId = TreasuryWithdrawalId {getTreasuryWithdrawalId :: Int64} + deriving (Eq, Show, Ord) + +newtype EventInfoId = EventInfoId {getEventInfoId :: Int64} + deriving (Eq, Show, Ord) + +----------------------------------------------------------------------------------------------------------------------------------- +-- MULTI ASSETS +----------------------------------------------------------------------------------------------------------------------------------- +newtype MultiAssetId = MultiAssetId {getMultiAssetId :: Int64} + deriving (Eq, Show, Ord) + +newtype MaTxMintId = MaTxMintId {getMaTxMintId :: Int64} + deriving (Eq, Show, Ord) + +----------------------------------------------------------------------------------------------------------------------------------- +-- OFFCHAIN +----------------------------------------------------------------------------------------------------------------------------------- +newtype OffChainPoolDataId = OffChainPoolDataId {getOffChainPoolDataId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainPoolFetchErrorId = OffChainPoolFetchErrorId {getOffChainPoolFetchErrorId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteDataId = OffChainVoteDataId {getOffChainVoteDataId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteGovActionDataId = OffChainVoteGovActionDataId {getOffChainVoteGovActionDataId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteDrepDataId = OffChainVoteDrepDataId {getOffChainVoteDrepDataId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteAuthorId = OffChainVoteAuthorId {getOffChainVoteAuthorId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteReferenceId = OffChainVoteReferenceId {getOffChainVoteReferenceId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteExternalUpdateId = OffChainVoteExternalUpdateId {getOffChainVoteExternalUpdateId :: Int64} + deriving (Eq, Show, Ord) + +newtype OffChainVoteFetchErrorId = OffChainVoteFetchErrorId {getOffChainVoteFetchErrorId :: Int64} + deriving (Eq, Show, Ord) + +----------------------------------------------------------------------------------------------------------------------------------- +-- POOLS +----------------------------------------------------------------------------------------------------------------------------------- + +newtype PoolHashId = PoolHashId {getPoolHashId :: Int64} + deriving (Eq, Show, Ord) + +newtype PoolStatId = PoolStatId {getPoolStatId :: Int64} + deriving (Eq, Show, Ord) + +newtype PoolUpdateId = PoolUpdateId {getPoolUpdateId :: Int64} + deriving (Eq, Show, Ord) + +newtype PoolMetadataRefId = PoolMetadataRefId {getPoolMetadataRefId :: Int64} + deriving (Eq, Show, Ord) + +newtype PoolOwnerId = PoolOwnerId {getPoolOwnerId :: Int64} + deriving (Eq, Show, Ord) + +newtype PoolRetireId = PoolRetireId {getPoolRetireId :: Int64} + deriving (Eq, Show, Ord) + +newtype PoolRelayId = PoolRelayId {getPoolRelayId :: Int64} + deriving (Eq, Show, Ord) + +newtype DelistedPoolId = DelistedPoolId {getDelistedPoolId :: Int64} + deriving (Eq, Show, Ord) + +newtype ReservedPoolTickerId = ReservedPoolTickerId {getReservedPoolTickerId :: Int64} + deriving (Eq, Show, Ord) + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | STAKE DELEGATION + +----------------------------------------------------------------------------------------------------------------------------------- +newtype StakeAddressId = StakeAddressId {getStakeAddressId :: Int64} + deriving (Eq, Show, Ord) + +newtype StakeRegistrationId = StakeRegistrationId {getStakeRegistrationId :: Int64} + deriving (Eq, Show, Ord) + +newtype StakeDeregistrationId = StakeDeregistrationId {getStakeDeregistrationId :: Int64} + deriving (Eq, Show, Ord) + +newtype DelegationId = DelegationId {getDelegationId :: Int64} + deriving (Eq, Show, Ord) + +newtype RewardId = RewardId {getRewardId :: Int64} + deriving (Eq, Show, Ord) + +newtype RewardRestId = RewardRestId {getRewardRestId :: Int64} + deriving (Eq, Show, Ord) + +newtype EpochStakeId = EpochStakeId {getEpochStakeId :: Int64} + deriving (Eq, Show, Ord) + +newtype EpochStakeProgressId = EpochStakeProgressId {getEpochStakeProgressId :: Int64} + deriving (Eq, Show, Ord) diff --git a/cardano-db/src/Cardano/Db/Schema/Orphans.hs b/cardano-db/src/Cardano/Db/Schema/Orphans.hs index 41881802f..73bfeb2d6 100644 --- a/cardano-db/src/Cardano/Db/Schema/Orphans.hs +++ b/cardano-db/src/Cardano/Db/Schema/Orphans.hs @@ -8,7 +8,6 @@ import Cardano.Db.Schema.Types ( ) import Cardano.Db.Types ( AnchorType (..), - DbInt65 (..), DbLovelace (..), DbWord64 (..), GovActionType (..), @@ -19,26 +18,23 @@ import Cardano.Db.Types ( Vote (..), VoteUrl (..), VoterRole (..), - readAnchorType, - readDbInt65, - readGovActionType, - readRewardSource, - readScriptPurpose, - readScriptType, - readSyncState, - readVote, - readVoterRole, - renderAnchorType, - renderGovActionType, - renderScriptPurpose, - renderScriptType, - renderSyncState, - renderVote, - renderVoterRole, - showDbInt65, - showRewardSource, + anchorTypeFromText, + anchorTypeToText, + govActionTypeFromText, + govActionTypeToText, + rewardSourceFromText, + rewardSourceToText, + scriptPurposeFromText, + scriptPurposeToText, + scriptTypeFromText, + scriptTypeToText, + syncStateFromText, + syncStateToText, + voteFromText, + voteToText, + voterRoleFromText, + voterRoleToText, ) -import qualified Data.ByteString.Char8 as BS import Data.Ratio (denominator, numerator) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -46,24 +42,24 @@ import Data.WideWord.Word128 (Word128) import Database.Persist.Class (PersistField (..)) import Database.Persist.Types (PersistValue (..)) -instance PersistField DbInt65 where - toPersistValue = PersistText . Text.pack . showDbInt65 - fromPersistValue (PersistInt64 i) = - Right $ - if i >= 0 - then PosInt65 (fromIntegral i) - else NegInt65 (fromIntegral $ negate i) - fromPersistValue (PersistText bs) = Right $ readDbInt65 (Text.unpack bs) - fromPersistValue x@(PersistRational r) = - if denominator r == 1 - then - Right $ - if numerator r >= 0 - then PosInt65 (fromIntegral $ numerator r) - else NegInt65 (fromIntegral . numerator $ negate r) - else Left $ mconcat ["Failed to parse Haskell type DbInt65: ", Text.pack (show x)] - fromPersistValue x = - Left $ mconcat ["Failed to parse Haskell type DbInt65: ", Text.pack (show x)] +-- instance PersistField DbInt65 where +-- toPersistValue = PersistText . Text.pack . show +-- fromPersistValue (PersistInt64 i) = +-- Right $ +-- if i >= 0 +-- then PosInt65 (fromIntegral i) +-- else NegInt65 (fromIntegral $ negate i) +-- fromPersistValue (PersistText bs) = Right $ readDbInt65 (Text.unpack bs) +-- fromPersistValue x@(PersistRational r) = +-- if denominator r == 1 +-- then +-- Right $ +-- if numerator r >= 0 +-- then PosInt65 (fromIntegral $ numerator r) +-- else NegInt65 (fromIntegral . numerator $ negate r) +-- else Left $ mconcat ["Failed to parse Haskell type DbInt65: ", Text.pack (show x)] +-- fromPersistValue x = +-- Left $ mconcat ["Failed to parse Haskell type DbInt65: ", Text.pack (show x)] instance PersistField DbLovelace where toPersistValue = PersistText . Text.pack . show . unDbLovelace @@ -97,26 +93,26 @@ instance PersistField PoolUrl where Left $ mconcat ["Failed to parse Haskell type PoolUrl: ", Text.pack (show x)] instance PersistField RewardSource where - toPersistValue = PersistText . showRewardSource - fromPersistValue (PersistLiteral bs) = Right $ readRewardSource (Text.decodeLatin1 bs) + toPersistValue = PersistText . rewardSourceToText + fromPersistValue (PersistLiteral bs) = Right $ rewardSourceFromText (Text.decodeLatin1 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type RewardSource: ", Text.pack (show x)] instance PersistField SyncState where - toPersistValue = PersistText . renderSyncState - fromPersistValue (PersistLiteral bs) = Right $ readSyncState (BS.unpack bs) + toPersistValue = PersistText . syncStateToText + fromPersistValue (PersistLiteral bs) = Right $ syncStateFromText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type SyncState: ", Text.pack (show x)] instance PersistField ScriptPurpose where - toPersistValue = PersistText . renderScriptPurpose - fromPersistValue (PersistLiteral bs) = Right $ readScriptPurpose (BS.unpack bs) + toPersistValue = PersistText . scriptPurposeFromText + fromPersistValue (PersistLiteral bs) = Right $ scriptPurposeToText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type ScriptPurpose: ", Text.pack (show x)] instance PersistField ScriptType where - toPersistValue = PersistText . renderScriptType - fromPersistValue (PersistLiteral bs) = Right $ readScriptType (BS.unpack bs) + toPersistValue = PersistText . scriptTypeToText + fromPersistValue (PersistLiteral bs) = Right $ scriptTypeFromText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type ScriptType: ", Text.pack (show x)] @@ -138,25 +134,25 @@ instance PersistField VoteUrl where Left $ mconcat ["Failed to parse Haskell type VoteUrl: ", Text.pack (show x)] instance PersistField Vote where - toPersistValue = PersistText . renderVote - fromPersistValue (PersistLiteral bs) = Right $ readVote (BS.unpack bs) + toPersistValue = PersistText . voteToText + fromPersistValue (PersistLiteral bs) = Right $ voteFromText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type Vote: ", Text.pack (show x)] instance PersistField VoterRole where - toPersistValue = PersistText . renderVoterRole - fromPersistValue (PersistLiteral bs) = Right $ readVoterRole (BS.unpack bs) + toPersistValue = PersistText . voterRoleToText + fromPersistValue (PersistLiteral bs) = Right $ voterRoleFromText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type VoterRole: ", Text.pack (show x)] instance PersistField GovActionType where - toPersistValue = PersistText . renderGovActionType - fromPersistValue (PersistLiteral bs) = Right $ readGovActionType (BS.unpack bs) + toPersistValue = PersistText . govActionTypeToText + fromPersistValue (PersistLiteral bs) = Right $ govActionTypeFromText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type GovActionType: ", Text.pack (show x)] instance PersistField AnchorType where - toPersistValue = PersistText . renderAnchorType - fromPersistValue (PersistLiteral bs) = Right $ readAnchorType (BS.unpack bs) + toPersistValue = PersistText . anchorTypeToText + fromPersistValue (PersistLiteral bs) = Right $ anchorTypeFromText (Text.decodeUtf8 bs) fromPersistValue x = Left $ mconcat ["Failed to parse Haskell type AnchorType: ", Text.pack (show x)] diff --git a/cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs b/cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs deleted file mode 100644 index 875e71792..000000000 --- a/cardano-db/src/Cardano/Db/Schema/Variant/TxOut.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Cardano.Db.Schema.Variant.TxOut where - -import Cardano.Db.Schema.BaseSchema (DatumId, MultiAssetId, ScriptId, StakeAddressId, TxId) -import Cardano.Db.Types (DbLovelace, DbWord64) -import Data.ByteString.Char8 (ByteString) -import Data.Text (Text) -import Data.Word (Word64) -import Database.Persist.Documentation (deriveShowFields, document, (#), (--^)) -import Database.Persist.EntityDef.Internal (EntityDef (..)) -import Database.Persist.TH - -share - [ mkPersist sqlSettings - , mkMigrate "migrateVariantAddressCardanoDb" - , mkEntityDefList "entityDefsTxOutVariant" - , deriveShowFields - ] - [persistLowerCase| ----------------------------------------------- --- Variant Address TxOut ----------------------------------------------- - TxOut - addressId AddressId noreference - consumedByTxId TxId Maybe noreference - dataHash ByteString Maybe sqltype=hash32type - index Word64 sqltype=txindex - inlineDatumId DatumId Maybe noreference - referenceScriptId ScriptId Maybe noreference - stakeAddressId StakeAddressId Maybe noreference - txId TxId noreference - value DbLovelace sqltype=lovelace - UniqueTxout txId index -- The (tx_id, index) pair must be unique. - - CollateralTxOut - txId TxId noreference -- This type is the primary key for the 'tx' table. - index Word64 sqltype=txindex - addressId AddressId - stakeAddressId StakeAddressId Maybe noreference - value DbLovelace sqltype=lovelace - dataHash ByteString Maybe sqltype=hash32type - multiAssetsDescr Text - inlineDatumId DatumId Maybe noreference - referenceScriptId ScriptId Maybe noreference - deriving Show - - Address - address Text - raw ByteString - hasScript Bool - paymentCred ByteString Maybe sqltype=hash28type - stakeAddressId StakeAddressId Maybe noreference - ----------------------------------------------- --- MultiAsset ----------------------------------------------- - MaTxOut - ident MultiAssetId noreference - quantity DbWord64 sqltype=word64type - txOutId TxOutId noreference - deriving Show -|] - -schemaDocsTxOutVariant :: [EntityDef] -schemaDocsTxOutVariant = - document entityDefsTxOutVariant $ do - TxOut --^ do - "A table for transaction outputs." - TxOutAddressId # "The Address table index for the output address." - TxOutConsumedByTxId # "The Tx table index of the transaction that consumes this transaction output. Not populated by default, can be activated via tx-out configs." - TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - TxOutIndex # "The index of this transaction output with the transaction." - TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - TxOutValue # "The output value (in Lovelace) of the transaction output." - TxOutTxId # "The Tx table index of the transaction that contains this transaction output." - - CollateralTxOut --^ do - "A table for transaction collateral outputs. New in v13." - CollateralTxOutTxId # "The Address table index for the output address." - CollateralTxOutIndex # "The index of this transaction output with the transaction." - CollateralTxOutAddressId # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - CollateralTxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - CollateralTxOutValue # "The output value (in Lovelace) of the transaction output." - CollateralTxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." - CollateralTxOutMultiAssetsDescr # "This is a description of the multiassets in collateral output. Since the output is not really created, we don't need to add them in separate tables." - CollateralTxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." - CollateralTxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." - - Address --^ do - "A table for addresses that appear in outputs." - AddressAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." - AddressRaw # "The raw binary address." - AddressHasScript # "Flag which shows if this address is locked by a script." - AddressPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." - AddressStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." - - MaTxOut --^ do - "A table containing Multi-Asset transaction outputs." - MaTxOutIdent # "The MultiAsset table index specifying the asset." - MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." - MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." diff --git a/cardano-db/src/Cardano/Db/Schema/Variants.hs b/cardano-db/src/Cardano/Db/Schema/Variants.hs new file mode 100644 index 000000000..6c3a3379a --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants.hs @@ -0,0 +1,131 @@ +module Cardano.Db.Schema.Variants ( + TxOutTableType (..), + TxOutW (..), + TxOutIdW (..), + MaTxOutW (..), + MaTxOutIdW (..), + CollateralTxOutW (..), + CollateralTxOutIdW (..), + UtxoQueryResult (..), + convertTxOutIdCore, + convertTxOutIdAddress, + convertMaTxOutIdCore, + convertMaTxOutIdAddress, + convertCollateralTxOutIdCore, + convertCollateralTxOutIdAddress, + isTxOutCore, + isTxOutAddress, + module X, +) where + +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.Variants.TxOutAddress as X +import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +import Cardano.Db.Schema.Variants.TxOutCore as X +import qualified Cardano.Db.Schema.Variants.TxOutCore as C +import Cardano.Db.Schema.Variants.TxOutUtxoHd as X +import Cardano.Db.Schema.Variants.TxOutUtxoHdAddress as X +import Cardano.Prelude (ByteString, Text, mapMaybe) + +-------------------------------------------------------------------------------- +-- TxOutTableType +-------------------------------------------------------------------------------- +data TxOutTableType = TxOutTableCore | TxOutTableVariantAddress + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- TxOutW +-------------------------------------------------------------------------------- +data TxOutW + = CTxOutW !C.TxOutCore + | VTxOutW !V.TxOutAddress !(Maybe V.Address) + deriving (Eq, Show) + +data TxOutIdW + = CTxOutIdW !Id.TxOutCoreId + | VTxOutIdW !Id.TxOutAddressId + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- MaTxOutW +-------------------------------------------------------------------------------- +data MaTxOutW + = CMaTxOutW !C.MaTxOutCore + | VMaTxOutW !V.MaTxOutAddress + deriving (Eq, Show) + +data MaTxOutIdW + = CMaTxOutIdW !Id.MaTxOutCoreId + | VMaTxOutIdW !Id.MaTxOutAddressId + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- CollateralTxOutW +-------------------------------------------------------------------------------- +data CollateralTxOutW + = CCollateralTxOutW !C.CollateralTxOutCore + | VCollateralTxOutW !V.CollateralTxOutAddress + deriving (Eq, Show) + +data CollateralTxOutIdW + = CCollateralTxOutIdW !Id.CollateralTxOutCoreId + | VCollateralTxOutIdW !Id.CollateralTxOutAddressId + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- UTXOQueryResult +-------------------------------------------------------------------------------- + +-- | UtxoQueryResult which has utxoAddress that can come from Core or Variant TxOut +data UtxoQueryResult = UtxoQueryResult + { utxoTxOutW :: !TxOutW + , utxoAddress :: !Text + , utxoTxHash :: !ByteString + } + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- +convertTxOutIdCore :: [TxOutIdW] -> [Id.TxOutCoreId] +convertTxOutIdCore = mapMaybe unwrapCore + where + unwrapCore (CTxOutIdW txOutid) = Just txOutid + unwrapCore _ = Nothing + +convertTxOutIdAddress :: [TxOutIdW] -> [Id.TxOutAddressId] +convertTxOutIdAddress = mapMaybe unwrapVariant + where + unwrapVariant (VTxOutIdW txOutid) = Just txOutid + unwrapVariant _ = Nothing + +convertMaTxOutIdCore :: [MaTxOutIdW] -> [Id.MaTxOutCoreId] +convertMaTxOutIdCore = mapMaybe unwrapCore + where + unwrapCore (CMaTxOutIdW maTxOutId) = Just maTxOutId + unwrapCore _ = Nothing + +convertMaTxOutIdAddress :: [MaTxOutIdW] -> [Id.MaTxOutAddressId] +convertMaTxOutIdAddress = mapMaybe unwrapVariant + where + unwrapVariant (VMaTxOutIdW maTxOutId) = Just maTxOutId + unwrapVariant _ = Nothing + +convertCollateralTxOutIdCore :: [CollateralTxOutIdW] -> [Id.CollateralTxOutCoreId] +convertCollateralTxOutIdCore = mapMaybe unwrapCore + where + unwrapCore (CCollateralTxOutIdW iD) = Just iD + unwrapCore _ = Nothing + +convertCollateralTxOutIdAddress :: [CollateralTxOutIdW] -> [Id.CollateralTxOutAddressId] +convertCollateralTxOutIdAddress = mapMaybe unwrapVariant + where + unwrapVariant (VCollateralTxOutIdW iD) = Just iD + unwrapVariant _ = Nothing + +isTxOutCore :: TxOutTableType -> Bool +isTxOutCore TxOutTableCore = True +isTxOutCore _ = False + +isTxOutAddress :: TxOutTableType -> Bool +isTxOutAddress TxOutTableVariantAddress = True +isTxOutAddress _ = False diff --git a/cardano-db/src/Cardano/Db/Schema/Variants/TxOutAddress.hs b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutAddress.hs new file mode 100644 index 000000000..2026035aa --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutAddress.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Schema.Variants.TxOutAddress where + +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types (DbLovelace, DbWord64 (..), dbLovelaceDecoder, dbLovelaceEncoder, dbLovelaceValueEncoder) +import Contravariant.Extras (contrazip3, contrazip9) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant ((>$<)) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import qualified Hasql.Decoders as D +import qualified Hasql.Encoders as E + +----------------------------------------------------------------------------------------------- +-- TxOutAddress +----------------------------------------------------------------------------------------------- +data TxOutAddress = TxOutAddress + { txOutAddressTxId :: !Id.TxId + , txOutAddressIndex :: !Word64 + , txOutAddressStakeAddressId :: !(Maybe Id.StakeAddressId) + , txOutAddressValue :: !DbLovelace + , txOutAddressDataHash :: !(Maybe ByteString) + , txOutAddressInlineDatumId :: !(Maybe Id.DatumId) + , txOutAddressReferenceScriptId :: !(Maybe Id.ScriptId) + , txOutAddressConsumedByTxId :: !(Maybe Id.TxId) + , txOutAddressAddressId :: !Id.AddressId + } + deriving (Eq, Show, Generic) + +type instance Key TxOutAddress = Id.TxOutAddressId + +instance DbInfo TxOutAddress where + tableName _ = "tx_out" + columnNames _ = + NE.fromList + [ "tx_id" + , "index" + , "stake_address_id" + , "value" + , "data_hash" + , "inline_datum_id" + , "reference_script_id" + , "consumed_by_tx_id" + , "address_id" + ] + +entityTxOutAddressDecoder :: D.Row (Entity TxOutAddress) +entityTxOutAddressDecoder = + Entity + <$> Id.idDecoder Id.TxOutAddressId -- entityTxOutAddressId + <*> txOutAddressDecoder -- entityTxOutAddress + +txOutAddressDecoder :: D.Row TxOutAddress +txOutAddressDecoder = + TxOutAddress + <$> Id.idDecoder Id.TxId -- txOutAddressTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- txOutAddressIndex + <*> Id.maybeIdDecoder Id.StakeAddressId -- txOutAddressStakeAddressId + <*> dbLovelaceDecoder -- txOutAddressValue + <*> D.column (D.nullable D.bytea) -- txOutAddressDataHash + <*> Id.maybeIdDecoder Id.DatumId -- txOutAddressInlineDatumId + <*> Id.maybeIdDecoder Id.ScriptId -- txOutAddressReferenceScriptId + <*> Id.maybeIdDecoder Id.TxId -- txOutAddressConsumedByTxId + <*> Id.idDecoder Id.AddressId -- txOutAddressAddressId + +txOutAddressEncoder :: E.Params TxOutAddress +txOutAddressEncoder = + mconcat + [ txOutAddressTxId >$< Id.idEncoder Id.getTxId + , txOutAddressIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , txOutAddressStakeAddressId >$< Id.maybeIdEncoder Id.getStakeAddressId + , txOutAddressValue >$< dbLovelaceEncoder + , txOutAddressDataHash >$< E.param (E.nullable E.bytea) + , txOutAddressInlineDatumId >$< Id.maybeIdEncoder Id.getDatumId + , txOutAddressReferenceScriptId >$< Id.maybeIdEncoder Id.getScriptId + , txOutAddressConsumedByTxId >$< Id.maybeIdEncoder Id.getTxId + , txOutAddressAddressId >$< Id.idEncoder Id.getAddressId + ] + +txOutAddressBulkEncoder :: E.Params ([Id.TxId], [Word64], [Maybe Id.StakeAddressId], [DbLovelace], [Maybe ByteString], [Maybe Id.DatumId], [Maybe Id.ScriptId], [Maybe Id.TxId], [Id.AddressId]) +txOutAddressBulkEncoder = + contrazip9 + (bulkEncoder $ E.nonNullable $ Id.getTxId >$< E.int8) -- txOutAddressTxId + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) -- txOutAddressIndex + (bulkEncoder $ E.nullable $ Id.getStakeAddressId >$< E.int8) -- txOutAddressStakeAddressId + (bulkEncoder dbLovelaceValueEncoder) -- txOutAddressValue + (bulkEncoder $ E.nullable E.bytea) -- txOutAddressDataHash + (bulkEncoder $ E.nullable $ Id.getDatumId >$< E.int8) -- txOutAddressInlineDatumId + (bulkEncoder $ E.nullable $ Id.getScriptId >$< E.int8) -- txOutAddressReferenceScriptId + (bulkEncoder $ E.nullable $ Id.getTxId >$< E.int8) -- txOutAddressConsumedByTxId + (bulkEncoder $ E.nonNullable $ Id.getAddressId >$< E.int8) -- txOutAddressAddressId + +----------------------------------------------------------------------------------------------- +-- CollateralTxOutAddress +----------------------------------------------------------------------------------------------- +data CollateralTxOutAddress = CollateralTxOutAddress + { collateralTxOutAddressTxId :: !Id.TxId + , collateralTxOutAddressIndex :: !Word64 + , collateralTxOutAddressStakeAddressId :: !(Maybe Id.StakeAddressId) + , collateralTxOutAddressValue :: !DbLovelace + , collateralTxOutAddressDataHash :: !(Maybe ByteString) + , collateralTxOutAddressMultiAssetsDescr :: !Text + , collateralTxOutAddressInlineDatumId :: !(Maybe Id.DatumId) + , collateralTxOutAddressReferenceScriptId :: !(Maybe Id.ScriptId) + , collateralTxOutAddressId :: !Id.AddressId + } + deriving (Eq, Show, Generic) + +type instance Key CollateralTxOutAddress = Id.CollateralTxOutAddressId + +instance DbInfo CollateralTxOutAddress where + tableName _ = "collateral_tx_out" + columnNames _ = + NE.fromList + [ "tx_id" + , "index" + , "stake_address_id" + , "value" + , "data_hash" + , "multi_assets_descr" + , "inline_datum_id" + , "reference_script_id" + , "address_id" + ] + +entityCollateralTxOutAddressDecoder :: D.Row (Entity CollateralTxOutAddress) +entityCollateralTxOutAddressDecoder = + Entity + <$> Id.idDecoder Id.CollateralTxOutAddressId -- entityCollateralTxOutAddressId + <*> collateralTxOutAddressDecoder -- entityCollateralTxOutAddress + +collateralTxOutAddressDecoder :: D.Row CollateralTxOutAddress +collateralTxOutAddressDecoder = + CollateralTxOutAddress + <$> Id.idDecoder Id.TxId -- collateralTxOutAddressTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- collateralTxOutAddressIndex + <*> Id.maybeIdDecoder Id.StakeAddressId -- collateralTxOutAddressStakeAddressId + <*> dbLovelaceDecoder -- collateralTxOutAddressValue + <*> D.column (D.nullable D.bytea) -- collateralTxOutAddressDataHash + <*> D.column (D.nonNullable D.text) -- collateralTxOutAddressMultiAssetsDescr + <*> Id.maybeIdDecoder Id.DatumId -- collateralTxOutAddressInlineDatumId + <*> Id.maybeIdDecoder Id.ScriptId -- collateralTxOutAddressReferenceScriptId + <*> Id.idDecoder Id.AddressId -- collateralTxOutAddressId + +collateralTxOutAddressEncoder :: E.Params CollateralTxOutAddress +collateralTxOutAddressEncoder = + mconcat + [ collateralTxOutAddressTxId >$< Id.idEncoder Id.getTxId + , collateralTxOutAddressIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , collateralTxOutAddressStakeAddressId >$< Id.maybeIdEncoder Id.getStakeAddressId + , collateralTxOutAddressValue >$< dbLovelaceEncoder + , collateralTxOutAddressDataHash >$< E.param (E.nullable E.bytea) + , collateralTxOutAddressMultiAssetsDescr >$< E.param (E.nonNullable E.text) + , collateralTxOutAddressInlineDatumId >$< Id.maybeIdEncoder Id.getDatumId + , collateralTxOutAddressReferenceScriptId >$< Id.maybeIdEncoder Id.getScriptId + , collateralTxOutAddressId >$< Id.idEncoder Id.getAddressId + ] + +----------------------------------------------------------------------------------------------- +-- Address +----------------------------------------------------------------------------------------------- +data Address = Address + { addressAddress :: !Text + , addressRaw :: !ByteString + , addressHasScript :: !Bool + , addressPaymentCred :: !(Maybe ByteString) + , addressStakeAddressId :: !(Maybe Id.StakeAddressId) + } + deriving (Eq, Show, Generic) + +type instance Key Address = Id.AddressId +instance DbInfo Address + +entityAddressDecoder :: D.Row (Entity Address) +entityAddressDecoder = + Entity + <$> Id.idDecoder Id.AddressId -- entityAddressId + <*> addressDecoder -- entityAddress + +addressDecoder :: D.Row Address +addressDecoder = + Address + <$> D.column (D.nonNullable D.text) -- addressAddress + <*> D.column (D.nonNullable D.bytea) -- addressRaw + <*> D.column (D.nonNullable D.bool) -- addressHasScript + <*> D.column (D.nullable D.bytea) -- addressPaymentCred + <*> Id.maybeIdDecoder Id.StakeAddressId -- addressStakeAddressId + +addressEncoder :: E.Params Address +addressEncoder = + mconcat + [ addressAddress >$< E.param (E.nonNullable E.text) + , addressRaw >$< E.param (E.nonNullable E.bytea) + , addressHasScript >$< E.param (E.nonNullable E.bool) + , addressPaymentCred >$< E.param (E.nullable E.bytea) + , addressStakeAddressId >$< Id.maybeIdEncoder Id.getStakeAddressId + ] + +----------------------------------------------------------------------------------------------- +-- MultiAssetTxOut +----------------------------------------------------------------------------------------------- +data MaTxOutAddress = MaTxOutAddress + { maTxOutAddressIdent :: !Id.MultiAssetId + , maTxOutAddressQuantity :: !DbWord64 + , maTxOutAddressTxOutId :: !Id.TxOutCoreId + } + deriving (Eq, Show, Generic) + +type instance Key MaTxOutAddress = Id.MaTxOutAddressId + +instance DbInfo MaTxOutAddress where + tableName _ = "ma_tx_out" + columnNames _ = + NE.fromList + [ "ident" + , "quantity" + , "tx_out_id" + ] + +entityMaTxOutAddressDecoder :: D.Row (Entity MaTxOutAddress) +entityMaTxOutAddressDecoder = + Entity + <$> Id.idDecoder Id.MaTxOutAddressId -- entityMaTxOutAddressId + <*> maTxOutAddressDecoder -- entityMaTxOutAddress + +maTxOutAddressDecoder :: D.Row MaTxOutAddress +maTxOutAddressDecoder = + MaTxOutAddress + <$> Id.idDecoder Id.MultiAssetId -- maTxOutAddressIdent + <*> D.column (D.nonNullable $ DbWord64 . fromIntegral <$> D.int8) -- maTxOutAddressQuantity + <*> Id.idDecoder Id.TxOutCoreId -- maTxOutAddressTxOutId + +maTxOutAddressEncoder :: E.Params MaTxOutAddress +maTxOutAddressEncoder = + mconcat + [ maTxOutAddressIdent >$< Id.idEncoder Id.getMultiAssetId + , maTxOutAddressQuantity >$< E.param (E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + , maTxOutAddressTxOutId >$< Id.idEncoder Id.getTxOutCoreId + ] + +maTxOutAddressBulkEncoder :: E.Params ([Id.MultiAssetId], [DbWord64], [Id.TxOutCoreId]) +maTxOutAddressBulkEncoder = + contrazip3 + (bulkEncoder $ E.nonNullable $ Id.getMultiAssetId >$< E.int8) -- maTxOutAddressIdent + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) -- maTxOutAddressQuantity + (bulkEncoder $ E.nonNullable $ Id.getTxOutCoreId >$< E.int8) -- maTxOutAddressTxOutId + +-- share +-- [ mkPersist sqlSettings +-- , mkMigrate "migrateVariantAddressCardanoDb" +-- , mkEntityDefList "entityDefsTxOutAddress" +-- , deriveShowFields +-- ] +-- [persistLowerCase| +-- ---------------------------------------------- +-- -- Variant Address TxOutAddress +-- ---------------------------------------------- +-- TxOutAddress +-- addressId AddressId noreference +-- consumedByTxId TxId Maybe noreference +-- dataHash ByteString Maybe sqltype=hash32type +-- index Word64 sqltype=txindex +-- inlineDatumId DatumId Maybe noreference +-- referenceScriptId ScriptId Maybe noreference +-- stakeAddressId Id.StakeAddressId Maybe noreference +-- txId TxId noreference +-- value DbLovelace sqltype=lovelace +-- UniqueTxout txId index -- The (tx_id, index) pair must be unique. + +-- CollateralTxOutAddress +-- txId TxId noreference -- This type is the primary key for the 'tx' table. +-- index Word64 sqltype=txindex +-- addressId AddressId +-- stakeAddressId Id.StakeAddressId Maybe noreference +-- value DbLovelace sqltype=lovelace +-- dataHash ByteString Maybe sqltype=hash32type +-- multiAssetsDescr Text +-- inlineDatumId DatumId Maybe noreference +-- referenceScriptId ScriptId Maybe noreference +-- deriving Show + +-- Address +-- address Text +-- raw ByteString +-- hasScript Bool +-- paymentCred ByteString Maybe sqltype=hash28type +-- stakeAddressId Id.StakeAddressId Maybe noreference + +-- ---------------------------------------------- +-- -- MultiAsset +-- ---------------------------------------------- +-- MaTxOutAddress +-- ident MultiAssetId noreference +-- quantity DbWord64 sqltype=word64type +-- txOutAddressId TxOutAddressId noreference +-- deriving Show + +-- | ] + +-- schemaDocsTxOutAddress :: [EntityDef] +-- schemaDocsTxOutAddress = +-- document entityDefsTxOutAddress $ do +-- TxOutAddress --^ do +-- "A table for transaction outputs." +-- TxOutAddressId # "The Address table index for the output address." +-- TxOutAddressConsumedByTxId # "The Tx table index of the transaction that consumes this transaction output. Not populated by default, can be activated via tx-out configs." +-- TxOutAddressDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." +-- TxOutAddressIndex # "The index of this transaction output with the transaction." +-- TxOutAddressInlineDatumId # "The inline datum of the output, if it has one. New in v13." +-- TxOutAddressReferenceScriptId # "The reference script of the output, if it has one. New in v13." +-- TxOutAddressValue # "The output value (in Lovelace) of the transaction output." +-- TxOutAddressTxId # "The Tx table index of the transaction that contains this transaction output." + +-- CollateralTxOutAddress --^ do +-- "A table for transaction collateral outputs. New in v13." +-- CollateralTxOutAddressTxId # "The Address table index for the output address." +-- CollateralTxOutAddressIndex # "The index of this transaction output with the transaction." +-- CollateralTxOutAddressId # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." +-- CollateralTxOutAddressStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." +-- CollateralTxOutAddressValue # "The output value (in Lovelace) of the transaction output." +-- CollateralTxOutAddressDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." +-- CollateralTxOutAddressMultiAssetsDescr # "This is a description of the multiassets in collateral output. Since the output is not really created, we don't need to add them in separate tables." +-- CollateralTxOutAddressInlineDatumId # "The inline datum of the output, if it has one. New in v13." +-- CollateralTxOutAddressReferenceScriptId # "The reference script of the output, if it has one. New in v13." + +-- Address --^ do +-- "A table for addresses that appear in outputs." +-- AddressAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." +-- AddressRaw # "The raw binary address." +-- AddressHasScript # "Flag which shows if this address is locked by a script." +-- AddressPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." +-- AddressStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." + +-- MaTxOutAddress --^ do +-- "A table containing Multi-Asset transaction outputs." +-- MaTxOutAddressIdent # "The MultiAsset table index specifying the asset." +-- MaTxOutAddressQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." +-- MaTxOutAddressTxOutAddressId # "The TxOutAddress table index for the transaction that this Multi Asset transaction output." diff --git a/cardano-db/src/Cardano/Db/Schema/Variants/TxOutCore.hs b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutCore.hs new file mode 100644 index 000000000..6ec07e31c --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutCore.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Schema.Variants.TxOutCore where + +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types (DbLovelace, DbWord64 (..), dbLovelaceDecoder, dbLovelaceEncoder, dbLovelaceValueEncoder) +import Contravariant.Extras (contrazip11, contrazip3) +import Data.ByteString.Char8 (ByteString) +import Data.Functor.Contravariant ((>$<)) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import qualified Hasql.Decoders as D +import qualified Hasql.Encoders as E + +----------------------------------------------------------------------------------------------- +-- TxOut +----------------------------------------------------------------------------------------------- +data TxOutCore = TxOutCore + { txOutCoreAddress :: !Text + , txOutCoreAddressHasScript :: !Bool + , txOutCoreDataHash :: !(Maybe ByteString) + , txOutCoreConsumedByTxId :: !(Maybe Id.TxId) + , txOutCoreIndex :: !Word64 + , txOutCoreInlineDatumId :: !(Maybe Id.DatumId) + , txOutCorePaymentCred :: !(Maybe ByteString) + , txOutCoreReferenceScriptId :: !(Maybe Id.ScriptId) + , txOutCoreStakeAddressId :: !(Maybe Id.StakeAddressId) + , txOutCoreTxId :: !Id.TxId + , txOutCoreValue :: !DbLovelace + } + deriving (Eq, Show, Generic) + +type instance Key TxOutCore = Id.TxOutCoreId + +instance DbInfo TxOutCore where + tableName _ = "tx_out" + columnNames _ = + NE.fromList + [ "address" + , "address_has_script" + , "data_hash" + , "consumed_by_tx_id" + , "index" + , "inline_datum_id" + , "payment_cred" + , "reference_script_id" + , "stake_address_id" + , "tx_id" + , "value" + ] + +entityTxOutCoreDecoder :: D.Row (Entity TxOutCore) +entityTxOutCoreDecoder = + Entity + <$> Id.idDecoder Id.TxOutCoreId + <*> txOutCoreDecoder + +txOutCoreDecoder :: D.Row TxOutCore +txOutCoreDecoder = + TxOutCore + <$> D.column (D.nonNullable D.text) -- txOutCoreAddress + <*> D.column (D.nonNullable D.bool) -- txOutCoreAddressHasScript + <*> D.column (D.nullable D.bytea) -- txOutCoreDataHash + <*> Id.maybeIdDecoder Id.TxId -- txOutCoreConsumedByTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- txOutCoreIndex + <*> Id.maybeIdDecoder Id.DatumId -- txOutCoreInlineDatumId + <*> D.column (D.nullable D.bytea) -- txOutCorePaymentCred + <*> Id.maybeIdDecoder Id.ScriptId -- txOutCoreReferenceScriptId + <*> Id.maybeIdDecoder Id.StakeAddressId -- txOutCoreStakeAddressId + <*> Id.idDecoder Id.TxId -- txOutCoreTxId + <*> dbLovelaceDecoder -- txOutCoreValue + +txOutCoreEncoder :: E.Params TxOutCore +txOutCoreEncoder = + mconcat + [ txOutCoreAddress >$< E.param (E.nonNullable E.text) + , txOutCoreAddressHasScript >$< E.param (E.nonNullable E.bool) + , txOutCoreDataHash >$< E.param (E.nullable E.bytea) + , txOutCoreConsumedByTxId >$< Id.maybeIdEncoder Id.getTxId + , txOutCoreIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , txOutCoreInlineDatumId >$< Id.maybeIdEncoder Id.getDatumId + , txOutCorePaymentCred >$< E.param (E.nullable E.bytea) + , txOutCoreReferenceScriptId >$< Id.maybeIdEncoder Id.getScriptId + , txOutCoreStakeAddressId >$< Id.maybeIdEncoder Id.getStakeAddressId + , txOutCoreTxId >$< Id.idEncoder Id.getTxId + , txOutCoreValue >$< dbLovelaceEncoder + ] + +txOutCoreBulkEncoder :: E.Params ([Text], [Bool], [Maybe ByteString], [Maybe Id.TxId], [Word64], [Maybe Id.DatumId], [Maybe ByteString], [Maybe Id.ScriptId], [Maybe Id.StakeAddressId], [Id.TxId], [DbLovelace]) +txOutCoreBulkEncoder = + contrazip11 + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.bool) + (bulkEncoder $ E.nullable E.bytea) + (bulkEncoder $ E.nullable $ Id.getTxId >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral >$< E.int8) + (bulkEncoder $ E.nullable $ Id.getDatumId >$< E.int8) + (bulkEncoder $ E.nullable E.bytea) + (bulkEncoder $ E.nullable $ Id.getScriptId >$< E.int8) + (bulkEncoder $ E.nullable $ Id.getStakeAddressId >$< E.int8) + (bulkEncoder $ E.nonNullable $ Id.getTxId >$< E.int8) + (bulkEncoder dbLovelaceValueEncoder) + +----------------------------------------------------------------------------------------------- +-- CollateralTxOut +----------------------------------------------------------------------------------------------- +data CollateralTxOutCore = CollateralTxOutCore + { collateralTxOutCoreTxId :: !Id.TxId + , collateralTxOutCoreIndex :: !Word64 + , collateralTxOutCoreAddress :: !Text + , collateralTxOutCoreAddressHasScript :: !Bool + , collateralTxOutCorePaymentCred :: !(Maybe ByteString) + , collateralTxOutCoreStakeAddressId :: !(Maybe Id.StakeAddressId) + , collateralTxOutCoreValue :: !DbLovelace + , collateralTxOutCoreDataHash :: !(Maybe ByteString) + , collateralTxOutCoreMultiAssetsDescr :: !Text + , collateralTxOutCoreInlineDatumId :: !(Maybe Id.DatumId) + , collateralTxOutCoreReferenceScriptId :: !(Maybe Id.ScriptId) + } + deriving (Eq, Show, Generic) + +type instance Key CollateralTxOutCore = Id.CollateralTxOutCoreId + +instance DbInfo CollateralTxOutCore where + tableName _ = "collateral_tx_out" + columnNames _ = + NE.fromList + [ "tx_id" + , "index" + , "address" + , "address_has_script" + , "payment_cred" + , "stake_address_id" + , "value" + , "data_hash" + , "multi_assets_descr" + , "inline_datum_id" + , "reference_script_id" + ] + +entityCollateralTxOutCoreDecoder :: D.Row (Entity CollateralTxOutCore) +entityCollateralTxOutCoreDecoder = + Entity + <$> Id.idDecoder Id.CollateralTxOutCoreId + <*> collateralTxOutCoreDecoder + +collateralTxOutCoreDecoder :: D.Row CollateralTxOutCore +collateralTxOutCoreDecoder = + CollateralTxOutCore + <$> Id.idDecoder Id.TxId -- collateralTxOutCoreTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- collateralTxOutCoreIndex + <*> D.column (D.nonNullable D.text) -- collateralTxOutCoreAddress + <*> D.column (D.nonNullable D.bool) -- collateralTxOutCoreAddressHasScript + <*> D.column (D.nullable D.bytea) -- collateralTxOutCorePaymentCred + <*> Id.maybeIdDecoder Id.StakeAddressId -- collateralTxOutCoreStakeAddressId + <*> dbLovelaceDecoder -- collateralTxOutCoreValue + <*> D.column (D.nullable D.bytea) -- collateralTxOutCoreDataHash + <*> D.column (D.nonNullable D.text) -- collateralTxOutCoreMultiAssetsDescr + <*> Id.maybeIdDecoder Id.DatumId -- collateralTxOutCoreInlineDatumId + <*> Id.maybeIdDecoder Id.ScriptId -- collateralTxOutCoreReferenceScriptId + +collateralTxOutCoreEncoder :: E.Params CollateralTxOutCore +collateralTxOutCoreEncoder = + mconcat + [ collateralTxOutCoreTxId >$< Id.idEncoder Id.getTxId + , collateralTxOutCoreIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , collateralTxOutCoreAddress >$< E.param (E.nonNullable E.text) + , collateralTxOutCoreAddressHasScript >$< E.param (E.nonNullable E.bool) + , collateralTxOutCorePaymentCred >$< E.param (E.nullable E.bytea) + , collateralTxOutCoreStakeAddressId >$< Id.maybeIdEncoder Id.getStakeAddressId + , collateralTxOutCoreValue >$< dbLovelaceEncoder + , collateralTxOutCoreDataHash >$< E.param (E.nullable E.bytea) + , collateralTxOutCoreMultiAssetsDescr >$< E.param (E.nonNullable E.text) + , collateralTxOutCoreInlineDatumId >$< Id.maybeIdEncoder Id.getDatumId + , collateralTxOutCoreReferenceScriptId >$< Id.maybeIdEncoder Id.getScriptId + ] + +----------------------------------------------------------------------------------------------- +-- MultiAssetTxOut +----------------------------------------------------------------------------------------------- +data MaTxOutCore = MaTxOutCore + { maTxOutCoreIdent :: !Id.MultiAssetId + , maTxOutCoreQuantity :: !DbWord64 + , maTxOutCoreTxOutId :: !Id.TxOutCoreId + } + deriving (Eq, Show, Generic) + +type instance Key MaTxOutCore = Id.MaTxOutCoreId + +instance DbInfo MaTxOutCore where + tableName _ = "ma_tx_out" + columnNames _ = + NE.fromList + [ "ident" + , "quantity" + , "tx_out_id" + ] + +entityMaTxOutCoreDecoder :: D.Row (Entity MaTxOutCore) +entityMaTxOutCoreDecoder = + Entity + <$> Id.idDecoder Id.MaTxOutCoreId + <*> maTxOutCoreDecoder + +maTxOutCoreDecoder :: D.Row MaTxOutCore +maTxOutCoreDecoder = + MaTxOutCore + <$> Id.idDecoder Id.MultiAssetId -- maTxOutCoreIdent + <*> D.column (D.nonNullable $ DbWord64 . fromIntegral <$> D.int8) -- maTxOutCoreQuantity + <*> Id.idDecoder Id.TxOutCoreId -- maTxOutCoreTxOutId + +maTxOutCoreEncoder :: E.Params MaTxOutCore +maTxOutCoreEncoder = + mconcat + [ maTxOutCoreIdent >$< Id.idEncoder Id.getMultiAssetId + , maTxOutCoreQuantity >$< E.param (E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + , maTxOutCoreTxOutId >$< Id.idEncoder Id.getTxOutCoreId + ] + +maTxOutCoreBulkEncoder :: E.Params ([Id.MultiAssetId], [DbWord64], [Id.TxOutCoreId]) +maTxOutCoreBulkEncoder = + contrazip3 + (bulkEncoder $ E.nonNullable $ Id.getMultiAssetId >$< E.int8) + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) + (bulkEncoder $ E.nonNullable $ Id.getTxOutCoreId >$< E.int8) + +-- share +-- [ mkPersist sqlSettings +-- , mkMigrate "migrateCoreTxOutCardanoDb" +-- , mkEntityDefList "entityDefsTxOutCore" +-- , deriveShowFields +-- ] +-- [persistLowerCase| +-- ---------------------------------------------- +-- -- Core TxOut +-- ---------------------------------------------- +-- TxOut +-- address Text +-- addressHasScript Bool +-- dataHash ByteString Maybe sqltype=hash32type +-- consumedByTxId TxId Maybe noreference +-- index Word64 sqltype=txindex +-- inlineDatumId DatumId Maybe noreference +-- paymentCred ByteString Maybe sqltype=hash28type +-- referenceScriptId ScriptId Maybe noreference +-- stakeAddressId StakeAddressId Maybe noreference +-- txId TxId noreference +-- value DbLovelace sqltype=lovelace +-- UniqueTxout txId index -- The (tx_id, index) pair must be unique. + +-- ---------------------------------------------- +-- -- Core CollateralTxOut +-- ---------------------------------------------- +-- CollateralTxOut +-- txId TxId noreference -- This type is the primary key for the 'tx' table. +-- index Word64 sqltype=txindex +-- address Text +-- addressHasScript Bool +-- paymentCred ByteString Maybe sqltype=hash28type +-- stakeAddressId StakeAddressId Maybe noreference +-- value DbLovelace sqltype=lovelace +-- dataHash ByteString Maybe sqltype=hash32type +-- multiAssetsDescr Text +-- inlineDatumId DatumId Maybe noreference +-- referenceScriptId ScriptId Maybe noreference +-- deriving Show + +-- ---------------------------------------------- +-- -- MultiAsset +-- ---------------------------------------------- +-- MaTxOutCore +-- ident MultiAssetId noreference +-- quantity DbWord64 sqltype=word64type +-- txOutCoreId TxOutId noreference +-- deriving Show + +-- | ] + +-- schemaDocsTxOutCore :: [EntityDef] +-- schemaDocsTxOutCore = +-- document entityDefsTxOutCore $ do +-- TxOut --^ do +-- "A table for transaction outputs." +-- TxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." +-- TxOutAddressHasScript # "Flag which shows if this address is locked by a script." +-- TxOutConsumedByTxId # "The Tx table index of the transaction that consumes this transaction output. Not populated by default, can be activated via tx-out configs." +-- TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." +-- TxOutIndex # "The index of this transaction output with the transaction." +-- TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." +-- TxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." +-- TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." +-- TxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." +-- TxOutValue # "The output value (in Lovelace) of the transaction output." + +-- TxOutTxId # "The Tx table index of the transaction that contains this transaction output." + +-- CollateralTxOut --^ do +-- "A table for transaction collateral outputs. New in v13." +-- CollateralTxOutTxId # "The Tx table index of the transaction that contains this transaction output." +-- CollateralTxOutIndex # "The index of this transaction output with the transaction." +-- CollateralTxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era." +-- CollateralTxOutAddressHasScript # "Flag which shows if this address is locked by a script." +-- CollateralTxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash." +-- CollateralTxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)." +-- CollateralTxOutValue # "The output value (in Lovelace) of the transaction output." +-- CollateralTxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)." +-- CollateralTxOutMultiAssetsDescr # "This is a description of the multiassets in collateral output. Since the output is not really created, we don't need to add them in separate tables." +-- CollateralTxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13." +-- CollateralTxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13." + +-- MaTxOutCore --^ do +-- "A table containing Multi-Asset transaction outputs." +-- MaTxOutCoreIdent # "The MultiAsset table index specifying the asset." +-- MaTxOutCoreQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)." +-- MaTxOutCoreTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output." diff --git a/cardano-db/src/Cardano/Db/Schema/Variants/TxOutUtxoHd.hs b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutUtxoHd.hs new file mode 100644 index 000000000..7a86b92f0 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutUtxoHd.hs @@ -0,0 +1,4 @@ +module Cardano.Db.Schema.Variants.TxOutUtxoHd where + +placeHolderAddress :: () +placeHolderAddress = () diff --git a/cardano-db/src/Cardano/Db/Schema/Variants/TxOutUtxoHdAddress.hs b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutUtxoHdAddress.hs new file mode 100644 index 000000000..859213219 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutUtxoHdAddress.hs @@ -0,0 +1,4 @@ +module Cardano.Db.Schema.Variants.TxOutUtxoHdAddress where + +placeHolder :: () +placeHolder = () diff --git a/cardano-db/src/Cardano/Db/Statement.hs b/cardano-db/src/Cardano/Db/Statement.hs new file mode 100644 index 000000000..4cb44b93d --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement.hs @@ -0,0 +1,27 @@ +module Cardano.Db.Statement ( + module Cardano.Db.Statement.Base, + module Cardano.Db.Statement.EpochAndProtocol, + module Cardano.Db.Statement.GovernanceAndVoting, + module Cardano.Db.Statement.MultiAsset, + module Cardano.Db.Statement.OffChain, + module Cardano.Db.Statement.Pool, + module Cardano.Db.Statement.StakeDeligation, + module Cardano.Db.Statement.Types, + module Cardano.Db.Statement.Function.Core, + module Cardano.Db.Statement.Function.Delete, + module Cardano.Db.Statement.Function.Insert, + module Cardano.Db.Statement.Function.Query, +) where + +import Cardano.Db.Statement.Base +import Cardano.Db.Statement.EpochAndProtocol +import Cardano.Db.Statement.Function.Core +import Cardano.Db.Statement.Function.Delete +import Cardano.Db.Statement.Function.Insert +import Cardano.Db.Statement.Function.Query +import Cardano.Db.Statement.GovernanceAndVoting +import Cardano.Db.Statement.MultiAsset +import Cardano.Db.Statement.OffChain +import Cardano.Db.Statement.Pool +import Cardano.Db.Statement.StakeDeligation +import Cardano.Db.Statement.Types diff --git a/cardano-db/src/Cardano/Db/Statement/Base.hs b/cardano-db/src/Cardano/Db/Statement/Base.hs new file mode 100644 index 000000000..5c29d808f --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Base.hs @@ -0,0 +1,723 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Base where + +import Cardano.Prelude (ByteString, MonadError (..), MonadIO, Proxy (..), Word64, textShow, void) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import Cardano.Db.Error (DbError (..)) +import qualified Cardano.Db.Schema.Core.Base as SCB +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, mkCallSite, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk) +import Cardano.Db.Statement.Function.Query (parameterisedCountWhere) +import Cardano.Db.Statement.Types (DbInfo, Entity (..), tableName) +import Cardano.Db.Types (DbAction, DbCallInfo (..), DbWord64, ExtraMigration, extraDescription) +import Data.Functor.Contravariant ((>$<)) +import Data.Time (UTCTime) + +-------------------------------------------------------------------------------- +-- Block +-------------------------------------------------------------------------------- + +-- | INSERT -------------------------------------------------------------------- +insertBlockStmt :: HsqlStmt.Statement SCB.Block (Entity SCB.Block) +insertBlockStmt = + insert + SCB.blockEncoder + (WithResult $ HsqlD.singleRow SCB.entityBlockDecoder) + +insertBlock :: MonadIO m => SCB.Block -> DbAction m Id.BlockId +insertBlock block = do + entity <- runDbSession (mkCallInfo "insertBlock") $ HsqlSes.statement block insertBlockStmt + pure $ entityKey entity + +-- | QUERIES ------------------------------------------------------------------- +queryBlockHashBlockNoStmt :: HsqlStmt.Statement ByteString [Word64] +queryBlockHashBlockNoStmt = + HsqlStmt.Statement sql hashEncoder blockNoDecoder True + where + table = tableName (Proxy @SCB.Block) + hashEncoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + blockNoDecoder = HsqlD.rowList (HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8)) + sql = + TextEnc.encodeUtf8 $ + Text.concat + ["SELECT block_no FROM " <> table <> " WHERE hash = $1"] + +queryBlockHashBlockNo :: MonadIO m => ByteString -> DbAction m (Maybe Word64) +queryBlockHashBlockNo hash = do + result <- + runDbSession (mkCallInfo "queryBlockHashBlockNo") $ + HsqlSes.statement hash queryBlockHashBlockNoStmt + case result of + [] -> pure Nothing + [blockNo] -> pure (Just blockNo) + results -> + let callInfo = mkCallSite + errorMsg = + "Multiple blocks found with same hash: " + <> Text.pack (show hash) + <> " (found " + <> Text.pack (show $ length results) + <> ")" + in throwError $ + DbError + callInfo + errorMsg + Nothing + +-------------------------------------------------------------------------------- +queryBlockCountStmt :: HsqlStmt.Statement () Word64 +queryBlockCountStmt = + HsqlStmt.Statement sql mempty blockCountDecoder True + where + table = tableName (Proxy @SCB.Block) + blockCountDecoder = HsqlD.singleRow (HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8)) + sql = + TextEnc.encodeUtf8 $ + Text.concat + ["SELECT COUNT(*) FROM " <> table] + +queryBlockCount :: MonadIO m => DbAction m Word64 +queryBlockCount = runDbSession (mkCallInfo "queryBlockCount") $ HsqlSes.statement () queryBlockCountStmt + +-------------------------------------------------------------------------------- +querySlotUtcTimeStmt :: HsqlStmt.Statement Word64 (Maybe UTCTime) +querySlotUtcTimeStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe (HsqlD.column (HsqlD.nonNullable HsqlD.timestamptz)) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT time" + , " FROM block" + , " WHERE slot_no = $1" + ] + +-- | Calculate the slot time (as UTCTime) for a given slot number. +-- This will fail if the slot is empty. +querySlotUtcTime :: MonadIO m => Word64 -> DbAction m UTCTime +querySlotUtcTime slotNo = do + result <- runDbSession callInfo $ HsqlSes.statement slotNo querySlotUtcTimeStmt + case result of + Just time -> pure time + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "querySlotUtcTime" + errorMsg = "slot_no not found with number: " <> Text.pack (show slotNo) + +-------------------------------------------------------------------------------- +-- counting blocks after a specific BlockNo with >= operator +queryBlockCountAfterEqBlockNoStmt :: HsqlStmt.Statement Word64 Word64 +queryBlockCountAfterEqBlockNoStmt = + parameterisedCountWhere @SCB.Block + "block_no" + ">= $1" + (HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8)) + +-- counting blocks after a specific BlockNo with > operator +queryBlockCountAfterBlockNoStmt :: HsqlStmt.Statement Word64 Word64 +queryBlockCountAfterBlockNoStmt = + parameterisedCountWhere @SCB.Block + "block_no" + "> $1" + (HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8)) + +-- | Count the number of blocks in the Block table after a 'BlockNo'. +queryBlockCountAfterBlockNo :: MonadIO m => Word64 -> Bool -> DbAction m Word64 +queryBlockCountAfterBlockNo blockNo queryEq = do + let callInfo = mkCallInfo "queryBlockCountAfterBlockNo" + stmt = + if queryEq + then queryBlockCountAfterEqBlockNoStmt + else queryBlockCountAfterBlockNoStmt + runDbSession callInfo $ HsqlSes.statement blockNo stmt + +-------------------------------------------------------------------------------- +queryBlockNoStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement Word64 (Maybe Id.BlockId) +queryBlockNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.BlockId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM " <> tableName (Proxy @a) + , " WHERE block_no = $1" + ] + +queryBlockNo :: MonadIO m => Word64 -> DbAction m (Maybe Id.BlockId) +queryBlockNo blkNo = + runDbSession (mkCallInfo "queryBlockNo") $ + HsqlSes.statement blkNo $ + queryBlockNoStmt @SCB.Block + +-------------------------------------------------------------------------------- +queryBlockNoAndEpochStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement Word64 (Maybe (Id.BlockId, Word64)) +queryBlockNoAndEpochStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe $ do + blockId <- Id.idDecoder Id.BlockId + epochNo <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + pure (blockId, epochNo) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id, epoch_no" + , " FROM " <> tableName (Proxy @a) + , " WHERE block_no = $1" + ] + +queryBlockNoAndEpoch :: MonadIO m => Word64 -> DbAction m (Maybe (Id.BlockId, Word64)) +queryBlockNoAndEpoch blkNo = + runDbSession (mkCallInfo "queryBlockNoAndEpoch") $ + HsqlSes.statement blkNo $ + queryBlockNoAndEpochStmt @SCB.Block + +-------------------------------------------------------------------------------- +queryNearestBlockSlotNoStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement Word64 (Maybe (Id.BlockId, Word64)) +queryNearestBlockSlotNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id, block_no" + , " FROM " <> tableName (Proxy @a) + , " WHERE slot_no IS NULL OR slot_no >= $1" + , " ORDER BY slot_no ASC" + , " LIMIT 1" + ] + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe $ do + blockId <- Id.idDecoder Id.BlockId + blockNo <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + pure (blockId, blockNo) + +queryNearestBlockSlotNo :: MonadIO m => Word64 -> DbAction m (Maybe (Id.BlockId, Word64)) +queryNearestBlockSlotNo slotNo = + runDbSession (mkCallInfo "queryNearestBlockSlotNo") $ + HsqlSes.statement slotNo $ + queryNearestBlockSlotNoStmt @SCB.Block + +-------------------------------------------------------------------------------- +queryBlockHashStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement ByteString (Maybe (Id.BlockId, Word64)) +queryBlockHashStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id, epoch_no" + , " FROM " <> tableName (Proxy @a) + , " WHERE hash = $1" + ] + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe $ do + blockId <- Id.idDecoder Id.BlockId + epochNo <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + pure (blockId, epochNo) + +queryBlockHash :: MonadIO m => SCB.Block -> DbAction m (Maybe (Id.BlockId, Word64)) +queryBlockHash block = + runDbSession (mkCallInfo "queryBlockHash") $ + HsqlSes.statement (SCB.blockHash block) $ + queryBlockHashStmt @SCB.Block + +-------------------------------------------------------------------------------- +queryMinBlockStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement () (Maybe (Id.BlockId, Word64)) +queryMinBlockStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id, block_no" + , " FROM " <> tableName (Proxy @a) + , " ORDER BY id ASC" + , " LIMIT 1" + ] + + decoder = HsqlD.rowMaybe $ do + blockId <- Id.idDecoder Id.BlockId + blockNo <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + pure (blockId, blockNo) + +queryMinBlock :: MonadIO m => DbAction m (Maybe (Id.BlockId, Word64)) +queryMinBlock = + runDbSession (mkCallInfo "queryMinBlock") $ + HsqlSes.statement () $ + queryMinBlockStmt @SCB.Block + +-------------------------------------------------------------------------------- +queryReverseIndexBlockIdStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement Id.BlockId [Maybe Text.Text] +queryReverseIndexBlockIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = Id.idEncoder Id.getBlockId + decoder = HsqlD.rowList $ HsqlD.column (HsqlD.nullable HsqlD.text) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT ridx.min_ids" + , " FROM " <> tableName (Proxy @a) <> " blk" + , " LEFT JOIN reverse_index ridx ON blk.id = ridx.block_id" + , " WHERE blk.id >= $1" + , " ORDER BY blk.id ASC" + ] + +queryReverseIndexBlockId :: MonadIO m => Id.BlockId -> DbAction m [Maybe Text.Text] +queryReverseIndexBlockId blockId = + runDbSession (mkCallInfo "queryReverseIndexBlockId") $ + HsqlSes.statement blockId $ + queryReverseIndexBlockIdStmt @SCB.Block + +-------------------------------------------------------------------------------- +queryMinIdsAfterReverseIndexStmt :: HsqlStmt.Statement Id.ReverseIndexId [Text.Text] +queryMinIdsAfterReverseIndexStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = Id.idEncoder Id.getReverseIndexId + decoder = HsqlD.rowList $ HsqlD.column (HsqlD.nonNullable HsqlD.text) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT min_ids" + , " FROM reverse_index" + , " WHERE id >= $1" + , " ORDER BY id DESC" + ] + +queryMinIdsAfterReverseIndex :: MonadIO m => Id.ReverseIndexId -> DbAction m [Text.Text] +queryMinIdsAfterReverseIndex rollbackId = + runDbSession (mkCallInfo "queryMinIdsAfterReverseIndex") $ + HsqlSes.statement rollbackId queryMinIdsAfterReverseIndexStmt + +-------------------------------------------------------------------------------- + +-- | Get the number of transactions in the specified block. +queryBlockTxCountStmt :: HsqlStmt.Statement Id.BlockId Word64 +queryBlockTxCountStmt = + parameterisedCountWhere @SCB.Tx "block_id" "= $1" (Id.idEncoder Id.getBlockId) + +queryBlockTxCount :: MonadIO m => Id.BlockId -> DbAction m Word64 +queryBlockTxCount blkId = + runDbSession (mkCallInfo "queryBlockTxCount") $ + HsqlSes.statement blkId queryBlockTxCountStmt + +-------------------------------------------------------------------------------- +queryBlockIdStmt :: HsqlStmt.Statement ByteString (Maybe Id.BlockId) +queryBlockIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.BlockId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM block" + , " WHERE hash = $1" + ] + +queryBlockId :: MonadIO m => ByteString -> DbAction m Id.BlockId +queryBlockId hash = do + result <- runDbSession callInfo $ HsqlSes.statement hash queryBlockIdStmt + case result of + Just res -> pure res + Nothing -> + throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "queryBlockId" + errorMsg = "Block not found with hash: " <> Text.pack (show hash) + +----------------------------------------------------------------------------------- +queryGenesisStmt :: HsqlStmt.Statement () [Id.BlockId] +queryGenesisStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + decoder = HsqlD.rowList (Id.idDecoder Id.BlockId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM block" + , " WHERE previous_id IS NULL" + ] + +queryGenesis :: MonadIO m => DbAction m Id.BlockId +queryGenesis = do + let callInfo = mkCallInfo "queryGenesis" + errorMsg = "Multiple Genesis blocks found" + + result <- runDbSession callInfo $ HsqlSes.statement () queryGenesisStmt + case result of + [blk] -> pure blk + _otherwise -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + +-- | DELETE + +-------------------------------------------------------------------------------- +-- Datum +-------------------------------------------------------------------------------- +insertDatumStmt :: HsqlStmt.Statement SCB.Datum (Entity SCB.Datum) +insertDatumStmt = + insert + SCB.datumEncoder + (WithResult $ HsqlD.singleRow SCB.entityDatumDecoder) + +insertDatum :: MonadIO m => SCB.Datum -> DbAction m Id.DatumId +insertDatum datum = do + entity <- runDbSession (mkCallInfo "insertDatum") $ HsqlSes.statement datum insertDatumStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- TxMetadata +-------------------------------------------------------------------------------- +insertBulkTxMetadataStmt :: HsqlStmt.Statement [SCB.TxMetadata] [Entity SCB.TxMetadata] +insertBulkTxMetadataStmt = + insertBulk + extractTxMetadata + SCB.txMetadataBulkEncoder + (WithResultBulk (HsqlD.rowList SCB.entityTxMetadataDecoder)) + where + extractTxMetadata :: [SCB.TxMetadata] -> ([DbWord64], [Maybe Text.Text], [ByteString], [Id.TxId]) + extractTxMetadata xs = + ( map SCB.txMetadataKey xs + , map SCB.txMetadataJson xs + , map SCB.txMetadataBytes xs + , map SCB.txMetadataTxId xs + ) + +insertBulkTxMetadata :: MonadIO m => [SCB.TxMetadata] -> DbAction m [Id.TxMetadataId] +insertBulkTxMetadata txMetas = do + entities <- + runDbSession (mkCallInfo "insertBulkTxMetadata") $ + HsqlSes.statement txMetas insertBulkTxMetadataStmt + pure $ map entityKey entities + +-------------------------------------------------------------------------------- +-- CollateralTxIn +-------------------------------------------------------------------------------- +insertCollateralTxInStmt :: HsqlStmt.Statement SCB.CollateralTxIn (Entity SCB.CollateralTxIn) +insertCollateralTxInStmt = + insert + SCB.collateralTxInEncoder + (WithResult $ HsqlD.singleRow SCB.entityCollateralTxInDecoder) + +insertCollateralTxIn :: MonadIO m => SCB.CollateralTxIn -> DbAction m Id.CollateralTxInId +insertCollateralTxIn cTxIn = do + entity <- runDbSession (mkCallInfo "insertCollateralTxIn") $ HsqlSes.statement cTxIn insertCollateralTxInStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Meta +-------------------------------------------------------------------------------- +queryMetaStmt :: HsqlStmt.Statement () [SCB.Meta] +queryMetaStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + decoder = HsqlD.rowList SCB.metaDecoder + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM meta" + ] + +queryMeta :: MonadIO m => DbAction m SCB.Meta +queryMeta = do + let callInfo = mkCallInfo "queryMeta" + result <- runDbSession callInfo $ HsqlSes.statement () queryMetaStmt + case result of + [] -> throwError $ DbError (dciCallSite callInfo) "Meta table is empty" Nothing + [m] -> pure m + _otherwise -> throwError $ DbError (dciCallSite callInfo) "Multiple rows in meta table" Nothing + +-------------------------------------------------------------------------------- +-- ReferenceTxIn +-------------------------------------------------------------------------------- +insertReferenceTxInStmt :: HsqlStmt.Statement SCB.ReferenceTxIn (Entity SCB.ReferenceTxIn) +insertReferenceTxInStmt = + insert + SCB.referenceTxInEncoder + (WithResult $ HsqlD.singleRow SCB.entityReferenceTxInDecoder) + +insertReferenceTxIn :: MonadIO m => SCB.ReferenceTxIn -> DbAction m Id.ReferenceTxInId +insertReferenceTxIn rTxIn = do + entity <- runDbSession (mkCallInfo "insertReferenceTxIn") $ HsqlSes.statement rTxIn insertReferenceTxInStmt + pure (entityKey entity) + +-------------------------------------------------------------------------------- +insertExtraMigrationStmt :: HsqlStmt.Statement SCB.ExtraMigrations () +insertExtraMigrationStmt = + insert + SCB.extraMigrationsEncoder + NoResult + +insertExtraMigration :: MonadIO m => ExtraMigration -> DbAction m () +insertExtraMigration extraMigration = + void $ runDbSession (mkCallInfo "insertExtraMigration") $ HsqlSes.statement input insertExtraMigrationStmt + where + input = SCB.ExtraMigrations (textShow extraMigration) (Just $ extraDescription extraMigration) + +-------------------------------------------------------------------------------- +-- ExtraKeyWitness +-------------------------------------------------------------------------------- +insertExtraKeyWitnessStmt :: HsqlStmt.Statement SCB.ExtraKeyWitness (Entity SCB.ExtraKeyWitness) +insertExtraKeyWitnessStmt = + insert + SCB.extraKeyWitnessEncoder + (WithResult $ HsqlD.singleRow SCB.entityExtraKeyWitnessDecoder) + +insertExtraKeyWitness :: MonadIO m => SCB.ExtraKeyWitness -> DbAction m Id.ExtraKeyWitnessId +insertExtraKeyWitness eKeyWitness = do + entity <- runDbSession (mkCallInfo "insertExtraKeyWitness") $ HsqlSes.statement eKeyWitness insertExtraKeyWitnessStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Meta +-------------------------------------------------------------------------------- +insertMetaStmt :: HsqlStmt.Statement SCB.Meta (Entity SCB.Meta) +insertMetaStmt = + insert + SCB.metaEncoder + (WithResult $ HsqlD.singleRow SCB.entityMetaDecoder) + +insertMeta :: MonadIO m => SCB.Meta -> DbAction m Id.MetaId +insertMeta meta = do + entity <- runDbSession (mkCallInfo "insertMeta") $ HsqlSes.statement meta insertMetaStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Redeemer +-------------------------------------------------------------------------------- +insertRedeemerStmt :: HsqlStmt.Statement SCB.Redeemer (Entity SCB.Redeemer) +insertRedeemerStmt = + insert + SCB.redeemerEncoder + (WithResult $ HsqlD.singleRow SCB.entityRedeemerDecoder) + +insertRedeemer :: MonadIO m => SCB.Redeemer -> DbAction m Id.RedeemerId +insertRedeemer redeemer = do + entity <- runDbSession (mkCallInfo "insertRedeemer") $ HsqlSes.statement redeemer insertRedeemerStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +insertRedeemerDataStmt :: HsqlStmt.Statement SCB.RedeemerData (Entity SCB.RedeemerData) +insertRedeemerDataStmt = + insert + SCB.redeemerDataEncoder + (WithResult $ HsqlD.singleRow SCB.entityRedeemerDataDecoder) + +insertRedeemerData :: MonadIO m => SCB.RedeemerData -> DbAction m Id.RedeemerDataId +insertRedeemerData redeemerData = do + entity <- runDbSession (mkCallInfo "insertRedeemerData") $ HsqlSes.statement redeemerData insertRedeemerDataStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- ReverseIndex +-------------------------------------------------------------------------------- +insertReverseIndexStmt :: HsqlStmt.Statement SCB.ReverseIndex (Entity SCB.ReverseIndex) +insertReverseIndexStmt = + insert + SCB.reverseIndexEncoder + (WithResult $ HsqlD.singleRow SCB.entityReverseIndexDecoder) + +insertReverseIndex :: MonadIO m => SCB.ReverseIndex -> DbAction m Id.ReverseIndexId +insertReverseIndex reverseIndex = do + entity <- runDbSession (mkCallInfo "insertReverseIndex") $ HsqlSes.statement reverseIndex insertReverseIndexStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Script +-------------------------------------------------------------------------------- +insertScriptStmt :: HsqlStmt.Statement SCB.Script (Entity SCB.Script) +insertScriptStmt = + insert + SCB.scriptEncoder + (WithResult $ HsqlD.singleRow SCB.entityScriptDecoder) + +insertScript :: MonadIO m => SCB.Script -> DbAction m Id.ScriptId +insertScript script = do + entity <- runDbSession (mkCallInfo "insertScript") $ HsqlSes.statement script insertScriptStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- SlotLeader +-------------------------------------------------------------------------------- +insertSlotLeaderStmt :: HsqlStmt.Statement SCB.SlotLeader (Entity SCB.SlotLeader) +insertSlotLeaderStmt = + insert + SCB.slotLeaderEncoder + (WithResult $ HsqlD.singleRow SCB.entitySlotLeaderDecoder) + +insertSlotLeader :: MonadIO m => SCB.SlotLeader -> DbAction m Id.SlotLeaderId +insertSlotLeader slotLeader = do + entity <- runDbSession (mkCallInfo "insertSlotLeader") $ HsqlSes.statement slotLeader insertSlotLeaderStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +insertTxCborStmt :: HsqlStmt.Statement SCB.TxCbor (Entity SCB.TxCbor) +insertTxCborStmt = + insert + SCB.txCborEncoder + (WithResult $ HsqlD.singleRow SCB.entityTxCborDecoder) + +insertTxCbor :: MonadIO m => SCB.TxCbor -> DbAction m Id.TxCborId +insertTxCbor txCBOR = do + entity <- runDbSession (mkCallInfo "insertTxCBOR") $ HsqlSes.statement txCBOR insertTxCborStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Tx +-------------------------------------------------------------------------------- + +-- | INSERTTS +insertTxStmt :: HsqlStmt.Statement SCB.Tx (Entity SCB.Tx) +insertTxStmt = + insert + SCB.txEncoder + (WithResult $ HsqlD.singleRow SCB.entityTxDecoder) + +insertTx :: MonadIO m => SCB.Tx -> DbAction m Id.TxId +insertTx tx = do + entity <- runDbSession (mkCallInfo "insertTx") $ HsqlSes.statement tx insertTxStmt + pure $ entityKey entity + +-- | QUERIES + +-------------------------------------------------------------------------------- +queryTxIdStmt :: HsqlStmt.Statement ByteString (Maybe Id.TxId) +queryTxIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.TxId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM tx" + , " WHERE hash = $1" + ] + +-- | Get the 'TxId' associated with the given hash. +queryTxId :: MonadIO m => ByteString -> DbAction m Id.TxId +queryTxId hash = do + result <- runDbSession callInfo $ HsqlSes.statement hash queryTxIdStmt + case result of + Just res -> pure res + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "queryTxId" + errorMsg = "Transaction not found with hash: " <> Text.pack (show hash) + +-------------------------------------------------------------------------------- +-- TxIn +-------------------------------------------------------------------------------- +insertTxInStmt :: HsqlStmt.Statement SCB.TxIn (Entity SCB.TxIn) +insertTxInStmt = + insert + SCB.txInEncoder + (WithResult $ HsqlD.singleRow SCB.entityTxInDecoder) + +insertTxIn :: MonadIO m => SCB.TxIn -> DbAction m Id.TxInId +insertTxIn txIn = do + entity <- runDbSession (mkCallInfo "insertTxIn") $ HsqlSes.statement txIn insertTxInStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +insertBulkTxInStmt :: HsqlStmt.Statement [SCB.TxIn] [Entity SCB.TxIn] +insertBulkTxInStmt = + insertBulk + extractTxIn + SCB.encodeTxInBulk + (WithResultBulk $ HsqlD.rowList SCB.entityTxInDecoder) + where + extractTxIn :: [SCB.TxIn] -> ([Id.TxId], [Id.TxId], [Word64], [Maybe Id.RedeemerId]) + extractTxIn xs = + ( map SCB.txInTxInId xs + , map SCB.txInTxOutId xs + , map SCB.txInTxOutIndex xs + , map SCB.txInRedeemerId xs + ) + +insertBulkTxIn :: MonadIO m => [SCB.TxIn] -> DbAction m [Id.TxInId] +insertBulkTxIn txIns = do + entities <- + runDbSession (mkCallInfo "insertBulkTxIn") $ + HsqlSes.statement txIns insertBulkTxInStmt + pure $ map entityKey entities + +-------------------------------------------------------------------------------- +-- Withdrawal +-------------------------------------------------------------------------------- +insertWithdrawalStmt :: HsqlStmt.Statement SCB.Withdrawal (Entity SCB.Withdrawal) +insertWithdrawalStmt = + insert + SCB.withdrawalEncoder + (WithResult $ HsqlD.singleRow SCB.entityWithdrawalDecoder) + +insertWithdrawal :: MonadIO m => SCB.Withdrawal -> DbAction m Id.WithdrawalId +insertWithdrawal withdrawal = do + entity <- runDbSession (mkCallInfo "insertWithdrawal") $ HsqlSes.statement withdrawal insertWithdrawalStmt + pure $ entityKey entity + +-- These tables store fundamental blockchain data, such as blocks, transactions, and UTXOs. + +-- block +-- collateral_tx_in +-- collateral_tx_out +-- datum +-- extra_key_witness +-- metaa +-- redeemer +-- redeemer_data +-- reference_tx_in +-- reverse_index +-- script +-- slot_leader +-- tx +-- tx_cbor +-- tx_in +-- tx_out +-- utxo_byron_view +-- utxo_view diff --git a/cardano-db/src/Cardano/Db/Statement/EpochAndProtocol.hs b/cardano-db/src/Cardano/Db/Statement/EpochAndProtocol.hs new file mode 100644 index 000000000..0a0b4084f --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/EpochAndProtocol.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.EpochAndProtocol where + +import Cardano.Prelude (MonadError (..), MonadIO (..), Word64, void) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Session as HsqlSess +import qualified Hasql.Statement as HsqlStmt + +import Cardano.Db.Error (DbError (..)) +import qualified Cardano.Db.Schema.Core.EpochAndProtocol as SEnP +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk) +import Cardano.Db.Statement.Function.Query (replace, selectByField) +import Cardano.Db.Statement.Types (Entity (..)) +import Cardano.Db.Types (DbAction (..), DbCallInfo (..), DbLovelace (..)) +import Data.Functor.Contravariant ((>$<)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import Data.Time (UTCTime) +import qualified Hasql.Encoders as HsqlE + +-------------------------------------------------------------------------------- +-- CostModel +-------------------------------------------------------------------------------- +costModelStmt :: HsqlStmt.Statement SEnP.CostModel (Entity SEnP.CostModel) +costModelStmt = + insert + SEnP.costModelEncoder + (WithResult $ HsqlD.singleRow SEnP.entityCostModelDecoder) + +insertCostModel :: MonadIO m => SEnP.CostModel -> DbAction m Id.CostModelId +insertCostModel costModel = do + entity <- runDbSession (mkCallInfo "insertCostModel") $ HsqlSess.statement costModel costModelStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- AdaPots +-------------------------------------------------------------------------------- + +-- | INSERT +insertAdaPotsStmt :: HsqlStmt.Statement SEnP.AdaPots (Entity SEnP.AdaPots) +insertAdaPotsStmt = + insert + SEnP.adaPotsEncoder + (WithResult $ HsqlD.singleRow SEnP.entityAdaPotsDecoder) + +insertAdaPots :: MonadIO m => SEnP.AdaPots -> DbAction m Id.AdaPotsId +insertAdaPots adaPots = do + entity <- runDbSession (mkCallInfo "insertAdaPots") $ HsqlSess.statement adaPots insertAdaPotsStmt + pure $ entityKey entity + +-- | QUERY + +-- AdaPots query statement +queryAdaPotsIdStmt :: HsqlStmt.Statement Id.BlockId (Maybe (Entity SEnP.AdaPots)) +queryAdaPotsIdStmt = selectByField "block_id" (Id.idEncoder Id.getBlockId) SEnP.entityAdaPotsDecoder + +-- AdaPots query function +queryAdaPotsId :: MonadIO m => Id.BlockId -> DbAction m (Maybe (Entity SEnP.AdaPots)) +queryAdaPotsId blockId = + runDbSession (mkCallInfo "queryAdaPotsId") $ + HsqlSess.statement blockId queryAdaPotsIdStmt + +replaceAdaPotsStmt :: HsqlStmt.Statement (Id.AdaPotsId, SEnP.AdaPots) () +replaceAdaPotsStmt = + replace + (Id.idEncoder Id.getAdaPotsId) + SEnP.adaPotsEncoder + +replaceAdaPots :: MonadIO m => Id.BlockId -> SEnP.AdaPots -> DbAction m Bool +replaceAdaPots blockId adapots = do + -- Do the query first + mAdaPotsEntity <- + runDbSession (mkCallInfo "queryAdaPots") $ + HsqlSess.statement blockId queryAdaPotsIdStmt + + -- Then conditionally do the update + case mAdaPotsEntity of + Nothing -> pure False + Just adaPotsEntity + | entityVal adaPotsEntity == adapots -> pure False + | otherwise -> do + runDbSession (mkCallInfo "updateAdaPots") $ + HsqlSess.statement (entityKey adaPotsEntity, adapots) replaceAdaPotsStmt + pure True + +-------------------------------------------------------------------------------- +-- Epoch +-------------------------------------------------------------------------------- +insertEpochStmt :: HsqlStmt.Statement SEnP.Epoch (Entity SEnP.Epoch) +insertEpochStmt = + insert + SEnP.epochEncoder + (WithResult $ HsqlD.singleRow SEnP.entityEpochDecoder) + +insertEpoch :: MonadIO m => SEnP.Epoch -> DbAction m Id.EpochId +insertEpoch epoch = do + entity <- runDbSession (mkCallInfo "insertEpoch") $ HsqlSess.statement epoch insertEpochStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +insertEpochParamStmt :: HsqlStmt.Statement SEnP.EpochParam (Entity SEnP.EpochParam) +insertEpochParamStmt = + insert + SEnP.epochParamEncoder + (WithResult $ HsqlD.singleRow SEnP.entityEpochParamDecoder) + +insertEpochParam :: MonadIO m => SEnP.EpochParam -> DbAction m Id.EpochParamId +insertEpochParam epochParam = do + entity <- runDbSession (mkCallInfo "insertEpochParam") $ HsqlSess.statement epochParam insertEpochParamStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +insertEpochSyncTimeStmt :: HsqlStmt.Statement SEnP.EpochSyncTime (Entity SEnP.EpochSyncTime) +insertEpochSyncTimeStmt = + insert + SEnP.epochSyncTimeEncoder + (WithResult $ HsqlD.singleRow SEnP.entityEpochSyncTimeDecoder) + +insertEpochSyncTime :: MonadIO m => SEnP.EpochSyncTime -> DbAction m Id.EpochSyncTimeId +insertEpochSyncTime epochSyncTime = do + entity <- runDbSession (mkCallInfo "insertEpochSyncTime") $ HsqlSess.statement epochSyncTime insertEpochSyncTimeStmt + pure $ entityKey entity + +-- | QUERY ---------------------------------------------------------------------------------- +queryEpochEntryStmt :: HsqlStmt.Statement Word64 (Maybe SEnP.Epoch) +queryEpochEntryStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe SEnP.epochDecoder + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM epoch" + , " WHERE no = $1" + ] + +queryEpochEntry :: MonadIO m => Word64 -> DbAction m SEnP.Epoch +queryEpochEntry epochNum = do + result <- runDbSession callInfo $ HsqlSess.statement epochNum queryEpochEntryStmt + case result of + Just res -> pure res + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "queryEpochEntry" + errorMsg = "Epoch not found with number: " <> Text.pack (show epochNum) + +-------------------------------------------------------------------------------- +queryCalcEpochEntryStmt :: HsqlStmt.Statement Word64 SEnP.Epoch +queryCalcEpochEntryStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH block_stats AS (" + , " SELECT COUNT(*) as block_count, MIN(time) as min_time, MAX(time) as max_time" + , " FROM block" + , " WHERE epoch_no = $1" + , ")," + , "tx_stats AS (" + , " SELECT COALESCE(SUM(tx.out_sum), 0) as out_sum, " + , " COALESCE(SUM(tx.fee), 0) as fee_sum, " + , " COUNT(tx.out_sum) as tx_count" + , " FROM tx" + , " INNER JOIN block ON tx.block_id = block.id" + , " WHERE block.epoch_no = $1" + , ")" + , "SELECT $1 as epoch_no, " + , " bs.block_count, " + , " bs.min_time, " + , " bs.max_time, " + , " ts.out_sum, " + , " ts.fee_sum, " + , " ts.tx_count" + , "FROM block_stats bs, tx_stats ts" + ] + + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + + decoder = HsqlD.singleRow $ do + epochNo <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + blockCount <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + minTime <- HsqlD.column (HsqlD.nullable HsqlD.timestamptz) + maxTime <- HsqlD.column (HsqlD.nullable HsqlD.timestamptz) + outSum <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + feeSum <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + txCount <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + + pure $ case (blockCount, minTime, maxTime) of + (0, _, _) -> emptyEpoch epochNo + (_, Just start, Just end) -> + if txCount == 0 + then convertBlk epochNo (blockCount, Just start, Just end) + else + SEnP.Epoch + { SEnP.epochOutSum = fromIntegral outSum + , SEnP.epochFees = DbLovelace $ fromIntegral feeSum + , SEnP.epochTxCount = txCount + , SEnP.epochBlkCount = blockCount + , SEnP.epochNo = epochNo + , SEnP.epochStartTime = start + , SEnP.epochEndTime = end + } + _otherwise -> emptyEpoch epochNo + +convertBlk :: Word64 -> (Word64, Maybe UTCTime, Maybe UTCTime) -> SEnP.Epoch +convertBlk epochNum (blkCount, b, c) = + case (b, c) of + (Just start, Just end) -> SEnP.Epoch 0 (DbLovelace 0) 0 blkCount epochNum start end + _otherwise -> emptyEpoch epochNum + +-- We only return this when something has screwed up. +emptyEpoch :: Word64 -> SEnP.Epoch +emptyEpoch epochNum = + SEnP.Epoch + { SEnP.epochOutSum = 0 + , SEnP.epochFees = DbLovelace 0 + , SEnP.epochTxCount = 0 + , SEnP.epochBlkCount = 0 + , SEnP.epochNo = epochNum + , SEnP.epochStartTime = defaultUTCTime + , SEnP.epochEndTime = defaultUTCTime + } + +defaultUTCTime :: UTCTime +defaultUTCTime = read "2000-01-01 00:00:00.000000 UTC" + +-- | 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 Epoch entry for the last epoch. +queryCalcEpochEntry :: MonadIO m => Word64 -> DbAction m SEnP.Epoch +queryCalcEpochEntry epochNum = + runDbSession (mkCallInfo "queryCalcEpochEntry") $ + HsqlSess.statement epochNum queryCalcEpochEntryStmt + +-------------------------------------------------------------------------------- + +-- | Get the PostgreSQL row index (EpochId) that matches the given epoch number. +queryForEpochIdStmt :: HsqlStmt.Statement Word64 (Maybe Id.EpochId) +queryForEpochIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.EpochId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM epoch" + , " WHERE no = $1" + ] + +-- | Get the PostgreSQL row index (EpochId) that matches the given epoch number. +queryForEpochId :: MonadIO m => Word64 -> DbAction m (Maybe Id.EpochId) +queryForEpochId epochNum = + runDbSession (mkCallInfo "queryForEpochId") $ + HsqlSess.statement epochNum queryForEpochIdStmt + +-------------------------------------------------------------------------------- +queryEpochFromNumStmt :: HsqlStmt.Statement Word64 (Maybe SEnP.Epoch) +queryEpochFromNumStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM epoch" + , " WHERE no = $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowMaybe SEnP.epochDecoder + +-- | Get an epoch given it's number. +queryEpochFromNum :: MonadIO m => Word64 -> DbAction m (Maybe SEnP.Epoch) +queryEpochFromNum epochNum = + runDbSession (mkCallInfo "queryEpochFromNum") $ + HsqlSess.statement epochNum queryEpochFromNumStmt + +-------------------------------------------------------------------------------- +queryLatestEpochStmt :: HsqlStmt.Statement () (Maybe SEnP.Epoch) +queryLatestEpochStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM epoch" + , " ORDER BY no DESC" + , " LIMIT 1" + ] + + decoder = HsqlD.rowMaybe SEnP.epochDecoder + +-- | Get the most recent epoch in the Epoch DB table. +queryLatestEpoch :: MonadIO m => DbAction m (Maybe SEnP.Epoch) +queryLatestEpoch = + runDbSession (mkCallInfo "queryLatestEpoch") $ + HsqlSess.statement () queryLatestEpochStmt + +-------------------------------------------------------------------------------- +-- EpochStake +-------------------------------------------------------------------------------- +-- insertBulkEpochStakeStmt :: HsqlStmt.Statement [SSD.EpochStake] () +-- insertBulkEpochStakeStmt = +-- insertBulk +-- extractEpochStake +-- SSD.epochStakeBulkEncoder +-- NoResultBulk +-- where +-- extractEpochStake :: [SSD.EpochStake] -> ([Id.StakeAddressId], [Id.PoolHashId], [DbLovelace], [Word64]) +-- extractEpochStake xs = +-- ( map SSD.epochStakeAddrId xs +-- , map SSD.epochStakePoolId xs +-- , map SSD.epochStakeAmount xs +-- , map SSD.epochStakeEpochNo xs +-- ) + +-- insertBulkEpochStake :: MonadIO m => [SSD.EpochStake] -> DbAction m () +-- insertBulkEpochStake epochStakes = +-- void $ +-- runDbSession (mkCallInfo "insertBulkEpochStake") $ +-- HsqlSess.statement epochStakes insertBulkEpochStakeStmt + +-------------------------------------------------------------------------------- +-- EpochState +-------------------------------------------------------------------------------- +insertEpochStateStmt :: HsqlStmt.Statement SEnP.EpochState (Entity SEnP.EpochState) +insertEpochStateStmt = + insert + SEnP.epochStateEncoder + (WithResult $ HsqlD.singleRow SEnP.entityEpochStateDecoder) + +insertEpochState :: MonadIO m => SEnP.EpochState -> DbAction m Id.EpochStateId +insertEpochState epochState = do + entity <- runDbSession (mkCallInfo "insertEpochState") $ HsqlSess.statement epochState insertEpochStateStmt + pure $ entityKey entity + +insertBulkEpochStateStmt :: HsqlStmt.Statement [SEnP.EpochState] () +insertBulkEpochStateStmt = + insertBulk + extractEpochState + SEnP.epochStateBulkEncoder + NoResultBulk + where + extractEpochState :: [SEnP.EpochState] -> ([Maybe Id.CommitteeId], [Maybe Id.GovActionProposalId], [Maybe Id.ConstitutionId], [Word64]) + extractEpochState xs = + ( map SEnP.epochStateCommitteeId xs + , map SEnP.epochStateNoConfidenceId xs + , map SEnP.epochStateConstitutionId xs + , map SEnP.epochStateEpochNo xs + ) + +insertBulkEpochState :: MonadIO m => [SEnP.EpochState] -> DbAction m () +insertBulkEpochState epochStates = + void $ + runDbSession (mkCallInfo "insertBulkEpochState") $ + HsqlSess.statement epochStates insertBulkEpochStateStmt + +-------------------------------------------------------------------------------- +-- PotTransfer +-------------------------------------------------------------------------------- +insertPotTransferStmt :: HsqlStmt.Statement SEnP.PotTransfer (Entity SEnP.PotTransfer) +insertPotTransferStmt = + insert + SEnP.potTransferEncoder + (WithResult $ HsqlD.singleRow SEnP.entityPotTransferDecoder) + +insertPotTransfer :: MonadIO m => SEnP.PotTransfer -> DbAction m Id.PotTransferId +insertPotTransfer potTransfer = do + entity <- runDbSession (mkCallInfo "insertPotTransfer") $ HsqlSess.statement potTransfer insertPotTransferStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Reserve +-------------------------------------------------------------------------------- +insertRervedStmt :: HsqlStmt.Statement SEnP.Reserve (Entity SEnP.Reserve) +insertRervedStmt = + insert + SEnP.reserveEncoder + (WithResult $ HsqlD.singleRow SEnP.entityReserveDecoder) + +insertRerved :: MonadIO m => SEnP.Reserve -> DbAction m Id.ReserveId +insertRerved reserve = do + entity <- runDbSession (mkCallInfo "insertRerved") $ HsqlSess.statement reserve insertRervedStmt + pure $ entityKey entity + +-- Epoch And Protocol Parameters +-- These tables store epoch-specific data and protocol parameters. + +-- ada_pots +-- cost_model +-- epoch +-- epoch_param +-- epoch_stake +-- epoch_stake_progress +-- epoch_state +-- epoch_sync_time +-- pot_transfer +-- reserve +-- treasury diff --git a/cardano-db/src/Cardano/Db/Statement/Function/Core.hs b/cardano-db/src/Cardano/Db/Statement/Function/Core.hs new file mode 100644 index 000000000..21f9e7e67 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Core.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Db.Statement.Function.Core ( + runDbSession, + mkCallInfo, + mkCallSite, + -- runPipelinedSession, + -- runDbActionWith, + bulkEncoder, + ResultType (..), + ResultTypeBulk (..), +) +where + +import Cardano.BM.Trace (logDebug) +import Cardano.Db.Error (CallSite (..), DbError (..)) +import Cardano.Db.Types (DbAction (..), DbCallInfo (..), DbEnv (..)) +import Cardano.Prelude (MonadError (..), MonadIO (..), Text, ask, for_, when) +import qualified Data.Text as Text +import Data.Time (diffUTCTime, getCurrentTime) +import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlS + +-- | Runs a database session (regular or pipelined) with optional logging. +-- +-- This function executes a `Session` within the `DbAction` monad, handling +-- the execution and logging details if enabled in the `DbEnv`. It captures +-- timing information and call site details for debugging purposes when logging +-- is active. +-- +-- This is the core function for executing both regular and pipelined database +-- operations. +-- +-- ==== Parameters +-- * @DbCallInfo@: Call site information for debugging and logging. +-- * @Session a@: The `Hasql` session to execute (can be a regular session or pipeline). +-- +-- ==== Returns +-- * @DbAction m a@: The result of the session wrapped in the `DbAction` monad. +-- +-- ==== Examples +-- ``` +-- -- Regular session: +-- result <- runDbSession (mkCallInfo "operation") $ +-- HsqlS.statement record statement +-- +-- -- Pipeline session: +-- results <- runDbSession (mkCallInfo "batchOperation") $ +-- HsqlS.pipeline $ do +-- r1 <- HsqlP.statement input1 statement1 +-- r2 <- HsqlP.statement input2 statement2 +-- pure (r1, r2) +-- ``` +runDbSession :: MonadIO m => DbCallInfo -> HsqlS.Session a -> DbAction m a +runDbSession DbCallInfo {..} session = DbAction $ do + dbEnv <- ask + let logMsg msg = + when (dbEnableLogging dbEnv) $ + for_ (dbTracer dbEnv) $ + \tracer -> liftIO $ logDebug tracer msg + locationInfo = + " at " + <> csModule dciCallSite + <> ":" + <> csFile dciCallSite + <> ":" + <> Text.pack (show $ csLine dciCallSite) + + if dbEnableLogging dbEnv + then do + start <- liftIO getCurrentTime + result <- run dbEnv + end <- liftIO getCurrentTime + let duration = diffUTCTime end start + logMsg $ "Query: " <> dciName <> locationInfo <> " in " <> Text.pack (show duration) + pure result + else run dbEnv + where + run dbEnv = do + result <- liftIO $ HsqlS.run session (dbConnection dbEnv) + case result of + Left sessionErr -> + throwError $ DbError dciCallSite "Database query failed: " (Just sessionErr) + Right val -> pure val + +-- | Creates a `DbCallInfo` with a function name and call site. +-- +-- ==== Parameters +-- * @name@: The name of the function or database operation being performed. +-- +-- ==== Returns +-- * @DbCallInfo@: A call information record with operation name and location metadata. +mkCallInfo :: HasCallStack => Text -> DbCallInfo +mkCallInfo name = DbCallInfo name mkCallSite + +-- | Extracts call site information from the current call stack. +-- +-- This helper function parses the Haskell call stack to provide source location +-- details. +-- +-- ==== Returns +-- * @CallSite@: A record containing module name, file path, and line number +mkCallSite :: HasCallStack => CallSite +mkCallSite = + case reverse (getCallStack callStack) of + (_, srcLoc) : _ -> + CallSite + { csModule = Text.pack $ srcLocModule srcLoc + , csFile = Text.pack $ srcLocFile srcLoc + , csLine = srcLocStartLine srcLoc + } + [] -> error "No call stack info" + +-- | The result type of an insert operation (usualy it's newly generated id). +data ResultType c r where + NoResult :: ResultType c () -- No ID, result type is () + WithResult :: HsqlD.Result c -> ResultType c c -- Return ID, result type is c + +-- | The result type of an insert operation (usualy it's newly generated id). +data ResultTypeBulk c r where + NoResultBulk :: ResultTypeBulk c () -- No IDs, result type is () + WithResultBulk :: HsqlD.Result [c] -> ResultTypeBulk c [c] -- Return IDs, result type is [c] + +-- | Creates a parameter encoder for an array of values from a single-value encoder +bulkEncoder :: HsqlE.NullableOrNot HsqlE.Value a -> HsqlE.Params [a] +bulkEncoder v = HsqlE.param $ HsqlE.nonNullable $ HsqlE.foldableArray v diff --git a/cardano-db/src/Cardano/Db/Statement/Function/Insert.hs b/cardano-db/src/Cardano/Db/Statement/Function/Insert.hs new file mode 100644 index 000000000..f96f28ebf --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Insert.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Function.Insert ( + insert, + insertCheckUnique, + insertBulk, +) +where + +import qualified Data.Text as Text +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Statement as HsqlS + +import qualified Data.List.NonEmpty as NE +import qualified Data.Text.Encoding as TextEnc + +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..)) +import Cardano.Db.Statement.Types (DbInfo (..), Entity) +import Cardano.Prelude (Proxy (..)) +import Data.Functor.Contravariant (contramap) + +-- | Inserts a record into a table, with option of returning the generated ID. +-- +-- ==== Parameters +-- * @encoder@: The encoder for the record. +-- * @resultType@: Whether to return a result (usually it's newly generated id) and decoder. +-- * @record@: The record to insert. +insert :: + forall a c r. + (DbInfo a) => + HsqlE.Params a -> -- Encoder for record (without ID) + ResultType (Entity c) r -> -- Whether to return Entity and decoder + HsqlS.Statement a r -- Returns the prepared statement +insert encoder resultType = + HsqlS.Statement sql encoder decoder True + where + (decoder, returnClause) = case resultType of + NoResult -> (HsqlD.noResult, "") + WithResult dec -> (dec, "RETURNING id") + + table = tableName (Proxy @a) + colNames = columnNames (Proxy @a) + columns = Text.intercalate ", " (NE.toList colNames) + + values = Text.intercalate ", " $ map (\i -> "$" <> Text.pack (show i)) [1 .. length colNames] + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "INSERT INTO " <> table + , " (" <> columns <> ")" + , " VALUES (" <> values <> ")" + , returnClause + ] + +-- | Inserts a record into a table, checking for a unique constraint violation. +-- +-- If the `DbInfoConstraints` instance does not match any table type records, this function will throw an error. +-- +-- ==== Parameters +-- * @encoder@: The encoder for the record. +-- * @resultType@: Whether to return a result (usually it's newly generated id) and decoder. +-- * @record@: The record to insert. +insertCheckUnique :: + forall a c r. + (DbInfo a) => + HsqlE.Params a -> -- Encoder + ResultType (Entity c) r -> -- Whether to return a result and decoder + HsqlS.Statement a r -- Returns the prepared statement +insertCheckUnique encoder resultType = + case validateUniqueConstraints (Proxy @a) of + Left err -> error err + Right _ -> HsqlS.Statement sql encoder decoder True + where + (decoder, returnClause) = case resultType of + NoResult -> (HsqlD.noResult, "") + WithResult dec -> (dec, "RETURNING id") + + table = tableName (Proxy @a) + colNames = columnNames (Proxy @a) + uniqueCols = uniqueFields (Proxy @a) + + -- Drop the ID column for value placeholders + dummyUpdateField = NE.head colNames + placeholders = Text.intercalate ", " $ map (\i -> "$" <> Text.pack (show i)) [1 .. length colNames] + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "INSERT INTO " <> table + , " (" <> Text.intercalate ", " (NE.toList colNames) <> ")" + , " VALUES (" <> placeholders <> ")" + , " ON CONFLICT (" <> Text.intercalate ", " uniqueCols <> ")" + , " DO UPDATE SET " <> dummyUpdateField <> " = EXCLUDED." <> dummyUpdateField + , returnClause + ] + +-- | Inserts multiple records into a table in a single transaction using UNNEST. +-- +-- This function performs a bulk insert into a specified table, using PostgreSQL’s +-- `UNNEST` to expand arrays of field values into rows. It’s designed for efficiency, +-- executing all inserts in one SQL statement, and can return the generated IDs. +-- This will automatically handle unique constraints, if they are present. +insertBulk :: + forall a b c r. + (DbInfo a) => + ([a] -> b) -> -- Field extractor + HsqlE.Params b -> -- Encoder + ResultTypeBulk (Entity c) r -> -- Result type + HsqlS.Statement [a] r -- Returns a Statement +insertBulk extract enc returnIds = + case validateUniqueConstraints (Proxy @a) of + Left err -> error err + Right uniques -> + HsqlS.Statement sql (contramap extract enc) decoder True + where + table = tableName (Proxy @a) + colNames = NE.toList $ columnNames (Proxy @a) + + unnestVals = Text.intercalate ", " $ map (\i -> "$" <> Text.pack (show i)) [1 .. length colNames] + + conflictClause :: [Text.Text] -> Text.Text + conflictClause [] = "" + conflictClause uniqueConstraints = " ON CONFLICT (" <> Text.intercalate ", " uniqueConstraints <> ") DO NOTHING" + + (decoder, shouldReturnId) = case returnIds of + NoResultBulk -> (HsqlD.noResult, "") + WithResultBulk dec -> (dec, "RETURNING id") + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "INSERT INTO " <> table + , " (" <> Text.intercalate ", " colNames <> ") " + , " SELECT * FROM UNNEST (" + , unnestVals <> " ) " + , conflictClause uniques + , shouldReturnId + ] + +-- | Validates that the unique constraints are valid columns in the table. +-- If there are no unique constraints, this function will return successfully with []. +validateUniqueConstraints :: (DbInfo a) => Proxy a -> Either String [Text.Text] +validateUniqueConstraints p = + let colNames = NE.toList $ columnNames p + constraints = uniqueFields p + invalidConstraints = filter (`notElem` colNames) constraints + in if null invalidConstraints + then Right constraints + else Left $ "Invalid unique constraint columns: " ++ show invalidConstraints diff --git a/cardano-db/src/Cardano/Db/Statement/Function/Query.hs b/cardano-db/src/Cardano/Db/Statement/Function/Query.hs new file mode 100644 index 000000000..e1b0fbb0b --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Query.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Cardano.Db.Statement.Function.Query where + +import qualified Data.Text as Text +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Statement as HsqlS + +import qualified Data.Text.Encoding as TextEnc + +import Cardano.Db.Statement.Function.Core (ResultType (..)) +import Cardano.Db.Statement.Types (DbInfo (..), Entity, Key, validateColumn) +import Cardano.Prelude (Proxy (..), Word64) +import Data.Functor.Contravariant (Contravariant (..)) +import qualified Data.List.NonEmpty as NE + +replace :: + forall a. + (DbInfo a) => + HsqlE.Params (Key a) -> -- ID encoder + HsqlE.Params a -> -- Record encoder + HsqlS.Statement (Key a, a) () +replace keyEncoder recordEncoder = + HsqlS.Statement sql encoder HsqlD.noResult True + where + table = tableName (Proxy @a) + colNames = NE.toList $ columnNames (Proxy @a) + + setClause = + Text.intercalate ", " $ + zipWith + (\col i -> col <> " = $" <> Text.pack (show (i + (1 :: Integer)))) + colNames + [1 ..] + + encoder = contramap fst keyEncoder <> contramap snd recordEncoder + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE " <> table + , " SET " <> setClause + , " WHERE id = $1" + ] + +selectByField :: + forall a b. + (DbInfo a) => + Text.Text -> -- Field name + HsqlE.Params b -> -- Parameter encoder (not Value) + HsqlD.Row (Entity a) -> -- Entity decoder + HsqlS.Statement b (Maybe (Entity a)) +selectByField fieldName paramEncoder entityDecoder = + HsqlS.Statement + ( TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT * FROM " <> tableName (Proxy @a) + , " WHERE " <> fieldName <> " = $1" + ] + ) + paramEncoder -- Direct use of paramEncoder + (HsqlD.rowMaybe entityDecoder) + True + +-- | Checks if a record with a specific ID exists in a table. +-- +-- This function performs an EXISTS check on a given table, using the record's ID. +-- +-- === Example +-- @ +-- queryVotingAnchorIdStmt :: HsqlS.Statement Id.VotingAnchorId Bool +-- queryVotingAnchorIdStmt = existsById @VotingAnchor +-- (Id.idEncoder Id.getVotingAnchorId) +-- (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) +-- @ +existsById :: + forall a r. + (DbInfo a, Key a ~ Key a) => + HsqlE.Params (Key a) -> -- Key encoder + ResultType Bool r -> -- Whether to return Entity and decoder + HsqlS.Statement (Key a) r +existsById encoder resultType = + HsqlS.Statement sql encoder decoder True + where + decoder = case resultType of + NoResult -> HsqlD.noResult + WithResult dec -> dec + + table = tableName (Proxy @a) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT EXISTS (SELECT 1 FROM " <> table + , " WHERE id = $1)" + ] + +-- | Creates a statement to replace a record with a new value +-- +-- === Example +-- @ +-- replaceVotingAnchor :: MonadIO m => VotingAnchorId -> VotingAnchor -> DbAction m () +-- replaceVotingAnchor key record = +-- runDbSession (mkCallInfo "replaceVotingAnchor") $ +-- HsqlS.statement (key, record) $ replaceRecord +-- @VotingAnchor +-- (idEncoder getVotingAnchorId) +-- votingAnchorEncoder +-- @ +replaceRecord :: + forall a. + (DbInfo a) => + HsqlE.Params (Key a) -> -- Key encoder + HsqlE.Params a -> -- Record encoder + HsqlS.Statement (Key a, a) () -- Returns a statement to replace a record +replaceRecord keyEnc recordEnc = + HsqlS.Statement sql encoder HsqlD.noResult True + where + table = tableName (Proxy @a) + colsNames = NE.toList $ columnNames (Proxy @a) + + setClause = + Text.intercalate ", " $ + zipWith + (\col idx -> col <> " = $" <> Text.pack (show idx)) + colsNames + [2 .. (length colsNames + 1)] + + -- Combined encoder for the (key, record) tuple + encoder = contramap fst keyEnc <> contramap snd recordEnc + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE " <> table + , " SET " <> setClause + , " WHERE id = $1" + ] + +-- | Creates a statement to count rows in a table where a column matches a condition +-- +-- The function validates that the column exists in the table schema +-- and throws an error if it doesn't. +-- +-- === Example +-- @ +-- queryTxOutUnspentCount :: MonadIO m => TxOutTableType -> DbAction m Word64 +-- queryTxOutUnspentCount txOutTableType = +-- case txOutTableType of +-- TxOutCore -> +-- runDbSession (mkCallInfo "queryTxOutUnspentCountCore") $ +-- HsqlSes.statement () (countWhere @TxOutCore "consumed_by_tx_id" "IS NULL") +-- +-- TxOutVariantAddress -> +-- runDbSession (mkCallInfo "queryTxOutUnspentCountAddress") $ +-- HsqlSes.statement () (countWhere @TxOutAddress "consumed_by_tx_id" "IS NULL") +-- @ +countWhere :: + forall a. + (DbInfo a) => + -- | Column name to filter on + Text.Text -> + -- | SQL condition to apply (e.g., "IS NULL", "= $1", "> 100") + Text.Text -> + -- | Returns a statement that counts matching rows + HsqlS.Statement () Word64 +countWhere colName condition = + HsqlS.Statement sql HsqlE.noParams decoder True + where + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + -- Validate the column name + validCol = validateColumn @a colName + + -- SQL statement to count rows matching the condition + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " " <> condition + ] + +-- | Creates a statement to count rows matching a parameterized condition +parameterisedCountWhere :: + forall a p. + (DbInfo a) => + -- | Column name to filter on + Text.Text -> + -- | SQL condition with parameter placeholders + Text.Text -> + -- | Parameter encoder + HsqlE.Params p -> + HsqlS.Statement p Word64 +parameterisedCountWhere colName condition encoder = + HsqlS.Statement sql encoder decoder True + where + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + -- Validate the column name + validCol = validateColumn @a colName + + -- SQL statement to count rows matching the condition + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " " <> condition + ] + +-- | Creates a statement to count all rows in a table +-- +-- === Example +-- @ +-- queryTableCount :: MonadIO m => DbAction m Word64 +-- queryTableCount = +-- runDbSession (mkCallInfo "queryTableCount") $ +-- HsqlSes.statement () (countAll @TxOutCore) +-- @ +countAll :: + forall a. + (DbInfo a) => + -- | Returns a statement that counts all rows + HsqlS.Statement () Word64 +countAll = + HsqlS.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @a) + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> table + ] diff --git a/cardano-db/src/Cardano/Db/Statement/GovernanceAndVoting.hs b/cardano-db/src/Cardano/Db/Statement/GovernanceAndVoting.hs new file mode 100644 index 000000000..1bbd2fed5 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/GovernanceAndVoting.hs @@ -0,0 +1,525 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Statement.GovernanceAndVoting where + +import Data.Functor.Contravariant ((>$<)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlSess +import qualified Hasql.Statement as HsqlStm + +import qualified Cardano.Db.Schema.Core.EpochAndProtocol as SEP +import qualified Cardano.Db.Schema.Core.GovernanceAndVoting as SGV +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert) +import Cardano.Db.Statement.Function.Query (existsById) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..)) +import Cardano.Db.Types (DbAction, hardcodedAlwaysAbstain, hardcodedAlwaysNoConfidence) +import Cardano.Prelude (ByteString, Int64, MonadIO, Proxy (..), Word64) + +-------------------------------------------------------------------------------- +-- Committee +-------------------------------------------------------------------------------- +insertCommitteeStmt :: HsqlStm.Statement SGV.Committee (Entity SGV.Committee) +insertCommitteeStmt = + insert + SGV.committeeEncoder + (WithResult $ HsqlD.singleRow SGV.entityCommitteeDecoder) + +insertCommittee :: MonadIO m => SGV.Committee -> DbAction m Id.CommitteeId +insertCommittee committee = do + entity <- runDbSession (mkCallInfo "insertCommittee") $ HsqlSess.statement committee insertCommitteeStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- CommitteeHash +-------------------------------------------------------------------------------- + +-- | Insert +insertCommitteeHashStmt :: HsqlStm.Statement SGV.CommitteeHash (Entity SGV.CommitteeHash) +insertCommitteeHashStmt = + insert + SGV.committeeHashEncoder + (WithResult $ HsqlD.singleRow SGV.entityCommitteeHashDecoder) + +insertCommitteeHash :: MonadIO m => SGV.CommitteeHash -> DbAction m Id.CommitteeHashId +insertCommitteeHash committeeHash = do + entity <- runDbSession (mkCallInfo "insertCommitteeHash") $ HsqlSess.statement committeeHash insertCommitteeHashStmt + pure $ entityKey entity + +-- | Query +queryCommitteeHashStmt :: HsqlStm.Statement ByteString (Maybe Id.CommitteeHashId) +queryCommitteeHashStmt = + HsqlStm.Statement sql encoder decoder True + where + table = tableName (Proxy @SGV.CommitteeHash) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM " <> table + , " WHERE raw IS NULL" + , " LIMIT 1" + ] + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.singleRow $ Id.maybeIdDecoder Id.CommitteeHashId + +queryCommitteeHash :: MonadIO m => ByteString -> DbAction m (Maybe Id.CommitteeHashId) +queryCommitteeHash hash = + runDbSession (mkCallInfo "queryCommitteeHash") $ + HsqlSess.statement hash queryCommitteeHashStmt + +-------------------------------------------------------------------------------- +-- CommitteeMember +-------------------------------------------------------------------------------- +insertCommitteeMemberStmt :: HsqlStm.Statement SGV.CommitteeMember (Entity SGV.CommitteeMember) +insertCommitteeMemberStmt = + insert + SGV.committeeMemberEncoder + (WithResult $ HsqlD.singleRow SGV.entityCommitteeMemberDecoder) + +insertCommitteeMember :: MonadIO m => SGV.CommitteeMember -> DbAction m Id.CommitteeMemberId +insertCommitteeMember committeeMember = do + entity <- runDbSession (mkCallInfo "insertCommitteeMember") $ HsqlSess.statement committeeMember insertCommitteeMemberStmt + pure $ entityKey entity + +insertCommitteeDeRegistrationStmt :: HsqlStm.Statement SGV.CommitteeDeRegistration (Entity SGV.CommitteeDeRegistration) +insertCommitteeDeRegistrationStmt = + insert + SGV.committeeDeRegistrationEncoder + (WithResult $ HsqlD.singleRow SGV.entityCommitteeDeRegistrationDecoder) + +insertCommitteeDeRegistration :: MonadIO m => SGV.CommitteeDeRegistration -> DbAction m Id.CommitteeDeRegistrationId +insertCommitteeDeRegistration committeeDeRegistration = do + entity <- + runDbSession (mkCallInfo "insertCommitteeDeRegistration") $ + HsqlSess.statement committeeDeRegistration insertCommitteeDeRegistrationStmt + pure $ entityKey entity + +insertCommitteeRegistrationStmt :: HsqlStm.Statement SGV.CommitteeRegistration (Entity SGV.CommitteeRegistration) +insertCommitteeRegistrationStmt = + insert + SGV.committeeRegistrationEncoder + (WithResult $ HsqlD.singleRow SGV.entityCommitteeRegistrationDecoder) + +insertCommitteeRegistration :: MonadIO m => SGV.CommitteeRegistration -> DbAction m Id.CommitteeRegistrationId +insertCommitteeRegistration committeeRegistration = do + entity <- + runDbSession (mkCallInfo "insertCommitteeRegistration") $ + HsqlSess.statement committeeRegistration insertCommitteeRegistrationStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Constitution +-------------------------------------------------------------------------------- +insertConstitutionStmt :: HsqlStm.Statement SGV.Constitution (Entity SGV.Constitution) +insertConstitutionStmt = + insert + SGV.constitutionEncoder + (WithResult $ HsqlD.singleRow SGV.entityConstitutionDecoder) + +insertConstitution :: MonadIO m => SGV.Constitution -> DbAction m Id.ConstitutionId +insertConstitution constitution = do + entity <- runDbSession (mkCallInfo "insertConstitution") $ HsqlSess.statement constitution insertConstitutionStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- DelegationVote +-------------------------------------------------------------------------------- +insertDelegationVoteStmt :: HsqlStm.Statement SGV.DelegationVote (Entity SGV.DelegationVote) +insertDelegationVoteStmt = + insert + SGV.delegationVoteEncoder + (WithResult $ HsqlD.singleRow SGV.entityDelegationVoteDecoder) + +insertDelegationVote :: MonadIO m => SGV.DelegationVote -> DbAction m Id.DelegationVoteId +insertDelegationVote delegationVote = do + entity <- runDbSession (mkCallInfo "insertDelegationVote") $ HsqlSess.statement delegationVote insertDelegationVoteStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Drep +-------------------------------------------------------------------------------- + +-- | INSERT +insertDrepHashStmt :: HsqlStm.Statement SGV.DrepHash (Entity SGV.DrepHash) +insertDrepHashStmt = + insert + SGV.drepHashEncoder + (WithResult $ HsqlD.singleRow SGV.entityDrepHashDecoder) + +insertDrepHash :: MonadIO m => SGV.DrepHash -> DbAction m Id.DrepHashId +insertDrepHash drepHash = do + entity <- runDbSession (mkCallInfo "insertDrepHash") $ HsqlSess.statement drepHash insertDrepHashStmt + pure $ entityKey entity + +insertDrepHashAbstainStmt :: HsqlStm.Statement SGV.DrepHash (Entity SGV.DrepHash) +insertDrepHashAbstainStmt = + insert + SGV.drepHashEncoder + (WithResult (HsqlD.singleRow SGV.entityDrepHashDecoder)) + +insertDrepHashAlwaysAbstain :: MonadIO m => DbAction m Id.DrepHashId +insertDrepHashAlwaysAbstain = do + qr <- queryDrepHashAlwaysAbstain + maybe ins pure qr + where + ins = do + entity <- + runDbSession (mkCallInfo "insertDrepHashAlwaysAbstain") $ + HsqlSess.statement drepHashAbstain insertDrepHashAbstainStmt + pure (entityKey entity) + + drepHashAbstain = + SGV.DrepHash + { SGV.drepHashRaw = Nothing + , SGV.drepHashView = hardcodedAlwaysAbstain + , SGV.drepHashHasScript = False + } + +insertDrepHashAlwaysNoConfidence :: MonadIO m => DbAction m Id.DrepHashId +insertDrepHashAlwaysNoConfidence = do + qr <- queryDrepHashAlwaysNoConfidence + maybe ins pure qr + where + ins = do + entity <- + runDbSession (mkCallInfo "insertDrepHashAlwaysNoConfidence") $ + HsqlSess.statement drepHashNoConfidence insertDrepHashAbstainStmt + pure (entityKey entity) + + drepHashNoConfidence = + SGV.DrepHash + { SGV.drepHashRaw = Nothing + , SGV.drepHashView = hardcodedAlwaysNoConfidence + , SGV.drepHashHasScript = False + } + +insertDrepRegistrationStmt :: HsqlStm.Statement SGV.DrepRegistration (Entity SGV.DrepRegistration) +insertDrepRegistrationStmt = + insert + SGV.drepRegistrationEncoder + (WithResult $ HsqlD.singleRow SGV.entityDrepRegistrationDecoder) + +insertDrepRegistration :: MonadIO m => SGV.DrepRegistration -> DbAction m Id.DrepRegistrationId +insertDrepRegistration drepRegistration = do + entity <- runDbSession (mkCallInfo "insertDrepRegistration") $ HsqlSess.statement drepRegistration insertDrepRegistrationStmt + pure $ entityKey entity + +-- | QUERY +queryDrepHashAlwaysStmt :: Text.Text -> HsqlStm.Statement () (Maybe Id.DrepHashId) +queryDrepHashAlwaysStmt hardcodedAlways = + HsqlStm.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @SGV.DrepHash) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM " <> table + , " WHERE raw IS NULL" + , " AND view = '" <> hardcodedAlways <> "'" + , " LIMIT 1" + ] + decoder = HsqlD.singleRow $ Id.maybeIdDecoder Id.DrepHashId + +queryDrepHashAlwaysAbstainStmt :: HsqlStm.Statement () (Maybe Id.DrepHashId) +queryDrepHashAlwaysAbstainStmt = queryDrepHashAlwaysStmt hardcodedAlwaysAbstain + +queryDrepHashAlwaysNoConfidenceStmt :: HsqlStm.Statement () (Maybe Id.DrepHashId) +queryDrepHashAlwaysNoConfidenceStmt = queryDrepHashAlwaysStmt hardcodedAlwaysNoConfidence + +queryDrepHashAlwaysAbstain :: MonadIO m => DbAction m (Maybe Id.DrepHashId) +queryDrepHashAlwaysAbstain = + runDbSession (mkCallInfo "queryDrepHashAlwaysAbstain") $ + HsqlSess.statement () queryDrepHashAlwaysAbstainStmt + +queryDrepHashAlwaysNoConfidence :: MonadIO m => DbAction m (Maybe Id.DrepHashId) +queryDrepHashAlwaysNoConfidence = + runDbSession (mkCallInfo "queryDrepHashAlwaysNoConfidence") $ + HsqlSess.statement () queryDrepHashAlwaysNoConfidenceStmt + +-------------------------------------------------------------------------------- +-- GovActionProposal +-------------------------------------------------------------------------------- + +-- | INSERT +insertGovActionProposalStmt :: HsqlStm.Statement SGV.GovActionProposal (Entity SGV.GovActionProposal) +insertGovActionProposalStmt = + insert + SGV.govActionProposalEncoder + (WithResult $ HsqlD.singleRow SGV.entityGovActionProposalDecoder) + +insertGovActionProposal :: MonadIO m => SGV.GovActionProposal -> DbAction m Id.GovActionProposalId +insertGovActionProposal govActionProposal = do + entity <- + runDbSession (mkCallInfo "insertGovActionProposal") $ + HsqlSess.statement govActionProposal insertGovActionProposalStmt + pure $ entityKey entity + +-- | UPDATE + +-- Statement for updateGovActionState +updateGovActionStateStmt :: + -- | Column name to update + Text.Text -> + -- | Whether to return affected rows count + ResultType Int64 r -> + HsqlStm.Statement (Id.GovActionProposalId, Int64) r +updateGovActionStateStmt columnName resultType = + HsqlStm.Statement sql encoder decoder True + where + (decoder, returnClause) = case resultType of + NoResult -> (HsqlD.noResult, "") + WithResult dec -> (dec, " RETURNING xmax != 0 AS changed") + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE gov_action_proposal" + , " SET " + , columnName + , " = $2" + , " WHERE id = $1 AND " + , columnName + , " IS NULL" + , returnClause + ] + encoder = + mconcat + [ fst >$< Id.idEncoder Id.getGovActionProposalId + , snd >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + ] + +-- Statement for setGovActionStateNull +setGovActionStateNullStmt :: + -- | Column name to update + Text.Text -> + HsqlStm.Statement Int64 Int64 +setGovActionStateNullStmt columnName = + HsqlStm.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE gov_action_proposal" + , " SET " + , columnName + , " = NULL" + , " WHERE " + , columnName + , " IS NOT NULL AND " + , columnName + , " > $1" + , " RETURNING xmax != 0 AS changed" + ] + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.rowsAffected + +-- Statements +updateGovActionEnactedStmt :: HsqlStm.Statement (Id.GovActionProposalId, Int64) Int64 +updateGovActionEnactedStmt = updateGovActionStateStmt "enacted_epoch" (WithResult HsqlD.rowsAffected) + +updateGovActionRatifiedStmt :: HsqlStm.Statement (Id.GovActionProposalId, Int64) () +updateGovActionRatifiedStmt = updateGovActionStateStmt "ratified_epoch" NoResult + +updateGovActionDroppedStmt :: HsqlStm.Statement (Id.GovActionProposalId, Int64) () +updateGovActionDroppedStmt = updateGovActionStateStmt "dropped_epoch" NoResult + +updateGovActionExpiredStmt :: HsqlStm.Statement (Id.GovActionProposalId, Int64) () +updateGovActionExpiredStmt = updateGovActionStateStmt "expired_epoch" NoResult + +setNullEnactedStmt :: HsqlStm.Statement Int64 Int64 +setNullEnactedStmt = setGovActionStateNullStmt "enacted_epoch" + +setNullRatifiedStmt :: HsqlStm.Statement Int64 Int64 +setNullRatifiedStmt = setGovActionStateNullStmt "ratified_epoch" + +setNullExpiredStmt :: HsqlStm.Statement Int64 Int64 +setNullExpiredStmt = setGovActionStateNullStmt "expired_epoch" + +setNullDroppedStmt :: HsqlStm.Statement Int64 Int64 +setNullDroppedStmt = setGovActionStateNullStmt "dropped_epoch" + +-- Executions +updateGovActionEnacted :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m Int64 +updateGovActionEnacted gaid eNo = + runDbSession (mkCallInfo "updateGovActionEnacted") $ + HsqlSess.statement (gaid, fromIntegral eNo) updateGovActionEnactedStmt + +updateGovActionRatified :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m () +updateGovActionRatified gaid eNo = + runDbSession (mkCallInfo "updateGovActionRatified") $ + HsqlSess.statement (gaid, fromIntegral eNo) updateGovActionRatifiedStmt + +updateGovActionDropped :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m () +updateGovActionDropped gaid eNo = + runDbSession (mkCallInfo "updateGovActionDropped") $ + HsqlSess.statement (gaid, fromIntegral eNo) updateGovActionDroppedStmt + +updateGovActionExpired :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m () +updateGovActionExpired gaid eNo = + runDbSession (mkCallInfo "updateGovActionExpired") $ + HsqlSess.statement (gaid, fromIntegral eNo) updateGovActionExpiredStmt + +setNullEnacted :: MonadIO m => Word64 -> DbAction m Int64 +setNullEnacted eNo = + runDbSession (mkCallInfo "setNullEnacted") $ + HsqlSess.statement (fromIntegral eNo) setNullEnactedStmt + +setNullRatified :: MonadIO m => Word64 -> DbAction m Int64 +setNullRatified eNo = + runDbSession (mkCallInfo "setNullRatified") $ + HsqlSess.statement (fromIntegral eNo) setNullRatifiedStmt + +setNullExpired :: MonadIO m => Word64 -> DbAction m Int64 +setNullExpired eNo = + runDbSession (mkCallInfo "setNullExpired") $ + HsqlSess.statement (fromIntegral eNo) setNullExpiredStmt + +setNullDropped :: MonadIO m => Word64 -> DbAction m Int64 +setNullDropped eNo = + runDbSession (mkCallInfo "setNullDropped") $ + HsqlSess.statement (fromIntegral eNo) setNullDroppedStmt + +queryGovActionProposalIdStmt :: HsqlStm.Statement (Id.TxId, Word64) (Maybe Id.GovActionProposalId) +queryGovActionProposalIdStmt = + HsqlStm.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM gov_action_proposal" + , " WHERE tx_id = $1 AND index = $2" + ] + + encoder = + contramap fst (Id.idEncoder Id.getTxId) + <> contramap snd (HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8)) + + decoder = HsqlD.rowMaybe (Id.idDecoder Id.GovActionProposalId) + +queryGovActionProposalId :: MonadIO m => Id.TxId -> Word64 -> DbAction m Id.GovActionProposalId +queryGovActionProposalId txId index = do + let callInfo = mkCallInfo "queryGovActionProposalId" + errorMsg = + "GovActionProposal not found with txId: " + <> Text.pack (show txId) + <> " and index: " + <> Text.pack (show index) + + result <- runDbSession callInfo $ HsqlSes.statement (txId, index) queryGovActionProposalIdStmt + case result of + Just res -> pure res + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + +-------------------------------------------------------------------------------- +-- ParamProposal +-------------------------------------------------------------------------------- +insertParamProposalStmt :: HsqlStm.Statement SGV.ParamProposal (Entity SGV.ParamProposal) +insertParamProposalStmt = + insert + SGV.paramProposalEncoder + (WithResult $ HsqlD.singleRow SGV.entityParamProposalDecoder) + +insertParamProposal :: MonadIO m => SGV.ParamProposal -> DbAction m Id.ParamProposalId +insertParamProposal paramProposal = do + entity <- + runDbSession (mkCallInfo "insertParamProposal") $ + HsqlSess.statement paramProposal insertParamProposalStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Treasury +-------------------------------------------------------------------------------- +insertTreasuryStmt :: HsqlStm.Statement SEP.Treasury (Entity SEP.Treasury) +insertTreasuryStmt = + insert + SEP.treasuryEncoder + (WithResult $ HsqlD.singleRow SEP.entityTreasuryDecoder) + +insertTreasury :: MonadIO m => SEP.Treasury -> DbAction m Id.TreasuryId +insertTreasury treasury = do + entity <- runDbSession (mkCallInfo "insertTreasury") $ HsqlSess.statement treasury insertTreasuryStmt + pure $ entityKey entity + +insertTreasuryWithdrawalStmt :: HsqlStm.Statement SGV.TreasuryWithdrawal (Entity SGV.TreasuryWithdrawal) +insertTreasuryWithdrawalStmt = + insert + SGV.treasuryWithdrawalEncoder + (WithResult $ HsqlD.singleRow SGV.entityTreasuryWithdrawalDecoder) + +insertTreasuryWithdrawal :: MonadIO m => SGV.TreasuryWithdrawal -> DbAction m Id.TreasuryWithdrawalId +insertTreasuryWithdrawal treasuryWithdrawal = do + entity <- + runDbSession (mkCallInfo "insertTreasuryWithdrawal") $ + HsqlSess.statement treasuryWithdrawal insertTreasuryWithdrawalStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Voting +-------------------------------------------------------------------------------- + +-- | INSERT +insertVotingAnchorStmt :: HsqlStm.Statement SGV.VotingAnchor (Entity SGV.VotingAnchor) +insertVotingAnchorStmt = + insert + SGV.votingAnchorEncoder + (WithResult $ HsqlD.singleRow SGV.entityVotingAnchorDecoder) + +insertVotingAnchor :: MonadIO m => SGV.VotingAnchor -> DbAction m Id.VotingAnchorId +insertVotingAnchor votingAnchor = do + entity <- + runDbSession (mkCallInfo "insertVotingAnchor") $ + HsqlSess.statement votingAnchor insertVotingAnchorStmt + pure $ entityKey entity + +insertVotingProcedureStmt :: HsqlStm.Statement SGV.VotingProcedure (Entity SGV.VotingProcedure) +insertVotingProcedureStmt = + insert + SGV.votingProcedureEncoder + (WithResult $ HsqlD.singleRow SGV.entityVotingProcedureDecoder) + +insertVotingProcedure :: MonadIO m => SGV.VotingProcedure -> DbAction m Id.VotingProcedureId +insertVotingProcedure votingProcedure = do + entity <- + runDbSession (mkCallInfo "insertVotingProcedure") $ + HsqlSess.statement votingProcedure insertVotingProcedureStmt + pure $ entityKey entity + +-- | QUERY +queryVotingAnchorIdStmt :: HsqlStm.Statement Id.VotingAnchorId Bool +queryVotingAnchorIdStmt = + existsById + (Id.idEncoder Id.getVotingAnchorId) + (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) + +queryVotingAnchorIdExists :: MonadIO m => Id.VotingAnchorId -> DbAction m Bool +queryVotingAnchorIdExists votingAnchorId = + runDbSession (mkCallInfo "queryVotingAnchorIdExists") $ + HsqlSess.statement votingAnchorId queryVotingAnchorIdStmt + +-- These tables manage governance-related data, including DReps, committees, and voting procedures. + +-- committee +-- committee_de_registration +-- committee_hash +-- committee_member +-- committee_registration +-- constitution +-- delegation_vote +-- drep_distr +-- drep_hash +-- drep_registration +-- event_info +-- gov_action_proposal +-- new_committee +-- param_proposal +-- treasury_withdrawal +-- voting_anchor +-- voting_procedure diff --git a/cardano-db/src/Cardano/Db/Statement/MultiAsset.hs b/cardano-db/src/Cardano/Db/Statement/MultiAsset.hs new file mode 100644 index 000000000..fbcc30e0f --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/MultiAsset.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.MultiAsset where + +import Cardano.Db.Schema.Core.MultiAsset (MaTxMint) +import qualified Cardano.Db.Schema.Core.MultiAsset as SMA +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk) +import Cardano.Db.Statement.Types (Entity (..)) +import Cardano.Db.Types (DbAction, DbInt65) +import Cardano.Prelude (MonadIO) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlS + +-------------------------------------------------------------------------------- +-- MultiAsset +-------------------------------------------------------------------------------- + +-- | INSERT +insertMultiAssetStmt :: HsqlS.Statement SMA.MultiAsset (Entity SMA.MultiAsset) +insertMultiAssetStmt = + insert + SMA.multiAssetEncoder + (WithResult $ HsqlD.singleRow SMA.entityMultiAssetDecoder) + +insertMultiAsset :: MonadIO m => SMA.MultiAsset -> DbAction m Id.MultiAssetId +insertMultiAsset multiAsset = do + entity <- + runDbSession (mkCallInfo "insertMultiAsset") $ + HsqlSes.statement multiAsset insertMultiAssetStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- MaTxMint +-------------------------------------------------------------------------------- +insertMaTxMintStmt :: HsqlS.Statement SMA.MaTxMint (Entity SMA.MaTxMint) +insertMaTxMintStmt = + insert + SMA.maTxMintEncoder + (WithResult $ HsqlD.singleRow SMA.entityMaTxMintDecoder) + +insertMaTxMint :: MonadIO m => SMA.MaTxMint -> DbAction m Id.MaTxMintId +insertMaTxMint maTxMint = do + entity <- runDbSession (mkCallInfo "insertMaTxMint") $ HsqlSes.statement maTxMint insertMaTxMintStmt + pure $ entityKey entity + +insertBulkMaTxMintStmt :: HsqlS.Statement [SMA.MaTxMint] [Entity MaTxMint] +insertBulkMaTxMintStmt = + insertBulk + extractMaTxMint + SMA.maTxMintBulkEncoder + (WithResultBulk (HsqlD.rowList SMA.entityMaTxMintDecoder)) + where + extractMaTxMint :: [MaTxMint] -> ([DbInt65], [Id.MultiAssetId], [Id.TxId]) + extractMaTxMint xs = + ( map SMA.maTxMintQuantity xs + , map SMA.maTxMintIdent xs + , map SMA.maTxMintTxId xs + ) + +insertBulkMaTxMint :: MonadIO m => [SMA.MaTxMint] -> DbAction m [Id.MaTxMintId] +insertBulkMaTxMint maTxMints = do + ids <- + runDbSession (mkCallInfo "insertBulkMaTxMint") $ + HsqlSes.statement maTxMints insertBulkMaTxMintStmt + pure $ map entityKey ids + +-- These tables handle multi-asset (native token) data. + +-- multi_asset +-- ma_tx_mint +-- ma_tx_out diff --git a/cardano-db/src/Cardano/Db/Statement/OffChain.hs b/cardano-db/src/Cardano/Db/Statement/OffChain.hs new file mode 100644 index 000000000..20ee1f823 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/OffChain.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.OffChain where + +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Pipeline as HsqlP +import qualified Hasql.Session as HsqlS + +import qualified Cardano.Db.Schema.Core.OffChain as SO +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk, insertCheckUnique) +import Cardano.Db.Statement.GovernanceAndVoting (queryVotingAnchorIdExists) +import Cardano.Db.Statement.Pool (queryPoolHashIdExistsStmt, queryPoolMetadataRefIdExistsStmt) +import Cardano.Db.Statement.Types (Entity (..)) +import Cardano.Db.Types (DbAction) +import Cardano.Prelude (MonadIO (..), Text, when) +import qualified Hasql.Statement as HsqlS + +-------------------------------------------------------------------------------- +-- OffChainPoolData +-------------------------------------------------------------------------------- +insertOffChainPoolDataStmt :: HsqlS.Statement SO.OffChainPoolData () +insertOffChainPoolDataStmt = + insertCheckUnique + SO.offChainPoolDataEncoder + NoResult + +insertCheckOffChainPoolData :: MonadIO m => SO.OffChainPoolData -> DbAction m () +insertCheckOffChainPoolData offChainPoolData = do + let poolHashId = SO.offChainPoolDataPoolId offChainPoolData + let metadataRefId = SO.offChainPoolDataPmrId offChainPoolData + + -- Run checks in pipeline + (poolExists, metadataExists) <- runDbSession (mkCallInfo "checkPoolAndMetadata") $ + HsqlS.pipeline $ do + poolResult <- HsqlP.statement poolHashId queryPoolHashIdExistsStmt + metadataResult <- HsqlP.statement metadataRefId queryPoolMetadataRefIdExistsStmt + pure (poolResult, metadataResult) + + -- Only insert if both exist + when (poolExists && metadataExists) $ + runDbSession (mkCallInfo "insertOffChainPoolData") $ + HsqlS.statement offChainPoolData insertOffChainPoolDataStmt + +-------------------------------------------------------------------------------- +-- OffChainVoteAuthor +-------------------------------------------------------------------------------- +insertBulkOffChainVoteAuthorsStmt :: HsqlS.Statement [SO.OffChainVoteAuthor] () +insertBulkOffChainVoteAuthorsStmt = + insertBulk + extractOffChainVoteAuthor + SO.offChainVoteAuthorBulkEncoder + NoResultBulk + where + extractOffChainVoteAuthor :: [SO.OffChainVoteAuthor] -> ([Id.OffChainVoteDataId], [Maybe Text], [Text], [Text], [Text], [Maybe Text]) + extractOffChainVoteAuthor xs = + ( map SO.offChainVoteAuthorOffChainVoteDataId xs + , map SO.offChainVoteAuthorName xs + , map SO.offChainVoteAuthorWitnessAlgorithm xs + , map SO.offChainVoteAuthorPublicKey xs + , map SO.offChainVoteAuthorSignature xs + , map SO.offChainVoteAuthorWarning xs + ) + +insertBulkOffChainVoteAuthors :: MonadIO m => [SO.OffChainVoteAuthor] -> DbAction m () +insertBulkOffChainVoteAuthors offChainVoteAuthors = + runDbSession (mkCallInfo "insertBulkOffChainVoteAuthors") $ + HsqlS.statement offChainVoteAuthors insertBulkOffChainVoteAuthorsStmt + +insertOffChainVoteDataStmt :: HsqlS.Statement SO.OffChainVoteData (Entity SO.OffChainVoteData) +insertOffChainVoteDataStmt = + insertCheckUnique + SO.offChainVoteDataEncoder + (WithResult $ HsqlD.singleRow SO.entityOffChainVoteDataDecoder) + +insertOffChainVoteData :: MonadIO m => SO.OffChainVoteData -> DbAction m (Maybe Id.OffChainVoteDataId) +insertOffChainVoteData offChainVoteData = do + foundVotingAnchorId <- queryVotingAnchorIdExists (SO.offChainVoteDataVotingAnchorId offChainVoteData) + if foundVotingAnchorId + then do + entity <- + runDbSession (mkCallInfo "insertOffChainVoteData") $ + HsqlS.statement offChainVoteData insertOffChainVoteDataStmt + pure $ Just (entityKey entity) + else pure Nothing + +insertOffChainVoteDrepDataStmt :: HsqlS.Statement SO.OffChainVoteDrepData (Entity SO.OffChainVoteDrepData) +insertOffChainVoteDrepDataStmt = + insert + SO.offChainVoteDrepDataEncoder + (WithResult $ HsqlD.singleRow SO.entityOffChainVoteDrepDataDecoder) + +insertOffChainVoteDrepData :: MonadIO m => SO.OffChainVoteDrepData -> DbAction m Id.OffChainVoteDrepDataId +insertOffChainVoteDrepData drepData = do + entity <- + runDbSession (mkCallInfo "insertOffChainVoteDrepData") $ + HsqlS.statement drepData insertOffChainVoteDrepDataStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- OffChainVoteExternalUpdate +-------------------------------------------------------------------------------- +insertBulkOffChainVoteExternalUpdatesStmt :: HsqlS.Statement [SO.OffChainVoteExternalUpdate] () +insertBulkOffChainVoteExternalUpdatesStmt = + insertBulk + extractOffChainVoteExternalUpdate + SO.offChainVoteExternalUpdatesBulkEncoder + NoResultBulk + where + extractOffChainVoteExternalUpdate :: [SO.OffChainVoteExternalUpdate] -> ([Id.OffChainVoteDataId], [Text], [Text]) + extractOffChainVoteExternalUpdate xs = + ( map SO.offChainVoteExternalUpdateOffChainVoteDataId xs + , map SO.offChainVoteExternalUpdateTitle xs + , map SO.offChainVoteExternalUpdateUri xs + ) + +insertBulkOffChainVoteExternalUpdate :: MonadIO m => [SO.OffChainVoteExternalUpdate] -> DbAction m () +insertBulkOffChainVoteExternalUpdate offChainVoteExternalUpdates = + runDbSession (mkCallInfo "insertBulkOffChainVoteExternalUpdate") $ + HsqlS.statement offChainVoteExternalUpdates insertBulkOffChainVoteExternalUpdatesStmt + +insertOffChainVoteFetchErrorStmt :: HsqlS.Statement SO.OffChainVoteFetchError () +insertOffChainVoteFetchErrorStmt = + insert + SO.offChainVoteFetchErrorEncoder + NoResult + +insertOffChainVoteFetchError :: MonadIO m => SO.OffChainVoteFetchError -> DbAction m () +insertOffChainVoteFetchError offChainVoteFetchError = do + foundVotingAnchor <- + queryVotingAnchorIdExists (SO.offChainVoteFetchErrorVotingAnchorId offChainVoteFetchError) + when foundVotingAnchor $ do + runDbSession (mkCallInfo "insertOffChainVoteFetchError") $ + HsqlS.statement offChainVoteFetchError insertOffChainVoteFetchErrorStmt + +-------------------------------------------------------------------------------- +-- OffChainVoteGovActionData +-------------------------------------------------------------------------------- +insertOffChainVoteGovActionDataStmt :: HsqlS.Statement SO.OffChainVoteGovActionData (Entity SO.OffChainVoteGovActionData) +insertOffChainVoteGovActionDataStmt = + insert + SO.offChainVoteGovActionDataEncoder + (WithResult $ HsqlD.singleRow SO.entityOffChainVoteGovActionDataDecoder) + +insertOffChainVoteGovActionData :: MonadIO m => SO.OffChainVoteGovActionData -> DbAction m Id.OffChainVoteGovActionDataId +insertOffChainVoteGovActionData offChainVoteGovActionData = do + entity <- + runDbSession (mkCallInfo "insertOffChainVoteGovActionData") $ + HsqlS.statement offChainVoteGovActionData insertOffChainVoteGovActionDataStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- OffChainVoteReference +-------------------------------------------------------------------------------- +insertBulkOffChainVoteReferencesStmt :: HsqlS.Statement [SO.OffChainVoteReference] () +insertBulkOffChainVoteReferencesStmt = + insertBulk + extractOffChainVoteReference + SO.offChainVoteReferenceBulkEncoder + NoResultBulk + where + extractOffChainVoteReference :: [SO.OffChainVoteReference] -> ([Id.OffChainVoteDataId], [Text], [Text], [Maybe Text], [Maybe Text]) + extractOffChainVoteReference xs = + ( map SO.offChainVoteReferenceOffChainVoteDataId xs + , map SO.offChainVoteReferenceLabel xs + , map SO.offChainVoteReferenceUri xs + , map SO.offChainVoteReferenceHashDigest xs + , map SO.offChainVoteReferenceHashAlgorithm xs + ) + +insertBulkOffChainVoteReferences :: MonadIO m => [SO.OffChainVoteReference] -> DbAction m () +insertBulkOffChainVoteReferences offChainVoteReferences = + runDbSession (mkCallInfo "insertBulkOffChainVoteReferences") $ + HsqlS.statement offChainVoteReferences insertBulkOffChainVoteReferencesStmt + +-- off_chain_pool_data +-- off_chain_pool_fetch_error +-- off_chain_vote_author +-- off_chain_vote_data +-- off_chain_vote_drep_data +-- off_chain_vote_external_update +-- off_chain_vote_fetch_error +-- off_chain_vote_gov_action_data +-- off_chain_vote_reference diff --git a/cardano-db/src/Cardano/Db/Statement/Pool.hs b/cardano-db/src/Cardano/Db/Statement/Pool.hs new file mode 100644 index 000000000..c9318af85 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Pool.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.Pool where + +import Cardano.Db.Schema.Core.GovernanceAndVoting () +import qualified Cardano.Db.Schema.Core.Pool as SP +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk) +import Cardano.Db.Statement.Function.Query (existsById) +import Cardano.Db.Statement.Types (Entity (..)) +import Cardano.Db.Types (DbAction, DbWord64) +import Cardano.Prelude (MonadIO, Word64) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlS + +-------------------------------------------------------------------------------- +-- DelistedPool +-------------------------------------------------------------------------------- +insertDelistedPoolStmt :: HsqlS.Statement SP.DelistedPool (Entity SP.DelistedPool) +insertDelistedPoolStmt = + insert + SP.delistedPoolEncoder + (WithResult $ HsqlD.singleRow SP.entityDelistedPoolDecoder) + +insertDelistedPool :: MonadIO m => SP.DelistedPool -> DbAction m Id.DelistedPoolId +insertDelistedPool delistedPool = do + entity <- + runDbSession (mkCallInfo "insertDelistedPool") $ + HsqlSes.statement delistedPool insertDelistedPoolStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- PoolHash +-------------------------------------------------------------------------------- +insertPoolHashStmt :: HsqlS.Statement SP.PoolHash (Entity SP.PoolHash) +insertPoolHashStmt = + insert + SP.poolHashEncoder + (WithResult $ HsqlD.singleRow SP.entityPoolHashDecoder) + +insertPoolHash :: MonadIO m => SP.PoolHash -> DbAction m Id.PoolHashId +insertPoolHash poolHash = do + entity <- + runDbSession (mkCallInfo "insertPoolHash") $ + HsqlSes.statement poolHash insertPoolHashStmt + pure $ entityKey entity + +queryPoolHashIdExists :: MonadIO m => Id.PoolHashId -> DbAction m Bool +queryPoolHashIdExists poolHashId = + runDbSession (mkCallInfo "queryPoolHashIdExists") $ + HsqlSes.statement poolHashId queryPoolHashIdExistsStmt + +queryPoolHashIdExistsStmt :: HsqlS.Statement Id.PoolHashId Bool +queryPoolHashIdExistsStmt = + existsById + (Id.idEncoder Id.getPoolHashId) + (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) + +-- queryVotingAnchorIdExists :: MonadIO m => Id.VotingAnchorId -> DbAction m Bool +-- queryVotingAnchorIdExists votingAnchorId = +-- runDbSession (mkCallInfo "queryVotingAnchorIdExists") $ +-- HsqlSes.statement votingAnchorId queryVotingAnchorIdExistsStmt + +-- queryVotingAnchorIdExistsStmt :: HsqlS.Statement Id.VotingAnchorId Bool +-- queryVotingAnchorIdExistsStmt = +-- existsById +-- (Id.idEncoder Id.getVotingAnchorId) +-- (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) + +-------------------------------------------------------------------------------- + +-- | PoolMetadataRef + +-------------------------------------------------------------------------------- +insertPoolMetadataRefStmt :: HsqlS.Statement SP.PoolMetadataRef (Entity SP.PoolMetadataRef) +insertPoolMetadataRefStmt = + insert + SP.poolMetadataRefEncoder + (WithResult $ HsqlD.singleRow SP.entityPoolMetadataRefDecoder) + +insertPoolMetadataRef :: MonadIO m => SP.PoolMetadataRef -> DbAction m Id.PoolMetadataRefId +insertPoolMetadataRef poolMetadataRef = do + entity <- + runDbSession (mkCallInfo "insertPoolMetadataRef") $ + HsqlSes.statement poolMetadataRef insertPoolMetadataRefStmt + pure $ entityKey entity + +queryPoolMetadataRefIdExistsStmt :: HsqlS.Statement Id.PoolMetadataRefId Bool +queryPoolMetadataRefIdExistsStmt = + existsById + (Id.idEncoder Id.getPoolMetadataRefId) + (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) + +queryPoolMetadataRefIdExists :: MonadIO m => Id.PoolMetadataRefId -> DbAction m Bool +queryPoolMetadataRefIdExists poolMetadataRefId = + runDbSession (mkCallInfo "queryPoolMetadataRefIdExists") $ + HsqlSes.statement poolMetadataRefId queryPoolMetadataRefIdExistsStmt + +insertPoolOwnerStmt :: HsqlS.Statement SP.PoolOwner (Entity SP.PoolOwner) +insertPoolOwnerStmt = + insert + SP.poolOwnerEncoder + (WithResult $ HsqlD.singleRow SP.entityPoolOwnerDecoder) + +insertPoolOwner :: MonadIO m => SP.PoolOwner -> DbAction m Id.PoolOwnerId +insertPoolOwner poolOwner = do + entity <- + runDbSession (mkCallInfo "insertPoolOwner") $ + HsqlSes.statement poolOwner insertPoolOwnerStmt + pure $ entityKey entity + +insertPoolRelayStmt :: HsqlS.Statement SP.PoolRelay (Entity SP.PoolRelay) +insertPoolRelayStmt = + insert + SP.poolRelayEncoder + (WithResult $ HsqlD.singleRow SP.entityPoolRelayDecoder) + +insertPoolRelay :: MonadIO m => SP.PoolRelay -> DbAction m Id.PoolRelayId +insertPoolRelay poolRelay = do + entity <- runDbSession (mkCallInfo "insertPoolRelay") $ HsqlSes.statement poolRelay insertPoolRelayStmt + pure $ entityKey entity + +insertPoolRetireStmt :: HsqlS.Statement SP.PoolRetire (Entity SP.PoolRetire) +insertPoolRetireStmt = + insert + SP.poolRetireEncoder + (WithResult $ HsqlD.singleRow SP.entityPoolRetireDecoder) + +insertPoolRetire :: MonadIO m => SP.PoolRetire -> DbAction m Id.PoolRetireId +insertPoolRetire poolRetire = do + entity <- runDbSession (mkCallInfo "insertPoolRetire") $ HsqlSes.statement poolRetire insertPoolRetireStmt + pure $ entityKey entity + +insertBulkPoolStatStmt :: HsqlS.Statement [SP.PoolStat] () +insertBulkPoolStatStmt = + insertBulk + extractPoolStat + SP.poolStatBulkEncoder + NoResultBulk + where + extractPoolStat :: [SP.PoolStat] -> ([Id.PoolHashId], [Word64], [DbWord64], [DbWord64], [DbWord64], [Maybe DbWord64]) + extractPoolStat xs = + ( map SP.poolStatPoolHashId xs + , map SP.poolStatEpochNo xs + , map SP.poolStatNumberOfBlocks xs + , map SP.poolStatNumberOfDelegators xs + , map SP.poolStatStake xs + , map SP.poolStatVotingPower xs + ) + +insertBulkPoolStat :: MonadIO m => [SP.PoolStat] -> DbAction m () +insertBulkPoolStat poolStats = do + runDbSession (mkCallInfo "insertBulkPoolStat") $ + HsqlSes.statement poolStats insertBulkPoolStatStmt + +insertPoolUpdateStmt :: HsqlS.Statement SP.PoolUpdate (Entity SP.PoolUpdate) +insertPoolUpdateStmt = + insert + SP.poolUpdateEncoder + (WithResult $ HsqlD.singleRow SP.entityPoolUpdateDecoder) + +insertPoolUpdate :: MonadIO m => SP.PoolUpdate -> DbAction m Id.PoolUpdateId +insertPoolUpdate poolUpdate = do + entity <- runDbSession (mkCallInfo "insertPoolUpdate") $ HsqlSes.statement poolUpdate insertPoolUpdateStmt + pure $ entityKey entity + +insertReservedPoolTickerStmt :: HsqlS.Statement SP.ReservedPoolTicker (Entity SP.ReservedPoolTicker) +insertReservedPoolTickerStmt = + insert + SP.reservedPoolTickerEncoder + (WithResult $ HsqlD.singleRow SP.entityReservedPoolTickerDecoder) + +insertReservedPoolTicker :: MonadIO m => SP.ReservedPoolTicker -> DbAction m Id.ReservedPoolTickerId +insertReservedPoolTicker reservedPool = do + entity <- runDbSession (mkCallInfo "insertReservedPoolTicker") $ HsqlSes.statement reservedPool insertReservedPoolTickerStmt + pure $ entityKey entity + +-- These tables manage stake pool-related data, including pool registration, updates, and retirements. + +-- delisted_pool +-- pool_hash +-- pool_metadata_ref +-- pool_owner +-- pool_relay +-- pool_retire +-- pool_stat +-- pool_update +-- reserved_pool_ticker diff --git a/cardano-db/src/Cardano/Db/Statement/StakeDeligation.hs b/cardano-db/src/Cardano/Db/Statement/StakeDeligation.hs new file mode 100644 index 000000000..2ee816f82 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/StakeDeligation.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.StakeDeligation where + +import Data.Word (Word64) + +import Cardano.Db.Error (DbError (..)) +import qualified Cardano.Db.Schema.Core.StakeDeligation as SS +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk, insertCheckUnique) +import Cardano.Db.Statement.Types (Entity (..)) +import Cardano.Db.Types (DbAction, DbCallInfo (..), DbLovelace, RewardSource) +import Cardano.Prelude (ByteString, MonadError (..), MonadIO) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlStmt + +-------------------------------------------------------------------------------- +-- Deligation +-------------------------------------------------------------------------------- +insertDelegationStmt :: HsqlStmt.Statement SS.Delegation (Entity SS.Delegation) +insertDelegationStmt = + insert + SS.delegationEncoder + (WithResult $ HsqlD.singleRow SS.entityDelegationDecoder) + +insertDelegation :: MonadIO m => SS.Delegation -> DbAction m Id.DelegationId +insertDelegation delegation = do + entity <- runDbSession (mkCallInfo "insertDelegation") $ HsqlSes.statement delegation insertDelegationStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- EpochStake +-------------------------------------------------------------------------------- +insertBulkEpochStakeStmt :: HsqlStmt.Statement [SS.EpochStake] () +insertBulkEpochStakeStmt = + insertBulk + extractEpochStake + SS.epochStakeBulkEncoder + NoResultBulk + where + extractEpochStake :: [SS.EpochStake] -> ([Id.StakeAddressId], [Id.PoolHashId], [DbLovelace], [Word64]) + extractEpochStake xs = + ( map SS.epochStakeAddrId xs + , map SS.epochStakePoolId xs + , map SS.epochStakeAmount xs + , map SS.epochStakeEpochNo xs + ) + +insertBulkEpochStake :: MonadIO m => [SS.EpochStake] -> DbAction m () +insertBulkEpochStake epochStakes = + runDbSession (mkCallInfo "insertBulkEpochStake") $ + HsqlSes.statement epochStakes insertBulkEpochStakeStmt + +-------------------------------------------------------------------------------- +-- EpochProgress +-------------------------------------------------------------------------------- +insertBulkEpochStakeProgressStmt :: HsqlStmt.Statement [SS.EpochStakeProgress] () +insertBulkEpochStakeProgressStmt = + insertBulk + extractEpochStakeProgress + SS.epochStakeProgressBulkEncoder + NoResultBulk + where + extractEpochStakeProgress :: [SS.EpochStakeProgress] -> ([Word64], [Bool]) + extractEpochStakeProgress xs = + ( map SS.epochStakeProgressEpochNo xs + , map SS.epochStakeProgressCompleted xs + ) + +insertBulkEpochStakeProgress :: MonadIO m => [SS.EpochStakeProgress] -> DbAction m () +insertBulkEpochStakeProgress epochStakeProgresses = + runDbSession (mkCallInfo "insertBulkEpochStakeProgress") $ + HsqlSes.statement epochStakeProgresses insertBulkEpochStakeProgressStmt + +-------------------------------------------------------------------------------- +-- Reward +-------------------------------------------------------------------------------- +insertBulkRewardsStmt :: HsqlStmt.Statement [SS.Reward] () +insertBulkRewardsStmt = + insertBulk + extractReward + SS.rewardBulkEncoder + NoResultBulk + where + extractReward :: [SS.Reward] -> ([Id.StakeAddressId], [RewardSource], [DbLovelace], [Word64], [Word64], [Id.PoolHashId]) + extractReward xs = + ( map SS.rewardAddrId xs + , map SS.rewardType xs + , map SS.rewardAmount xs + , map SS.rewardEarnedEpoch xs + , map SS.rewardSpendableEpoch xs + , map SS.rewardPoolId xs + ) + +insertBulkRewards :: MonadIO m => [SS.Reward] -> DbAction m () +insertBulkRewards rewards = + runDbSession (mkCallInfo "insertBulkRewards") $ + HsqlSes.statement rewards insertBulkRewardsStmt + +-------------------------------------------------------------------------------- +-- RewardRest +-------------------------------------------------------------------------------- +insertBulkRewardRestsStmt :: HsqlStmt.Statement [SS.RewardRest] () +insertBulkRewardRestsStmt = + insertBulk + extractRewardRest + SS.rewardRestBulkEncoder + NoResultBulk + where + extractRewardRest :: [SS.RewardRest] -> ([Id.StakeAddressId], [RewardSource], [DbLovelace], [Word64], [Word64]) + extractRewardRest xs = + ( map SS.rewardRestAddrId xs + , map SS.rewardRestType xs + , map SS.rewardRestAmount xs + , map SS.rewardRestEarnedEpoch xs + , map SS.rewardRestSpendableEpoch xs + ) + +insertBulkRewardRests :: MonadIO m => [SS.RewardRest] -> DbAction m () +insertBulkRewardRests rewardRests = + runDbSession (mkCallInfo "insertBulkRewardRests") $ + HsqlSes.statement rewardRests insertBulkRewardRestsStmt + +-------------------------------------------------------------------------------- +-- StakeAddress +-------------------------------------------------------------------------------- +insertStakeAddressStmt :: HsqlStmt.Statement SS.StakeAddress (Entity SS.StakeAddress) +insertStakeAddressStmt = + insertCheckUnique + SS.stakeAddressEncoder + (WithResult $ HsqlD.singleRow SS.entityStakeAddressDecoder) + +insertStakeAddress :: MonadIO m => SS.StakeAddress -> DbAction m Id.StakeAddressId +insertStakeAddress stakeAddress = + runDbSession (mkCallInfo "insertStakeAddress") $ do + entity <- + HsqlSes.statement stakeAddress insertStakeAddressStmt + pure $ entityKey entity + +insertStakeDeregistrationStmt :: HsqlStmt.Statement SS.StakeDeregistration (Entity SS.StakeDeregistration) +insertStakeDeregistrationStmt = + insertCheckUnique + SS.stakeDeregistrationEncoder + (WithResult $ HsqlD.singleRow SS.entityStakeDeregistrationDecoder) + +insertStakeDeregistration :: MonadIO m => SS.StakeDeregistration -> DbAction m Id.StakeDeregistrationId +insertStakeDeregistration stakeDeregistration = + runDbSession (mkCallInfo "insertStakeDeregistration") $ do + entity <- + HsqlSes.statement stakeDeregistration insertStakeDeregistrationStmt + pure $ entityKey entity + +insertStakeRegistrationStmt :: HsqlStmt.Statement SS.StakeRegistration (Entity SS.StakeRegistration) +insertStakeRegistrationStmt = + insert + SS.stakeRegistrationEncoder + (WithResult $ HsqlD.singleRow SS.entityStakeRegistrationDecoder) + +insertStakeRegistration :: MonadIO m => SS.StakeRegistration -> DbAction m Id.StakeRegistrationId +insertStakeRegistration stakeRegistration = do + entity <- + runDbSession (mkCallInfo "insertStakeRegistration") $ + HsqlSes.statement stakeRegistration insertStakeRegistrationStmt + pure $ entityKey entity + +-- | Queries +queryStakeAddressStmt :: HsqlStmt.Statement ByteString (Maybe Id.StakeAddressId) +queryStakeAddressStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.StakeAddressId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM stake_address" + , " WHERE hash_raw = $1" + ] + +queryStakeAddress :: MonadIO m => ByteString -> (ByteString -> Text.Text) -> DbAction m Id.StakeAddressId +queryStakeAddress addr toText = do + result <- runDbSession callInfo $ HsqlSes.statement addr queryStakeAddressStmt + case result of + Just res -> pure res + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "queryStakeAddress" + errorMsg = "StakeAddress " <> toText addr <> " not found" + +-- These tables handle stake addresses, delegation, and reward + +-- delegation +-- epoch_stake +-- epoch_stake_progress +-- reward +-- reward_rest +-- stake_address +-- stake_deregistration +-- stake_registration diff --git a/cardano-db/src/Cardano/Db/Statement/Types.hs b/cardano-db/src/Cardano/Db/Statement/Types.hs new file mode 100644 index 000000000..b08f868a4 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Types.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Db.Statement.Types where + +import Data.Char (isUpper, toLower) +import Data.List (stripPrefix) +import qualified Data.List.NonEmpty as NE +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) +import GHC.Generics +import qualified Hasql.Decoders as HsqlD + +-- | DbInfo provides automatic derivation of table and column names from Haskell types. +-- Table names are derived from the type name converted to snake_case. +-- Column names are derived from record field names, where each field must follow +-- this convention: +-- * Start with the type name (first letter lowercased) +-- * Continue with an uppercase letter +-- * E.g., for type 'TxMetadata', use field names like 'txMetadataId', 'txMetadataKey' +-- +-- Example: +-- +-- @ +-- data TxMetadata = TxMetadata +-- { txMetadataId :: !Int +-- , txMetadataKey :: !Int +-- , txMetadataJson :: !(Maybe Text) +-- } deriving (Show, Generic, Typeable) +-- +-- instance DbInfo TxMetadata +-- uniqueFields _ = ["key", "json"] +-- +-- -- Table name: "tx_metadata" +-- -- Column names: ["id", "key", "json"] +-- -- Unique fields: ["key", "json"] +-- @ +class Typeable a => DbInfo a where + tableName :: Proxy a -> Text + default tableName :: Proxy a -> Text + tableName = Text.pack . camelToSnake . tyConName . typeRepTyCon . typeRep + + columnNames :: Proxy a -> NE.NonEmpty Text + default columnNames :: (Generic a, GRecordFieldNames (Rep a)) => Proxy a -> NE.NonEmpty Text + columnNames p = + let typeName = tyConName $ typeRepTyCon $ typeRep p + fieldNames = gRecordFieldNames (from (undefined :: a)) + in case fieldNames of + [] -> error "No fields found" + ns -> NE.fromList $ map (fieldToColumnWithType typeName) ns + + uniqueFields :: + Proxy a -> + -- | Lists of column names that form unique constraints + [Text] + default uniqueFields :: Proxy a -> [Text] + uniqueFields _ = [] + +-- | Convert a field name to a column name +fieldToColumnWithType :: String -> String -> Text +fieldToColumnWithType typeName field = Text.pack $ + camelToSnake $ + case stripPrefix (uncamelize typeName) field of + Just remaining -> case remaining of + (c : _) | isUpper c -> remaining + _otherwise -> + error $ + "Field name '" + ++ field + ++ "' does not match pattern '" + ++ uncamelize typeName + ++ "X...'" + Nothing -> + error $ + "Field name '" + ++ field + ++ "' does not start with type prefix '" + ++ uncamelize typeName + ++ "'" + +-- | Convert a string to snake case +uncamelize :: String -> String +uncamelize [] = [] +uncamelize (x : xs) = toLower x : xs + +-- | Convert a camel case string to snake case +camelToSnake :: String -> String +camelToSnake [] = [] +camelToSnake (x : xs) = toLower x : go xs + where + go [] = [] + go (c : cs) + | isUpper c = '_' : toLower c : go cs + | otherwise = c : go cs + +-- | Type class for generic representation of record field names +class GRecordFieldNames f where + gRecordFieldNames :: f p -> [String] + +instance GRecordFieldNames U1 where + gRecordFieldNames _ = [] + +instance (GRecordFieldNames a, GRecordFieldNames b) => GRecordFieldNames (a :*: b) where + gRecordFieldNames _ = gRecordFieldNames (undefined :: a p) ++ gRecordFieldNames (undefined :: b p) + +instance GRecordFieldNames a => GRecordFieldNames (M1 D c a) where + gRecordFieldNames _ = gRecordFieldNames (undefined :: a p) + +instance GRecordFieldNames a => GRecordFieldNames (M1 C c a) where + gRecordFieldNames _ = gRecordFieldNames (undefined :: a p) + +instance (Selector c) => GRecordFieldNames (M1 S c (K1 i a)) where + gRecordFieldNames m = [selName m] + +instance GRecordFieldNames (K1 i c) where + gRecordFieldNames _ = [] + +-- | Validate a column name against the list of columns in the table. +validateColumn :: forall a. (DbInfo a) => Text -> Text +validateColumn colName = + let cols = NE.toList $ columnNames (Proxy @a) + in if colName `elem` cols + then colName + else + error $ + "Column " + <> Text.unpack colName + <> " not found in table " + <> Text.unpack (tableName (Proxy @a)) + +-------------------------------------------------------------------------------- +-- Entity +-------------------------------------------------------------------------------- +data Entity record = Entity + { entityKey :: Key record + , entityVal :: record + } + +-- Type family for keys +type family Key a = k | k -> a + +-- Add standalone deriving instances +deriving instance Generic (Entity record) +deriving instance (Eq (Key record), Eq record) => Eq (Entity record) +deriving instance (Ord (Key record), Ord record) => Ord (Entity record) +deriving instance (Show (Key record), Show record) => Show (Entity record) +deriving instance (Read (Key record), Read record) => Read (Entity record) + +-- Functions to work with entities +fromEntity :: Entity a -> a +fromEntity = entityVal + +toEntity :: Key a -> a -> Entity a +toEntity = Entity + +-- Decoder for Entity +entityDecoder :: HsqlD.Row (Key a) -> HsqlD.Row a -> HsqlD.Row (Entity a) +entityDecoder keyDec valDec = Entity <$> keyDec <*> valDec diff --git a/cardano-db/src/Cardano/Db/Types.hs b/cardano-db/src/Cardano/Db/Types.hs index 8dd52f1d5..7f439af75 100644 --- a/cardano-db/src/Cardano/Db/Types.hs +++ b/cardano-db/src/Cardano/Db/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,6 +9,9 @@ {-# LANGUAGE TypeApplications #-} module Cardano.Db.Types ( + DbAction (..), + DbCallInfo (..), + DbEnv (..), Ada (..), AnchorType (..), AssetFingerprint (..), @@ -30,6 +34,19 @@ module Cardano.Db.Types ( VoterRole (..), GovActionType (..), BootstrapState (..), + dbInt65Decoder, + dbInt65Encoder, + rewardSourceDecoder, + rewardSourceEncoder, + dbLovelaceDecoder, + maybeDbLovelaceDecoder, + dbLovelaceEncoder, + dbLovelaceValueEncoder, + maybeDbLovelaceEncoder, + dbWord64Decoder, + maybeDbWord64Decoder, + dbWord64Encoder, + maybeDbWord64Encoder, processMigrationValues, isStakeDistrComplete, bootstrapState, @@ -40,48 +57,99 @@ module Cardano.Db.Types ( mkAssetFingerprint, renderAda, scientificToAda, - readDbInt65, - showDbInt65, - readRewardSource, - readScriptPurpose, - readScriptType, - readSyncState, - renderScriptPurpose, - renderScriptType, - renderSyncState, - showRewardSource, - renderVote, - readVote, - renderVoterRole, - readVoterRole, - renderGovActionType, - readGovActionType, - renderAnchorType, - readAnchorType, + rewardSourceFromText, + syncStateToText, + syncStateFromText, + syncStateDecoder, + syncStateEncoder, + scriptPurposeDecoder, + scriptPurposeEncoder, + scriptPurposeFromText, + scriptPurposeToText, + scriptTypeEncoder, + scriptTypeDecoder, + scriptTypeFromText, + scriptTypeToText, + rewardSourceToText, + voteEncoder, + voteDecoder, + voterRoleEncoder, + voterRoleDecoder, + voteToText, + voteFromText, + voterRoleToText, + voterRoleFromText, + voteUrlDecoder, + voteUrlEncoder, + govActionTypeToText, + govActionTypeFromText, + govActionTypeDecoder, + govActionTypeEncoder, + anchorTypeToText, + anchorTypeFromText, + anchorTypeDecoder, + anchorTypeEncoder, word64ToAda, + word128Decoder, + word128Encoder, hardcodedAlwaysAbstain, hardcodedAlwaysNoConfidence, ) where +import Cardano.BM.Trace (Trace) +import Cardano.Db.Error (CallSite (..), DbError (..)) import Cardano.Ledger.Coin (DeltaCoin (..)) +import Cardano.Prelude (Bifunctor (..), MonadError (..), MonadIO (..), MonadReader) import qualified Codec.Binary.Bech32 as Bech32 +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT) import Crypto.Hash (Blake2b_160) import qualified Crypto.Hash import Data.Aeson.Encoding (unsafeToEncoding) import Data.Aeson.Types (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.Types as Aeson +import Data.Bits (Bits (..)) import qualified Data.ByteArray as ByteArray import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as Builder import Data.Either (fromRight) import Data.Fixed (Micro, showFixed) +import Data.Functor.Contravariant ((>$<)) +import Data.Int (Int64) import Data.Scientific (Scientific) import Data.Text (Text) import qualified Data.Text as Text +import Data.WideWord (Word128 (..)) import Data.Word (Word16, Word64) -import GHC.Generics (Generic) +import GHC.Generics +import qualified Hasql.Connection as HsqlCon +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE import Quiet (Quiet (..)) +newtype DbAction m a = DbAction + {runDbAction :: ExceptT DbError (ReaderT DbEnv m) a} + deriving newtype + ( Functor + , Applicative + , Monad + , MonadError DbError + , MonadReader DbEnv + , MonadIO + ) + +data DbCallInfo = DbCallInfo + { dciName :: !Text + , dciCallSite :: !CallSite + } + +data DbEnv = DbEnv + { dbConnection :: !HsqlCon.Connection + , dbEnableLogging :: !Bool + , dbTracer :: !(Maybe (Trace IO Text)) + } + +-- | Convert a `Scientific` to `Ada`. newtype Ada = Ada { unAda :: Micro } @@ -96,7 +164,7 @@ instance ToJSON Ada where -- `Number` results in it becoming `7.3112484749601107e10` while the old explorer is returning `73112484749.601107` toEncoding (Ada ada) = unsafeToEncoding $ - Builder.string8 $ -- convert ByteString to Aeson's Encoding + Builder.string8 $ -- convert ByteString to Aeson's showFixed True ada -- convert String to ByteString using Latin1 encoding -- convert Micro to String chopping off trailing zeros @@ -124,21 +192,78 @@ mkAssetFingerprint policyBs assetNameBs = Bech32.humanReadablePartFromText "asset" -- Should never happen -- This is horrible. Need a 'Word64' with an extra sign bit. -data DbInt65 - = PosInt65 !Word64 - | NegInt65 !Word64 - deriving (Eq, Generic, Show) +-- data DbInt65 +-- = PosInt65 !Word64 +-- | NegInt65 !Word64 +-- deriving (Eq, Generic, Show) + +newtype DbInt65 = DbInt65 {unDbInt65 :: Word64} + deriving (Eq, Generic) + +instance Show DbInt65 where + show = show . fromDbInt65 + +instance Read DbInt65 where + readsPrec d = map (first toDbInt65) . readsPrec d + +dbInt65Decoder :: HsqlD.Value DbInt65 +dbInt65Decoder = toDbInt65 <$> HsqlD.int8 + +dbInt65Encoder :: HsqlE.Value DbInt65 +dbInt65Encoder = fromDbInt65 >$< HsqlE.int8 + +-- Helper functions to pack/unpack the sign and value +toDbInt65 :: Int64 -> DbInt65 +toDbInt65 n = + DbInt65 $ + if n >= 0 + then fromIntegral n + else setBit (fromIntegral (abs n)) 63 -- Set sign bit for negative + +fromDbInt65 :: DbInt65 -> Int64 +fromDbInt65 (DbInt65 w) = + if testBit w 63 + then negate $ fromIntegral (clearBit w 63) -- Clear sign bit for value + else fromIntegral w -- Newtype wrapper around Word64 so we can hand define a PersistentField instance. newtype DbLovelace = DbLovelace {unDbLovelace :: Word64} deriving (Eq, Generic, Ord) deriving (Read, Show) via (Quiet DbLovelace) +dbLovelaceEncoder :: HsqlE.Params DbLovelace +dbLovelaceEncoder = HsqlE.param $ HsqlE.nonNullable $ fromIntegral . unDbLovelace >$< HsqlE.int8 + +dbLovelaceValueEncoder :: HsqlE.NullableOrNot HsqlE.Value DbLovelace +dbLovelaceValueEncoder = HsqlE.nonNullable $ fromIntegral . unDbLovelace >$< HsqlE.int8 + +maybeDbLovelaceEncoder :: HsqlE.Params (Maybe DbLovelace) +maybeDbLovelaceEncoder = HsqlE.param $ HsqlE.nullable $ fromIntegral . unDbLovelace >$< HsqlE.int8 + +dbLovelaceDecoder :: HsqlD.Row DbLovelace +dbLovelaceDecoder = HsqlD.column (HsqlD.nonNullable (DbLovelace . fromIntegral <$> HsqlD.int8)) + +maybeDbLovelaceDecoder :: HsqlD.Row (Maybe DbLovelace) +maybeDbLovelaceDecoder = HsqlD.column (HsqlD.nullable (DbLovelace . fromIntegral <$> HsqlD.int8)) + -- Newtype wrapper around Word64 so we can hand define a PersistentField instance. newtype DbWord64 = DbWord64 {unDbWord64 :: Word64} deriving (Eq, Generic, Num) deriving (Read, Show) via (Quiet DbWord64) +dbWord64Encoder :: HsqlE.Params DbWord64 +dbWord64Encoder = HsqlE.param $ HsqlE.nonNullable $ fromIntegral . unDbWord64 >$< HsqlE.int8 + +maybeDbWord64Encoder :: HsqlE.Params (Maybe DbWord64) +maybeDbWord64Encoder = HsqlE.param $ HsqlE.nullable $ fromIntegral . unDbWord64 >$< HsqlE.int8 + +dbWord64Decoder :: HsqlD.Row DbWord64 +dbWord64Decoder = HsqlD.column (HsqlD.nonNullable (DbWord64 . fromIntegral <$> HsqlD.int8)) + +maybeDbWord64Decoder :: HsqlD.Row (Maybe DbWord64) +maybeDbWord64Decoder = HsqlD.column (HsqlD.nullable (DbWord64 . fromIntegral <$> HsqlD.int8)) + +-------------------------------------------------------------------------------- -- The following must be in alphabetic order. data RewardSource = RwdLeader @@ -149,11 +274,43 @@ data RewardSource | RwdProposalRefund deriving (Bounded, Enum, Eq, Ord, Show) +rewardSourceDecoder :: HsqlD.Value RewardSource +rewardSourceDecoder = HsqlD.enum $ \case + "leader" -> Just RwdLeader + "member" -> Just RwdMember + "reserves" -> Just RwdReserves + "treasury" -> Just RwdTreasury + "deposit_refund" -> Just RwdDepositRefund + "proposal_refund" -> Just RwdProposalRefund + _ -> Nothing + +rewardSourceEncoder :: HsqlE.Value RewardSource +rewardSourceEncoder = HsqlE.enum $ \case + RwdLeader -> "leader" + RwdMember -> "member" + RwdReserves -> "reserves" + RwdTreasury -> "treasury" + RwdDepositRefund -> "deposit_refund" + RwdProposalRefund -> "proposal_refund" + +-------------------------------------------------------------------------------- data SyncState = SyncLagging -- Local tip is lagging the global chain tip. | SyncFollowing -- Local tip is following global chain tip. deriving (Eq, Show) +syncStateDecoder :: HsqlD.Value SyncState +syncStateDecoder = HsqlD.enum $ \case + "lagging" -> Just SyncLagging + "following" -> Just SyncFollowing + _ -> Nothing + +syncStateEncoder :: HsqlE.Value SyncState +syncStateEncoder = HsqlE.enum $ \case + SyncLagging -> "lagging" + SyncFollowing -> "following" + +-------------------------------------------------------------------------------- data ScriptPurpose = Spend | Mint @@ -163,6 +320,26 @@ data ScriptPurpose | Propose deriving (Eq, Generic, Show) +scriptPurposeDecoder :: HsqlD.Value ScriptPurpose +scriptPurposeDecoder = HsqlD.enum $ \case + "spend" -> Just Spend + "mint" -> Just Mint + "cert" -> Just Cert + "reward" -> Just Rewrd + "vote" -> Just Vote + "propose" -> Just Propose + _ -> Nothing + +scriptPurposeEncoder :: HsqlE.Value ScriptPurpose +scriptPurposeEncoder = HsqlE.enum $ \case + Spend -> "spend" + Mint -> "mint" + Cert -> "cert" + Rewrd -> "reward" + Vote -> "vote" + Propose -> "propose" + +-------------------------------------------------------------------------------- data ScriptType = MultiSig | Timelock @@ -171,6 +348,24 @@ data ScriptType | PlutusV3 deriving (Eq, Generic, Show) +scriptTypeDecoder :: HsqlD.Value ScriptType +scriptTypeDecoder = HsqlD.enum $ \case + "multisig" -> Just MultiSig + "timelock" -> Just Timelock + "plutusv1" -> Just PlutusV1 + "plutusv2" -> Just PlutusV2 + "plutusv3" -> Just PlutusV3 + _ -> Nothing + +scriptTypeEncoder :: HsqlE.Value ScriptType +scriptTypeEncoder = HsqlE.enum $ \case + MultiSig -> "multisig" + Timelock -> "timelock" + PlutusV1 -> "plutusv1" + PlutusV2 -> "plutusv2" + PlutusV3 -> "plutusv3" + +-------------------------------------------------------------------------------- data PoolCertAction = Retirement !Word64 -- retirement epoch | Register !ByteString -- metadata hash @@ -262,24 +457,65 @@ extraDescription = \case instance Ord PoolCert where compare a b = compare (pcCertNo a) (pcCertNo b) +-------------------------------------------------------------------------------- + -- | The vote url wrapper so we have some additional safety. newtype VoteUrl = VoteUrl {unVoteUrl :: Text} deriving (Eq, Ord, Generic) deriving (Show) via (Quiet VoteUrl) +voteUrlDecoder :: HsqlD.Value VoteUrl +voteUrlDecoder = VoteUrl <$> HsqlD.text + +voteUrlEncoder :: HsqlE.Value VoteUrl +voteUrlEncoder = unVoteUrl >$< HsqlE.text + +-------------------------------------------------------------------------------- + -- | The raw binary hash of a vote metadata. newtype VoteMetaHash = VoteMetaHash {unVoteMetaHash :: ByteString} deriving (Eq, Ord, Generic) deriving (Show) via (Quiet VoteMetaHash) +-------------------------------------------------------------------------------- data Vote = VoteYes | VoteNo | VoteAbstain deriving (Eq, Ord, Generic) deriving (Show) via (Quiet Vote) +voteDecoder :: HsqlD.Value Vote +voteDecoder = HsqlD.enum $ \case + "yes" -> Just VoteYes + "no" -> Just VoteNo + "abstain" -> Just VoteAbstain + _ -> Nothing + +voteEncoder :: HsqlE.Value Vote +voteEncoder = HsqlE.enum $ \case + VoteYes -> "yes" + VoteNo -> "no" + VoteAbstain -> "abstain" + +-------------------------------------------------------------------------------- data VoterRole = ConstitutionalCommittee | DRep | SPO deriving (Eq, Ord, Generic) deriving (Show) via (Quiet VoterRole) +voterRoleDecoder :: HsqlD.Value VoterRole +voterRoleDecoder = HsqlD.enum $ \case + "constitutional-committee" -> Just ConstitutionalCommittee + "drep" -> Just DRep + "spo" -> Just SPO + _ -> Nothing + +voterRoleEncoder :: HsqlE.Value VoterRole +voterRoleEncoder = HsqlE.enum $ \case + ConstitutionalCommittee -> "constitutional-committee" + DRep -> "drep" + SPO -> "spo" + +-------------------------------------------------------------------------------- + +-- | The type of governance action. data GovActionType = ParameterChange | HardForkInitiation @@ -291,6 +527,30 @@ data GovActionType deriving (Eq, Ord, Generic) deriving (Show) via (Quiet GovActionType) +govActionTypeDecoder :: HsqlD.Value GovActionType +govActionTypeDecoder = HsqlD.enum $ \case + "parameter-change" -> Just ParameterChange + "hard-fork-initiation" -> Just HardForkInitiation + "treasury-withdrawals" -> Just TreasuryWithdrawals + "no-confidence" -> Just NoConfidence + "new-committee" -> Just NewCommitteeType + "new-constitution" -> Just NewConstitution + "info-action" -> Just InfoAction + _ -> Nothing + +govActionTypeEncoder :: HsqlE.Value GovActionType +govActionTypeEncoder = HsqlE.enum $ \case + ParameterChange -> "parameter-change" + HardForkInitiation -> "hard-fork-initiation" + TreasuryWithdrawals -> "treasury-withdrawals" + NoConfidence -> "no-confidence" + NewCommitteeType -> "new-committee" + NewConstitution -> "new-constitution" + InfoAction -> "info-action" + +-------------------------------------------------------------------------------- + +-- | The type of anchor. data AnchorType = GovActionAnchor | DrepAnchor @@ -301,17 +561,58 @@ data AnchorType deriving (Eq, Ord, Generic) deriving (Show) via (Quiet AnchorType) +anchorTypeDecoder :: HsqlD.Value AnchorType +anchorTypeDecoder = HsqlD.enum $ \case + "gov-action" -> Just GovActionAnchor + "drep" -> Just DrepAnchor + "other" -> Just OtherAnchor + "vote" -> Just VoteAnchor + "committee-dereg" -> Just CommitteeDeRegAnchor + "constitution" -> Just ConstitutionAnchor + _ -> Nothing + +anchorTypeEncoder :: HsqlE.Value AnchorType +anchorTypeEncoder = HsqlE.enum $ \case + GovActionAnchor -> "gov-action" + DrepAnchor -> "drep" + OtherAnchor -> "other" + VoteAnchor -> "vote" + CommitteeDeRegAnchor -> "committee-dereg" + ConstitutionAnchor -> "constitution" + deltaCoinToDbInt65 :: DeltaCoin -> DbInt65 deltaCoinToDbInt65 (DeltaCoin dc) = - if dc < 0 - then NegInt65 (fromIntegral $ abs dc) - else PosInt65 (fromIntegral dc) + toDbInt65 (fromIntegral dc) integerToDbInt65 :: Integer -> DbInt65 -integerToDbInt65 i = - if i >= 0 - then PosInt65 (fromIntegral i) - else NegInt65 (fromIntegral $ negate i) +integerToDbInt65 i + | i > fromIntegral (maxBound :: Int64) = error "Integer too large for DbInt65" + | i < fromIntegral (minBound :: Int64) = error "Integer too small for DbInt65" + | otherwise = toDbInt65 (fromIntegral i) + +-- deltaCoinToDbInt65 :: DeltaCoin -> DbInt65 +-- deltaCoinToDbInt65 (DeltaCoin dc) = +-- if dc < 0 +-- then NegInt65 (fromIntegral $ abs dc) +-- else PosInt65 (fromIntegral dc) + +-- integerToDbInt65 :: Integer -> DbInt65 +-- integerToDbInt65 i = +-- if i >= 0 +-- then PosInt65 (fromIntegral i) +-- else NegInt65 (fromIntegral $ negate i) + +word128Decoder :: HsqlD.Value Word128 +word128Decoder = HsqlD.composite $ do + hi <- HsqlD.field (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + lo <- HsqlD.field (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + pure $ Word128 hi lo + +word128Encoder :: HsqlE.Value Word128 +word128Encoder = + HsqlE.composite $ + HsqlE.field (HsqlE.nonNullable $ fromIntegral . word128Hi64 >$< HsqlE.int8) + <> HsqlE.field (HsqlE.nonNullable $ fromIntegral . word128Lo64 >$< HsqlE.int8) lovelaceToAda :: Micro -> Ada lovelaceToAda ll = @@ -324,22 +625,9 @@ scientificToAda :: Scientific -> Ada scientificToAda s = word64ToAda $ floor (s * 1000000) -readDbInt65 :: String -> DbInt65 -readDbInt65 str = - case str of - ('-' : rest) -> NegInt65 $ read rest - _other -> PosInt65 $ read str - -showDbInt65 :: DbInt65 -> String -showDbInt65 i65 = - case i65 of - PosInt65 w -> show w - NegInt65 0 -> "0" - NegInt65 w -> '-' : show w - -readRewardSource :: Text -> RewardSource -readRewardSource str = - case str of +rewardSourceFromText :: Text -> RewardSource +rewardSourceFromText txt = + case txt of "member" -> RwdMember "leader" -> RwdLeader "reserves" -> RwdReserves @@ -348,25 +636,25 @@ readRewardSource str = "proposal_refund" -> RwdProposalRefund -- This should never happen. On the Postgres side we defined an ENUM with -- only the two values as above. - _other -> error $ "readRewardSource: Unknown RewardSource " ++ Text.unpack str + _other -> error $ "rewardSourceFromText: Unknown RewardSource " ++ show txt -readSyncState :: String -> SyncState -readSyncState str = - case str of +syncStateFromText :: Text -> SyncState +syncStateFromText txt = + case txt of "lagging" -> SyncLagging "following" -> SyncFollowing -- This should never happen. On the Postgres side we defined an ENUM with -- only the two values as above. - _other -> error $ "readSyncState: Unknown SyncState " ++ str + _other -> error $ "syncStateToText: Unknown SyncState " ++ show txt -renderSyncState :: SyncState -> Text -renderSyncState ss = +syncStateToText :: SyncState -> Text +syncStateToText ss = case ss of SyncFollowing -> "following" SyncLagging -> "lagging" -renderScriptPurpose :: ScriptPurpose -> Text -renderScriptPurpose ss = +scriptPurposeFromText :: ScriptPurpose -> Text +scriptPurposeFromText ss = case ss of Spend -> "spend" Mint -> "mint" @@ -375,19 +663,19 @@ renderScriptPurpose ss = Vote -> "vote" Propose -> "propose" -readScriptPurpose :: String -> ScriptPurpose -readScriptPurpose str = - case str of +scriptPurposeToText :: Text -> ScriptPurpose +scriptPurposeToText txt = + case txt of "spend" -> Spend "mint" -> Mint "cert" -> Cert "reward" -> Rewrd "vote" -> Vote "propose" -> Propose - _other -> error $ "readScriptPurpose: Unknown ScriptPurpose " ++ str + _other -> error $ "scriptPurposeFromText: Unknown ScriptPurpose " ++ show txt -showRewardSource :: RewardSource -> Text -showRewardSource rs = +rewardSourceToText :: RewardSource -> Text +rewardSourceToText rs = case rs of RwdMember -> "member" RwdLeader -> "leader" @@ -396,8 +684,8 @@ showRewardSource rs = RwdDepositRefund -> "refund" RwdProposalRefund -> "proposal_refund" -renderScriptType :: ScriptType -> Text -renderScriptType st = +scriptTypeToText :: ScriptType -> Text +scriptTypeToText st = case st of MultiSig -> "multisig" Timelock -> "timelock" @@ -405,48 +693,48 @@ renderScriptType st = PlutusV2 -> "plutusV2" PlutusV3 -> "plutusV3" -readScriptType :: String -> ScriptType -readScriptType str = - case str of +scriptTypeFromText :: Text -> ScriptType +scriptTypeFromText txt = + case txt of "multisig" -> MultiSig "timelock" -> Timelock "plutusV1" -> PlutusV1 "plutusV2" -> PlutusV2 "plutusV3" -> PlutusV3 - _other -> error $ "readScriptType: Unknown ScriptType " ++ str + _other -> error $ "scriptTypeFromText: Unknown ScriptType " ++ show txt -renderVote :: Vote -> Text -renderVote ss = +voteToText :: Vote -> Text +voteToText ss = case ss of VoteYes -> "Yes" VoteNo -> "No" VoteAbstain -> "Abstain" -readVote :: String -> Vote -readVote str = - case str of +voteFromText :: Text -> Vote +voteFromText txt = + case txt of "Yes" -> VoteYes "No" -> VoteNo "Abstain" -> VoteAbstain - _other -> error $ "readVote: Unknown Vote " ++ str + _other -> error $ "readVote: Unknown Vote " ++ show txt -renderVoterRole :: VoterRole -> Text -renderVoterRole ss = +voterRoleToText :: VoterRole -> Text +voterRoleToText ss = case ss of ConstitutionalCommittee -> "ConstitutionalCommittee" DRep -> "DRep" SPO -> "SPO" -readVoterRole :: String -> VoterRole -readVoterRole str = - case str of +voterRoleFromText :: Text -> VoterRole +voterRoleFromText txt = + case txt of "ConstitutionalCommittee" -> ConstitutionalCommittee "DRep" -> DRep "SPO" -> SPO - _other -> error $ "readVoterRole: Unknown VoterRole " ++ str + _other -> error $ "voterRoleFromText: Unknown VoterRole " ++ show txt -renderGovActionType :: GovActionType -> Text -renderGovActionType gav = +govActionTypeToText :: GovActionType -> Text +govActionTypeToText gav = case gav of ParameterChange -> "ParameterChange" HardForkInitiation -> "HardForkInitiation" @@ -456,19 +744,19 @@ renderGovActionType gav = NewConstitution -> "NewConstitution" InfoAction -> "InfoAction" -readGovActionType :: String -> GovActionType -readGovActionType str = - case str of +govActionTypeFromText :: Text -> GovActionType +govActionTypeFromText txt = + case txt of "ParameterChange" -> ParameterChange "HardForkInitiation" -> HardForkInitiation "TreasuryWithdrawals" -> TreasuryWithdrawals "NoConfidence" -> NoConfidence "NewCommittee" -> NewCommitteeType "NewConstitution" -> NewConstitution - _other -> error $ "readGovActionType: Unknown GovActionType " ++ str + _other -> error $ "govActionTypeFromText: Unknown GovActionType " ++ show txt -renderAnchorType :: AnchorType -> Text -renderAnchorType gav = +anchorTypeToText :: AnchorType -> Text +anchorTypeToText gav = case gav of GovActionAnchor -> "gov_action" DrepAnchor -> "drep" @@ -477,16 +765,16 @@ renderAnchorType gav = CommitteeDeRegAnchor -> "committee_dereg" ConstitutionAnchor -> "constitution" -readAnchorType :: String -> AnchorType -readAnchorType str = - case str of +anchorTypeFromText :: Text -> AnchorType +anchorTypeFromText txt = + case txt of "gov_action" -> GovActionAnchor "drep" -> DrepAnchor "other" -> OtherAnchor "vote" -> VoteAnchor "committee_dereg" -> CommitteeDeRegAnchor "constitution" -> ConstitutionAnchor - _other -> error $ "readAnchorType: Unknown AnchorType " ++ str + _other -> error $ "anchorTypeFromText: Unknown AnchorType " ++ show txt word64ToAda :: Word64 -> Ada word64ToAda w = diff --git a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs index 0a7ac3dc4..7e898cf2e 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs @@ -12,7 +12,7 @@ module Test.IO.Cardano.Db.TotalSupply ( ) where import Cardano.Db -import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variants.TxOutCore as C import qualified Data.Text as Text import Test.IO.Cardano.Db.Util import Test.Tasty (TestTree, testGroup) diff --git a/cardano-db/test/Test/IO/Cardano/Db/Util.hs b/cardano-db/test/Test/IO/Cardano/Db/Util.hs index 1bf6cece7..c101a4aed 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Util.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Util.hs @@ -15,7 +15,7 @@ module Test.IO.Cardano.Db.Util ( ) where import Cardano.Db -import qualified Cardano.Db.Schema.Core.TxOut as C +import qualified Cardano.Db.Schema.Variants.TxOutCore as C import Control.Monad (unless) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO, liftIO) diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs index 7d5e1c99f..2da333138 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs @@ -12,7 +12,7 @@ import Cardano.Db ( PGPassSource (PGPassDefaultEnv), readPGPass, runOrThrowIODb, - toConnectionString, + toConnectionSetting, ) import qualified Cardano.Db as Db import Cardano.Prelude @@ -42,7 +42,7 @@ runSmashServer config = do defaultSettings pgconfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) - Db.runIohkLogging trce $ withPostgresqlPool (toConnectionString pgconfig) (sscSmashPort config) $ \pool -> do + Db.runIohkLogging trce $ withPostgresqlPool (toConnectionSetting pgconfig) (sscSmashPort config) $ \pool -> do let poolDataLayer = postgresqlPoolDataLayer trce pool app <- liftIO $ mkApp (sscTrace config) poolDataLayer (sscAdmins config) liftIO $ runSettings settings app diff --git a/flake.lock b/flake.lock index a8d647c65..e117f0c76 100644 --- a/flake.lock +++ b/flake.lock @@ -171,11 +171,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1729470551, - "narHash": "sha256-AKBK4jgOjIz5DxIsIKFZR0mf30qc4Dv+Dm/DVRjdjD8=", + "lastModified": 1738753148, + "narHash": "sha256-51bAmpHmhB8f0kfIgoNa+Bcbo7MEkSksl0U3oEbJOi0=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "ee5b803d828db6efac3ef7e7e072c855287dc298", + "rev": "fef267ea152c43844462ef7f06c6056dbd2918be", "type": "github" }, "original": {