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/src/Cardano/Mock/Query.hs b/cardano-chain-gen/src/Cardano/Mock/Query.hs index 1d82cde64..ebf500f0c 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Query.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Query.hs @@ -36,7 +36,7 @@ import Prelude () queryVersionMajorFromEpoch :: MonadIO io => Word64 -> - ReaderT SqlBackend io (Maybe Word16) + DB.DbAction io (Maybe Word16) queryVersionMajorFromEpoch epochNo = do res <- selectOne $ do prop <- from $ table @Db.EpochParam @@ -48,7 +48,7 @@ queryVersionMajorFromEpoch epochNo = do queryParamProposalFromEpoch :: MonadIO io => Word64 -> - ReaderT SqlBackend io (Maybe Db.ParamProposal) + DB.DbAction io (Maybe Db.ParamProposal) queryParamProposalFromEpoch epochNo = do res <- selectOne $ do prop <- from $ table @Db.ParamProposal @@ -59,7 +59,7 @@ queryParamProposalFromEpoch epochNo = do queryParamFromEpoch :: MonadIO io => Word64 -> - ReaderT SqlBackend io (Maybe Db.EpochParam) + DB.DbAction io (Maybe Db.EpochParam) queryParamFromEpoch epochNo = do res <- selectOne $ do param <- from $ table @Db.EpochParam @@ -68,14 +68,14 @@ queryParamFromEpoch epochNo = do pure (entityVal <$> res) -- | Query whether there any null tx deposits? -queryNullTxDepositExists :: MonadIO io => ReaderT SqlBackend io Bool +queryNullTxDepositExists :: MonadIO io => DB.DbAction io Bool queryNullTxDepositExists = do res <- select $ do tx <- from $ table @Db.Tx where_ $ isNothing_ (tx ^. Db.TxDeposit) pure $ not (null res) -queryMultiAssetCount :: MonadIO io => ReaderT SqlBackend io Word +queryMultiAssetCount :: MonadIO io => DB.DbAction io Word queryMultiAssetCount = do res <- select $ do _ <- from (table @Db.MultiAsset) @@ -83,7 +83,7 @@ queryMultiAssetCount = do pure $ maybe 0 unValue (listToMaybe res) -queryTxMetadataCount :: MonadIO io => ReaderT SqlBackend io Word +queryTxMetadataCount :: MonadIO io => DB.DbAction io Word queryTxMetadataCount = do res <- selectOne $ do _ <- from (table @Db.TxMetadata) @@ -95,7 +95,7 @@ queryDRepDistrAmount :: MonadIO io => ByteString -> Word64 -> - ReaderT SqlBackend io Word64 + DB.DbAction io Word64 queryDRepDistrAmount drepHash epochNo = do res <- selectOne $ do (distr :& hash) <- @@ -113,7 +113,7 @@ queryDRepDistrAmount drepHash epochNo = do queryGovActionCounts :: MonadIO io => - ReaderT SqlBackend io (Word, Word, Word, Word) + DB.DbAction io (Word, Word, Word, Word) queryGovActionCounts = do ratified <- countNonNulls Db.GovActionProposalRatifiedEpoch enacted <- countNonNulls Db.GovActionProposalEnactedEpoch @@ -125,7 +125,7 @@ queryGovActionCounts = do countNonNulls :: (MonadIO io, PersistField field) => EntityField Db.GovActionProposal (Maybe field) -> - ReaderT SqlBackend io Word + DB.DbAction io Word countNonNulls field = do res <- selectOne $ do e <- from $ table @Db.GovActionProposal @@ -137,7 +137,7 @@ queryGovActionCounts = do queryConstitutionAnchor :: MonadIO io => Word64 -> - ReaderT SqlBackend io (Maybe (Text, ByteString)) + DB.DbAction io (Maybe (Text, ByteString)) queryConstitutionAnchor epochNo = do res <- selectOne $ do (_ :& anchor :& epochState) <- @@ -160,7 +160,7 @@ queryConstitutionAnchor epochNo = do queryRewardRests :: MonadIO io => - ReaderT SqlBackend io [(Db.RewardSource, Word64)] + DB.DbAction io [(Db.RewardSource, Word64)] queryRewardRests = do res <- select $ do reward <- from $ table @Db.RewardRest @@ -170,7 +170,7 @@ queryRewardRests = do queryTreasuryDonations :: MonadIO io => - ReaderT SqlBackend io Word64 + DB.DbAction io Word64 queryTreasuryDonations = do res <- selectOne $ do txs <- from $ table @Db.Tx @@ -183,7 +183,7 @@ queryVoteCounts :: MonadIO io => ByteString -> Word16 -> - ReaderT SqlBackend io (Word64, Word64, Word64) + DB.DbAction io (Word64, Word64, Word64) queryVoteCounts txHash idx = do yes <- countVotes Db.VoteYes no <- countVotes Db.VoteNo @@ -210,7 +210,7 @@ queryVoteCounts txHash idx = do queryEpochStateCount :: MonadIO io => Word64 -> - ReaderT SqlBackend io Word64 + DB.DbAction io Word64 queryEpochStateCount epochNo = do res <- selectOne $ do epochState <- from (table @Db.EpochState) @@ -222,7 +222,7 @@ queryEpochStateCount epochNo = do queryCommitteeByTxHash :: MonadIO io => ByteString -> - ReaderT SqlBackend io (Maybe Db.Committee) + DB.DbAction io (Maybe Db.Committee) queryCommitteeByTxHash txHash = do res <- selectOne $ do (committee :& _ :& tx) <- @@ -244,7 +244,7 @@ queryCommitteeByTxHash txHash = do queryCommitteeMemberCountByTxHash :: MonadIO io => Maybe ByteString -> - ReaderT SqlBackend io Word64 + DB.DbAction io Word64 queryCommitteeMemberCountByTxHash txHash = do res <- selectOne $ do (_ :& committee :& _ :& tx) <- 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..3ac4b696e 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -58,7 +58,7 @@ module Test.Cardano.Db.Mock.Config ( withCustomConfigAndLogs, withFullConfig', replaceConfigFile, - txOutTableTypeFromConfig, + txOutVariantTypeFromConfig, ) where import Cardano.Api (NetworkMagic (..)) @@ -226,13 +226,13 @@ withDBSyncEnv mkEnv = bracket mkEnv stopDBSyncIfRunning getDBSyncPGPass :: DBSyncEnv -> DB.PGPassSource getDBSyncPGPass = enpPGPassSource . dbSyncParams -queryDBSync :: DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> IO a +queryDBSync :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> IO a 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 @@ -601,14 +601,14 @@ replaceConfigFile newFilename dbSync@DBSyncEnv {..} = do newParams = dbSyncParams {enpConfigFile = ConfigFile $ configDir newFilename} -txOutTableTypeFromConfig :: DBSyncEnv -> DB.TxOutTableType -txOutTableTypeFromConfig dbSyncEnv = +txOutVariantTypeFromConfig :: DBSyncEnv -> DB.TxOutVariantType +txOutVariantTypeFromConfig dbSyncEnv = case sioTxOut $ dncInsertOptions $ dbSyncConfig dbSyncEnv of - TxOutDisable -> DB.TxOutCore + TxOutDisable -> DB.TxOutVariantCore TxOutEnable useTxOutAddress -> getTxOutTT useTxOutAddress TxOutConsumed _ useTxOutAddress -> getTxOutTT useTxOutAddress TxOutConsumedPrune _ useTxOutAddress -> getTxOutTT useTxOutAddress TxOutConsumedBootstrap _ useTxOutAddress -> getTxOutTT useTxOutAddress where - getTxOutTT :: UseTxOutAddress -> DB.TxOutTableType - getTxOutTT value = if unUseTxOutAddress value then DB.TxOutVariantAddress else DB.TxOutCore + getTxOutTT :: UseTxOutAddress -> DB.TxOutVariantType + getTxOutTT value = if unUseTxOutAddress value then DB.TxOutVariantAddress else DB.TxOutVariantCore 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..ca84d8679 --- /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 (TxOutVariantType (..)) +import qualified Cardano.Db as DB +import qualified Cardano.Db.Schema.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC +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.VCTxOutW txOut -> + ( VC.txOutAddress txOut + , VC.txOutAddressHasScript txOut + , VC.txOutValue txOut + , VC.txOutDataHash txOut + ) + DB.VATxOutW txout mAddress -> case mAddress of + Just address -> + ( VA.addressAddress address + , VA.addressHasScript address + , VA.txOutValue txout + , VA.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..fefda6fa8 --- /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.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC +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, txOutVariantTypeFromConfig, 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 txOutVariantType = txOutVariantTypeFromConfig 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 txOutVariantType) [expectedFields] "Unexpected script outputs" + where + testLabel = "simpleScript" + getOutFields txOutW = + case txOutW of + DB.VCTxOutW txOut -> + ( VC.txOutAddress txOut + , VC.txOutAddressHasScript txOut + , VC.txOutValue txOut + , VC.txOutDataHash txOut + ) + DB.VATxOutW txOut mAddress -> case mAddress of + Just address -> + ( VA.addressAddress address + , VA.addressHasScript address + , VA.txOutValue txOut + , VA.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/Config/MigrateConsumedPruneTxOut.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs index 2d8f723f9..7a35f1865 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs @@ -60,7 +60,7 @@ performBasicPrune :: Bool -> IOManager -> [(Text, Text)] -> Assertion performBasicPrune useTxOutAddress = do withCustomConfigAndDropDB args (Just $ configPruneForceTxIn useTxOutAddress) cfgDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Add some blocks blks <- forgeAndSubmitBlocks interpreter mockServer 50 @@ -75,13 +75,13 @@ performBasicPrune useTxOutAddress = do -- Check tx-out count before pruning assertBlockNoBackoff dbSync (fullBlockSize blks) - assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSync (DB.queryTxOutCount txOutVariantType) 14 "new epoch didn't prune tx_out column that are null" blks' <- forgeAndSubmitBlocks interpreter mockServer 48 assertBlockNoBackoff dbSync (fullBlockSize $ blks <> blks') -- Check that tx_out was pruned - assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 12 "the pruning didn't work correctly as the tx-out count is incorrect" + assertEqQuery dbSync (DB.queryTxOutCount txOutVariantType) 12 "the pruning didn't work correctly as the tx-out count is incorrect" -- Check unspent tx assertUnspentTx dbSync where @@ -99,7 +99,7 @@ pruneWithSimpleRollbackWithAddress = performPruneWithSimpleRollback True performPruneWithSimpleRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion performPruneWithSimpleRollback useTxOutAddress = withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge some blocks blk0 <- forgeNext interpreter mockBlock0 blk1 <- forgeNext interpreter mockBlock1 @@ -115,18 +115,18 @@ performPruneWithSimpleRollback useTxOutAddress = void $ withConwayFindLeaderAndSubmitTx interpreter mockServer $ Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 - assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "" + assertEqQuery dbSync (DB.queryTxOutCount txOutVariantType) 14 "" -- Submit some blocks blks <- forgeAndSubmitBlocks interpreter mockServer 96 assertBlockNoBackoff dbSync (fullBlockSize blks) - assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 12 "the txOut count is incorrect" - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSync (DB.queryTxOutCount txOutVariantType) 12 "the txOut count is incorrect" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 0 "Unexpected TxOutConsumedByTxId count after prune" assertUnspentTx dbSync -- Rollback rollbackTo interpreter mockServer (blockPoint blk1) - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 0 "Unexpected TxOutConsumedByTxId count after rollback" assertBlockNoBackoff dbSync (fullBlockSize blks) where cmdLineArgs = initCommandLineArgs @@ -143,7 +143,7 @@ performPruneWithFullTxRollback :: Bool -> IOManager -> [(Text, Text)] -> Asserti performPruneWithFullTxRollback useTxOutAddress = withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge a block blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Add some transactions @@ -156,7 +156,7 @@ performPruneWithFullTxRollback useTxOutAddress = assertBlockNoBackoff dbSync 2 assertTxCount dbSync 13 assertUnspentTx dbSync - assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSync (DB.queryTxOutCount txOutVariantType) 14 "new epoch didn't prune tx_out column that are null" -- Rollback rollbackTo interpreter mockServer $ blockPoint blk0 @@ -170,7 +170,7 @@ performPruneWithFullTxRollback useTxOutAddress = -- Verify tx_out was pruned again assertBlockNoBackoff dbSync 2 assertTxCount dbSync 14 - assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 16 "new epoch didn't prune tx_out column that are null" + assertEqQuery dbSync (DB.queryTxOutCount txOutVariantType) 16 "new epoch didn't prune tx_out column that are null" assertUnspentTx dbSync where cmdLineArgs = initCommandLineArgs @@ -188,7 +188,7 @@ performPruningShouldKeepSomeTx :: Bool -> IOManager -> [(Text, Text)] -> Asserti performPruningShouldKeepSomeTx useTxOutAddress = do withCustomConfigAndDropDB cmdLineArgs (Just $ configPrune useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge some blocks blk1 <- forgeAndSubmitBlocks interpreter mockServer 80 -- These two blocks/transactions will fall within the last (2 * securityParam) 20 @@ -202,14 +202,14 @@ performPruningShouldKeepSomeTx useTxOutAddress = do blk2 <- forgeAndSubmitBlocks interpreter mockServer 18 -- Verify the two transactions above weren't pruned assertBlockNoBackoff dbSync (fromIntegral $ length (blk1 <> blk2) + 2) - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 2 "Unexpected TxOutConsumedByTxId count after prune" -- Add more blocks blk3 <- forgeAndSubmitBlocks interpreter mockServer 110 -- Verify everything has been pruned assertBlockNoBackoff dbSync (fromIntegral $ length (blk1 <> blk2 <> blk3) + 2) assertTxInCount dbSync 0 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 0 "Unexpected TxOutConsumedByTxId count after prune" where cmdLineArgs = initCommandLineArgs testLabel = "conwayConfigPruneCorrectAmount" @@ -225,7 +225,7 @@ performPruneAndRollBackOneBlock useTxOutAddress = withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 98 -- These transactions will fall within the last (2 * securityParam) 20 @@ -241,7 +241,7 @@ performPruneAndRollBackOneBlock useTxOutAddress = void $ withConwayFindLeaderAndSubmit interpreter mockServer (\_ -> sequence [tx1]) -- Verify the last 2 transactions weren't pruned assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 2 "Unexpected TxOutConsumedByTxId count before rollback" rollbackTo interpreter mockServer (blockPoint blk100) @@ -249,13 +249,13 @@ performPruneAndRollBackOneBlock useTxOutAddress = void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Verify the transactions were removed in the rollback assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 1 "Unexpected TxOutConsumedByTxId count after rollback" -- Trigger a prune void $ forgeAndSubmitBlocks interpreter mockServer 102 -- Verify everything was pruned assertBlockNoBackoff dbSync 203 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 0 "Unexpected TxOutConsumedByTxId count after rollback" where cmdLineArgs = initCommandLineArgs testLabel = "conwayConfigPruneAndRollBack" @@ -271,7 +271,7 @@ performNoPruneAndRollBack useTxOutAddress = withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 98 -- Add a block with transactions @@ -287,7 +287,7 @@ performNoPruneAndRollBack useTxOutAddress = -- Verify the transactions weren't pruned assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 2 "Unexpected TxOutConsumedByTxId count before rollback" rollbackTo interpreter mockServer (blockPoint blk100) @@ -295,13 +295,13 @@ performNoPruneAndRollBack useTxOutAddress = void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Verify transactions were removed assertBlockNoBackoff dbSync 101 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 1 "Unexpected TxOutConsumedByTxId count after rollback" -- Add some more blocks void $ forgeAndSubmitBlocks interpreter mockServer 102 -- Verify nothing has been pruned assertBlockNoBackoff dbSync 203 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 1 "Unexpected TxOutConsumedByTxId count after rollback" where cmdLineArgs = initCommandLineArgs testLabel = "conwayConfigNoPruneAndRollBack" @@ -317,7 +317,7 @@ performPruneSameBlock useTxOutAddress = withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 76 blk77 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] @@ -329,13 +329,13 @@ performPruneSameBlock useTxOutAddress = pure [tx0, tx1] -- Verify the transactions weren't pruned assertBlockNoBackoff dbSync 78 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId before rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 2 "Unexpected TxOutConsumedByTxId before rollback" -- Trigger a prune void $ forgeAndSubmitBlocks interpreter mockServer 22 -- Verify the transactions were pruned assertBlockNoBackoff dbSync 100 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after prune" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 0 "Unexpected TxOutConsumedByTxId after prune" rollbackTo interpreter mockServer (blockPoint blk77) @@ -344,7 +344,7 @@ performPruneSameBlock useTxOutAddress = -- Verify the transactions were pruned again assertBlockNoBackoff dbSync 78 assertTxInCount dbSync 0 - assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount txOutVariantType) 0 "Unexpected TxOutConsumedByTxId after rollback" where cmdLineArgs = initCommandLineArgs testLabel = "conwayConfigPruneSameBlock" @@ -382,7 +382,7 @@ performNoPruneSameBlock useTxOutAddress = void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Verify everything was pruned assertBlockNoBackoff dbSync 98 - assertEqQuery dbSync (DB.queryTxOutConsumedCount $ txOutTableTypeFromConfig dbSync) 0 "Unexpected TxOutConsumedByTxId after rollback" + assertEqQuery dbSync (DB.queryTxOutConsumedCount $ txOutVariantTypeFromConfig dbSync) 0 "Unexpected TxOutConsumedByTxId after rollback" where cmdLineArgs = initCommandLineArgs testLabel = "conwayConfigNoPruneSameBlock" 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..e31b783a1 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.Variants.TxOutAddress as V +import qualified Cardano.Db.Schema.Variants.TxOutCore as C import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) @@ -63,7 +63,7 @@ import Test.Cardano.Db.Mock.Config ( conwayConfigDir, initCommandLineArgs, startDBSync, - txOutTableTypeFromConfig, + txOutVariantTypeFromConfig, withCustomConfig, withFullConfig, withFullConfigAndDropDB, @@ -80,7 +80,7 @@ simpleScript :: IOManager -> [(Text, Text)] -> Assertion simpleScript = withFullConfigAndDropDB conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do startDBSync dbSync - let txOutTableType = txOutTableTypeFromConfig dbSync + let txOutVariantType = txOutVariantTypeFromConfig dbSync -- Forge a block with stake credentials void $ Api.registerAllStakeCreds interpreter mockServer @@ -96,20 +96,20 @@ simpleScript = assertBlockNoBackoff dbSync (length epoch + 2) assertEqQuery dbSync - (map getOutFields <$> DB.queryScriptOutputs txOutTableType) + (map getOutFields <$> DB.queryScriptOutputs txOutVariantType) [expectedFields] "Unexpected script outputs" where testLabel = "conwaySimpleScript" getOutFields txOut = case txOut of - DB.CTxOutW txOut' -> + DB.VCTxOutW txOut' -> ( C.txOutAddress txOut' , C.txOutAddressHasScript txOut' , C.txOutValue txOut' , C.txOutDataHash txOut' ) - DB.VTxOutW txOut' mAddress -> + DB.VATxOutW txOut' mAddress -> case mAddress of Just address -> ( V.addressAddress address 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..dda4d9f04 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.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Util import qualified Cardano.Ledger.Address as Ledger @@ -139,24 +139,24 @@ expectFailSilent name action = testCase name $ do -- checking that unspent count matches from tx_in to tx_out assertUnspentTx :: DBSyncEnv -> IO () assertUnspentTx dbSyncEnv = do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - unspentTxCount <- queryDBSync dbSyncEnv $ DB.queryTxOutConsumedNullCount txOutTableType - consumedNullCount <- queryDBSync dbSyncEnv $ DB.queryTxOutUnspentCount txOutTableType + let txOutVariantType = txOutVariantTypeFromConfig dbSyncEnv + unspentTxCount <- queryDBSync dbSyncEnv $ DB.queryTxOutConsumedNullCount txOutVariantType + consumedNullCount <- queryDBSync dbSyncEnv $ DB.queryTxOutUnspentCount txOutVariantType assertEqual "Unexpected tx unspent count between tx-in & tx-out" unspentTxCount consumedNullCount defaultDelays :: [Int] defaultDelays = [1, 2, 4, 8, 16, 32, 64, 128, 256] -assertEqQuery :: (Eq a, Show a) => DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> a -> String -> IO () +assertEqQuery :: (Eq a, Show a) => DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> a -> String -> IO () assertEqQuery env query a msg = do assertEqBackoff env query a defaultDelays msg -assertEqBackoff :: (Eq a, Show a) => DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> a -> [Int] -> String -> IO () +assertEqBackoff :: (Eq a, Show a) => DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> a -> [Int] -> String -> IO () assertEqBackoff env query a delays msg = do checkStillRuns env assertBackoff env query delays (== a) (\a' -> msg <> ": got " <> show a' <> " expected " <> show a) -assertBackoff :: DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> [Int] -> (a -> Bool) -> (a -> String) -> IO () +assertBackoff :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> [Int] -> (a -> Bool) -> (a -> String) -> IO () assertBackoff env query delays check errMsg = go delays where go ds = do @@ -168,7 +168,7 @@ assertBackoff env query delays check errMsg = go delays threadDelay $ dl * 100_000 go rest -assertQuery :: DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> (a -> Bool) -> (a -> String) -> IO (Maybe String) +assertQuery :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> (a -> Bool) -> (a -> String) -> IO (Maybe String) assertQuery env query check errMsg = do ma <- try $ queryDBSync env query case ma of @@ -179,7 +179,7 @@ assertQuery env query check errMsg = do Right a | not (check a) -> pure $ Just $ errMsg a _ -> pure Nothing -runQuery :: DBSyncEnv -> ReaderT SqlBackend (NoLoggingT IO) a -> IO a +runQuery :: DBSyncEnv -> DB.DbAction (NoLoggingT IO) a -> IO a runQuery env query = do ma <- try $ queryDBSync env query case ma of @@ -205,7 +205,7 @@ assertCurrentEpoch :: DBSyncEnv -> Word64 -> IO () assertCurrentEpoch env expected = assertEqBackoff env q (Just expected) defaultDelays "Unexpected epoch stake counts" where - q = queryCurrentEpochNo + q = queryBlocksForCurrentEpochNo assertAddrValues :: (EraCrypto era ~ StandardCrypto, Core.EraTxOut era) => @@ -217,7 +217,7 @@ assertAddrValues :: assertAddrValues env ix expected sta = do addr <- assertRight $ resolveAddress ix sta let address = Generic.renderAddress addr - q = queryAddressOutputs TxOutCore address + q = queryAddressOutputs TxOutVariantCore address assertEqBackoff env q expected defaultDelays "Unexpected Balance" assertRight :: Show err => Either err a -> IO a @@ -338,7 +338,7 @@ assertNonZeroFeesContract :: DBSyncEnv -> IO () assertNonZeroFeesContract env = assertEqBackoff env q 0 defaultDelays "Found contract tx with zero fees" where - q :: ReaderT SqlBackend (NoLoggingT IO) Word64 + q :: DB.DbAction (NoLoggingT IO) Word64 q = maybe 0 unValue . listToMaybe <$> ( select . from $ \tx -> do @@ -351,7 +351,7 @@ assertDatumCBOR :: DBSyncEnv -> ByteString -> IO () assertDatumCBOR env bs = assertEqBackoff env q 1 defaultDelays "Datum bytes not found" where - q :: ReaderT SqlBackend (NoLoggingT IO) Word64 + q :: DB.DbAction (NoLoggingT IO) Word64 q = maybe 0 unValue . listToMaybe <$> ( select . from $ \datum -> do @@ -419,29 +419,29 @@ assertBabbageCounts env expected = referenceTxIn <- maybe 0 unValue . listToMaybe <$> (select . from $ \(_a :: SqlExpr (Entity ReferenceTxIn)) -> pure countRows) - collTxOut <- case txOutTableTypeFromConfig env of - TxOutCore -> do + collTxOut <- case txOutVariantTypeFromConfig env of + TxOutVariantCore -> do maybe 0 unValue . listToMaybe - <$> (select . from $ \(_a :: SqlExpr (Entity C.CollateralTxOut)) -> pure countRows) + <$> (select . from $ \(_a :: SqlExpr (Entity VC.CollateralTxOut)) -> pure countRows) TxOutVariantAddress -> do maybe 0 unValue . listToMaybe - <$> (select . from $ \(_a :: SqlExpr (Entity V.CollateralTxOut)) -> pure countRows) + <$> (select . from $ \(_a :: SqlExpr (Entity VA.CollateralTxOut)) -> pure countRows) inlineDatum <- - case txOutTableTypeFromConfig env of - TxOutCore -> do + case txOutVariantTypeFromConfig env of + TxOutVariantCore -> do maybe 0 unValue . listToMaybe - <$> (select . from $ \txOut -> where_ (isJust (txOut ^. C.TxOutInlineDatumId)) >> pure countRows) + <$> (select . from $ \txOut -> where_ (isJust (txOut ^. VC.TxOutInlineDatumId)) >> pure countRows) TxOutVariantAddress -> do maybe 0 unValue . listToMaybe - <$> (select . from $ \txOut -> where_ (isJust (txOut ^. V.TxOutInlineDatumId)) >> pure countRows) + <$> (select . from $ \txOut -> where_ (isJust (txOut ^. VA.TxOutInlineDatumId)) >> pure countRows) referenceScript <- - case txOutTableTypeFromConfig env of - TxOutCore -> do + case txOutVariantTypeFromConfig env of + TxOutVariantCore -> do maybe 0 unValue . listToMaybe - <$> (select . from $ \txOut -> where_ (isJust (txOut ^. C.TxOutReferenceScriptId)) >> pure countRows) + <$> (select . from $ \txOut -> where_ (isJust (txOut ^. VC.TxOutReferenceScriptId)) >> pure countRows) TxOutVariantAddress -> do maybe 0 unValue . listToMaybe - <$> (select . from $ \txOut -> where_ (isJust (txOut ^. V.TxOutReferenceScriptId)) >> pure countRows) + <$> (select . from $ \txOut -> where_ (isJust (txOut ^. VA.TxOutReferenceScriptId)) >> pure countRows) pure ( scripts , redeemers @@ -473,7 +473,7 @@ assertPoolCounters :: DBSyncEnv -> (Word64, Word64, Word64, Word64, Word64, Word assertPoolCounters env expected = assertEqBackoff env poolCountersQuery expected defaultDelays "Unexpected Pool counts" -poolCountersQuery :: ReaderT SqlBackend (NoLoggingT IO) (Word64, Word64, Word64, Word64, Word64, Word64) +poolCountersQuery :: DB.DbAction (NoLoggingT IO) (Word64, Word64, Word64, Word64, Word64, Word64) poolCountersQuery = do poolHash <- maybe 0 unValue . listToMaybe diff --git a/cardano-db-sync/app/test-http-get-json-metadata.hs b/cardano-db-sync/app/test-http-get-json-metadata.hs index 5fb02f07a..c6398b21f 100644 --- a/cardano-db-sync/app/test-http-get-json-metadata.hs +++ b/cardano-db-sync/app/test-http-get-json-metadata.hs @@ -138,7 +138,7 @@ reportTestFailures tf = do -- reportTestOffChain :: TestOffChain -> IO () -- reportTestOffChain tof = Text.putStrLn $ mconcat [ toTicker tof, " ", unPoolUrl (toUrl tof) ] -queryTestOffChainData :: MonadIO m => ReaderT SqlBackend m [TestOffChain] +queryTestOffChainData :: MonadIO m => DB.DbAction m [TestOffChain] queryTestOffChainData = do res <- select $ do (pod :& pmr) <- diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index c3010c23a..fd77c20d6 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -54,7 +54,7 @@ library Cardano.DbSync.Config.Shelley Cardano.DbSync.Config.Types Cardano.DbSync.Database - Cardano.DbSync.DbAction + Cardano.DbSync.DbEvent Cardano.DbSync.Error Cardano.DbSync.Era @@ -97,10 +97,6 @@ library Cardano.DbSync.Era.Universal.Insert.Pool Cardano.DbSync.Era.Universal.Insert.Tx - - -- Temporary debugging validation - Cardano.DbSync.Era.Shelley.ValidateWithdrawal - Cardano.DbSync.Era.Util Cardano.DbSync.Ledger.Event @@ -180,10 +176,10 @@ library , directory , data-default-class , either - , esqueleto , extra , filepath , groups + , hasql , 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..319662629 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 @@ -34,7 +46,7 @@ import Cardano.DbSync.Config (configureLogging) import Cardano.DbSync.Config.Cardano import Cardano.DbSync.Config.Types import Cardano.DbSync.Database -import Cardano.DbSync.DbAction +import Cardano.DbSync.DbEvent import Cardano.DbSync.Era import Cardano.DbSync.Error import Cardano.DbSync.Ledger.State @@ -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 @@ -193,10 +198,10 @@ runSyncNode metricsSetters trce iomgr dbConnString runMigrationFnc syncNodeConfi when (not isJsonbInSchema && not removeJsonbFromSchemaConfig) $ do liftIO $ logWarning trce "Adding jsonb datatypes back to the database. This can take time." liftIO $ runAddJsonbToSchema syncEnv - liftIO $ runExtraMigrationsMaybe syncEnv + liftIO $ runConsumedTxOutMigrationsMaybe 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 @@ -206,10 +211,11 @@ runSyncNode metricsSetters trce iomgr dbConnString runMigrationFnc syncNodeConfi id [ runDbThread syncEnv metricsSetters threadChannels , runSyncNodeClient metricsSetters syncEnv iomgr trce threadChannels (enpSocketPath syncNodeParams) - , runFetchOffChainPoolThread syncEnv - , runFetchOffChainVoteThread syncEnv + , runFetchOffChainPoolThread syncEnv syncNodeConfigFromFile + , runFetchOffChainVoteThread syncEnv syncNodeConfigFromFile , runLedgerStateWriteThread (getTrace syncEnv) (envLedgerEnv syncEnv) ] + ) where useShelleyInit :: SyncNodeConfig -> Bool useShelleyInit cfg = @@ -272,7 +278,7 @@ extractSyncOptions snp aop snc = , ioPoolStats = isPoolStatsEnabled (sioPoolStats (dncInsertOptions snc)) , ioGov = useGovernance , ioRemoveJsonbFromSchema = isRemoveJsonbFromSchemaEnabled (sioRemoveJsonbFromSchema (dncInsertOptions snc)) - , ioTxOutTableType = ioTxOutTableType' + , ioTxOutVariantType = ioTxOutVariantType' } useLedger = sioLedger (dncInsertOptions snc) == LedgerEnable @@ -286,7 +292,7 @@ extractSyncOptions snp aop snc = isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions $ snc isTxOutEnabled' = isTxOutEnabled . sioTxOut . dncInsertOptions $ snc forceTxIn' = forceTxIn . sioTxOut . dncInsertOptions $ snc - ioTxOutTableType' = txOutConfigToTableType $ sioTxOut $ dncInsertOptions snc + ioTxOutVariantType' = txOutConfigToTableType $ sioTxOut $ dncInsertOptions snc startupReport :: Trace IO Text -> Bool -> SyncNodeParams -> IO () startupReport trce aop params = do @@ -295,7 +301,7 @@ startupReport trce aop params = do logInfo trce $ mconcat ["Enviroment variable DbSyncAbortOnPanic: ", textShow aop] logInfo trce $ textShow params -txOutConfigToTableType :: TxOutConfig -> DB.TxOutTableType +txOutConfigToTableType :: TxOutConfig -> DB.TxOutVariantType txOutConfigToTableType config = case config of TxOutEnable (UseTxOutAddress flag) -> if flag then DB.TxOutVariantAddress else DB.TxOutCore TxOutDisable -> DB.TxOutCore diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index a24f1baae..7c5881664 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -17,14 +17,14 @@ module Cardano.DbSync.Api ( getRanIndexes, runIndexMigrations, initPruneConsumeMigration, - runExtraMigrationsMaybe, + runConsumedTxOutMigrationsMaybe, runAddJsonbToSchema, runRemoveJsonbFromSchema, getSafeBlockNoDiff, getPruneInterval, whenConsumeOrPruneTxOut, whenPruneTxOut, - getTxOutTableType, + getTxOutVariantType, getPruneConsume, getHasConsumedOrPruneTxOut, getSkipTxIn, @@ -46,31 +46,10 @@ module Cardano.DbSync.Api ( convertToPoint, ) where +import Cardano.Prelude import Cardano.BM.Trace (Trace, logInfo, logWarning) import qualified Cardano.Chain.Genesis as Byron import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..)) -import qualified Cardano.Db as DB -import Cardano.DbSync.Api.Types -import Cardano.DbSync.Cache.Types (CacheCapacity (..), newEmptyCache, useNoCache) -import Cardano.DbSync.Config.Cardano -import Cardano.DbSync.Config.Shelley -import Cardano.DbSync.Config.Types -import Cardano.DbSync.Error -import Cardano.DbSync.Ledger.Event (LedgerEvent (..)) -import Cardano.DbSync.Ledger.State ( - getHeaderHash, - hashToAnnotation, - listKnownSnapshots, - mkHasLedgerEnv, - ) -import Cardano.DbSync.Ledger.Types (HasLedgerEnv (..), LedgerStateFile (..), SnapshotPoint (..)) -import Cardano.DbSync.LocalStateQuery -import Cardano.DbSync.Types -import Cardano.DbSync.Util -import Cardano.DbSync.Util.Constraint (dbConstraintNamesExists) -import qualified Cardano.Ledger.BaseTypes as Ledger -import qualified Cardano.Ledger.Shelley.Genesis as Shelley -import Cardano.Prelude import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..)) import Control.Concurrent.Class.MonadSTM.Strict ( newTBQueueIO, @@ -83,7 +62,6 @@ import Control.Monad.Trans.Maybe (MaybeT (..)) import qualified Data.Strict.Maybe as Strict import Data.Time.Clock (getCurrentTime) import Database.Persist.Postgresql (ConnectionString) -import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.Block.Abstract (BlockProtocol, HeaderHash, Point (..), fromRawHash) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..)) import Ouroboros.Consensus.Config (SecurityParam (..), TopLevelConfig, configSecurityParam) @@ -94,6 +72,28 @@ import Ouroboros.Network.Block (BlockNo (..), Point (..)) import Ouroboros.Network.Magic (NetworkMagic (..)) import qualified Ouroboros.Network.Point as Point + +import qualified Cardano.Db as DB +import Cardano.DbSync.Api.Types +import Cardano.DbSync.Cache.Types (CacheCapacity (..), newEmptyCache, useNoCache) +import Cardano.DbSync.Config.Cardano +import Cardano.DbSync.Config.Shelley +import Cardano.DbSync.Config.Types +import Cardano.DbSync.Error +import Cardano.DbSync.Ledger.Event (LedgerEvent (..)) +import Cardano.DbSync.Ledger.State ( + getHeaderHash, + hashToAnnotation, + listKnownSnapshots, + mkHasLedgerEnv, + ) +import Cardano.DbSync.Ledger.Types (HasLedgerEnv (..), LedgerStateFile (..), SnapshotPoint (..)) +import Cardano.DbSync.LocalStateQuery +import Cardano.DbSync.Types +import Cardano.DbSync.Util +import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Ledger.Shelley.Genesis as Shelley + setConsistentLevel :: SyncEnv -> ConsistentLevel -> IO () setConsistentLevel env cst = do logInfo (getTrace env) $ "Setting ConsistencyLevel to " <> textShow cst @@ -108,17 +108,17 @@ isConsistent env = do cst <- getConsistentLevel env case cst of Consistent -> pure True - _ -> pure False + _otherwise -> pure False getIsConsumedFixed :: SyncEnv -> IO (Maybe Word64) getIsConsumedFixed env = case (DB.pcmPruneTxOut pcm, DB.pcmConsumedTxOut pcm) of - (False, True) -> Just <$> DB.runDbIohkNoLogging backend (DB.queryWrongConsumedBy txOutTableType) - _ -> pure Nothing + (False, True) -> Just <$> DB.runDbIohkNoLogging backend (DB.queryWrongConsumedBy txOutVariantType) + _otherwise -> pure Nothing where - txOutTableType = getTxOutTableType env + txOutVariantType = getTxOutVariantType env pcm = soptPruneConsumeMigration $ envOptions env - backend = envBackend env + backend = envDbEnv env getDisableInOutState :: SyncEnv -> IO Bool getDisableInOutState syncEnv = do @@ -150,25 +150,25 @@ initPruneConsumeMigration consumed pruneTxOut bootstrap forceTxIn' = getPruneConsume :: SyncEnv -> DB.PruneConsumeMigration getPruneConsume = soptPruneConsumeMigration . envOptions -runExtraMigrationsMaybe :: SyncEnv -> IO () -runExtraMigrationsMaybe syncEnv = do +runConsumedTxOutMigrationsMaybe :: SyncEnv -> IO () +runConsumedTxOutMigrationsMaybe syncEnv = do let pcm = getPruneConsume syncEnv - txOutTableType = getTxOutTableType syncEnv - logInfo (getTrace syncEnv) $ "runExtraMigrationsMaybe: " <> textShow pcm - DB.runDbIohkNoLogging (envBackend syncEnv) $ - DB.runExtraMigrations + txOutVariantType = getTxOutVariantType syncEnv + logInfo (getTrace syncEnv) $ "runConsumedTxOutMigrationsMaybe: " <> textShow pcm + DB.runDbIohkNoLogging (envDbEnv syncEnv) $ + DB.runConsumedTxOutMigrations (getTrace syncEnv) - txOutTableType + txOutVariantType (getSafeBlockNoDiff syncEnv) pcm runAddJsonbToSchema :: SyncEnv -> IO () runAddJsonbToSchema syncEnv = - void $ DB.runDbIohkNoLogging (envBackend syncEnv) DB.enableJsonbInSchema + void $ DB.runDbIohkNoLogging (envDbEnv syncEnv) DB.enableJsonbInSchema runRemoveJsonbFromSchema :: SyncEnv -> IO () runRemoveJsonbFromSchema syncEnv = - void $ DB.runDbIohkNoLogging (envBackend syncEnv) DB.disableJsonbInSchema + void $ DB.runDbIohkNoLogging (envDbEnv syncEnv) DB.disableJsonbInSchema getSafeBlockNoDiff :: SyncEnv -> Word64 getSafeBlockNoDiff syncEnv = 2 * getSecurityParam syncEnv @@ -184,8 +184,8 @@ whenPruneTxOut :: (MonadIO m) => SyncEnv -> m () -> m () whenPruneTxOut env = when (DB.pcmPruneTxOut $ getPruneConsume env) -getTxOutTableType :: SyncEnv -> DB.TxOutTableType -getTxOutTableType syncEnv = ioTxOutTableType . soptInsertOptions $ envOptions syncEnv +getTxOutVariantType :: SyncEnv -> DB.TxOutVariantType +getTxOutVariantType syncEnv = ioTxOutVariantType . soptInsertOptions $ envOptions syncEnv getHasConsumedOrPruneTxOut :: SyncEnv -> Bool getHasConsumedOrPruneTxOut = @@ -224,7 +224,7 @@ generateNewEpochEvents env details = do Strict.Just oldEpoch | currentEpochNo == EpochNo (1 + unEpochNo oldEpoch) -> Just $ LedgerNewEpoch currentEpochNo (getSyncStatus details) - _ -> Nothing + _otherwise -> Nothing newCurrentEpochNo :: CurrentEpochNo newCurrentEpochNo = @@ -253,7 +253,7 @@ getNetwork sEnv = getInsertOptions :: SyncEnv -> InsertOptions getInsertOptions = soptInsertOptions . envOptions -getSlotHash :: SqlBackend -> SlotNo -> IO [(SlotNo, ByteString)] +getSlotHash :: DB.DbEnv -> SlotNo -> IO [(SlotNo, ByteString)] getSlotHash backend = DB.runDbIohkNoLogging backend . DB.querySlotHash hasLedgerState :: SyncEnv -> Bool @@ -262,10 +262,10 @@ hasLedgerState syncEnv = HasLedger _ -> True NoLedger _ -> False -getDbLatestBlockInfo :: SqlBackend -> IO (Maybe TipInfo) -getDbLatestBlockInfo backend = do +getDbLatestBlockInfo :: DB.DbEnv -> IO (Maybe TipInfo) +getDbLatestBlockInfo dbEnv = do runMaybeT $ do - block <- MaybeT $ DB.runDbIohkNoLogging backend DB.queryLatestBlock + block <- MaybeT $ DB.runDbIohkNoLogging dbEnv DB.queryLatestBlock -- The EpochNo, SlotNo and BlockNo can only be zero for the Byron -- era, but we need to make the types match, hence `fromMaybe`. pure $ @@ -278,12 +278,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 +302,63 @@ 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 -> + -- | run migration function + RunMigration -> + IO (Either SyncNodeError SyncEnv) +mkSyncEnvFromConfig trce dbEnv connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams 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 + runMigrationFnc + mkSyncEnv :: Trace IO Text -> - SqlBackend -> + DB.DbEnv -> ConnectionString -> SyncOptions -> ProtocolInfo CardanoBlock -> @@ -320,8 +369,7 @@ mkSyncEnv :: SyncNodeParams -> RunMigration -> IO SyncEnv -mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runMigrationFnc = do - dbCNamesVar <- newTVarIO =<< dbConstraintNamesExists backend +mkSyncEnv trce dbEnv connectionString syncOptions protoInfo nw nwMagic systemStart syncNodeConfigFromFile syncNP runMigrationFnc = do cache <- if soptCache syncOptions then @@ -336,7 +384,7 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS else pure useNoCache consistentLevelVar <- newTVarIO Unchecked indexesVar <- newTVarIO $ enpForceIndexes syncNP - bts <- getBootstrapInProgress trce (isTxOutConsumedBootstrap' syncNodeConfigFromFile) backend + bts <- getBootstrapInProgress trce (isTxOutConsumedBootstrap' syncNodeConfigFromFile) dbEnv bootstrapVar <- newTVarIO bts -- Offline Pool + Anchor queues opwq <- newTBQueueIO 1000 @@ -367,12 +415,11 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS pure $ SyncEnv - { envBackend = backend + { envDbEnv = dbEnv , envBootstrap = bootstrapVar , envCache = cache , envConnectionString = connectionString , envConsistentLevel = consistentLevelVar - , envDbConstraints = dbCNamesVar , envCurrentEpochNo = epochVar , envEpochSyncTime = epochSyncTime , envIndexes = indexesVar @@ -391,54 +438,6 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS hasLedger' = hasLedger . sioLedger . dncInsertOptions isTxOutConsumedBootstrap' = isTxOutConsumedBootstrap . sioTxOut . dncInsertOptions -mkSyncEnvFromConfig :: - Trace IO Text -> - SqlBackend -> - ConnectionString -> - SyncOptions -> - GenesisConfig -> - SyncNodeConfig -> - SyncNodeParams -> - -- | run migration function - RunMigration -> - IO (Either SyncNodeError SyncEnv) -mkSyncEnvFromConfig trce backend connectionString syncOptions genCfg syncNodeConfigFromFile syncNodeParams 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 - backend - connectionString - syncOptions - (fst $ mkProtocolInfoCardano genCfg []) - (Shelley.sgNetworkId $ scConfig sCfg) - (NetworkMagic . unProtocolMagicId $ Byron.configProtocolMagicId bCfg) - (SystemStart . Byron.gdStartTime $ Byron.configGenesisData bCfg) - syncNodeConfigFromFile - syncNodeParams - runMigrationFnc -- | 'True' is for in memory points and 'False' for on disk getLatestPoints :: SyncEnv -> IO [(CardanoPoint, Bool)] @@ -449,7 +448,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,20 +460,20 @@ 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 - _ -> pure Nothing + _otherwise -> pure Nothing validLedgerFileToPoint (InMemory pnt) = do 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) - _ -> pure Nothing + _otherwise -> pure Nothing convertToDiskPoint :: SlotNo -> ByteString -> Maybe (CardanoPoint, Bool) convertToDiskPoint slot hashBlob = (,False) <$> convertToPoint slot hashBlob @@ -501,10 +500,10 @@ getMaxRollbacks = maxRollbacks . configSecurityParam . pInfoConfig getBootstrapInProgress :: Trace IO Text -> Bool -> - SqlBackend -> + DB.DbEnv -> IO Bool -getBootstrapInProgress trce bootstrapFlag sqlBackend = do - DB.runDbIohkNoLogging sqlBackend $ do +getBootstrapInProgress trce bootstrapFlag dbEnv = do + DB.runDbIohkNoLogging dbEnv $ do ems <- DB.queryAllExtraMigrations let btsState = DB.bootstrapState ems case (bootstrapFlag, btsState) of diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs index c0afff911..c9993d5b5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs @@ -49,23 +49,23 @@ import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState) import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus bootStrapMaybe :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () bootStrapMaybe syncEnv = do bts <- liftIO $ readTVarIO (envBootstrap syncEnv) when bts $ migrateBootstrapUTxO syncEnv migrateBootstrapUTxO :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () migrateBootstrapUTxO syncEnv = do case envLedgerEnv syncEnv of HasLedger lenv -> do liftIO $ logInfo trce "Starting UTxO bootstrap migration" cls <- liftIO $ readCurrentStateUnsafe lenv - count <- lift $ DB.deleteTxOut (getTxOutTableType syncEnv) + count <- lift $ DB.deleteTxOut (getTxOutVariantType syncEnv) when (count > 0) $ liftIO $ logWarning trce $ @@ -80,10 +80,10 @@ migrateBootstrapUTxO syncEnv = do trce = getTrace syncEnv storeUTxOFromLedger :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> ExtLedgerState CardanoBlock -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () storeUTxOFromLedger env st = case ledgerState st of LedgerStateBabbage bts -> storeUTxO env (getUTxO bts) LedgerStateConway stc -> storeUTxO env (getUTxO stc) @@ -109,7 +109,7 @@ storeUTxO :: ) => SyncEnv -> Map (TxIn StandardCrypto) (BabbageTxOut era) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () storeUTxO env mp = do liftIO $ logInfo trce $ @@ -140,16 +140,16 @@ storePage :: SyncEnv -> Float -> (Int, [(TxIn StandardCrypto, BabbageTxOut era)]) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () storePage syncEnv percQuantum (n, ls) = do when (n `mod` 10 == 0) $ liftIO $ logInfo trce $ "Bootstrap in progress " <> prc <> "%" txOuts <- mapM (prepareTxOut syncEnv) ls txOutIds <- lift . DB.insertManyTxOut False $ etoTxOut . fst <$> txOuts - let maTxOuts = concatMap (mkmaTxOuts txOutTableType) $ zip txOutIds (snd <$> txOuts) + let maTxOuts = concatMap (mkmaTxOuts txOutVariantType) $ zip txOutIds (snd <$> txOuts) void . lift $ DB.insertManyMaTxOut maTxOuts where - txOutTableType = getTxOutTableType syncEnv + txOutVariantType = getTxOutVariantType syncEnv trce = getTrace syncEnv prc = Text.pack $ showGFloat (Just 1) (max 0 $ min 100.0 (fromIntegral n * percQuantum)) "" @@ -166,7 +166,7 @@ prepareTxOut :: ) => SyncEnv -> (TxIn StandardCrypto, BabbageTxOut era) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut]) + ExceptT SyncNodeError (DB.DbAction m) (ExtendedTxOut, [MissingMaTxOut]) prepareTxOut syncEnv (TxIn txIntxId (TxIx index), txOut) = do let txHashByteString = Generic.safeHashToByteString $ unTxId txIntxId let genTxOut = fromTxOut index txOut diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs index cb10af966..ace61cd88 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Types.hs @@ -32,16 +32,15 @@ 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 (..)) +-- | SyncEnv is the main environment for the whole application. data SyncEnv = SyncEnv - { envBackend :: !SqlBackend + { envDbEnv :: !DB.DbEnv , envCache :: !CacheStatus , envConnectionString :: !ConnectionString , envConsistentLevel :: !(StrictTVar IO ConsistentLevel) - , envDbConstraints :: !(StrictTVar IO DB.ManualDbConstraints) , envCurrentEpochNo :: !(StrictTVar IO CurrentEpochNo) , envEpochSyncTime :: !(StrictTVar IO UTCTime) , envIndexes :: !(StrictTVar IO Bool) @@ -83,7 +82,7 @@ data InsertOptions = InsertOptions , ioPoolStats :: !Bool , ioGov :: !Bool , ioRemoveJsonbFromSchema :: !Bool - , ioTxOutTableType :: !DB.TxOutTableType + , ioTxOutVariantType :: !DB.TxOutVariantType } deriving (Show) diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache.hs b/cardano-db-sync/src/Cardano/DbSync/Cache.hs index 36c8315fd..4c64610de 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache.hs @@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module Cardano.DbSync.Cache ( @@ -32,15 +31,13 @@ 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.Variants.TxOutAddress as VA import Cardano.DbSync.Cache.Epoch (rollbackMapEpochInCache) import qualified Cardano.DbSync.Cache.FIFO as FIFO import qualified Cardano.DbSync.Cache.LRU as LRU import Cardano.DbSync.Cache.Types (CacheAction (..), CacheInternal (..), CacheStatistics (..), CacheStatus (..), StakeCache (..), initCacheStatistics, shouldCache) import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic import Cardano.DbSync.Era.Shelley.Query -import Cardano.DbSync.Era.Util -import Cardano.DbSync.Error import Cardano.DbSync.Types import qualified Cardano.Ledger.Address as Ledger import Cardano.Ledger.BaseTypes (Network) @@ -53,10 +50,8 @@ import Control.Concurrent.Class.MonadSTM.Strict ( readTVarIO, writeTVar, ) -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Either.Combinators import qualified Data.Map.Strict as Map -import Database.Persist.Postgresql (SqlBackend) import Ouroboros.Consensus.Cardano.Block (StandardCrypto) -- Rollbacks make everything harder and the same applies to caching. @@ -74,7 +69,7 @@ import Ouroboros.Consensus.Cardano.Block (StandardCrypto) -- NOTE: BlockId is cleaned up on rollbacks, since it may get reinserted on -- a different id. -- NOTE: Other tables are not cleaned up since they are not rollbacked. -rollbackCache :: MonadIO m => CacheStatus -> DB.BlockId -> ReaderT SqlBackend m () +rollbackCache :: MonadIO m => CacheStatus -> DB.BlockId -> DB.DbAction m () rollbackCache NoCache _ = pure () rollbackCache (ActiveCache cache) blockId = do liftIO $ do @@ -86,7 +81,7 @@ rollbackCache (ActiveCache cache) blockId = do -- | When syncing and we get within 2 minutes of the tip, we can optimise the caches -- and set the flag to True on ActiveCache.leaving the following caches as they are: -- cPools, cPrevBlock, Cstats, cEpoch -optimiseCaches :: MonadIO m => CacheStatus -> ReaderT SqlBackend m () +optimiseCaches :: MonadIO m => CacheStatus -> DB.DbAction m () optimiseCaches cache = case cache of NoCache -> pure () @@ -110,36 +105,39 @@ getCacheStatistics cs = ActiveCache ci -> readTVarIO (cStats ci) queryOrInsertRewardAccount :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> CacheAction -> Ledger.RewardAccount StandardCrypto -> - ReaderT SqlBackend m DB.StakeAddressId + DB.DbAction m DB.StakeAddressId queryOrInsertRewardAccount trce cache cacheUA rewardAddr = do eiAddrId <- queryStakeAddrWithCacheRetBs trce cache cacheUA rewardAddr case eiAddrId of - Left (_err, bs) -> insertStakeAddress rewardAddr (Just bs) - Right addrId -> pure addrId + Just addrId -> pure addrId + Nothing -> do + -- TODO: Cmdv is this the right byteString? + let bs = Ledger.serialiseRewardAccount rewardAddr + insertStakeAddress rewardAddr (Just bs) queryOrInsertStakeAddress :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> CacheAction -> Network -> StakeCred -> - ReaderT SqlBackend m DB.StakeAddressId + DB.DbAction m DB.StakeAddressId queryOrInsertStakeAddress trce cache cacheUA nw cred = queryOrInsertRewardAccount trce cache cacheUA $ Ledger.RewardAccount nw cred -- If the address already exists in the table, it will not be inserted again (due to -- the uniqueness constraint) but the function will return the 'StakeAddressId'. insertStakeAddress :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Ledger.RewardAccount StandardCrypto -> Maybe ByteString -> - ReaderT SqlBackend m DB.StakeAddressId + DB.DbAction m DB.StakeAddressId insertStakeAddress rewardAddr stakeCredBs = do DB.insertStakeAddress $ DB.StakeAddress @@ -158,9 +156,9 @@ queryStakeAddrWithCache :: CacheAction -> Network -> StakeCred -> - ReaderT SqlBackend m (Either DB.LookupFail DB.StakeAddressId) + DB.DbAction m (Maybe DB.StakeAddressId) queryStakeAddrWithCache trce cache cacheUA nw cred = - mapLeft fst <$> queryStakeAddrWithCacheRetBs trce cache cacheUA (Ledger.RewardAccount nw cred) + queryStakeAddrWithCacheRetBs trce cache cacheUA (Ledger.RewardAccount nw cred) queryStakeAddrWithCacheRetBs :: forall m. @@ -169,13 +167,13 @@ queryStakeAddrWithCacheRetBs :: CacheStatus -> CacheAction -> Ledger.RewardAccount StandardCrypto -> - ReaderT SqlBackend m (Either (DB.LookupFail, ByteString) DB.StakeAddressId) + DB.DbAction m (Maybe DB.StakeAddressId) queryStakeAddrWithCacheRetBs _trce cache cacheUA ra@(Ledger.RewardAccount _ cred) = do let bs = Ledger.serialiseRewardAccount ra case cache of - NoCache -> rsStkAdrrs bs + NoCache -> resolveStakeAddress bs ActiveCache ci -> do - withCacheOptimisationCheck ci (rsStkAdrrs bs) $ do + withCacheOptimisationCheck ci (resolveStakeAddress bs) $ do stakeCache <- liftIO $ readTVarIO (cStake ci) case queryStakeCache cred stakeCache of Just (addrId, stakeCache') -> do @@ -183,16 +181,16 @@ queryStakeAddrWithCacheRetBs _trce cache cacheUA ra@(Ledger.RewardAccount _ cred case cacheUA of EvictAndUpdateCache -> do liftIO $ atomically $ writeTVar (cStake ci) $ deleteStakeCache cred stakeCache' - pure $ Right addrId + pure $ Just addrId _other -> do liftIO $ atomically $ writeTVar (cStake ci) stakeCache' - pure $ Right addrId + pure $ Just addrId Nothing -> do - queryRes <- mapLeft (,bs) <$> resolveStakeAddress bs + queryRes <- resolveStakeAddress bs liftIO $ missCreds (cStats ci) case queryRes of - Left _ -> pure queryRes - Right stakeAddrsId -> do + Nothing -> pure queryRes + Just stakeAddrsId -> do let !stakeCache' = case cacheUA of UpdateCache -> stakeCache {scLruCache = LRU.insert cred stakeAddrsId (scLruCache stakeCache)} UpdateCacheStrong -> stakeCache {scStableCache = Map.insert cred stakeAddrsId (scStableCache stakeCache)} @@ -200,9 +198,7 @@ queryStakeAddrWithCacheRetBs _trce cache cacheUA ra@(Ledger.RewardAccount _ cred liftIO $ atomically $ writeTVar (cStake ci) stakeCache' - pure $ Right stakeAddrsId - where - rsStkAdrrs bs = mapLeft (,bs) <$> resolveStakeAddress bs + pure $ Just stakeAddrsId -- | True if it was found in LRU queryStakeCache :: StakeCred -> StakeCache -> Maybe (DB.StakeAddressId, StakeCache) @@ -221,13 +217,13 @@ queryPoolKeyWithCache :: CacheStatus -> CacheAction -> PoolKeyHash -> - ReaderT SqlBackend m (Either DB.LookupFail DB.PoolHashId) + DB.DbAction m (Either DB.DbError DB.PoolHashId) queryPoolKeyWithCache cache cacheUA hsh = case cache of NoCache -> do mPhId <- DB.queryPoolHashId (Generic.unKeyHashRaw hsh) case mPhId of - Nothing -> pure $ Left (DB.DbLookupMessage "PoolKeyHash") + Nothing -> pure $ Left $ DB.DbError DB.mkCallSite "queryPoolKeyWithCache: NoCache queryPoolHashId" Nothing Just phId -> pure $ Right phId ActiveCache ci -> do mp <- liftIO $ readTVarIO (cPools ci) @@ -245,7 +241,7 @@ queryPoolKeyWithCache cache cacheUA hsh = liftIO $ missPools (cStats ci) mPhId <- DB.queryPoolHashId (Generic.unKeyHashRaw hsh) case mPhId of - Nothing -> pure $ Left (DB.DbLookupMessage "PoolKeyHash") + Nothing -> throwError $ DB.DbError DB.mkCallSite "queryPoolKeyWithCache: ActiveCache queryPoolHashId" Nothing Just phId -> do -- missed so we can't evict even with 'EvictAndReturn' when (shouldCache cacheUA) $ @@ -255,13 +251,13 @@ queryPoolKeyWithCache cache cacheUA hsh = Map.insert hsh phId pure $ Right phId + insertAddressUsingCache :: - (MonadBaseControl IO m, MonadIO m) => - CacheStatus -> + MonadIO m =>CacheStatus -> CacheAction -> ByteString -> - V.Address -> - ReaderT SqlBackend m V.AddressId + VA.Address -> + DB.DbAction m DB.AddressId insertAddressUsingCache cache cacheUA addrRaw vAdrs = do case cache of NoCache -> do @@ -311,11 +307,11 @@ insertAddressUsingCache cache cacheUA addrRaw vAdrs = do LRU.insert addrRaw addrId insertPoolKeyWithCache :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => CacheStatus -> CacheAction -> PoolKeyHash -> - ReaderT SqlBackend m DB.PoolHashId + DB.DbAction m DB.PoolHashId insertPoolKeyWithCache cache cacheUA pHash = case cache of NoCache -> @@ -351,14 +347,14 @@ insertPoolKeyWithCache cache cacheUA pHash = pure phId queryPoolKeyOrInsert :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Text -> Trace IO Text -> CacheStatus -> CacheAction -> Bool -> PoolKeyHash -> - ReaderT SqlBackend m DB.PoolHashId + DB.DbAction m DB.PoolHashId queryPoolKeyOrInsert txt trce cache cacheUA logsWarning hsh = do pk <- queryPoolKeyWithCache cache cacheUA hsh case pk of @@ -383,7 +379,7 @@ queryMAWithCache :: CacheStatus -> PolicyID StandardCrypto -> AssetName -> - ReaderT SqlBackend m (Either (ByteString, ByteString) DB.MultiAssetId) + DB.DbAction m (Either (ByteString, ByteString) DB.MultiAssetId) queryMAWithCache cache policyId asset = case cache of NoCache -> queryDb @@ -412,13 +408,12 @@ queryMAWithCache cache policyId asset = queryPrevBlockWithCache :: MonadIO m => - Text -> CacheStatus -> ByteString -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.BlockId -queryPrevBlockWithCache msg cache hsh = + DB.DbAction m (Maybe DB.BlockId) +queryPrevBlockWithCache cache hsh = case cache of - NoCache -> liftLookupFail msg $ DB.queryBlockId hsh + NoCache -> DB.queryBlockId hsh ActiveCache ci -> do mCachedPrev <- liftIO $ readTVarIO (cPrevBlock ci) case mCachedPrev of @@ -427,23 +422,23 @@ queryPrevBlockWithCache msg cache hsh = if cachedHash == hsh then do liftIO $ hitPBlock (cStats ci) - pure cachedBlockId + pure $ Just cachedBlockId else queryFromDb ci Nothing -> queryFromDb ci where queryFromDb :: MonadIO m => CacheInternal -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.BlockId + DB.DbAction m (Maybe DB.BlockId) queryFromDb ci = do liftIO $ missPrevBlock (cStats ci) - liftLookupFail msg $ DB.queryBlockId hsh + DB.queryBlockId hsh queryTxIdWithCache :: MonadIO m => CacheStatus -> Ledger.TxId StandardCrypto -> - ReaderT SqlBackend m (Either DB.LookupFail DB.TxId) + DB.DbAction m DB.TxId queryTxIdWithCache cache txIdLedger = do case cache of -- Direct database query if no cache. @@ -452,24 +447,19 @@ queryTxIdWithCache cache txIdLedger = do withCacheOptimisationCheck ci qTxHash $ do -- Read current cache state. cacheTx <- liftIO $ readTVarIO (cTxIds ci) - case FIFO.lookup txIdLedger cacheTx of -- Cache hit, return the transaction ID. Just txId -> do liftIO $ hitTxIds (cStats ci) - pure $ Right txId + pure txId -- Cache miss. Nothing -> do - eTxId <- qTxHash + txId <- qTxHash liftIO $ missTxIds (cStats ci) - case eTxId of - Right txId -> do - -- Update cache. - liftIO $ atomically $ modifyTVar (cTxIds ci) $ FIFO.insert txIdLedger txId - -- Return ID after updating cache. - pure $ Right txId - -- Return lookup failure. - Left _ -> pure $ Left $ DB.DbLookupTxHash txHash + -- Update cache. + liftIO $ atomically $ modifyTVar (cTxIds ci) $ FIFO.insert txIdLedger txId + -- Return ID after updating cache. + pure txId where txHash = Generic.unTxHash txIdLedger qTxHash = DB.queryTxId txHash @@ -485,10 +475,10 @@ tryUpdateCacheTx (ActiveCache ci) ledgerTxId txId = tryUpdateCacheTx _ _ _ = pure () insertBlockAndCache :: - (MonadIO m, MonadBaseControl IO m) => + MonadIO m => CacheStatus -> DB.Block -> - ReaderT SqlBackend m DB.BlockId + DB.DbAction m DB.BlockId insertBlockAndCache cache block = case cache of NoCache -> insBlck @@ -506,7 +496,7 @@ queryDatum :: MonadIO m => CacheStatus -> DataHash -> - ReaderT SqlBackend m (Maybe DB.DatumId) + DB.DbAction m (Maybe DB.DatumId) queryDatum cache hsh = do case cache of NoCache -> queryDtm @@ -527,11 +517,11 @@ queryDatum cache hsh = do -- This assumes the entry is not cached. insertDatumAndCache :: - (MonadIO m, MonadBaseControl IO m) => + MonadIO m => CacheStatus -> DataHash -> DB.Datum -> - ReaderT SqlBackend m DB.DatumId + DB.DbAction m DB.DatumId insertDatumAndCache cache hsh dt = do datumId <- DB.insertDatum dt case cache of diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Cache/Epoch.hs index a7877cdcd..b50043703 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/Epoch.hs @@ -14,13 +14,11 @@ import qualified Cardano.Db as DB import Cardano.DbSync.Api.Types (LedgerEnv (..), SyncEnv (..)) import Cardano.DbSync.Cache.Types (CacheEpoch (..), CacheInternal (..), CacheStatus (..), EpochBlockDiff (..)) import Cardano.DbSync.Era.Shelley.Generic.StakeDist (getSecurityParameter) -import Cardano.DbSync.Error (SyncNodeError (..)) import Cardano.DbSync.Ledger.Types (HasLedgerEnv (..)) import Cardano.DbSync.LocalStateQuery (NoLedgerEnv (..)) import Cardano.Prelude import Control.Concurrent.Class.MonadSTM.Strict (readTVarIO, writeTVar) import Data.Map.Strict (deleteMin, insert, lookupMax, size, split) -import Database.Persist.Postgresql (SqlBackend) ------------------------------------------------------------------------------------- -- Epoch Cache @@ -56,7 +54,7 @@ readLastMapEpochFromCache cache = Nothing -> pure Nothing Just (_, ep) -> pure $ Just ep -rollbackMapEpochInCache :: MonadIO m => CacheInternal -> DB.BlockId -> m (Either SyncNodeError ()) +rollbackMapEpochInCache :: MonadIO m => CacheInternal -> DB.BlockId -> m () rollbackMapEpochInCache cacheInternal blockId = do cE <- liftIO $ readTVarIO (cEpoch cacheInternal) -- split the map and delete anything after blockId including it self as new blockId might be @@ -68,10 +66,10 @@ writeEpochBlockDiffToCache :: MonadIO m => CacheStatus -> EpochBlockDiff -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () writeEpochBlockDiffToCache cache epCurrent = case cache of - NoCache -> pure $ Left $ SNErrDefault "writeEpochBlockDiffToCache: Cache is NoCache" + NoCache -> throwError $ DB.DbError DB.mkCallSite "writeEpochBlockDiffToCache: Cache is NoCache" Nothing ActiveCache ci -> do cE <- liftIO $ readTVarIO (cEpoch ci) case (ceMapEpoch cE, ceEpochBlockDiff cE) of @@ -85,7 +83,7 @@ writeToMapEpochCache :: SyncEnv -> CacheStatus -> DB.Epoch -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () writeToMapEpochCache syncEnv cache latestEpoch = do -- this can also be tought of as max rollback number let securityParam = @@ -93,12 +91,12 @@ writeToMapEpochCache syncEnv cache latestEpoch = do HasLedger hle -> getSecurityParameter $ leProtocolInfo hle NoLedger nle -> getSecurityParameter $ nleProtocolInfo nle case cache of - NoCache -> pure $ Left $ SNErrDefault "writeToMapEpochCache: Cache is NoCache" + NoCache -> throwError $ DB.DbError DB.mkCallSite "writeToMapEpochCache: Cache is NoCache" Nothing ActiveCache ci -> do -- get EpochBlockDiff so we can use the BlockId we stored when inserting blocks epochInternalCE <- readEpochBlockDiffFromCache cache case epochInternalCE of - Nothing -> pure $ Left $ SNErrDefault "writeToMapEpochCache: No epochInternalEpochCache" + Nothing -> throwError $ DB.DbError DB.mkCallSite "writeToMapEpochCache: No epochInternalEpochCache" Nothing Just ei -> do cE <- liftIO $ readTVarIO (cEpoch ci) let currentBlockId = ebdBlockId ei @@ -117,7 +115,6 @@ writeToMapEpochCache syncEnv cache latestEpoch = do -- Helpers ------------------------------------------------------------------ -writeToCache :: MonadIO m => CacheInternal -> CacheEpoch -> m (Either SyncNodeError ()) +writeToCache :: MonadIO m => CacheInternal -> CacheEpoch -> m () writeToCache ci newCacheEpoch = do void $ liftIO $ atomically $ writeTVar (cEpoch ci) newCacheEpoch - pure $ Right () diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs index 9c060f907..bbe7d2a11 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs @@ -31,7 +31,6 @@ module Cardano.DbSync.Cache.Types ( ) where import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Variant.TxOut as V import Cardano.DbSync.Cache.FIFO (FIFOCache) import qualified Cardano.DbSync.Cache.FIFO as FIFO import Cardano.DbSync.Cache.LRU (LRUCache) @@ -83,7 +82,7 @@ data CacheInternal = CacheInternal , cPrevBlock :: !(StrictTVar IO (Maybe (DB.BlockId, ByteString))) , cStats :: !(StrictTVar IO CacheStatistics) , cEpoch :: !(StrictTVar IO CacheEpoch) - , cAddress :: !(StrictTVar IO (LRUCache ByteString V.AddressId)) + , cAddress :: !(StrictTVar IO (LRUCache ByteString DB.AddressId)) , cTxIds :: !(StrictTVar IO (FIFOCache (Ledger.TxId StandardCrypto) DB.TxId)) } 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..e543064b9 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -19,7 +19,7 @@ module Cardano.DbSync.Config.Types ( GenesisHashAlonzo (..), GenesisHashConway (..), RemoveJsonbFromSchemaConfig (..), - TxOutTableTypeConfig (..), + TxOutVariantTypeConfig (..), SyncNodeConfig (..), SyncPreConfig (..), SyncInsertConfig (..), @@ -69,7 +69,7 @@ import qualified Cardano.BM.Data.Configuration as Logging import qualified Cardano.Chain.Update as Byron import Cardano.Crypto (RequiresNetworkMagic (..)) import qualified Cardano.Crypto.Hash as Crypto -import Cardano.Db (MigrationDir, PGPassSource (..), TxOutTableType (..)) +import Cardano.Db (MigrationDir, PGPassSource (..), TxOutVariantType (..)) import Cardano.Prelude import Cardano.Slotting.Slot (SlotNo (..)) import Control.Monad (fail) @@ -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 @@ -185,6 +187,7 @@ data SyncInsertOptions = SyncInsertOptions , sioPoolStats :: PoolStatsConfig , sioJsonType :: JsonTypeConfig , sioRemoveJsonbFromSchema :: RemoveJsonbFromSchemaConfig + , sioDbDebug :: Bool } deriving (Eq, Show) @@ -263,8 +266,8 @@ newtype RemoveJsonbFromSchemaConfig = RemoveJsonbFromSchemaConfig } deriving (Eq, Show) -newtype TxOutTableTypeConfig = TxOutTableTypeConfig - { unTxOutTableTypeConfig :: TxOutTableType +newtype TxOutVariantTypeConfig = TxOutVariantTypeConfig + { unTxOutVariantTypeConfig :: TxOutVariantType } deriving (Eq, Show) @@ -384,7 +387,7 @@ isPlutusEnabled PlutusDisable = False isPlutusEnabled PlutusEnable = True isPlutusEnabled (PlutusScripts _) = True --- ------------------------------------------------------------------------------------------------- +--------------------------------------------------------------------------------------------------- instance FromJSON SyncPreConfig where parseJSON = @@ -398,6 +401,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 +455,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 +477,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 +499,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 +516,7 @@ instance ToJSON SyncInsertOptions where , "pool_stat" .= sioPoolStats , "json_type" .= sioJsonType , "remove_jsonb_from_schema" .= sioRemoveJsonbFromSchema + , "db_debug" .= sioDbDebug ] instance ToJSON RewardsConfig where @@ -692,14 +700,14 @@ instance FromJSON RemoveJsonbFromSchemaConfig where instance ToJSON RemoveJsonbFromSchemaConfig where toJSON = boolToEnableDisable . isRemoveJsonbFromSchemaEnabled -instance FromJSON TxOutTableTypeConfig where +instance FromJSON TxOutVariantTypeConfig where parseJSON = Aeson.withText "use_address_table" $ \v -> - case enableDisableToTxOutTableType v of - Just g -> pure (TxOutTableTypeConfig g) + case enableDisableToTxOutVariantType v of + Just g -> pure (TxOutVariantTypeConfig g) Nothing -> fail $ "unexpected use_address_table: " <> show v -instance ToJSON TxOutTableTypeConfig where - toJSON = addressTypeToEnableDisable . unTxOutTableTypeConfig +instance ToJSON TxOutVariantTypeConfig where + toJSON = addressTypeToEnableDisable . unTxOutVariantTypeConfig instance FromJSON OffchainPoolDataConfig where parseJSON = Aeson.withText "offchain_pool_data" $ \v -> @@ -738,6 +746,7 @@ instance Default SyncInsertOptions where , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioDbDebug = False } fullInsertOptions :: SyncInsertOptions @@ -756,6 +765,7 @@ fullInsertOptions = , sioPoolStats = PoolStatsConfig True , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioDbDebug = False } onlyUTxOInsertOptions :: SyncInsertOptions @@ -774,6 +784,7 @@ onlyUTxOInsertOptions = , sioPoolStats = PoolStatsConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioDbDebug = False } onlyGovInsertOptions :: SyncInsertOptions @@ -800,16 +811,17 @@ disableAllInsertOptions = , sioGovernance = GovernanceConfig False , sioJsonType = JsonTypeText , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False + , sioDbDebug = False } -addressTypeToEnableDisable :: IsString s => TxOutTableType -> s +addressTypeToEnableDisable :: IsString s => TxOutVariantType -> s addressTypeToEnableDisable TxOutVariantAddress = "enable" -addressTypeToEnableDisable TxOutCore = "disable" +addressTypeToEnableDisable TxOutVariantCore = "disable" -enableDisableToTxOutTableType :: (Eq s, IsString s) => s -> Maybe TxOutTableType -enableDisableToTxOutTableType = \case +enableDisableToTxOutVariantType :: (Eq s, IsString s) => s -> Maybe TxOutVariantType +enableDisableToTxOutVariantType = \case "enable" -> Just TxOutVariantAddress - "disable" -> Just TxOutCore + "disable" -> Just TxOutVariantCore _ -> Nothing boolToEnableDisable :: IsString s => Bool -> s diff --git a/cardano-db-sync/src/Cardano/DbSync/Database.hs b/cardano-db-sync/src/Cardano/DbSync/Database.hs index 4583b8204..7ad1606fb 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Database.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Database.hs @@ -4,9 +4,9 @@ {-# LANGUAGE NoImplicitPrelude #-} module Cardano.DbSync.Database ( - DbAction (..), + DbEvent (..), ThreadChannels, - lengthDbActionQueue, + lengthDbEventQueue, mkDbApply, runDbThread, ) where @@ -14,7 +14,7 @@ module Cardano.DbSync.Database ( import Cardano.BM.Trace (logDebug, logError, logInfo) import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (ConsistentLevel (..), LedgerEnv (..), SyncEnv (..)) -import Cardano.DbSync.DbAction +import Cardano.DbSync.DbEvent import Cardano.DbSync.Default import Cardano.DbSync.Error import Cardano.DbSync.Ledger.State @@ -44,53 +44,111 @@ 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 - --- | Run the list of 'DbAction's. Block are applied in a single set (as a transaction) + tracer = getTrace syncEnv + + -- Main loop to process the queue + processQueue :: IO () + processQueue = do + actions <- blockingFlushDbEventQueue 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 :: [DbEvent] -> 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 <- blockingFlushDbEventQueue 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 'DbEvent's. Block are applied in a single set (as a transaction) -- and other operations are applied one-by-one. runActions :: SyncEnv -> - [DbAction] -> + [DbEvent] -> ExceptT SyncNodeError IO NextState runActions syncEnv actions = do - dbAction Continue actions + dbEvent Continue actions where - dbAction :: NextState -> [DbAction] -> ExceptT SyncNodeError IO NextState - dbAction next [] = pure next - dbAction Done _ = pure Done - dbAction Continue xs = + dbEvent :: NextState -> [DbEvent] -> ExceptT SyncNodeError IO NextState + dbEvent next [] = pure next + dbEvent Done _ = pure Done + dbEvent Continue xs = case spanDbApply xs of ([], DbFinish : _) -> do pure Done @@ -113,12 +171,12 @@ runActions syncEnv actions = do liftIO $ setConsistentLevel syncEnv DBAheadOfLedger blockNo <- lift $ getDbTipBlockNo syncEnv lift $ atomically $ putTMVar resultVar (points, blockNo) - dbAction Continue ys + dbEvent Continue ys (ys, zs) -> do newExceptT $ insertListBlocks syncEnv ys if null zs then pure Continue - else dbAction Continue zs + else dbEvent Continue zs rollbackLedger :: SyncEnv -> CardanoPoint -> IO (Maybe [CardanoPoint]) rollbackLedger syncEnv point = @@ -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 @@ -180,14 +238,14 @@ validateConsistentLevel syncEnv stPoint = do , show cLevel ] --- | Split the DbAction list into a prefix containing blocks to apply and a postfix. -spanDbApply :: [DbAction] -> ([CardanoBlock], [DbAction]) +-- | Split the DbEvent list into a prefix containing blocks to apply and a postfix. +spanDbApply :: [DbEvent] -> ([CardanoBlock], [DbEvent]) spanDbApply lst = case lst of (DbApplyBlock bt : xs) -> let (ys, zs) = spanDbApply xs in (bt : ys, zs) xs -> ([], xs) -hasRestart :: [DbAction] -> Maybe (StrictTMVar IO ([(CardanoPoint, Bool)], WithOrigin BlockNo)) +hasRestart :: [DbEvent] -> Maybe (StrictTMVar IO ([(CardanoPoint, Bool)], WithOrigin BlockNo)) hasRestart = go where go [] = Nothing diff --git a/cardano-db-sync/src/Cardano/DbSync/DbAction.hs b/cardano-db-sync/src/Cardano/DbSync/DbEvent.hs similarity index 80% rename from cardano-db-sync/src/Cardano/DbSync/DbAction.hs rename to cardano-db-sync/src/Cardano/DbSync/DbEvent.hs index 096280191..5a3da6a74 100644 --- a/cardano-db-sync/src/Cardano/DbSync/DbAction.hs +++ b/cardano-db-sync/src/Cardano/DbSync/DbEvent.hs @@ -1,13 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.DbAction ( - DbAction (..), +module Cardano.DbSync.DbEvent ( + DbEvent (..), ThreadChannels (..), - blockingFlushDbActionQueue, - lengthDbActionQueue, + blockingFlushDbEventQueue, + lengthDbEventQueue, mkDbApply, newThreadChannels, - writeDbActionQueue, + writeDbEventQueue, waitRollback, waitRestartState, waitDoneInit, @@ -23,18 +23,18 @@ import qualified Control.Concurrent.STM.TBQueue as TBQ import Ouroboros.Network.Block (BlockNo, Tip (..)) import qualified Ouroboros.Network.Point as Point -data DbAction +data DbEvent = DbApplyBlock !CardanoBlock | DbRollBackToPoint !CardanoPoint !(Tip CardanoBlock) (StrictTMVar IO (Maybe [CardanoPoint], Point.WithOrigin BlockNo)) | DbRestartState (StrictTMVar IO ([(CardanoPoint, Bool)], Point.WithOrigin BlockNo)) | DbFinish data ThreadChannels = ThreadChannels - { tcQueue :: TBQueue DbAction + { tcQueue :: TBQueue DbEvent , tcDoneInit :: !(StrictTVar IO Bool) } -mkDbApply :: CardanoBlock -> DbAction +mkDbApply :: CardanoBlock -> DbEvent mkDbApply = DbApplyBlock -- | This simulates a synhronous operations, since the thread waits for the db @@ -42,7 +42,7 @@ mkDbApply = DbApplyBlock waitRollback :: ThreadChannels -> CardanoPoint -> Tip CardanoBlock -> IO (Maybe [CardanoPoint], Point.WithOrigin BlockNo) waitRollback tc point serverTip = do resultVar <- newEmptyTMVarIO - atomically $ writeDbActionQueue tc $ DbRollBackToPoint point serverTip resultVar + atomically $ writeDbEventQueue tc $ DbRollBackToPoint point serverTip resultVar atomically $ takeTMVar resultVar waitRestartState :: ThreadChannels -> IO ([(CardanoPoint, Bool)], Point.WithOrigin BlockNo) @@ -50,7 +50,7 @@ waitRestartState tc = do resultVar <- newEmptyTMVarIO atomically $ do _ <- TBQ.flushTBQueue (tcQueue tc) - writeDbActionQueue tc $ DbRestartState resultVar + writeDbEventQueue tc $ DbRestartState resultVar atomically $ takeTMVar resultVar waitDoneInit :: ThreadChannels -> IO () @@ -68,8 +68,8 @@ runAndSetDone tc action = do atomically $ writeTVar (tcDoneInit tc) fl pure fl -lengthDbActionQueue :: ThreadChannels -> STM Natural -lengthDbActionQueue = STM.lengthTBQueue . tcQueue +lengthDbEventQueue :: ThreadChannels -> STM Natural +lengthDbEventQueue = STM.lengthTBQueue . tcQueue newThreadChannels :: IO ThreadChannels newThreadChannels = @@ -81,15 +81,15 @@ newThreadChannels = <$> TBQ.newTBQueueIO 47 <*> newTVarIO False -writeDbActionQueue :: ThreadChannels -> DbAction -> STM () -writeDbActionQueue = TBQ.writeTBQueue . tcQueue +writeDbEventQueue :: ThreadChannels -> DbEvent -> STM () +writeDbEventQueue = TBQ.writeTBQueue . tcQueue -- | Block if the queue is empty and if its not read/flush everything. -- Need this because `flushTBQueue` never blocks and we want to block until -- there is one item or more. -- Use this instead of STM.check to make sure it blocks if the queue is empty. -blockingFlushDbActionQueue :: ThreadChannels -> IO [DbAction] -blockingFlushDbActionQueue tc = do +blockingFlushDbEventQueue :: ThreadChannels -> IO [DbEvent] +blockingFlushDbEventQueue tc = do STM.atomically $ do x <- TBQ.readTBQueue $ tcQueue tc xs <- TBQ.flushTBQueue $ tcQueue tc diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 1703a584d..932006523 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 @@ -61,7 +61,7 @@ applyAndInsertBlockMaybe :: SyncEnv -> Trace IO Text -> CardanoBlock -> - ExceptT SyncNodeError (ReaderT SqlBackend (LoggingT IO)) () + ExceptT SyncNodeError (DB.DbAction (LoggingT IO)) () applyAndInsertBlockMaybe syncEnv tracer cblk = do bl <- liftIO $ isConsistent syncEnv (!applyRes, !tookSnapshot) <- liftIO (mkApplyResult bl) @@ -120,7 +120,7 @@ insertBlock :: Bool -> -- has snapshot been taken Bool -> - ExceptT SyncNodeError (ReaderT SqlBackend (LoggingT IO)) () + ExceptT SyncNodeError (DB.DbAction (LoggingT IO)) () insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do !epochEvents <- liftIO $ atomically $ generateNewEpochEvents syncEnv (apSlotDetails applyRes) let !applyResult = applyRes {apEvents = sort $ epochEvents <> apEvents applyRes} @@ -177,11 +177,11 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do whenPruneTxOut syncEnv $ when (unBlockNo blkNo `mod` getPruneInterval syncEnv == 0) $ do - lift $ DB.deleteConsumedTxOut tracer txOutTableType (getSafeBlockNoDiff syncEnv) + lift $ DB.deleteConsumedTxOut tracer txOutVariantType (getSafeBlockNoDiff syncEnv) commitOrIndexes withinTwoMin withinHalfHour where tracer = getTrace syncEnv - txOutTableType = getTxOutTableType syncEnv + txOutVariantType = getTxOutVariantType syncEnv iopts = getInsertOptions syncEnv updateEpoch details isNewEpochEvent = @@ -201,7 +201,7 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do Strict.Nothing | hasLedgerState syncEnv -> Just $ Ledger.Prices minBound minBound Strict.Nothing -> Nothing - commitOrIndexes :: Bool -> Bool -> ExceptT SyncNodeError (ReaderT SqlBackend (LoggingT IO)) () + commitOrIndexes :: Bool -> Bool -> ExceptT SyncNodeError (DB.DbAction (LoggingT IO)) () commitOrIndexes withinTwoMin withinHalfHour = do commited <- if withinTwoMin || tookSnapshot diff --git a/cardano-db-sync/src/Cardano/DbSync/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Epoch.hs index 113c032e4..b113982ee 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Epoch.hs @@ -14,7 +14,6 @@ import Cardano.DbSync.Api (getTrace) import Cardano.DbSync.Api.Types (SyncEnv) import Cardano.DbSync.Cache.Epoch (readEpochBlockDiffFromCache, readLastMapEpochFromCache, writeToMapEpochCache) import Cardano.DbSync.Cache.Types (CacheStatus (..), EpochBlockDiff (..)) -import Cardano.DbSync.Error import Cardano.DbSync.Types ( BlockDetails (BlockDetails), SlotDetails (..), @@ -24,8 +23,6 @@ import Cardano.DbSync.Util import Cardano.Prelude hiding (from, on, replace) import Cardano.Slotting.Slot (unEpochNo) import Control.Monad.Logger (LoggingT) -import Control.Monad.Trans.Control (MonadBaseControl) -import Database.Esqueleto.Experimental (SqlBackend, replace) import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..)) import Ouroboros.Consensus.Cardano.Block (HardForkBlock (..)) @@ -41,7 +38,7 @@ epochHandler :: CacheStatus -> Bool -> BlockDetails -> - ReaderT SqlBackend (LoggingT IO) (Either SyncNodeError ()) + DB.DbAction (LoggingT IO) () epochHandler syncEnv trce cache isNewEpochEvent (BlockDetails cblk details) = case cblk of BlockByron bblk -> @@ -60,7 +57,7 @@ epochHandler syncEnv trce cache isNewEpochEvent (BlockDetails cblk details) = BlockConway {} -> epochSlotTimecheck where -- What we do here is completely independent of Shelley/Allegra/Mary eras. - epochSlotTimecheck :: ReaderT SqlBackend (LoggingT IO) (Either SyncNodeError ()) + epochSlotTimecheck :: DB.DbAction (LoggingT IO) () epochSlotTimecheck = do when (sdSlotTime details > sdCurrentTime details) $ liftIO @@ -75,7 +72,7 @@ updateEpochStart :: SlotDetails -> Bool -> Bool -> - ReaderT SqlBackend (LoggingT IO) (Either SyncNodeError ()) + DB.DbAction (LoggingT IO) () updateEpochStart syncEnv cache slotDetails isNewEpochEvent isBoundaryBlock = do mLastMapEpochFromCache <- liftIO $ readLastMapEpochFromCache cache mEpochBlockDiff <- liftIO $ readEpochBlockDiffFromCache cache @@ -104,13 +101,13 @@ updateEpochStart syncEnv cache slotDetails isNewEpochEvent isBoundaryBlock = do -- When updating an epoch whilst following we have the opertunity to try and use the cacheEpoch values -- to calculate our epoch rather than querying the db which is expensive. handleEpochWhenFollowing :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> CacheStatus -> Maybe DB.Epoch -> Maybe EpochBlockDiff -> Word64 -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () handleEpochWhenFollowing syncEnv cache newestEpochFromMap epochBlockDiffCache epochNo = do case newestEpochFromMap of Just newestEpochFromMapCache -> do @@ -139,13 +136,13 @@ handleEpochWhenFollowing syncEnv cache newestEpochFromMap epochBlockDiffCache ep -- Update the epoch in cache and db, which could be either an update or insert -- dependent on if epoch already exists. makeEpochWithCacheWhenFollowing :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> CacheStatus -> DB.Epoch -> EpochBlockDiff -> Word64 -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () makeEpochWithCacheWhenFollowing syncEnv cache newestEpochFromMapache currentEpCache epochNo = do let calculatedEpoch = calculateNewEpoch newestEpochFromMapache currentEpCache -- if the epoch already exists then we update it otherwise create new entry. @@ -153,10 +150,10 @@ makeEpochWithCacheWhenFollowing syncEnv cache newestEpochFromMapache currentEpCa case mEpochID of Nothing -> do _ <- writeToMapEpochCache syncEnv cache calculatedEpoch - (\_ -> Right ()) <$> DB.insertEpoch calculatedEpoch + void $ DB.insertEpoch calculatedEpoch Just epochId -> do _ <- writeToMapEpochCache syncEnv cache calculatedEpoch - Right <$> replace epochId calculatedEpoch + DB.replaceEpoch epochId calculatedEpoch ----------------------------------------------------------------------------------------------------- -- When Syncing @@ -166,14 +163,14 @@ makeEpochWithCacheWhenFollowing syncEnv cache newestEpochFromMapache currentEpCa -- At that point we can get the previously accumilated data from previous epoch and insert/update it into the db. -- Whilst at the same time store the current block data into epoch cache. updateEpochWhenSyncing :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> CacheStatus -> Maybe EpochBlockDiff -> Maybe DB.Epoch -> Word64 -> Bool -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () updateEpochWhenSyncing syncEnv cache mEpochBlockDiff mLastMapEpochFromCache epochNo isBoundaryBlock = do let trce = getTrace syncEnv isFirstEpoch = epochNo == 0 @@ -194,7 +191,7 @@ updateEpochWhenSyncing syncEnv cache mEpochBlockDiff mLastMapEpochFromCache epoc Nothing -> do let calculatedEpoch = initCalculateNewEpoch epochBlockDiffCache additionalBlockCount _ <- makeEpochWithDBQuery syncEnv cache (Just calculatedEpoch) epochNo "updateEpochWhenSyncing" - pure $ Right () + pure () -- simply use cache Just lastMapEpochFromCache -> do let calculatedEpoch = initCalculateNewEpoch epochBlockDiffCache additionalBlockCount @@ -204,19 +201,18 @@ updateEpochWhenSyncing syncEnv cache mEpochBlockDiff mLastMapEpochFromCache epoc Nothing -> do liftIO . logInfo trce $ epochSucessMsg "Inserted" "updateEpochWhenSyncing" "Cache" lastMapEpochFromCache _ <- DB.insertEpoch lastMapEpochFromCache - pure $ Right () + pure () Just epochId -> do liftIO . logInfo trce $ epochSucessMsg "Replaced" "updateEpochWhenSyncing" "Cache" calculatedEpoch - Right <$> replace epochId calculatedEpoch + DB.replaceEpoch epochId calculatedEpoch -- When syncing, on every block we update the Map epoch in cache. Making sure to handle restarts handleEpochCachingWhenSyncing :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> + MonadIO m =>SyncEnv -> CacheStatus -> Maybe DB.Epoch -> Maybe EpochBlockDiff -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () handleEpochCachingWhenSyncing syncEnv cache newestEpochFromMap epochBlockDiffCache = do case (newestEpochFromMap, epochBlockDiffCache) of (Just newestEpMap, Just currentEpC) -> do @@ -228,7 +224,7 @@ handleEpochCachingWhenSyncing syncEnv cache newestEpochFromMap epochBlockDiffCac newEpoch <- DB.queryCalcEpochEntry $ ebdEpochNo currentEpC writeToMapEpochCache syncEnv cache newEpoch -- There will always be a EpochBlockDiff at this point in time - (_, _) -> pure $ Left $ SNErrDefault "handleEpochCachingWhenSyncing: No caches available to update cache" + (_, _) -> throwError $ DB.DbError DB.mkCallSite "handleEpochCachingWhenSyncing: No caches available to update cache" Nothing ----------------------------------------------------------------------------------------------------- -- Helper functions @@ -237,13 +233,12 @@ handleEpochCachingWhenSyncing syncEnv cache newestEpochFromMap epochBlockDiffCac -- This is an expensive DB query so we minimise its use to -- server restarts when syncing or following and rollbacks makeEpochWithDBQuery :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> + MonadIO m =>SyncEnv -> CacheStatus -> Maybe DB.Epoch -> Word64 -> Text -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () makeEpochWithDBQuery syncEnv cache mInitEpoch epochNo callSiteMsg = do let trce = getTrace syncEnv calcEpoch <- DB.queryCalcEpochEntry epochNo @@ -254,12 +249,12 @@ makeEpochWithDBQuery syncEnv cache mInitEpoch epochNo callSiteMsg = do _ <- writeToMapEpochCache syncEnv cache epochInitOrCalc _ <- DB.insertEpoch calcEpoch liftIO . logInfo trce $ epochSucessMsg "Inserted " callSiteMsg "DB query" calcEpoch - pure $ Right () + pure () Just epochId -> do -- write the newly calculated epoch to cache. _ <- writeToMapEpochCache syncEnv cache epochInitOrCalc liftIO . logInfo trce $ epochSucessMsg "Replaced " callSiteMsg "DB query" calcEpoch - Right <$> replace epochId calcEpoch + DB.replaceEpoch epochId calcEpoch -- Because we store a Map of epochs, at every iteration we take the newest epoch and it's values -- We then add those to the data we kept when inserting the txs & block inside the EpochBlockDiff cache. 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..65ec38389 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.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (SyncEnv (..)) import Cardano.DbSync.Cache (insertAddressUsingCache) @@ -29,13 +29,11 @@ import Cardano.DbSync.Era.Util (liftLookupFail) import Cardano.DbSync.Error import Cardano.DbSync.Util import Cardano.Prelude -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except.Extra (newExceptT) import qualified Data.ByteString.Char8 as BS import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Database.Persist.Sql (SqlBackend) import Paths_cardano_db_sync (version) -- | Idempotent insert the initial Genesis distribution transactions into the DB. @@ -49,20 +47,20 @@ 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 tracer (envDbEnv syncEnv) insertAction + else newExceptT $ DB.runDbIohkNoLogging (envDbEnv syncEnv) insertAction where tracer = getTrace syncEnv - insertAction :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m (Either SyncNodeError ()) + insertAction :: MonadIO m => DB.DbAction m (Either SyncNodeError ()) insertAction = do disInOut <- liftIO $ getDisableInOutState syncEnv let prunes = getPrunes syncEnv ebid <- DB.queryBlockId (configGenesisHash cfg) case ebid of - Right bid -> validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid - Left _ -> + Just bid -> validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid + Nothing -> runExceptT $ do liftIO $ logInfo tracer "Inserting Byron Genesis distribution" count <- lift DB.queryBlockCount @@ -114,12 +112,12 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do "Initial genesis distribution populated. Hash " <> renderByteArray (configGenesisHash cfg) - supply <- lift $ DB.queryTotalSupply $ getTxOutTableType syncEnv + supply <- lift $ DB.queryTotalSupply $ getTxOutVariantType syncEnv liftIO $ logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply) -- | Validate that the initial Genesis distribution in the DB matches the Genesis data. validateGenesisDistribution :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Bool -> Bool -> @@ -127,7 +125,7 @@ validateGenesisDistribution :: Text -> Byron.Config -> DB.BlockId -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m (Either SyncNodeError ()) validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid = runExceptT $ do meta <- liftLookupFail "validateGenesisDistribution" DB.queryMeta @@ -161,7 +159,7 @@ validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid = , textShow txCount ] unless disInOut $ do - totalSupply <- lift $ DB.queryGenesisSupply $ getTxOutTableType syncEnv + totalSupply <- DB.queryGenesisSupply $ getTxOutVariantType syncEnv case DB.word64ToAda <$> configGenesisSupply cfg of Left err -> dbSyncNodeError $ "validateGenesisDistribution: " <> textShow err Right expectedSupply -> @@ -180,12 +178,12 @@ validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid = ------------------------------------------------------------------------------- insertTxOutsByron :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Bool -> DB.BlockId -> (Byron.Address, Byron.Lovelace) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertTxOutsByron syncEnv disInOut blkId (address, value) = do case txHashOfAddress address of Left err -> throwError err @@ -210,54 +208,54 @@ insertTxOutsByron syncEnv disInOut blkId (address, value) = do } -- unless disInOut $ - case getTxOutTableType syncEnv of - DB.TxOutCore -> + case getTxOutVariantType syncEnv of + DB.TxOutVariantCore -> void . DB.insertTxOut $ - DB.CTxOutW - C.TxOut - { C.txOutTxId = txId - , C.txOutIndex = 0 - , C.txOutAddress = Text.decodeUtf8 $ Byron.addrToBase58 address - , C.txOutAddressHasScript = False - , C.txOutPaymentCred = Nothing - , C.txOutStakeAddressId = Nothing - , C.txOutValue = DB.DbLovelace (Byron.unsafeGetLovelace value) - , C.txOutDataHash = Nothing - , C.txOutInlineDatumId = Nothing - , C.txOutReferenceScriptId = Nothing - , C.txOutConsumedByTxId = Nothing + DB.VCTxOutW + VC.TxOutCore + { VC.txOutCoreTxId = txId + , VC.txOutCoreIndex = 0 + , VC.txOutCoreAddress = Text.decodeUtf8 $ Byron.addrToBase58 address + , VC.txOutCoreAddressHasScript = False + , VC.txOutCorePaymentCred = Nothing + , VC.txOutCoreStakeAddressId = Nothing + , VC.txOutCoreValue = DB.DbLovelace (Byron.unsafeGetLovelace value) + , VC.txOutCoreDataHash = Nothing + , VC.txOutCoreInlineDatumId = Nothing + , VC.txOutCoreReferenceScriptId = Nothing + , VC.txOutCoreConsumedByTxId = Nothing } DB.TxOutVariantAddress -> do let addrRaw = serialize' address vAddress = mkVAddress addrRaw addrDetailId <- insertAddressUsingCache cache UpdateCache addrRaw vAddress void . DB.insertTxOut $ - DB.VTxOutW (mkVTxOut txId addrDetailId) Nothing + DB.VATxOutW (mkTxOutAddress txId addrDetailId) Nothing where cache = envCache syncEnv - mkVTxOut :: DB.TxId -> V.AddressId -> V.TxOut - mkVTxOut txId addrDetailId = - V.TxOut - { V.txOutTxId = txId - , V.txOutIndex = 0 - , V.txOutValue = DB.DbLovelace (Byron.unsafeGetLovelace value) - , V.txOutDataHash = Nothing - , V.txOutInlineDatumId = Nothing - , V.txOutReferenceScriptId = Nothing - , V.txOutAddressId = addrDetailId - , V.txOutConsumedByTxId = Nothing - , V.txOutStakeAddressId = Nothing + mkTxOutAddress :: DB.TxId -> DB.AddressId -> VA.TxOutAddress + mkTxOutAddress txId addrDetailId = + VA.TxOutAddress + { VA.txOutAddressTxId = txId + , VA.txOutAddressIndex = 0 + , VA.txOutAddressValue = DB.DbLovelace (Byron.unsafeGetLovelace value) + , VA.txOutAddressDataHash = Nothing + , VA.txOutAddressInlineDatumId = Nothing + , VA.txOutAddressReferenceScriptId = Nothing + , VA.txOutAddressAddressId = addrDetailId + , VA.txOutAddressConsumedByTxId = Nothing + , VA.txOutAddressStakeAddressId = Nothing } - mkVAddress :: ByteString -> V.Address + mkVAddress :: ByteString -> VA.Address mkVAddress addrRaw = do - V.Address - { V.addressAddress = Text.decodeUtf8 $ Byron.addrToBase58 address - , V.addressRaw = addrRaw - , V.addressHasScript = False - , V.addressPaymentCred = Nothing -- Byron does not have a payment credential. - , V.addressStakeAddressId = Nothing -- Byron does not have a stake address. + VA.Address + { VA.addressAddress = Text.decodeUtf8 $ Byron.addrToBase58 address + , VA.addressRaw = addrRaw + , VA.addressHasScript = False + , VA.addressPaymentCred = Nothing -- Byron does not have a payment credential. + , VA.addressStakeAddressId = Nothing -- Byron does not have a stake address. } --------------------------------------------------------------------------------- diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs index e9934f6da..68ef831eb 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -6,10 +6,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Byron.Insert ( - insertByronBlock, - resolveTxInputs, -) where +module Cardano.DbSync.Era.Byron.Insert + ( insertByronBlock, + resolveTxInputs, + ) +where import Cardano.BM.Trace (Trace, logDebug, logInfo) import Cardano.Binary (serialize') @@ -20,153 +21,148 @@ import qualified Cardano.Chain.Update as Byron hiding (protocolVersion) import qualified Cardano.Crypto as Crypto (serializeCborHash) import Cardano.Db (DbLovelace (..)) 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.Variants.TxOutAddress as V +import qualified Cardano.Db.Schema.Variants.TxOutCore as C import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..)) -import Cardano.DbSync.Cache ( - insertAddressUsingCache, - insertBlockAndCache, - queryPrevBlockWithCache, - ) +import Cardano.DbSync.Cache + ( insertAddressUsingCache, + insertBlockAndCache, + queryPrevBlockWithCache, + ) import Cardano.DbSync.Cache.Epoch (writeEpochBlockDiffToCache) import Cardano.DbSync.Cache.Types (CacheAction (..), CacheStatus (..), EpochBlockDiff (..)) import qualified Cardano.DbSync.Era.Byron.Util as Byron -import Cardano.DbSync.Era.Util (liftLookupFail) import Cardano.DbSync.Error import Cardano.DbSync.Types import Cardano.DbSync.Util import Cardano.Prelude import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..)) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Except.Extra (firstExceptT, newExceptT) import qualified Data.ByteString.Char8 as BS import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..)) -- Trivial local data type for use in place of a tuple. data ValueFee = ValueFee - { vfValue :: !DbLovelace - , vfFee :: !DbLovelace + { vfValue :: !DbLovelace, + vfFee :: !DbLovelace } insertByronBlock :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => SyncEnv -> Bool -> ByronBlock -> SlotDetails -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m () insertByronBlock syncEnv firstBlockOfEpoch blk details = do - res <- runExceptT $ - case byronBlockRaw blk of - Byron.ABOBBlock ablk -> insertABlock syncEnv firstBlockOfEpoch ablk details - Byron.ABOBBoundary abblk -> insertABOBBoundary syncEnv abblk details + res <- case byronBlockRaw blk of + Byron.ABOBBlock ablk -> insertABlock syncEnv firstBlockOfEpoch ablk details + Byron.ABOBBoundary abblk -> insertABOBBoundary syncEnv abblk details -- Serializing things during syncing can drastically slow down full sync -- times (ie 10x or more). when (getSyncStatus details == SyncFollowing) - DB.transactionCommit + DB.createTransactionCheckpoint pure res insertABOBBoundary :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => SyncEnv -> Byron.ABoundaryBlock ByteString -> SlotDetails -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + DB.DbAction m () insertABOBBoundary syncEnv blk details = do let tracer = getTrace syncEnv cache = envCache syncEnv -- Will not get called in the OBFT part of the Byron era. - pbid <- queryPrevBlockWithCache "insertABOBBoundary" cache (Byron.ebbPrevHash blk) + pbid <- queryPrevBlockWithCache cache (Byron.ebbPrevHash blk) let epochNo = unEpochNo $ sdEpochNo details slid <- - lift . DB.insertSlotLeader $ - DB.SlotLeader - { DB.slotLeaderHash = BS.replicate 28 '\0' - , DB.slotLeaderPoolHashId = Nothing - , DB.slotLeaderDescription = "Epoch boundary slot leader" + DB.insertSlotLeader + $ DB.SlotLeader + { DB.slotLeaderHash = BS.replicate 28 '\0', + DB.slotLeaderPoolHashId = Nothing, + DB.slotLeaderDescription = "Epoch boundary slot leader" } blkId <- - lift . insertBlockAndCache cache $ - DB.Block - { DB.blockHash = Byron.unHeaderHash $ Byron.boundaryHashAnnotated blk - , DB.blockEpochNo = Just epochNo - , -- No slotNo for a boundary block - DB.blockSlotNo = Nothing - , DB.blockEpochSlotNo = Nothing - , DB.blockBlockNo = Nothing - , DB.blockPreviousId = Just pbid - , DB.blockSlotLeaderId = slid - , DB.blockSize = fromIntegral $ Byron.boundaryBlockLength blk - , DB.blockTime = sdSlotTime details - , DB.blockTxCount = 0 - , -- EBBs do not seem to have protocol version fields, so set this to '0'. - DB.blockProtoMajor = 0 - , DB.blockProtoMinor = 0 - , -- Shelley specific - DB.blockVrfKey = Nothing - , DB.blockOpCert = Nothing - , DB.blockOpCertCounter = Nothing + insertBlockAndCache cache + $ DB.Block + { DB.blockHash = Byron.unHeaderHash $ Byron.boundaryHashAnnotated blk, + DB.blockEpochNo = Just epochNo, + -- No slotNo for a boundary block + DB.blockSlotNo = Nothing, + DB.blockEpochSlotNo = Nothing, + DB.blockBlockNo = Nothing, + DB.blockPreviousId = pbid, + DB.blockSlotLeaderId = slid, + DB.blockSize = fromIntegral $ Byron.boundaryBlockLength blk, + DB.blockTime = sdSlotTime details, + DB.blockTxCount = 0, + -- EBBs do not seem to have protocol version fields, so set this to '0'. + DB.blockProtoMajor = 0, + DB.blockProtoMinor = 0, + -- Shelley specific + DB.blockVrfKey = Nothing, + DB.blockOpCert = Nothing, + DB.blockOpCertCounter = Nothing } -- now that we've inserted the Block and all it's txs lets cache what we'll need -- when we later update the epoch values. -- If have --dissable-epoch && --dissable-cache then no need to cache data. when (soptEpochAndCacheEnabled $ envOptions syncEnv) - . newExceptT $ writeEpochBlockDiffToCache cache EpochBlockDiff - { ebdBlockId = blkId - , ebdFees = 0 - , ebdOutSum = 0 - , ebdTxCount = 0 - , ebdEpochNo = epochNo - , ebdTime = sdSlotTime details + { ebdBlockId = blkId, + ebdFees = 0, + ebdOutSum = 0, + ebdTxCount = 0, + ebdEpochNo = epochNo, + ebdTime = sdSlotTime details } - liftIO . logInfo tracer $ - Text.concat - [ "insertABOBBoundary: epoch " - , textShow (Byron.boundaryEpoch $ Byron.boundaryHeader blk) - , ", hash " - , Byron.renderAbstractHash (Byron.boundaryHashAnnotated blk) + liftIO + . logInfo tracer + $ Text.concat + [ "insertABOBBoundary: epoch ", + textShow (Byron.boundaryEpoch $ Byron.boundaryHeader blk), + ", hash ", + Byron.renderAbstractHash (Byron.boundaryHashAnnotated blk) ] insertABlock :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => SyncEnv -> Bool -> Byron.ABlock ByteString -> SlotDetails -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + DB.DbAction m () insertABlock syncEnv firstBlockOfEpoch blk details = do - pbid <- queryPrevBlockWithCache "insertABlock" cache (Byron.blockPreviousHash blk) - slid <- lift . DB.insertSlotLeader $ Byron.mkSlotLeader blk + pbid <- queryPrevBlockWithCache cache (Byron.blockPreviousHash blk) + slid <- DB.insertSlotLeader $ Byron.mkSlotLeader blk let txs = Byron.blockPayload blk blkId <- - lift . insertBlockAndCache cache $ - DB.Block - { DB.blockHash = Byron.blockHash blk - , DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details) - , DB.blockSlotNo = Just $ Byron.slotNumber blk - , DB.blockEpochSlotNo = Just $ unEpochSlot (sdEpochSlot details) - , DB.blockBlockNo = Just $ Byron.blockNumber blk - , DB.blockPreviousId = Just pbid - , DB.blockSlotLeaderId = slid - , DB.blockSize = fromIntegral $ Byron.blockLength blk - , DB.blockTime = sdSlotTime details - , DB.blockTxCount = fromIntegral $ length txs - , DB.blockProtoMajor = Byron.pvMajor (Byron.protocolVersion blk) - , DB.blockProtoMinor = Byron.pvMinor (Byron.protocolVersion blk) - , -- Shelley specific - DB.blockVrfKey = Nothing - , DB.blockOpCert = Nothing - , DB.blockOpCertCounter = Nothing + insertBlockAndCache cache + $ DB.Block + { DB.blockHash = Byron.blockHash blk, + DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details), + DB.blockSlotNo = Just $ Byron.slotNumber blk, + DB.blockEpochSlotNo = Just $ unEpochSlot (sdEpochSlot details), + DB.blockBlockNo = Just $ Byron.blockNumber blk, + DB.blockPreviousId = pbid, + DB.blockSlotLeaderId = slid, + DB.blockSize = fromIntegral $ Byron.blockLength blk, + DB.blockTime = sdSlotTime details, + DB.blockTxCount = fromIntegral $ length txs, + DB.blockProtoMajor = Byron.pvMajor (Byron.protocolVersion blk), + DB.blockProtoMinor = Byron.pvMinor (Byron.protocolVersion blk), + -- Shelley specific + DB.blockVrfKey = Nothing, + DB.blockOpCert = Nothing, + DB.blockOpCertCounter = Nothing } txFees <- zipWithM (insertByronTx syncEnv blkId) (Byron.blockPayload blk) [0 ..] @@ -177,16 +173,15 @@ insertABlock syncEnv firstBlockOfEpoch blk details = do -- when we later update the epoch values. -- If have --dissable-epoch && --dissable-cache then no need to cache data. when (soptEpochAndCacheEnabled $ envOptions syncEnv) - . newExceptT $ writeEpochBlockDiffToCache cache EpochBlockDiff - { ebdBlockId = blkId - , ebdFees = sum txFees - , ebdOutSum = fromIntegral outSum - , ebdTxCount = fromIntegral $ length txs - , ebdEpochNo = unEpochNo (sdEpochNo details) - , ebdTime = sdSlotTime details + { ebdBlockId = blkId, + ebdFees = sum txFees, + ebdOutSum = fromIntegral outSum, + ebdTxCount = fromIntegral $ length txs, + ebdEpochNo = unEpochNo (sdEpochNo details), + ebdTime = sdSlotTime details } liftIO $ do @@ -195,26 +190,26 @@ insertABlock syncEnv firstBlockOfEpoch blk details = do followingClosely = getSyncStatus details == SyncFollowing when (followingClosely && slotWithinEpoch /= 0 && Byron.blockNumber blk `mod` 20 == 0) $ do - logInfo tracer $ - mconcat - [ "Insert Byron Block: continuing epoch " - , textShow epoch - , " (slot " - , textShow slotWithinEpoch - , "/" - , textShow (unEpochSize $ sdEpochSize details) - , ")" + logInfo tracer + $ mconcat + [ "Insert Byron Block: continuing epoch ", + textShow epoch, + " (slot ", + textShow slotWithinEpoch, + "/", + textShow (unEpochSize $ sdEpochSize details), + ")" ] - logger followingClosely tracer $ - mconcat - [ "Insert Byron Block: epoch " - , textShow (unEpochNo $ sdEpochNo details) - , ", slot " - , textShow (Byron.slotNumber blk) - , ", block " - , textShow (Byron.blockNumber blk) - , ", hash " - , renderByteArray (Byron.blockHash blk) + logger followingClosely tracer + $ mconcat + [ "Insert Byron Block: epoch ", + textShow (unEpochNo $ sdEpochNo details), + ", slot ", + textShow (Byron.slotNumber blk), + ", block ", + textShow (Byron.blockNumber blk), + ", hash ", + renderByteArray (Byron.blockHash blk) ] where tracer :: Trace IO Text @@ -231,42 +226,41 @@ insertABlock syncEnv firstBlockOfEpoch blk details = do | otherwise = logDebug insertByronTx :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => SyncEnv -> DB.BlockId -> Byron.TxAux -> Word64 -> - ExceptT SyncNodeError (ReaderT SqlBackend m) Word64 + DB.DbAction m Word64 insertByronTx syncEnv blkId tx blockIndex = do disInOut <- liftIO $ getDisableInOutState syncEnv if disInOut then do txId <- - lift . DB.insertTx $ - DB.Tx - { DB.txHash = Byron.unTxHash $ Crypto.serializeCborHash (Byron.taTx tx) - , DB.txBlockId = blkId - , DB.txBlockIndex = blockIndex - , DB.txOutSum = DbLovelace 0 - , DB.txFee = DbLovelace 0 - , DB.txDeposit = Nothing -- Byron does not have deposits/refunds - -- Would be really nice to have a way to get the transaction size - -- without re-serializing it. - , DB.txSize = fromIntegral $ BS.length (serialize' $ Byron.taTx tx) - , DB.txInvalidHereafter = Nothing - , DB.txInvalidBefore = Nothing - , DB.txValidContract = True - , DB.txScriptSize = 0 - , DB.txTreasuryDonation = DbLovelace 0 + DB.insertTx + $ DB.Tx + { DB.txHash = Byron.unTxHash $ Crypto.serializeCborHash (Byron.taTx tx), + DB.txBlockId = blkId, + DB.txBlockIndex = blockIndex, + DB.txOutSum = DbLovelace 0, + DB.txFee = DbLovelace 0, + DB.txDeposit = Nothing, -- Byron does not have deposits/refunds + -- Would be really nice to have a way to get the transaction size + -- without re-serializing it. + DB.txSize = fromIntegral $ BS.length (serialize' $ Byron.taTx tx), + DB.txInvalidHereafter = Nothing, + DB.txInvalidBefore = Nothing, + DB.txValidContract = True, + DB.txScriptSize = 0, + DB.txTreasuryDonation = DbLovelace 0 } when (ioTxCBOR iopts) $ do void - . lift - . DB.insertTxCBOR + $ DB.insertTxCbor $ DB.TxCbor - { DB.txCborTxId = txId - , DB.txCborBytes = serialize' $ Byron.taTx tx + { DB.txCborTxId = txId, + DB.txCborBytes = serialize' $ Byron.taTx tx } pure 0 @@ -275,56 +269,56 @@ insertByronTx syncEnv blkId tx blockIndex = do iopts = getInsertOptions syncEnv insertByronTx' :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => SyncEnv -> DB.BlockId -> Byron.TxAux -> Word64 -> - ExceptT SyncNodeError (ReaderT SqlBackend m) Word64 + DB.DbAction m Word64 insertByronTx' syncEnv blkId tx blockIndex = do - resolvedInputs <- mapM (resolveTxInputs txOutTableType) (toList $ Byron.txInputs (Byron.taTx tx)) - valFee <- firstExceptT annotateTx $ ExceptT $ pure (calculateTxFee (Byron.taTx tx) resolvedInputs) + resolvedInputs <- mapM (resolveTxInputs txOutVariantType) (toList $ Byron.txInputs (Byron.taTx tx)) + valFee <- case calculateTxFee (Byron.taTx tx) resolvedInputs of + Left err -> throwError $ DB.DbError DB.mkCallSite ("insertByronTx': " <> show (annotateTx err)) Nothing + Right vf -> pure vf txId <- - lift . DB.insertTx $ - DB.Tx - { DB.txHash = Byron.unTxHash $ Crypto.serializeCborHash (Byron.taTx tx) - , DB.txBlockId = blkId - , DB.txBlockIndex = blockIndex - , DB.txOutSum = vfValue valFee - , DB.txFee = vfFee valFee - , DB.txDeposit = Just 0 -- Byron does not have deposits/refunds - -- Would be really nice to have a way to get the transaction size - -- without re-serializing it. - , DB.txSize = fromIntegral $ BS.length (serialize' $ Byron.taTx tx) - , DB.txInvalidHereafter = Nothing - , DB.txInvalidBefore = Nothing - , DB.txValidContract = True - , DB.txScriptSize = 0 - , DB.txTreasuryDonation = DbLovelace 0 + DB.insertTx + $ DB.Tx + { DB.txHash = Byron.unTxHash $ Crypto.serializeCborHash (Byron.taTx tx), + DB.txBlockId = blkId, + DB.txBlockIndex = blockIndex, + DB.txOutSum = vfValue valFee, + DB.txFee = vfFee valFee, + DB.txDeposit = Just 0, -- Byron does not have deposits/refunds + -- Would be really nice to have a way to get the transaction size + -- without re-serializing it. + DB.txSize = fromIntegral $ BS.length (serialize' $ Byron.taTx tx), + DB.txInvalidHereafter = Nothing, + DB.txInvalidBefore = Nothing, + DB.txValidContract = True, + DB.txScriptSize = 0, + DB.txTreasuryDonation = DbLovelace 0 } when (ioTxCBOR iopts) $ do void - . lift - . DB.insertTxCBOR + $ DB.insertTxCbor $ DB.TxCbor - { DB.txCborTxId = txId - , DB.txCborBytes = serialize' $ Byron.taTx tx + { DB.txCborTxId = txId, + DB.txCborBytes = serialize' $ Byron.taTx tx } -- Insert outputs for a transaction before inputs in case the inputs for this transaction -- references the output (not sure this can even happen). disInOut <- liftIO $ getDisableInOutState syncEnv - lift $ zipWithM_ (insertTxOutByron syncEnv (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) - unless (getSkipTxIn syncEnv) $ - mapM_ (insertTxIn tracer txId) resolvedInputs - whenConsumeOrPruneTxOut syncEnv $ - lift $ - DB.updateListTxOutConsumedByTxId (prepUpdate txId <$> resolvedInputs) + zipWithM_ (insertTxOutByron syncEnv (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) + unless (getSkipTxIn syncEnv) + $ mapM_ (insertTxIn tracer txId) resolvedInputs + whenConsumeOrPruneTxOut syncEnv + $ DB.updateListTxOutConsumedByTxId (prepUpdate txId <$> resolvedInputs) -- fees are being returned so we can sum them and put them in cache to use when updating epochs pure $ unDbLovelace $ vfFee valFee where - txOutTableType = getTxOutTableType syncEnv + txOutVariantType = getTxOutVariantType syncEnv iopts = getInsertOptions syncEnv tracer :: Trace IO Text @@ -339,86 +333,87 @@ insertByronTx' syncEnv blkId tx blockIndex = do prepUpdate txId (_, _, txOutId, _) = (txOutId, txId) insertTxOutByron :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => SyncEnv -> Bool -> Bool -> DB.TxId -> Word32 -> Byron.TxOut -> - ReaderT SqlBackend m () + DB.DbAction m () insertTxOutByron syncEnv _hasConsumed bootStrap txId index txout = - unless bootStrap $ - case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of - DB.TxOutCore -> do - void . DB.insertTxOut $ - DB.CTxOutW $ - C.TxOut - { C.txOutAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) - , C.txOutAddressHasScript = False - , C.txOutDataHash = Nothing - , C.txOutConsumedByTxId = Nothing - , C.txOutIndex = fromIntegral index - , C.txOutInlineDatumId = Nothing - , C.txOutPaymentCred = Nothing -- Byron does not have a payment credential. - , C.txOutReferenceScriptId = Nothing - , C.txOutStakeAddressId = Nothing -- Byron does not have a stake address. - , C.txOutTxId = txId - , C.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) - } + unless bootStrap + $ case ioTxOutVariantType . soptInsertOptions $ envOptions syncEnv of + DB.TxOutVariantCore -> do + void + . DB.insertTxOut + $ DB.VCTxOutW + $ C.TxOutCore + { C.txOutCoreAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout), + C.txOutCoreAddressHasScript = False, + C.txOutCoreDataHash = Nothing, + C.txOutCoreConsumedByTxId = Nothing, + C.txOutCoreIndex = fromIntegral index, + C.txOutCoreInlineDatumId = Nothing, + C.txOutCorePaymentCred = Nothing, -- Byron does not have a payment credential. + C.txOutCoreReferenceScriptId = Nothing, + C.txOutCoreStakeAddressId = Nothing, -- Byron does not have a stake address. + C.txOutCoreTxId = txId, + C.txOutCoreValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) + } DB.TxOutVariantAddress -> do addrDetailId <- insertAddressUsingCache cache UpdateCache addrRaw vAddress - void . DB.insertTxOut $ DB.VTxOutW (vTxOut addrDetailId) Nothing + void . DB.insertTxOut $ DB.VATxOutW (vTxOut addrDetailId) Nothing where addrRaw :: ByteString addrRaw = serialize' (Byron.txOutAddress txout) cache = envCache syncEnv - vTxOut :: V.AddressId -> V.TxOut + vTxOut :: DB.AddressId -> V.TxOutAddress vTxOut addrDetailId = - V.TxOut - { V.txOutAddressId = addrDetailId - , V.txOutConsumedByTxId = Nothing - , V.txOutDataHash = Nothing - , V.txOutIndex = fromIntegral index - , V.txOutInlineDatumId = Nothing - , V.txOutReferenceScriptId = Nothing - , V.txOutTxId = txId - , V.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) - , V.txOutStakeAddressId = Nothing + V.TxOutAddress + { V.txOutAddressAddressId = addrDetailId, + V.txOutAddressConsumedByTxId = Nothing, + V.txOutAddressDataHash = Nothing, + V.txOutAddressIndex = fromIntegral index, + V.txOutAddressInlineDatumId = Nothing, + V.txOutAddressReferenceScriptId = Nothing, + V.txOutAddressTxId = txId, + V.txOutAddressValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout), + V.txOutAddressStakeAddressId = Nothing } vAddress :: V.Address vAddress = V.Address - { V.addressAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) - , V.addressRaw = addrRaw - , V.addressHasScript = False - , V.addressPaymentCred = Nothing -- Byron does not have a payment credential. - , V.addressStakeAddressId = Nothing -- Byron does not have a stake address. + { V.addressAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout), + V.addressRaw = addrRaw, + V.addressHasScript = False, + V.addressPaymentCred = Nothing, -- Byron does not have a payment credential. + V.addressStakeAddressId = Nothing -- Byron does not have a stake address. } insertTxIn :: - (MonadBaseControl IO m, MonadIO m) => + (MonadIO m) => Trace IO Text -> DB.TxId -> (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.TxInId + DB.DbAction m DB.TxInId insertTxIn _tracer txInTxId (Byron.TxInUtxo _txHash inIndex, txOutTxId, _, _) = do - lift . DB.insertTxIn $ - DB.TxIn - { DB.txInTxInId = txInTxId - , DB.txInTxOutId = txOutTxId - , DB.txInTxOutIndex = fromIntegral inIndex - , DB.txInRedeemerId = Nothing + DB.insertTxIn + $ DB.TxIn + { DB.txInTxInId = txInTxId, + DB.txInTxOutId = txOutTxId, + DB.txInTxOutIndex = fromIntegral inIndex, + DB.txInRedeemerId = Nothing } -- ----------------------------------------------------------------------------- -resolveTxInputs :: MonadIO m => DB.TxOutTableType -> Byron.TxIn -> ExceptT SyncNodeError (ReaderT SqlBackend m) (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) -resolveTxInputs txOutTableType txIn@(Byron.TxInUtxo txHash index) = do - res <- liftLookupFail "resolveInput" $ DB.queryTxOutIdValue txOutTableType (Byron.unTxHash txHash, fromIntegral index) +resolveTxInputs :: (MonadIO m) => DB.TxOutVariantType -> Byron.TxIn -> DB.DbAction m (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) +resolveTxInputs txOutVariantType txIn@(Byron.TxInUtxo txHash index) = do + res <- DB.queryTxOutIdValue txOutVariantType (Byron.unTxHash txHash, fromIntegral index) pure $ convert res where convert :: (DB.TxId, DB.TxOutIdW, DbLovelace) -> (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) @@ -427,9 +422,9 @@ resolveTxInputs txOutTableType txIn@(Byron.TxInUtxo txHash index) = do calculateTxFee :: Byron.Tx -> [(Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace)] -> Either SyncNodeError ValueFee calculateTxFee tx resolvedInputs = do outval <- first (\e -> SNErrDefault $ "calculateTxFee: " <> textShow e) output - when (null resolvedInputs) $ - Left $ - SNErrDefault "calculateTxFee: List of transaction inputs is zero." + when (null resolvedInputs) + $ Left + $ SNErrDefault "calculateTxFee: List of transaction inputs is zero." let inval = sum $ map (unDbLovelace . forth4) resolvedInputs if inval < outval then Left $ SNErrInvariant "calculateTxFee" $ EInvInOut inval outval diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs index 9fb9da939..c2a74c627 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs @@ -6,7 +6,7 @@ module Cardano.DbSync.Era.Cardano.Insert ( insertEpochSyncTime, ) where -import Cardano.Db (SyncState) +import Cardano.Db (DbAction, SyncState) import qualified Cardano.Db as Db import Cardano.Prelude hiding (STM, atomically) import Cardano.Slotting.Slot (EpochNo (..)) @@ -18,20 +18,18 @@ import Control.Concurrent.Class.MonadSTM.Strict ( readTVar, writeTVar, ) -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Time.Clock (UTCTime) import qualified Data.Time.Clock as Time -import Database.Persist.Sql (SqlBackend) -- If `db-sync` is started in epoch `N`, the number of seconds to sync that epoch will be recorded -- as `Nothing`. insertEpochSyncTime :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => EpochNo -> SyncState -> StrictTVar IO UTCTime -> - ReaderT SqlBackend m () + DbAction m () insertEpochSyncTime epochNo syncState estvar = do now <- liftIO Time.getCurrentTime mlast <- liftIO . atomically $ swapTVar estvar now 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..6aebcc435 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 @@ -86,7 +86,7 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do expectedTxCount :: Word64 expectedTxCount = fromIntegral $ genesisUTxOSize cfg + if hasStakes then 1 else 0 - insertAction :: (MonadBaseControl IO m, MonadIO m) => Bool -> ReaderT SqlBackend m (Either SyncNodeError ()) + insertAction :: MonadIO m => Bool -> DB.DbAction m (Either SyncNodeError ()) insertAction prunes = do ebid <- DB.queryBlockId (configGenesisHash cfg) case ebid of @@ -162,18 +162,18 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do -- | Validate that the initial Genesis distribution in the DB matches the Genesis data. validateGenesisDistribution :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Bool -> Text -> ShelleyGenesis StandardCrypto -> DB.BlockId -> Word64 -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m (Either SyncNodeError ()) validateGenesisDistribution syncEnv prunes networkName cfg bid expectedTxCount = runExceptT $ do let tracer = getTrace syncEnv - txOutTableType = getTxOutTableType syncEnv + txOutVariantType = getTxOutVariantType syncEnv liftIO $ logInfo tracer "Validating Genesis distribution" meta <- liftLookupFail "Shelley.validateGenesisDistribution" DB.queryMeta @@ -204,7 +204,7 @@ validateGenesisDistribution syncEnv prunes networkName cfg bid expectedTxCount = , " but got " , textShow txCount ] - totalSupply <- lift $ DB.queryShelleyGenesisSupply txOutTableType + totalSupply <- lift $ DB.queryShelleyGenesisSupply txOutVariantType let expectedSupply = configGenesisSupply cfg when (expectedSupply /= totalSupply && not prunes) $ dbSyncNodeError $ @@ -221,12 +221,12 @@ validateGenesisDistribution syncEnv prunes networkName cfg bid expectedTxCount = -- ----------------------------------------------------------------------------- insertTxOuts :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Trace IO Text -> DB.BlockId -> (TxIn StandardCrypto, ShelleyTxOut StandardShelley) -> - ReaderT SqlBackend m () + DB.DbAction m () insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do -- Each address/value pair of the initial coin distribution comes from an artifical transaction -- with a hash generated by hashing the address. @@ -249,10 +249,10 @@ insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do tryUpdateCacheTx (envCache syncEnv) txInId txId _ <- insertStakeAddressRefIfMissing trce useNoCache (txOut ^. Core.addrTxOutL) - case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of - DB.TxOutCore -> + case ioTxOutVariantType . soptInsertOptions $ envOptions syncEnv of + DB.TxOutVariantCore -> void . DB.insertTxOut $ - DB.CTxOutW + DB.VCTxOutW C.TxOut { C.txOutAddress = Generic.renderAddress addr , C.txOutAddressHasScript = hasScript @@ -268,7 +268,7 @@ insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do } DB.TxOutVariantAddress -> do addrDetailId <- insertAddressUsingCache cache UpdateCache addrRaw vAddress - void . DB.insertTxOut $ DB.VTxOutW (makeVTxOut addrDetailId txId) Nothing + void . DB.insertTxOut $ DB.VATxOutW (makeVTxOut addrDetailId txId) Nothing where addr = txOut ^. Core.addrTxOutL cache = envCache syncEnv @@ -301,12 +301,12 @@ insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do -- Insert pools and delegations coming from Genesis. insertStaking :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> DB.BlockId -> ShelleyGenesis StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertStaking tracer cache blkId genesis = do -- All Genesis staking comes from an artifical transaction -- with a hash generated by hashing the address. diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs index 51ad9952b..b6ec98574 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs @@ -11,33 +11,29 @@ module Cardano.DbSync.Era.Shelley.Query ( queryResolveInputCredentials, ) where -import Cardano.Db -import Cardano.DbSync.Api (getTxOutTableType) +import qualified Cardano.Db as DB +import Cardano.DbSync.Api (getTxOutVariantType) import Cardano.DbSync.Api.Types (SyncEnv) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Util import Cardano.Prelude hiding (Ptr, from, maybeToEither, on) -import Database.Esqueleto.Experimental ( - SqlBackend, - ) {- HLINT ignore "Fuse on/on" -} -resolveStakeAddress :: MonadIO m => ByteString -> ReaderT SqlBackend m (Either LookupFail StakeAddressId) -resolveStakeAddress addr = queryStakeAddress addr renderByteArray +resolveStakeAddress :: MonadIO m => ByteString -> DB.DbAction m (Maybe DB.StakeAddressId) +resolveStakeAddress = DB.queryStakeAddress -resolveInputTxOutId :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW)) +resolveInputTxOutId :: MonadIO m => SyncEnv -> Generic.TxIn -> DB.DbAction m (DB.TxId, DB.TxOutIdW) resolveInputTxOutId syncEnv txIn = - queryTxOutId (getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) + DB.queryTxOutId (getTxOutVariantType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) -resolveInputValue :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, DbLovelace)) -resolveInputValue syncEnv txIn = - queryTxOutValue (getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) +resolveInputValue :: MonadIO m => Generic.TxIn -> DB.DbAction m (DB.TxId, DB.DbLovelace) +resolveInputValue txIn = + DB.queryTxOutValue (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) -resolveInputTxOutIdValue :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) +resolveInputTxOutIdValue :: MonadIO m => SyncEnv -> Generic.TxIn -> DB.DbAction m (DB.TxId, DB.TxOutIdW, DB.DbLovelace) resolveInputTxOutIdValue syncEnv txIn = - queryTxOutIdValue (getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) + DB.queryTxOutIdValue (getTxOutVariantType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) -queryResolveInputCredentials :: MonadIO m => SyncEnv -> Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail (Maybe ByteString, Bool)) +queryResolveInputCredentials :: MonadIO m => SyncEnv -> Generic.TxIn -> DB.DbAction m (Maybe ByteString) queryResolveInputCredentials syncEnv txIn = do - queryTxOutCredentials (getTxOutTableType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) + DB.queryTxOutCredentials (getTxOutVariantType syncEnv) (Generic.toTxHash txIn, fromIntegral (Generic.txInIndex txIn)) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs index 3bb8b82da..6202658c7 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs @@ -1,158 +1,151 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +-- {-# LANGUAGE FlexibleContexts #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE TypeApplications #-} -module Cardano.DbSync.Era.Shelley.ValidateWithdrawal ( - validateRewardWithdrawals, -) where +module Cardano.DbSync.Era.Shelley.ValidateWithdrawal where +-- validateRewardWithdrawals, +-- ) where -import Cardano.BM.Trace (Trace, logError) -import Cardano.Db (Ada (..)) -import qualified Cardano.Db as Db -import Cardano.DbSync.Error (shouldAbortOnPanic) -import Cardano.DbSync.Util -import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import Data.Either (partitionEithers) -import Data.Fixed (Micro) -import qualified Data.List as List -import Data.Text (Text) -import Database.Esqueleto.Experimental ( - SqlBackend, - Value (Value), - asc, - distinct, - from, - groupBy, - having, - innerJoin, - on, - orderBy, - select, - sum_, - table, - unValue, - val, - where_, - (:&) ((:&)), - (<.), - (==.), - (^.), - ) +-- import Cardano.BM.Trace (Trace, logError) +-- import Cardano.Db (Ada (..)) +-- import qualified Cardano.Db as DB +-- import Cardano.DbSync.Error (shouldAbortOnPanic) +-- import Cardano.DbSync.Util +-- import Cardano.Slotting.Slot (EpochNo (..)) +-- import Control.Monad.IO.Class (MonadIO, liftIO) +-- import Control.Monad.Trans.Control (MonadBaseControl) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import Data.Either (partitionEithers) +-- import Data.Fixed (Micro) +-- import qualified Data.List as List +-- import Data.Text (Text) +-- import Database.Esqueleto.Experimental ( +-- SqlBackend, +-- Value (Value), +-- asc, +-- distinct, +-- from, +-- groupBy, +-- having, +-- innerJoin, +-- on, +-- orderBy, +-- select, +-- sum_, +-- table, +-- unValue, +-- val, +-- where_, +-- (:&) ((:&)), +-- (<.), +-- (==.), +-- (^.), +-- ) -{- HLINT ignore "Fuse on/on" -} +-- {- HLINT ignore "Fuse on/on" -} --- For any stake address which has seen a withdrawal, the sum of the withdrawals for that address --- should be less than or equal to the sum of the rewards for that address. -validateRewardWithdrawals :: - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - EpochNo -> - ReaderT SqlBackend m () -validateRewardWithdrawals trce (EpochNo epochNo) = do - res <- mapM validateAccounting =<< queryWithdrawalAddresses - _bad <- queryBadWithdrawals - liftIO $ - case partitionEithers res of - ([], _) -> pure () - (xs, _) -> do - logError trce . mconcat $ - [textShow epochNo, ": ", textShow (length xs), " errors, eg\n"] - ++ List.intersperse "\n" (map reportError xs) - shouldAbortOnPanic "Validation failure" +-- -- For any stake address which has seen a withdrawal, the sum of the withdrawals for that address +-- -- should be less than or equal to the sum of the rewards for that address. +-- validateRewardWithdrawals :: +-- MonadIO m => +-- Trace IO Text -> +-- EpochNo -> +-- DB.DbAction m () +-- validateRewardWithdrawals trce (EpochNo epochNo) = do +-- res <- mapM validateAccounting =<< DB.queryWithdrawalAddresses +-- _bad <- queryBadWithdrawals +-- liftIO $ +-- case partitionEithers res of +-- ([], _) -> pure () +-- (xs, _) -> do +-- logError trce . mconcat $ +-- [textShow epochNo, ": ", textShow (length xs), " errors, eg\n"] +-- ++ List.intersperse "\n" (map reportError xs) +-- shouldAbortOnPanic "Validation failure" --- ----------------------------------------------------------------------------- +-- -- ----------------------------------------------------------------------------- -data AddressInfo = AddressInfo - { aiStakeAddress :: !Text - , aiSumRewards :: !Ada - , aiSumWithdrawals :: !Ada - } - deriving (Eq, Ord, Show) +-- data AddressInfo = AddressInfo +-- { aiStakeAddress :: !Text +-- , aiSumRewards :: !Ada +-- , aiSumWithdrawals :: !Ada +-- } +-- deriving (Eq, Ord, Show) -reportError :: AddressInfo -> Text -reportError ai = - mconcat - [ " " - , aiStakeAddress ai - , " rewards are " - , textShow (aiSumRewards ai) - , " ADA and withdrawals are " - , textShow (aiSumWithdrawals ai) - , " ADA" - ] +-- reportError :: AddressInfo -> Text +-- reportError ai = +-- mconcat +-- [ " " +-- , aiStakeAddress ai +-- , " rewards are " +-- , textShow (aiSumRewards ai) +-- , " ADA and withdrawals are " +-- , textShow (aiSumWithdrawals ai) +-- , " ADA" +-- ] --- For a given TxId, validate the input/output accounting. -validateAccounting :: - (MonadBaseControl IO m, MonadIO m) => - Db.StakeAddressId -> - ReaderT SqlBackend m (Either AddressInfo ()) -validateAccounting addrId = do - ai <- queryAddressInfo addrId - pure $ - if aiSumRewards ai < aiSumWithdrawals ai - then Left ai - else Right () +-- -- For a given TxId, validate the input/output accounting. +-- validateAccounting :: +-- MonadIO m => +-- DB.StakeAddressId -> +-- DB.DbAction m (Either AddressInfo ()) +-- validateAccounting addrId = do +-- ai <- queryAddressInfo addrId +-- pure $ +-- if aiSumRewards ai < aiSumWithdrawals ai +-- then Left ai +-- else Right () --- ------------------------------------------------------------------------------------------------- +-- -- ------------------------------------------------------------------------------------------------- --- Get all stake addresses with have seen a withdrawal, and return them in shuffled order. -queryWithdrawalAddresses :: MonadIO m => ReaderT SqlBackend m [Db.StakeAddressId] -queryWithdrawalAddresses = do - res <- select . distinct $ do - wd <- from $ table @Db.Withdrawal - orderBy [asc (wd ^. Db.WithdrawalAddrId)] - pure (wd ^. Db.WithdrawalAddrId) - pure $ map unValue res +-- -- Get all stake addresses with have seen a withdrawal, and return them in shuffled order. -queryAddressInfo :: MonadIO m => Db.StakeAddressId -> ReaderT SqlBackend m AddressInfo -queryAddressInfo addrId = do - rwds <- select $ do - rwd <- from $ table @Db.Reward - where_ (rwd ^. Db.RewardAddrId ==. val addrId) - pure (sum_ $ rwd ^. Db.RewardAmount) - wdls <- select $ do - wdl <- from $ table @Db.Withdrawal - where_ (wdl ^. Db.WithdrawalAddrId ==. val addrId) - pure (sum_ (wdl ^. Db.WithdrawalAmount)) - view <- select $ do - saddr <- from $ table @Db.StakeAddress - where_ (saddr ^. Db.StakeAddressId ==. val addrId) - pure (saddr ^. Db.StakeAddressView) - pure $ convert (Db.listToMaybe rwds) (Db.listToMaybe wdls) (Db.listToMaybe view) - where - convert :: Maybe (Value (Maybe Micro)) -> Maybe (Value (Maybe Micro)) -> Maybe (Value Text) -> AddressInfo - convert rAmount wAmount mview = - AddressInfo - { aiStakeAddress = maybe "unknown" unValue mview - , aiSumRewards = Db.unValueSumAda rAmount - , aiSumWithdrawals = Db.unValueSumAda wAmount - } +-- queryAddressInfo :: MonadIO m => DB.StakeAddressId -> DB.DbAction m AddressInfo +-- queryAddressInfo addrId = do +-- rwds <- select $ do +-- rwd <- from $ table @DB.Reward +-- where_ (rwd ^. DB.RewardAddrId ==. val addrId) +-- pure (sum_ $ rwd ^. DB.RewardAmount) +-- wdls <- select $ do +-- wdl <- from $ table @DB.Withdrawal +-- where_ (wdl ^. DB.WithdrawalAddrId ==. val addrId) +-- pure (sum_ (wdl ^. DB.WithdrawalAmount)) +-- view <- select $ do +-- saddr <- from $ table @DB.StakeAddress +-- where_ (saddr ^. DB.StakeAddressId ==. val addrId) +-- pure (saddr ^. DB.StakeAddressView) +-- pure $ convert (DB.listToMaybe rwds) (DB.listToMaybe wdls) (DB.listToMaybe view) +-- where +-- convert :: Maybe (Value (Maybe Micro)) -> Maybe (Value (Maybe Micro)) -> Maybe (Value Text) -> AddressInfo +-- convert rAmount wAmount mview = +-- AddressInfo +-- { aiStakeAddress = maybe "unknown" unValue mview +-- , aiSumRewards = DB.unValueSumAda rAmount +-- , aiSumWithdrawals = DB.unValueSumAda wAmount +-- } --- A stake address state is bad if sum rewards < sum withdrawals -queryBadWithdrawals :: MonadIO m => ReaderT SqlBackend m [AddressInfo] -queryBadWithdrawals = do - res <- select $ do - (rwd :& sa :& wdrl) <- - from - $ table @Db.Reward - `innerJoin` table @Db.StakeAddress - `on` (\(rwd :& sa) -> rwd ^. Db.RewardAddrId ==. sa ^. Db.StakeAddressId) - `innerJoin` table @Db.Withdrawal - `on` (\(rwd :& _sa :& wdrl) -> rwd ^. Db.RewardAddrId ==. wdrl ^. Db.WithdrawalAddrId) - groupBy (sa ^. Db.StakeAddressId) - let sumReward = sum_ (rwd ^. Db.RewardAmount) - sumWithdraw = sum_ (wdrl ^. Db.WithdrawalAmount) - having (sumReward <. sumWithdraw) - pure (sa ^. Db.StakeAddressView, sumReward, sumWithdraw) - pure $ List.sort (map convert res) - where - convert :: (Value Text, Value (Maybe Micro), Value (Maybe Micro)) -> AddressInfo - convert (Value saView, rwdTotal, wdrlTotal) = - AddressInfo - { aiStakeAddress = saView - , aiSumRewards = Db.unValueSumAda (Just rwdTotal) - , aiSumWithdrawals = Db.unValueSumAda (Just wdrlTotal) - } +-- -- A stake address state is bad if sum rewards < sum withdrawals +-- queryBadWithdrawals :: MonadIO m => DB.DbAction m [AddressInfo] +-- queryBadWithdrawals = do +-- res <- select $ do +-- (rwd :& sa :& wdrl) <- +-- from +-- $ table @DB.Reward +-- `innerJoin` table @DB.StakeAddress +-- `on` (\(rwd :& sa) -> rwd ^. DB.RewardAddrId ==. sa ^. DB.StakeAddressId) +-- `innerJoin` table @DB.Withdrawal +-- `on` (\(rwd :& _sa :& wdrl) -> rwd ^. DB.RewardAddrId ==. wdrl ^. DB.WithdrawalAddrId) +-- groupBy (sa ^. DB.StakeAddressId) +-- let sumReward = sum_ (rwd ^. DB.RewardAmount) +-- sumWithdraw = sum_ (wdrl ^. DB.WithdrawalAmount) +-- having (sumReward <. sumWithdraw) +-- pure (sa ^. DB.StakeAddressView, sumReward, sumWithdraw) +-- pure $ List.sort (map convert res) +-- where +-- convert :: (Value Text, Value (Maybe Micro), Value (Maybe Micro)) -> AddressInfo +-- convert (Value saView, rwdTotal, wdrlTotal) = +-- AddressInfo +-- { aiStakeAddress = saView +-- , aiSumRewards = DB.unValueSumAda (Just rwdTotal) +-- , aiSumWithdrawals = DB.unValueSumAda (Just wdrlTotal) +-- } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs index 3c2dae95d..0b882795b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} module Cardano.DbSync.Era.Universal.Adjust ( @@ -8,7 +7,7 @@ module Cardano.DbSync.Era.Universal.Adjust ( ) where import Cardano.BM.Trace (Trace, logInfo) -import qualified Cardano.Db as Db +import qualified Cardano.Db as DB import Cardano.DbSync.Cache ( queryPoolKeyWithCache, queryStakeAddrWithCache, @@ -19,21 +18,10 @@ import Cardano.DbSync.Types (StakeCred) import Cardano.Ledger.BaseTypes (Network) import Cardano.Prelude hiding (from, groupBy, on) import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Database.Esqueleto.Experimental ( - SqlBackend, - delete, - from, - in_, - table, - val, - valList, - where_, - (==.), - (^.), - ) +import Data.List (unzip4) +import Data.List.Extra (chunksOf) -- Hlint warns about another version of this operator. {- HLINT ignore "Redundant ^." -} @@ -46,54 +34,69 @@ import Database.Esqueleto.Experimental ( -- been de-registered and not reregistered and then delete all rewards for those addresses and that -- epoch. +-- Update the adjustEpochRewards function to use bulk operations adjustEpochRewards :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> Network -> CacheStatus -> EpochNo -> Generic.Rewards -> Set StakeCred -> - ReaderT SqlBackend m () + DB.DbAction m () adjustEpochRewards trce nw cache epochNo rwds creds = do - let eraIgnored = Map.toList $ Generic.unRewards rwds + let rewardsToDelete = + [ (cred, rwd) + | (cred, rewards) <- Map.toList $ Generic.unRewards rwds + , rwd <- Set.toList rewards + ] liftIO . logInfo trce $ mconcat [ "Removing " - , if null eraIgnored then "" else textShow (length eraIgnored) <> " rewards and " + , if null rewardsToDelete then "0" else textShow (length rewardsToDelete) <> " rewards and " , show (length creds) , " orphaned rewards" ] - forM_ eraIgnored $ \(cred, rewards) -> - forM_ (Set.toList rewards) $ \rwd -> - deleteReward trce nw cache epochNo (cred, rwd) - crds <- rights <$> forM (Set.toList creds) (queryStakeAddrWithCache trce cache DoNotUpdateCache nw) - deleteOrphanedRewards epochNo crds -deleteReward :: - (MonadBaseControl IO m, MonadIO m) => + -- Process rewards in batches + unless (null rewardsToDelete) $ do + forM_ (chunksOf maxBatchSize rewardsToDelete) $ \batch -> do + params <- prepareRewardsForDeletion trce nw cache epochNo batch + unless (areParamsEmpty params) $ + DB.deleteRewardsBulk params + + -- Handle orphaned rewards in batches too + crds <- catMaybes <$> forM (Set.toList creds) (queryStakeAddrWithCache trce cache DoNotUpdateCache nw) + forM_ (chunksOf maxBatchSize crds) $ \batch -> + DB.deleteOrphanedRewardsBulk (unEpochNo epochNo) batch + +prepareRewardsForDeletion :: + MonadIO m => Trace IO Text -> Network -> CacheStatus -> EpochNo -> - (StakeCred, Generic.Reward) -> - ReaderT SqlBackend m () -deleteReward trce nw cache epochNo (cred, rwd) = do - mAddrId <- queryStakeAddrWithCache trce cache DoNotUpdateCache nw cred - eiPoolId <- queryPoolKeyWithCache cache DoNotUpdateCache (Generic.rewardPool rwd) - case (mAddrId, eiPoolId) of - (Right addrId, Right poolId) -> do - delete $ do - rwdDb <- from $ table @Db.Reward - where_ (rwdDb ^. Db.RewardAddrId ==. val addrId) - where_ (rwdDb ^. Db.RewardType ==. val (Generic.rewardSource rwd)) - where_ (rwdDb ^. Db.RewardSpendableEpoch ==. val (unEpochNo epochNo)) - where_ (rwdDb ^. Db.RewardPoolId ==. val poolId) - _otherwise -> pure () + [(StakeCred, Generic.Reward)] -> + DB.DbAction m ([DB.StakeAddressId], [DB.RewardSource], [Word64], [DB.PoolHashId]) +prepareRewardsForDeletion trce nw cache epochNo rewards = do + -- Process each reward to get parameter tuples + rewardParams <- forM rewards $ \(cred, rwd) -> do + mAddrId <- queryStakeAddrWithCache trce cache DoNotUpdateCache nw cred + eiPoolId <- queryPoolKeyWithCache cache DoNotUpdateCache (Generic.rewardPool rwd) + pure $ case (mAddrId, eiPoolId) of + (Just addrId, Right poolId) -> + Just (addrId, Generic.rewardSource rwd, unEpochNo epochNo, poolId) + _otherwise -> Nothing + -- Filter out Nothings and extract parameters + let validParams = catMaybes rewardParams + -- Return the unzipped parameters, or empty lists if none are valid + if null validParams + then pure ([], [], [], []) + else pure $ unzip4 validParams + +-- Add this helper function +areParamsEmpty :: ([a], [b], [c], [d]) -> Bool +areParamsEmpty (as, bs, cs, ds) = null as || null bs || null cs || null ds -deleteOrphanedRewards :: MonadIO m => EpochNo -> [Db.StakeAddressId] -> ReaderT SqlBackend m () -deleteOrphanedRewards (EpochNo epochNo) xs = - delete $ do - rwd <- from $ table @Db.Reward - where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) - where_ (rwd ^. Db.RewardAddrId `in_` valList xs) +maxBatchSize :: Int +maxBatchSize = 10000 diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs index 0a30009e8..b74b96a3f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs @@ -51,7 +51,7 @@ import Database.Persist.Sql (SqlBackend) -- This is the entry point for inserting a block into the database, used for all eras appart from Byron. -------------------------------------------------------------------------------------------- insertBlockUniversal :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> -- | Should log Bool -> @@ -63,7 +63,7 @@ insertBlockUniversal :: SlotDetails -> IsPoolMember -> ApplyResult -> - ReaderT SqlBackend m (Either SyncNodeError ()) + DB.DbAction m (Either SyncNodeError ()) insertBlockUniversal syncEnv shouldLog withinTwoMins withinHalfHour blk details isMember applyResult = do -- if we're syncing within 2 mins of the tip, we optimise the caches. when (isSyncedWithintwoMinutes details) $ optimiseCaches cache diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs index cc1f86205..977d5b7f1 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs @@ -51,7 +51,6 @@ import Cardano.Ledger.Conway.Rules (RatifyState (..)) import Cardano.Prelude import Cardano.Slotting.Slot (EpochNo (..), SlotNo) import Control.Concurrent.Class.MonadSTM.Strict (readTVarIO) -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Database.Persist.Sql (SqlBackend) @@ -62,13 +61,13 @@ import Database.Persist.Sql (SqlBackend) -- Insert Epoch -------------------------------------------------------------------------------------------- insertOnNewEpoch :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> DB.BlockId -> SlotNo -> EpochNo -> Generic.NewEpoch -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertOnNewEpoch syncEnv blkId slotNo epochNo newEpoch = do whenStrictJust (Generic.euProtoParams epochUpdate) $ \params -> lift $ insertEpochParam tracer blkId epochNo params (Generic.euNonce epochUpdate) @@ -106,13 +105,13 @@ insertOnNewEpoch syncEnv blkId slotNo epochNo newEpoch = do iopts = getInsertOptions syncEnv insertEpochParam :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> DB.BlockId -> EpochNo -> Generic.ProtoParams -> Ledger.Nonce -> - ReaderT SqlBackend m () + DB.DbAction m () insertEpochParam _tracer blkId (EpochNo epoch) params nonce = do cmId <- maybe (pure Nothing) (fmap Just . insertCostModel blkId) (Generic.ppCostmdls params) void @@ -194,10 +193,10 @@ hasEpochStartEvent = any isNewEpoch _otherwise -> False insertStakeSlice :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Generic.StakeSliceRes -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertStakeSlice _ Generic.NoSlices = pure () insertStakeSlice syncEnv (Generic.Slice slice finalSlice) = do insertEpochStake syncEnv network (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice) @@ -215,25 +214,24 @@ insertStakeSlice syncEnv (Generic.Slice slice finalSlice) = do network = getNetwork syncEnv insertEpochStake :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Network -> EpochNo -> [(StakeCred, (Shelley.Coin, PoolKeyHash))] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertEpochStake syncEnv nw epochNo stakeChunk = do let cache = envCache syncEnv - DB.ManualDbConstraints {..} <- liftIO $ readTVarIO $ envDbConstraints syncEnv dbStakes <- mapM (mkStake cache) stakeChunk let chunckDbStakes = splittRecordsEvery 100000 dbStakes -- minimising the bulk inserts into hundred thousand chunks to improve performance - forM_ chunckDbStakes $ \dbs -> lift $ DB.insertManyEpochStakes dbConstraintEpochStake constraintNameEpochStake dbs + forM_ chunckDbStakes $ \dbs -> lift $ DB.insertBulkEpochStakes dbs where mkStake :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => CacheStatus -> (StakeCred, (Shelley.Coin, PoolKeyHash)) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.EpochStake + ExceptT SyncNodeError (DB.DbAction m) DB.EpochStake mkStake cache (saddr, (coin, pool)) = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong nw saddr poolId <- lift $ queryPoolKeyOrInsert "insertEpochStake" trce cache UpdateCache (ioShelley iopts) pool @@ -249,34 +247,33 @@ insertEpochStake syncEnv nw epochNo stakeChunk = do iopts = getInsertOptions syncEnv insertRewards :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Network -> EpochNo -> EpochNo -> CacheStatus -> [(StakeCred, Set Generic.Reward)] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertRewards syncEnv nw earnedEpoch spendableEpoch cache rewardsChunk = do - DB.ManualDbConstraints {..} <- liftIO $ readTVarIO $ envDbConstraints syncEnv dbRewards <- concatMapM mkRewards rewardsChunk let chunckDbRewards = splittRecordsEvery 100000 dbRewards -- minimising the bulk inserts into hundred thousand chunks to improve performance - forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyRewards dbConstraintRewards constraintNameReward rws + forM_ chunckDbRewards $ \rws -> lift $ DB.insertBulkRewards rws where mkRewards :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (StakeCred, Set Generic.Reward) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.Reward] + ExceptT SyncNodeError (DB.DbAction m) [DB.Reward] mkRewards (saddr, rset) = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong nw saddr mapM (prepareReward saId) (Set.toList rset) prepareReward :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.StakeAddressId -> Generic.Reward -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.Reward + ExceptT SyncNodeError (DB.DbAction m) DB.Reward prepareReward saId rwd = do poolId <- queryPool (Generic.rewardPool rwd) pure $ @@ -290,9 +287,9 @@ insertRewards syncEnv nw earnedEpoch spendableEpoch cache rewardsChunk = do } queryPool :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => PoolKeyHash -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.PoolHashId + ExceptT SyncNodeError (DB.DbAction m) DB.PoolHashId queryPool poolHash = lift (queryPoolKeyOrInsert "insertRewards" trce cache UpdateCache (ioShelley iopts) poolHash) @@ -300,24 +297,24 @@ insertRewards syncEnv nw earnedEpoch spendableEpoch cache rewardsChunk = do iopts = getInsertOptions syncEnv insertRewardRests :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> Network -> EpochNo -> EpochNo -> CacheStatus -> [(StakeCred, Set Generic.RewardRest)] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertRewardRests trce nw earnedEpoch spendableEpoch cache rewardsChunk = do dbRewards <- concatMapM mkRewards rewardsChunk let chunckDbRewards = splittRecordsEvery 100000 dbRewards -- minimising the bulk inserts into hundred thousand chunks to improve performance - forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyRewardRests rws + forM_ chunckDbRewards $ \rws -> lift $ DB.insertBulkRewardRests rws where mkRewards :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (StakeCred, Set Generic.RewardRest) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.RewardRest] + ExceptT SyncNodeError (DB.DbAction m) [DB.RewardRest] mkRewards (saddr, rset) = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong nw saddr pure $ map (prepareReward saId) (Set.toList rset) @@ -336,22 +333,22 @@ insertRewardRests trce nw earnedEpoch spendableEpoch cache rewardsChunk = do } insertProposalRefunds :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> Network -> EpochNo -> EpochNo -> CacheStatus -> [GovActionRefunded] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertProposalRefunds trce nw earnedEpoch spendableEpoch cache refunds = do dbRewards <- mapM mkReward refunds - lift $ DB.insertManyRewardRests dbRewards + lift $ DB.insertBulkRewardRests dbRewards where mkReward :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => GovActionRefunded -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.RewardRest + ExceptT SyncNodeError (DB.DbAction m) DB.RewardRest mkReward refund = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong nw (raCredential $ garReturnAddr refund) pure $ @@ -372,11 +369,11 @@ splittRecordsEvery val = go in as : go bs insertPoolDepositRefunds :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> EpochNo -> Generic.Rewards -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPoolDepositRefunds syncEnv epochNo refunds = do insertRewards syncEnv nw epochNo epochNo (envCache syncEnv) (Map.toList rwds) liftIO . logInfo tracer $ "Inserted " <> show (Generic.rewardsCount refunds) <> " deposit refund rewards" @@ -395,16 +392,16 @@ sumRewardTotal = insertPoolStats :: forall m. - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> EpochNo -> Map PoolKeyHash Generic.PoolStats -> - ReaderT SqlBackend m () + DB.DbAction m () insertPoolStats syncEnv epochNo mp = do poolStats <- mapM preparePoolStat $ Map.toList mp DB.insertManyPoolStat poolStats where - preparePoolStat :: (PoolKeyHash, Generic.PoolStats) -> ReaderT SqlBackend m DB.PoolStat + preparePoolStat :: (PoolKeyHash, Generic.PoolStats) -> DB.DbAction m DB.PoolStat preparePoolStat (pkh, ps) = do poolId <- queryPoolKeyOrInsert "insertPoolStats" trce cache UpdateCache True pkh pure diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs index 46aac293a..a403c35ba 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs @@ -58,7 +58,7 @@ import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.Cardano.Block (StandardCrypto) insertCertificate :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> IsPoolMember -> Maybe Generic.Deposits -> @@ -68,7 +68,7 @@ insertCertificate :: SlotNo -> Map Word64 DB.RedeemerId -> Generic.TxCertificate -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers (Generic.TxCertificate ridx idx cert) = case cert of Left (ShelleyTxCertDelegCert deleg) -> @@ -105,7 +105,7 @@ insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers mRedeemerId = mlookup ridx redeemers insertDelegCert :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Maybe Generic.Deposits -> @@ -116,7 +116,7 @@ insertDelegCert :: EpochNo -> SlotNo -> ShelleyDelegCert StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertDelegCert tracer cache mDeposits network txId idx mRedeemerId epochNo slotNo dCert = case dCert of ShelleyRegCert cred -> insertStakeRegistration tracer cache epochNo mDeposits txId idx $ Generic.annotateStakingCred network cred @@ -124,7 +124,7 @@ insertDelegCert tracer cache mDeposits network txId idx mRedeemerId epochNo slot ShelleyDelegCert cred poolkh -> insertDelegation tracer cache network epochNo slotNo txId idx mRedeemerId cred poolkh insertConwayDelegCert :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Maybe Generic.Deposits -> DB.TxId -> @@ -133,7 +133,7 @@ insertConwayDelegCert :: EpochNo -> SlotNo -> ConwayDelegCert StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertConwayDelegCert syncEnv mDeposits txId idx mRedeemerId epochNo slotNo dCert = case dCert of ConwayRegCert cred _dep -> @@ -169,14 +169,14 @@ insertConwayDelegCert syncEnv mDeposits txId idx mRedeemerId epochNo slotNo dCer network = getNetwork syncEnv insertMirCert :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Ledger.Network -> DB.TxId -> Word16 -> MIRCert StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertMirCert tracer cache network txId idx mcert = do case mirPot mcert of ReservesMIR -> @@ -189,9 +189,9 @@ insertMirCert tracer cache network txId idx mcert = do SendToOppositePotMIR xfrs -> insertPotTransfer (invert $ Ledger.toDeltaCoin xfrs) where insertMirReserves :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (StakeCred, Ledger.DeltaCoin) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertMirReserves (cred, dcoin) = do addrId <- lift $ queryOrInsertStakeAddress tracer cache UpdateCacheStrong network cred void . lift . DB.insertReserve $ @@ -203,9 +203,9 @@ insertMirCert tracer cache network txId idx mcert = do } insertMirTreasury :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (StakeCred, Ledger.DeltaCoin) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertMirTreasury (cred, dcoin) = do addrId <- lift $ queryOrInsertStakeAddress tracer cache UpdateCacheStrong network cred void . lift . DB.insertTreasury $ @@ -217,9 +217,9 @@ insertMirCert tracer cache network txId idx mcert = do } insertPotTransfer :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Ledger.DeltaCoin -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPotTransfer dcoinTreasury = void . lift @@ -235,14 +235,14 @@ insertMirCert tracer cache network txId idx mcert = do -- Insert Registration -------------------------------------------------------------------------------------------- insertDrepRegistration :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.BlockId -> DB.TxId -> Word16 -> Ledger.Credential 'DRepRole StandardCrypto -> Maybe Coin -> Maybe (Anchor StandardCrypto) -> - ReaderT SqlBackend m () + DB.DbAction m () insertDrepRegistration blkId txId idx cred mcoin mAnchor = do drepId <- insertCredDrepHash cred votingAnchorId <- whenMaybe mAnchor $ insertVotingAnchor blkId DB.DrepAnchor @@ -257,12 +257,12 @@ insertDrepRegistration blkId txId idx cred mcoin mAnchor = do } insertDrepDeRegistration :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.TxId -> Word16 -> Ledger.Credential 'DRepRole StandardCrypto -> Coin -> - ReaderT SqlBackend m () + DB.DbAction m () insertDrepDeRegistration txId idx cred coin = do drepId <- insertCredDrepHash cred void @@ -276,12 +276,12 @@ insertDrepDeRegistration txId idx cred coin = do } insertCommitteeRegistration :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.TxId -> Word16 -> Ledger.Credential 'ColdCommitteeRole StandardCrypto -> Ledger.Credential 'HotCommitteeRole StandardCrypto -> - ReaderT SqlBackend m () + DB.DbAction m () insertCommitteeRegistration txId idx khCold cred = do khHotId <- insertCommitteeHash cred khColdId <- insertCommitteeHash khCold @@ -295,13 +295,13 @@ insertCommitteeRegistration txId idx khCold cred = do } insertCommitteeDeRegistration :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.BlockId -> DB.TxId -> Word16 -> Ledger.Credential 'ColdCommitteeRole StandardCrypto -> Maybe (Anchor StandardCrypto) -> - ReaderT SqlBackend m () + DB.DbAction m () insertCommitteeDeRegistration blockId txId idx khCold mAnchor = do votingAnchorId <- whenMaybe mAnchor $ insertVotingAnchor blockId DB.CommitteeDeRegAnchor khColdId <- insertCommitteeHash khCold @@ -315,7 +315,7 @@ insertCommitteeDeRegistration blockId txId idx khCold mAnchor = do } insertStakeDeregistration :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Ledger.Network -> @@ -324,7 +324,7 @@ insertStakeDeregistration :: Word16 -> Maybe DB.RedeemerId -> StakeCred -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertStakeDeregistration trce cache network epochNo txId idx mRedeemerId cred = do scId <- lift $ queryOrInsertStakeAddress trce cache EvictAndUpdateCache network cred void . lift . DB.insertStakeDeregistration $ @@ -337,7 +337,7 @@ insertStakeDeregistration trce cache network epochNo txId idx mRedeemerId cred = } insertStakeRegistration :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> EpochNo -> @@ -345,7 +345,7 @@ insertStakeRegistration :: DB.TxId -> Word16 -> Shelley.RewardAccount StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertStakeRegistration tracer cache epochNo mDeposits txId idx rewardAccount = do saId <- lift $ queryOrInsertRewardAccount tracer cache UpdateCache rewardAccount void . lift . DB.insertStakeRegistration $ @@ -361,12 +361,12 @@ insertStakeRegistration tracer cache epochNo mDeposits txId idx rewardAccount = -- Insert Pots -------------------------------------------------------------------------------------------- insertPots :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.BlockId -> SlotNo -> EpochNo -> Shelley.AdaPots -> - ExceptT e (ReaderT SqlBackend m) () + ExceptT e (DB.DbAction m) () insertPots blockId slotNo epochNo pots = void . lift @@ -400,7 +400,7 @@ mkAdaPots blockId slotNo epochNo pots = -- Insert Delegation -------------------------------------------------------------------------------------------- insertDelegation :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Ledger.Network -> @@ -411,7 +411,7 @@ insertDelegation :: Maybe DB.RedeemerId -> StakeCred -> Ledger.KeyHash 'Ledger.StakePool StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertDelegation trce cache network (EpochNo epoch) slotNo txId idx mRedeemerId cred poolkh = do addrId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong network cred poolHashId <- lift $ queryPoolKeyOrInsert "insertDelegation" trce cache UpdateCache True poolkh @@ -427,7 +427,7 @@ insertDelegation trce cache network (EpochNo epoch) slotNo txId idx mRedeemerId } insertDelegationVote :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Ledger.Network -> @@ -435,7 +435,7 @@ insertDelegationVote :: Word16 -> StakeCred -> DRep StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertDelegationVote trce cache network txId idx cred drep = do addrId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong network cred drepId <- lift $ insertDrep drep 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..863c464b5 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 @@ -76,7 +76,7 @@ insertGovActionProposal :: Maybe EpochNo -> Maybe (ConwayGovState StandardConway) -> (Word64, (GovActionId StandardCrypto, ProposalProcedure StandardConway)) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertGovActionProposal trce cache blkId txId govExpiresAt mcgs (index, (govId, pp)) = do addrId <- lift $ queryOrInsertRewardAccount trce cache UpdateCache $ pProcReturnAddr pp @@ -134,7 +134,7 @@ insertGovActionProposal trce cache blkId txId govExpiresAt mcgs (index, (govId, insertNewCommittee :: DB.GovActionProposalId -> - ReaderT SqlBackend m () + DB.DbAction m () insertNewCommittee govActionProposalId = do whenJust mcgs $ \cgs -> case findProposedCommittee govId cgs of @@ -142,7 +142,7 @@ insertGovActionProposal trce cache blkId txId govExpiresAt mcgs (index, (govId, other -> liftIO $ logWarning trce $ textShow other <> ": Failed to find committee for " <> textShow pp -insertCommittee :: (MonadIO m, MonadBaseControl IO m) => Maybe DB.GovActionProposalId -> Committee StandardConway -> ReaderT SqlBackend m DB.CommitteeId +insertCommittee :: (MonadIO m, MonadBaseControl IO m) => Maybe DB.GovActionProposalId -> Committee StandardConway -> DB.DbAction m DB.CommitteeId insertCommittee mgapId committee = do committeeId <- insertCommitteeDB mapM_ (insertNewMember committeeId) (Map.toList $ committeeMembers committee) @@ -173,7 +173,7 @@ resolveGovActionProposal :: MonadIO m => CacheStatus -> GovActionId StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.GovActionProposalId + ExceptT SyncNodeError (DB.DbAction m) DB.GovActionProposalId resolveGovActionProposal cache gaId = do let txId = gaidTxId gaId gaTxId <- liftLookupFail "resolveGovActionProposal.queryTxId" $ queryTxIdWithCache cache txId @@ -182,11 +182,11 @@ resolveGovActionProposal cache gaId = do DB.queryGovActionProposalId gaTxId (fromIntegral index) -- TODO: Use Word32? insertParamProposal :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.BlockId -> DB.TxId -> ParamProposal -> - ReaderT SqlBackend m DB.ParamProposalId + DB.DbAction m DB.ParamProposalId insertParamProposal blkId txId pp = do cmId <- maybe (pure Nothing) (fmap Just . insertCostModel blkId) (pppCostmdls pp) DB.insertParamProposal $ @@ -249,7 +249,7 @@ insertParamProposal blkId txId pp = do , DB.paramProposalMinFeeRefScriptCostPerByte = fromRational <$> pppMinFeeRefScriptCostPerByte pp } -insertConstitution :: (MonadIO m, MonadBaseControl IO m) => DB.BlockId -> Maybe DB.GovActionProposalId -> Constitution StandardConway -> ReaderT SqlBackend m DB.ConstitutionId +insertConstitution :: (MonadIO m, MonadBaseControl IO m) => DB.BlockId -> Maybe DB.GovActionProposalId -> Constitution StandardConway -> DB.DbAction m DB.ConstitutionId insertConstitution blockId mgapId constitution = do votingAnchorId <- insertVotingAnchor blockId DB.ConstitutionAnchor $ constitutionAnchor constitution DB.insertConstitution $ @@ -269,7 +269,7 @@ insertVotingProcedures :: DB.BlockId -> DB.TxId -> (Voter StandardCrypto, [(GovActionId StandardCrypto, VotingProcedure StandardConway)]) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertVotingProcedures trce cache blkId txId (voter, actions) = mapM_ (insertVotingProcedure trce cache blkId txId voter) (zip [0 ..] actions) @@ -281,7 +281,7 @@ insertVotingProcedure :: DB.TxId -> Voter StandardCrypto -> (Word16, (GovActionId StandardCrypto, VotingProcedure StandardConway)) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertVotingProcedure trce cache blkId txId voter (index, (gaId, vp)) = do govActionId <- resolveGovActionProposal cache gaId votingAnchorId <- whenMaybe (strictMaybeToMaybe $ vProcAnchor vp) $ lift . insertVotingAnchor blkId DB.VoteAnchor @@ -311,7 +311,7 @@ insertVotingProcedure trce cache blkId txId voter (index, (gaId, vp)) = do , DB.votingProcedureInvalid = Nothing } -insertVotingAnchor :: (MonadIO m, MonadBaseControl IO m) => DB.BlockId -> DB.AnchorType -> Anchor StandardCrypto -> ReaderT SqlBackend m DB.VotingAnchorId +insertVotingAnchor :: (MonadIO m, MonadBaseControl IO m) => DB.BlockId -> DB.AnchorType -> Anchor StandardCrypto -> DB.DbAction m DB.VotingAnchorId insertVotingAnchor blockId anchorType anchor = DB.insertAnchor $ DB.VotingAnchor @@ -321,7 +321,7 @@ insertVotingAnchor blockId anchorType anchor = , DB.votingAnchorType = anchorType } -insertCommitteeHash :: (MonadBaseControl IO m, MonadIO m) => Ledger.Credential kr StandardCrypto -> ReaderT SqlBackend m DB.CommitteeHashId +insertCommitteeHash :: MonadIO m => Ledger.Credential kr StandardCrypto -> DB.DbAction m DB.CommitteeHashId insertCommitteeHash cred = do DB.insertCommitteeHash DB.CommitteeHash @@ -332,13 +332,13 @@ insertCommitteeHash cred = do -------------------------------------------------------------------------------------- -- DREP -------------------------------------------------------------------------------------- -insertDrep :: (MonadBaseControl IO m, MonadIO m) => DRep StandardCrypto -> ReaderT SqlBackend m DB.DrepHashId +insertDrep :: MonadIO m => DRep StandardCrypto -> DB.DbAction 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 +insertCredDrepHash :: MonadIO m => Ledger.Credential 'DRepRole StandardCrypto -> DB.DbAction m DB.DrepHashId insertCredDrepHash cred = do DB.insertDrepHash DB.DrepHash @@ -349,12 +349,12 @@ insertCredDrepHash cred = do where bs = Generic.unCredentialHash cred -insertDrepDistr :: forall m. (MonadBaseControl IO m, MonadIO m) => EpochNo -> PulsingSnapshot StandardConway -> ReaderT SqlBackend m () +insertDrepDistr :: forall m. MonadIO m => EpochNo -> PulsingSnapshot StandardConway -> DB.DbAction m () insertDrepDistr e pSnapshot = do drepsDB <- mapM mkEntry (Map.toList $ psDRepDistr pSnapshot) DB.insertManyDrepDistr drepsDB where - mkEntry :: (DRep StandardCrypto, Ledger.CompactForm Coin) -> ReaderT SqlBackend m DB.DrepDistr + mkEntry :: (DRep StandardCrypto, Ledger.CompactForm Coin) -> DB.DbAction m DB.DrepDistr mkEntry (drep, coin) = do drepId <- insertDrep drep pure $ @@ -372,10 +372,10 @@ insertDrepDistr e pSnapshot = do DRepCredential cred -> drepExpiry <$> Map.lookup cred (psDRepState pSnapshot) insertCostModel :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.BlockId -> Map Language Ledger.CostModel -> - ReaderT SqlBackend m DB.CostModelId + DB.DbAction m DB.CostModelId insertCostModel _blkId cms = DB.insertCostModel $ DB.CostModel @@ -389,7 +389,7 @@ updateRatified :: CacheStatus -> EpochNo -> [GovActionState StandardConway] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () updateRatified cache epochNo ratifiedActions = do forM_ ratifiedActions $ \action -> do gaId <- resolveGovActionProposal cache $ gasId action @@ -401,7 +401,7 @@ updateExpired :: CacheStatus -> EpochNo -> [GovActionId StandardCrypto] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () updateExpired cache epochNo ratifiedActions = do forM_ ratifiedActions $ \action -> do gaId <- resolveGovActionProposal cache action @@ -413,7 +413,7 @@ updateDropped :: CacheStatus -> EpochNo -> [GovActionId StandardCrypto] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () updateDropped cache epochNo ratifiedActions = do forM_ ratifiedActions $ \action -> do gaId <- resolveGovActionProposal cache action @@ -421,13 +421,13 @@ updateDropped cache epochNo ratifiedActions = do insertUpdateEnacted :: forall m. - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> DB.BlockId -> EpochNo -> ConwayGovState StandardConway -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertUpdateEnacted trce cache blkId epochNo enactedState = do (mcommitteeId, mnoConfidenceGaId) <- handleCommittee constitutionId <- handleConstitution diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs index dc6b61234..b3f18cc36 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs @@ -15,22 +15,19 @@ module Cardano.DbSync.Era.Universal.Insert.Grouped ( ) where import Cardano.BM.Trace (Trace, logWarning) -import Cardano.Db (DbLovelace (..), MinIds (..), minIdsCoreToText, minIdsVariantToText) +import Cardano.Db (DbLovelace (..), MinIds (..)) 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.Variants.TxOutCore as VC +import qualified Cardano.Db.Schema.Variants.TxOutAddress as VA import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (SyncEnv (..)) import Cardano.DbSync.Cache (queryTxIdWithCache) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Query -import Cardano.DbSync.Era.Util import Cardano.DbSync.Error import Cardano.Prelude -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.List as List import qualified Data.Text as Text -import Database.Persist.Sql (SqlBackend) -- | Group data within the same block, to insert them together in batches -- @@ -86,71 +83,71 @@ instance Semigroup BlockGroupedData where (groupedTxOutSum tgd1 + groupedTxOutSum tgd2) insertBlockGroupedData :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> BlockGroupedData -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.MinIdsWrapper + DB.DbAction m DB.MinIdsWrapper insertBlockGroupedData syncEnv grouped = do disInOut <- liftIO $ getDisableInOutState syncEnv - txOutIds <- lift . DB.insertManyTxOut disInOut $ etoTxOut . fst <$> groupedTxOut grouped - let maTxOuts = concatMap (mkmaTxOuts txOutTableType) $ zip txOutIds (snd <$> groupedTxOut grouped) - maTxOutIds <- lift $ DB.insertManyMaTxOut maTxOuts + txOutIds <- DB.insertBulkTxOut disInOut $ etoTxOut . fst <$> groupedTxOut grouped + let maTxOuts = concatMap (mkmaTxOuts txOutVariantType) $ zip txOutIds (snd <$> groupedTxOut grouped) + maTxOutIds <- DB.insertBulkMaTxOut maTxOuts txInIds <- if getSkipTxIn syncEnv then pure [] - else lift . DB.insertManyTxIn $ etiTxIn <$> groupedTxIn grouped + else DB.insertBulkTxIn $ etiTxIn <$> groupedTxIn grouped whenConsumeOrPruneTxOut syncEnv $ do etis <- resolveRemainingInputs (groupedTxIn grouped) $ zip txOutIds (fst <$> groupedTxOut grouped) - updateTuples <- lift $ mapM (prepareUpdates tracer) etis - lift $ DB.updateListTxOutConsumedByTxId $ catMaybes updateTuples - void . lift . DB.insertManyTxMetadata $ groupedTxMetadata grouped - void . lift . DB.insertManyTxMint $ groupedTxMint grouped + updateTuples <- mapM (prepareUpdates tracer) etis + DB.updateListTxOutConsumedByTxId $ catMaybes updateTuples + void . DB.insertBulkTxMetadata $ groupedTxMetadata grouped + void . DB.insertBulkMaTxMint $ groupedTxMint grouped pure $ makeMinId txInIds txOutIds maTxOutIds where tracer = getTrace syncEnv - txOutTableType = getTxOutTableType syncEnv + txOutVariantType = getTxOutVariantType syncEnv makeMinId :: [DB.TxInId] -> [DB.TxOutIdW] -> [DB.MaTxOutIdW] -> DB.MinIdsWrapper makeMinId txInIds txOutIds maTxOutIds = - case txOutTableType of - DB.TxOutCore -> do + case txOutVariantType of + DB.TxOutVariantCore -> do DB.CMinIdsWrapper $ DB.MinIds { minTxInId = listToMaybe txInIds - , minTxOutId = listToMaybe $ DB.convertTxOutIdCore txOutIds - , minMaTxOutId = listToMaybe $ DB.convertMaTxOutIdCore maTxOutIds + , minTxOutId = listToMaybe txOutIds + , minMaTxOutId = listToMaybe maTxOutIds } DB.TxOutVariantAddress -> DB.VMinIdsWrapper $ DB.MinIds { minTxInId = listToMaybe txInIds - , minTxOutId = listToMaybe $ DB.convertTxOutIdVariant txOutIds - , minMaTxOutId = listToMaybe $ DB.convertMaTxOutIdVariant maTxOutIds + , minTxOutId = listToMaybe txOutIds + , minMaTxOutId = listToMaybe maTxOutIds } -mkmaTxOuts :: DB.TxOutTableType -> (DB.TxOutIdW, [MissingMaTxOut]) -> [DB.MaTxOutW] -mkmaTxOuts _txOutTableType (txOutId, mmtos) = mkmaTxOut <$> mmtos +mkmaTxOuts :: DB.TxOutVariantType -> (DB.TxOutIdW, [MissingMaTxOut]) -> [DB.MaTxOutW] +mkmaTxOuts _txOutVariantType (txOutId, mmtos) = mkmaTxOut <$> mmtos where mkmaTxOut :: MissingMaTxOut -> DB.MaTxOutW mkmaTxOut missingMaTx = case txOutId of - DB.CTxOutIdW txOutId' -> + DB.VCTxOutIdW txOutId' -> DB.CMaTxOutW $ - C.MaTxOut - { C.maTxOutIdent = mmtoIdent missingMaTx - , C.maTxOutQuantity = mmtoQuantity missingMaTx - , C.maTxOutTxOutId = txOutId' + VC.MaTxOutCore + { VC.maTxOutCoreIdent = mmtoIdent missingMaTx + , VC.maTxOutCoreQuantity = mmtoQuantity missingMaTx + , VC.maTxOutCoreTxOutId = txOutId' } - DB.VTxOutIdW txOutId' -> + DB.VATxOutIdW txOutId' -> DB.VMaTxOutW - V.MaTxOut - { V.maTxOutIdent = mmtoIdent missingMaTx - , V.maTxOutQuantity = mmtoQuantity missingMaTx - , V.maTxOutTxOutId = txOutId' + VA.MaTxOutAddress + { VA.maTxOutAddressIdent = mmtoIdent missingMaTx + , VA.maTxOutAddressQuantity = mmtoQuantity missingMaTx + , VA.maTxOutAddressTxOutId = txOutId' } prepareUpdates :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> ExtendedTxIn -> m (Maybe (DB.TxOutIdW, DB.TxId)) @@ -161,23 +158,23 @@ prepareUpdates trce eti = case etiTxOutId eti of pure Nothing insertReverseIndex :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.BlockId -> DB.MinIdsWrapper -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertReverseIndex blockId minIdsWrapper = case minIdsWrapper of DB.CMinIdsWrapper minIds -> void . lift . DB.insertReverseIndex $ DB.ReverseIndex { DB.reverseIndexBlockId = blockId - , DB.reverseIndexMinIds = minIdsCoreToText minIds + , DB.reverseIndexMinIds = DB.minIdsCoreToText minIds } DB.VMinIdsWrapper minIds -> void . lift . DB.insertReverseIndex $ DB.ReverseIndex { DB.reverseIndexBlockId = blockId - , DB.reverseIndexMinIds = minIdsVariantToText minIds + , DB.reverseIndexMinIds = DB.minIdsAddressToText minIds } -- | If we can't resolve from the db, we fall back to the provided outputs @@ -189,48 +186,48 @@ resolveTxInputs :: Bool -> [ExtendedTxOut] -> Generic.TxIn -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) -resolveTxInputs syncEnv hasConsumed needsValue groupedOutputs txIn = - liftLookupFail ("resolveTxInputs " <> textShow txIn <> " ") $ do + DB.DbAction m (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) +resolveTxInputs syncEnv hasConsumed needsValue groupedOutputs txIn = do qres <- case (hasConsumed, needsValue) of - (_, True) -> fmap convertFoundAll <$> resolveInputTxOutIdValue syncEnv txIn - (False, _) -> fmap convertnotFoundCache <$> queryTxIdWithCache (envCache syncEnv) (Generic.txInTxId txIn) - (True, False) -> fmap convertFoundTxOutId <$> resolveInputTxOutId syncEnv txIn + (_, True) -> convertFoundAll <$> resolveInputTxOutIdValue syncEnv txIn + (False, _) -> convertnotFoundCache <$> queryTxIdWithCache (envCache syncEnv) (Generic.txInTxId txIn) + (True, False) -> convertFoundTxOutId <$> resolveInputTxOutId syncEnv txIn case qres of - Right ret -> pure $ Right ret + Right result -> pure result Left err -> case (resolveInMemory txIn groupedOutputs, hasConsumed, needsValue) of - (Nothing, _, _) -> pure $ Left err - (Just eutxo, True, True) -> pure $ Right $ convertFoundValue (etoTxOut eutxo) - (Just eutxo, _, _) -> pure $ Right $ convertnotFound (etoTxOut eutxo) + (Nothing, _, _) -> + throwError err + (Just eutxo, True, True) -> + pure $ convertFoundValue (etoTxOut eutxo) + (Just eutxo, _, _) -> + pure $ convertnotFound (etoTxOut eutxo) where - convertnotFoundCache :: DB.TxId -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) - convertnotFoundCache txId = (txIn, txId, Left txIn, Nothing) + convertnotFoundCache :: DB.TxId -> Either err (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertnotFoundCache txId = Right (txIn, txId, Left txIn, Nothing) convertnotFound :: DB.TxOutW -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) convertnotFound txOutWrapper = case txOutWrapper of - DB.CTxOutW cTxOut -> (txIn, C.txOutTxId cTxOut, Left txIn, Nothing) - DB.VTxOutW vTxOut _ -> (txIn, V.txOutTxId vTxOut, Left txIn, Nothing) + DB.VCTxOutW cTxOut -> (txIn, VC.txOutCoreTxId cTxOut, Left txIn, Nothing) + DB.VATxOutW vTxOut _ -> (txIn, VA.txOutAddressTxId vTxOut, Left txIn, Nothing) - convertFoundTxOutId :: (DB.TxId, DB.TxOutIdW) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) - convertFoundTxOutId (txId, txOutId) = (txIn, txId, Right txOutId, Nothing) + convertFoundTxOutId :: (DB.TxId, DB.TxOutIdW) -> Either err (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertFoundTxOutId (txId, txOutId) = Right (txIn, txId, Right txOutId, Nothing) - -- convertFoundValue :: (DB.TxId, DbLovelace) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) convertFoundValue :: DB.TxOutW -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) convertFoundValue txOutWrapper = case txOutWrapper of - DB.CTxOutW cTxOut -> (txIn, C.txOutTxId cTxOut, Left txIn, Just $ C.txOutValue cTxOut) - DB.VTxOutW vTxOut _ -> (txIn, V.txOutTxId vTxOut, Left txIn, Just $ V.txOutValue vTxOut) - -- (txIn, txId, Left txIn, Just lovelace) + DB.VCTxOutW cTxOut -> (txIn, VC.txOutCoreTxId cTxOut, Left txIn, Just $ VC.txOutCoreValue cTxOut) + DB.VATxOutW vTxOut _ -> (txIn, VA.txOutAddressTxId vTxOut, Left txIn, Just $ VA.txOutAddressValue vTxOut) - convertFoundAll :: (DB.TxId, DB.TxOutIdW, DbLovelace) -> (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) - convertFoundAll (txId, txOutId, lovelace) = (txIn, txId, Right txOutId, Just lovelace) + convertFoundAll :: (DB.TxId, DB.TxOutIdW, DbLovelace) -> Either err (Generic.TxIn, DB.TxId, Either Generic.TxIn DB.TxOutIdW, Maybe DbLovelace) + convertFoundAll (txId, txOutId, lovelace) = Right (txIn, txId, Right txOutId, Just lovelace) resolveRemainingInputs :: MonadIO m => [ExtendedTxIn] -> [(DB.TxOutIdW, ExtendedTxOut)] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [ExtendedTxIn] + DB.DbAction m [ExtendedTxIn] resolveRemainingInputs etis mp = mapM f etis where @@ -239,27 +236,26 @@ resolveRemainingInputs etis mp = Left txIn | Just txOutId <- fst <$> find (matches txIn . snd) mp -> pure eti {etiTxOutId = Right txOutId} - _ -> pure eti + _otherwise -> pure eti resolveScriptHash :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> [ExtendedTxOut] -> Generic.TxIn -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe ByteString) -resolveScriptHash syncEnv groupedOutputs txIn = - liftLookupFail "resolveScriptHash" $ do - qres <- fmap fst <$> queryResolveInputCredentials syncEnv txIn - case qres of - Right ret -> pure $ Right ret - Left err -> - case resolveInMemory txIn groupedOutputs of - Nothing -> pure $ Left err - Just eutxo -> case etoTxOut eutxo of - DB.CTxOutW cTxOut -> pure $ Right $ C.txOutPaymentCred cTxOut - DB.VTxOutW _ vAddress -> case vAddress of - Nothing -> pure $ Left $ DB.DBTxOutVariant "resolveScriptHash: VTxOutW with Nothing address" - Just vAddr -> pure $ Right $ V.addressPaymentCred vAddr + DB.DbAction m (Maybe ByteString) +resolveScriptHash syncEnv groupedOutputs txIn = do + qres <- queryResolveInputCredentials syncEnv txIn + case qres of + Just ret -> pure $ Just ret + Nothing -> + case resolveInMemory txIn groupedOutputs of + Nothing -> throwError $ DB.DbError DB.mkCallSite "resolveScriptHash resolveInMemory: VATxOutW with Nothing address" Nothing + Just eutxo -> case etoTxOut eutxo of + DB.VCTxOutW cTxOut -> pure $ VC.txOutCorePaymentCred cTxOut + DB.VATxOutW _ vAddress -> case vAddress of + Nothing -> throwError $ DB.DbError DB.mkCallSite "resolveScriptHash: VATxOutW with Nothing address" Nothing + Just vAddr -> pure $ VA.addressPaymentCred vAddr resolveInMemory :: Generic.TxIn -> [ExtendedTxOut] -> Maybe ExtendedTxOut resolveInMemory txIn = @@ -272,5 +268,5 @@ matches txIn eutxo = where getTxOutIndex :: DB.TxOutW -> Word64 getTxOutIndex txOutWrapper = case txOutWrapper of - DB.CTxOutW cTxOut -> C.txOutIndex cTxOut - DB.VTxOutW vTxOut _ -> V.txOutIndex vTxOut + DB.VCTxOutW cTxOut -> VC.txOutCoreIndex cTxOut + DB.VATxOutW vTxOut _ -> VA.txOutAddressIndex vTxOut diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs index c4938e8f6..b5a397da2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs @@ -39,11 +39,11 @@ import Database.Persist.SqlBackend.Internal.StatementCache -- Insert LedgerEvents -------------------------------------------------------------------------------------------- insertNewEpochLedgerEvents :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> EpochNo -> [LedgerEvent] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertNewEpochLedgerEvents syncEnv currentEpochNo@(EpochNo curEpoch) = mapM_ handler where @@ -62,9 +62,9 @@ insertNewEpochLedgerEvents syncEnv currentEpochNo@(EpochNo curEpoch) = toSyncState SyncFollowing = DB.SyncFollowing handler :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => LedgerEvent -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () handler ev = case ev of LedgerNewEpoch en ss -> do diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs index 4099e8427..fc83e1063 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs @@ -35,27 +35,24 @@ import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Credential as Ledger import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..)) import Cardano.Prelude -import Control.Monad.Trans.Control (MonadBaseControl) -import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.Cardano.Block (StandardCrypto) -------------------------------------------------------------------------------------------- -- Insert Redeemer -------------------------------------------------------------------------------------------- insertRedeemer :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Bool -> [ExtendedTxOut] -> DB.TxId -> (Word64, Generic.TxRedeemer) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (Word64, DB.RedeemerId) + DB.DbAction m (Word64, DB.RedeemerId) insertRedeemer syncEnv disInOut groupedOutputs txId (rix, redeemer) = do tdId <- insertRedeemerData tracer txId $ Generic.txRedeemerData redeemer scriptHash <- findScriptHash rid <- - lift - . DB.insertRedeemer + DB.insertRedeemer $ DB.Redeemer { DB.redeemerTxId = txId , DB.redeemerUnitMem = Generic.txRedeemerMem redeemer @@ -70,8 +67,8 @@ insertRedeemer syncEnv disInOut groupedOutputs txId (rix, redeemer) = do where tracer = getTrace syncEnv findScriptHash :: - (MonadBaseControl IO m, MonadIO m) => - ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe ByteString) + MonadIO m => + DB.DbAction m (Maybe ByteString) findScriptHash = case (disInOut, Generic.txRedeemerScriptHash redeemer) of (True, _) -> pure Nothing @@ -80,19 +77,18 @@ insertRedeemer syncEnv disInOut groupedOutputs txId (rix, redeemer) = do (_, Just (Left txIn)) -> resolveScriptHash syncEnv groupedOutputs txIn insertRedeemerData :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> DB.TxId -> Generic.PlutusData -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.RedeemerDataId + DB.DbAction m DB.RedeemerDataId insertRedeemerData tracer txId txd = do - mRedeemerDataId <- lift $ DB.queryRedeemerData $ Generic.dataHashToBytes $ Generic.txDataHash txd + mRedeemerDataId <- DB.queryRedeemerData $ Generic.dataHashToBytes $ Generic.txDataHash txd case mRedeemerDataId of Just redeemerDataId -> pure redeemerDataId Nothing -> do value <- safeDecodeToJson tracer "insertDatum: Column 'value' in table 'datum' " $ Generic.txDataValue txd - lift - . DB.insertRedeemerData + DB.insertRedeemerData $ DB.RedeemerData { DB.redeemerDataHash = Generic.dataHashToBytes $ Generic.txDataHash txd , DB.redeemerDataTxId = txId @@ -104,12 +100,12 @@ insertRedeemerData tracer txId txd = do -- Insert Others -------------------------------------------------------------------------------------------- insertDatum :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> DB.TxId -> Generic.PlutusData -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.DatumId + ExceptT SyncNodeError (DB.DbAction m) DB.DatumId insertDatum tracer cache txId txd = do mDatumId <- lift $ queryDatum cache $ Generic.txDataHash txd case mDatumId of @@ -126,13 +122,13 @@ insertDatum tracer cache txId txd = do } insertWithdrawals :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> DB.TxId -> Map Word64 DB.RedeemerId -> Generic.TxWithdrawal -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertWithdrawals tracer cache txId redeemers txWdrl = do addrId <- lift $ queryOrInsertRewardAccount tracer cache UpdateCache $ Generic.txwRewardAccount txWdrl @@ -147,11 +143,11 @@ insertWithdrawals tracer cache txId redeemers txWdrl = do -- | Insert a stake address if it is not already in the `stake_address` table. Regardless of -- whether it is newly inserted or it is already there, we retrun the `StakeAddressId`. insertStakeAddressRefIfMissing :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Ledger.Addr StandardCrypto -> - ReaderT SqlBackend m (Maybe DB.StakeAddressId) + DB.DbAction m (Maybe DB.StakeAddressId) insertStakeAddressRefIfMissing trce cache addr = case addr of Ledger.AddrBootstrap {} -> pure Nothing @@ -164,17 +160,17 @@ insertStakeAddressRefIfMissing trce cache addr = Ledger.StakeRefNull -> pure Nothing insertMultiAsset :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => CacheStatus -> PolicyID StandardCrypto -> AssetName -> - ReaderT SqlBackend m DB.MultiAssetId + DB.DbAction m DB.MultiAssetId insertMultiAsset cache policy aName = do mId <- queryMAWithCache cache policy aName case mId of Right maId -> pure maId Left (policyBs, assetNameBs) -> - DB.insertMultiAssetUnchecked $ + DB.insertMultiAsset $ DB.MultiAsset { DB.multiAssetPolicy = policyBs , DB.multiAssetName = assetNameBs @@ -182,13 +178,13 @@ insertMultiAsset cache policy aName = do } insertScript :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> DB.TxId -> Generic.TxScript -> - ReaderT SqlBackend m DB.ScriptId + DB.DbAction m DB.ScriptId insertScript tracer txId script = do - mScriptId <- DB.queryScript $ Generic.txScriptHash script + mScriptId <- DB.queryScriptWithId $ Generic.txScriptHash script case mScriptId of Just scriptId -> pure scriptId Nothing -> do @@ -208,11 +204,11 @@ insertScript tracer txId script = do maybe (pure Nothing) (safeDecodeToJson tracer "insertScript: Column 'json' in table 'script' ") (Generic.txScriptJson s) insertExtraKeyWitness :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> DB.TxId -> ByteString -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertExtraKeyWitness _tracer txId keyHash = do void . lift diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs index 2631c8a6c..377924235 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs @@ -40,14 +40,12 @@ import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.PoolParams as PoolP import qualified Cardano.Ledger.Shelley.TxBody as Shelley import Cardano.Prelude -import Control.Monad.Trans.Control (MonadBaseControl) -import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.Cardano.Block (StandardCrypto) type IsPoolMember = PoolKeyHash -> Bool insertPoolRegister :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> IsPoolMember -> @@ -58,7 +56,7 @@ insertPoolRegister :: DB.TxId -> Word16 -> PoolP.PoolParams StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPoolRegister trce cache isMember mdeposits network (EpochNo epoch) blkId txId idx params = do poolHashId <- lift $ insertPoolKeyWithCache cache UpdateCache (PoolP.ppId params) mdId <- case strictMaybeToMaybe $ PoolP.ppMetadata params of @@ -90,7 +88,7 @@ insertPoolRegister trce cache isMember mdeposits network (EpochNo epoch) blkId t mapM_ (insertPoolOwner trce cache network poolUpdateId) $ toList (PoolP.ppOwners params) mapM_ (insertPoolRelay poolUpdateId) $ toList (PoolP.ppRelays params) where - isPoolRegistration :: MonadIO m => DB.PoolHashId -> ExceptT SyncNodeError (ReaderT SqlBackend m) Bool + isPoolRegistration :: MonadIO m => DB.PoolHashId -> ExceptT SyncNodeError (DB.DbAction m) Bool isPoolRegistration poolHashId = if isMember (PoolP.ppId params) then pure False @@ -107,14 +105,14 @@ insertPoolRegister trce cache isMember mdeposits network (EpochNo epoch) blkId t adjustNetworkTag (Shelley.RewardAccount _ cred) = Shelley.RewardAccount network cred insertPoolRetire :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> DB.TxId -> CacheStatus -> EpochNo -> Word16 -> Ledger.KeyHash 'Ledger.StakePool StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPoolRetire trce txId cache epochNum idx keyHash = do poolId <- lift $ queryPoolKeyOrInsert "insertPoolRetire" trce cache UpdateCache True keyHash void . lift . DB.insertPoolRetire $ @@ -126,11 +124,11 @@ insertPoolRetire trce txId cache epochNum idx keyHash = do } insertPoolMetaDataRef :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.PoolHashId -> DB.TxId -> PoolP.PoolMetadata -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.PoolMetadataRefId + ExceptT SyncNodeError (DB.DbAction m) DB.PoolMetadataRefId insertPoolMetaDataRef poolId txId md = lift . DB.insertPoolMetadataRef @@ -142,13 +140,13 @@ insertPoolMetaDataRef poolId txId md = } insertPoolOwner :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Ledger.Network -> DB.PoolUpdateId -> Ledger.KeyHash 'Ledger.Staking StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPoolOwner trce cache network poolUpdateId skh = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong network (Ledger.KeyHashObj skh) void . lift . DB.insertPoolOwner $ @@ -158,10 +156,10 @@ insertPoolOwner trce cache network poolUpdateId skh = do } insertPoolRelay :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => DB.PoolUpdateId -> PoolP.StakePoolRelay -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPoolRelay updateId relay = void . lift @@ -196,7 +194,7 @@ insertPoolRelay updateId relay = } insertPoolCert :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> IsPoolMember -> @@ -207,7 +205,7 @@ insertPoolCert :: DB.TxId -> Word16 -> PoolCert StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertPoolCert tracer cache isMember mdeposits network epoch blkId txId idx pCert = case pCert of RegPool pParams -> insertPoolRegister tracer cache isMember mdeposits network epoch blkId txId idx pParams diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs index 4f12d03a9..8c4f0cef5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs @@ -65,7 +65,7 @@ import Ouroboros.Consensus.Cardano.Block (StandardCrypto) -- INSERT TX -------------------------------------------------------------------------------------- insertTx :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> IsPoolMember -> DB.BlockId -> @@ -75,7 +75,7 @@ insertTx :: Word64 -> Generic.Tx -> BlockGroupedData -> - ExceptT SyncNodeError (ReaderT SqlBackend m) BlockGroupedData + ExceptT SyncNodeError (DB.DbAction m) BlockGroupedData insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped = do let !txHash = Generic.txHash tx let !mdeposits = if not (Generic.txValidContract tx) then Just (Coin 0) else lookupDepositsMap txHash (apDepositsMap applyResult) @@ -207,13 +207,13 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped -- INSERT TXOUT -------------------------------------------------------------------------------------- insertTxOut :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> InsertOptions -> (DB.TxId, ByteString) -> Generic.TxOut -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut]) + ExceptT SyncNodeError (DB.DbAction m) (ExtendedTxOut, [MissingMaTxOut]) insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value maMap mScript dt) = do mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr mDatumId <- @@ -225,10 +225,10 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma whenMaybe mScript $ lift . insertScript tracer txId !txOut <- - case ioTxOutTableType iopts of - DB.TxOutCore -> + case ioTxOutVariantType iopts of + DB.TxOutVariantCore -> pure $ - DB.CTxOutW $ + DB.VCTxOutW $ C.TxOut { C.txOutAddress = addrText , C.txOutAddressHasScript = hasScript @@ -253,13 +253,13 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma } addrId <- lift $ insertAddressUsingCache cache UpdateCache (Ledger.serialiseAddr addr) vAddress pure $ - DB.VTxOutW + DB.VATxOutW (mkTxOutVariant mSaId addrId mDatumId mScriptId) (Just vAddress) -- TODO: Unsure about what we should return here for eutxo let !eutxo = - case ioTxOutTableType iopts of - DB.TxOutCore -> ExtendedTxOut txHash txOut + case ioTxOutVariantType iopts of + DB.TxOutVariantCore -> ExtendedTxOut txHash txOut DB.TxOutVariantAddress -> ExtendedTxOut txHash txOut !maTxOuts <- whenFalseMempty (ioMultiAssets iopts) $ insertMaTxOuts tracer cache maMap pure (eutxo, maTxOuts) @@ -285,21 +285,21 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma } insertTxMetadata :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> DB.TxId -> InsertOptions -> Maybe (Map Word64 TxMetadataValue) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.TxMetadata] + ExceptT SyncNodeError (DB.DbAction m) [DB.TxMetadata] insertTxMetadata tracer txId inOpts mmetadata = do case mmetadata of Nothing -> pure [] Just metadata -> mapMaybeM prepare $ Map.toList metadata where prepare :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (Word64, TxMetadataValue) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe DB.TxMetadata) + ExceptT SyncNodeError (DB.DbAction m) (Maybe DB.TxMetadata) prepare (key, md) = do case ioKeepMetadataNames inOpts of Strict.Just metadataNames -> do @@ -311,9 +311,9 @@ insertTxMetadata tracer txId inOpts mmetadata = do Strict.Nothing -> mkDbTxMetadata (key, md) mkDbTxMetadata :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (Word64, TxMetadataValue) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe DB.TxMetadata) + ExceptT SyncNodeError (DB.DbAction m) (Maybe DB.TxMetadata) mkDbTxMetadata (key, md) = do let jsonbs = LBS.toStrict $ Aeson.encode (metadataValueToJsonNoSchema md) singleKeyCBORMetadata = serialiseTxMetadataToCbor $ Map.singleton key md @@ -331,27 +331,27 @@ insertTxMetadata tracer txId inOpts mmetadata = do -- INSERT MULTI ASSET -------------------------------------------------------------------------------------- insertMaTxMint :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> DB.TxId -> MultiAsset StandardCrypto -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.MaTxMint] + ExceptT SyncNodeError (DB.DbAction m) [DB.MaTxMint] insertMaTxMint _tracer cache txId (MultiAsset mintMap) = concatMapM (lift . prepareOuter) $ Map.toList mintMap where prepareOuter :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (PolicyID StandardCrypto, Map AssetName Integer) -> - ReaderT SqlBackend m [DB.MaTxMint] + DB.DbAction m [DB.MaTxMint] prepareOuter (policy, aMap) = mapM (prepareInner policy) $ Map.toList aMap prepareInner :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => PolicyID StandardCrypto -> (AssetName, Integer) -> - ReaderT SqlBackend m DB.MaTxMint + DB.DbAction m DB.MaTxMint prepareInner policy (aname, amount) = do maId <- insertMultiAsset cache policy aname pure $ @@ -362,26 +362,26 @@ insertMaTxMint _tracer cache txId (MultiAsset mintMap) = } insertMaTxOuts :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> Map (PolicyID StandardCrypto) (Map AssetName Integer) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [MissingMaTxOut] + ExceptT SyncNodeError (DB.DbAction m) [MissingMaTxOut] insertMaTxOuts _tracer cache maMap = concatMapM (lift . prepareOuter) $ Map.toList maMap where prepareOuter :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (PolicyID StandardCrypto, Map AssetName Integer) -> - ReaderT SqlBackend m [MissingMaTxOut] + DB.DbAction m [MissingMaTxOut] prepareOuter (policy, aMap) = mapM (prepareInner policy) $ Map.toList aMap prepareInner :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => PolicyID StandardCrypto -> (AssetName, Integer) -> - ReaderT SqlBackend m MissingMaTxOut + DB.DbAction m MissingMaTxOut prepareInner policy (aname, amount) = do maId <- insertMultiAsset cache policy aname pure $ @@ -394,13 +394,13 @@ insertMaTxOuts _tracer cache maMap = -- INSERT COLLATERAL -------------------------------------------------------------------------------------- insertCollateralTxOut :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> CacheStatus -> InsertOptions -> (DB.TxId, ByteString) -> Generic.TxOut -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertCollateralTxOut tracer cache iopts (txId, _txHash) (Generic.TxOut index addr value maMap mScript dt) = do mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr mDatumId <- @@ -412,8 +412,8 @@ insertCollateralTxOut tracer cache iopts (txId, _txHash) (Generic.TxOut index ad whenMaybe mScript $ lift . insertScript tracer txId _ <- - case ioTxOutTableType iopts of - DB.TxOutCore -> do + case ioTxOutVariantType iopts of + DB.TxOutVariantCore -> do lift . DB.insertCollateralTxOut $ DB.CCollateralTxOutW @@ -461,12 +461,12 @@ insertCollateralTxOut tracer cache iopts (txId, _txHash) (Generic.TxOut index ad hasScript = maybe False Generic.hasCredScript (Generic.getPaymentCred addr) insertCollateralTxIn :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Trace IO Text -> DB.TxId -> Generic.TxIn -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertCollateralTxIn syncEnv _tracer txInId txIn = do let txId = txInTxId txIn txOutId <- liftLookupFail "insertCollateralTxIn" $ queryTxIdWithCache (envCache syncEnv) txId @@ -480,12 +480,12 @@ insertCollateralTxIn syncEnv _tracer txInId txIn = do } insertReferenceTxIn :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> Trace IO Text -> DB.TxId -> Generic.TxIn -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () insertReferenceTxIn syncEnv _tracer txInId txIn = do let txId = txInTxId txIn txOutId <- liftLookupFail "insertReferenceTxIn" $ queryTxIdWithCache (envCache syncEnv) txId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs index d155df128..2f798c050 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} module Cardano.DbSync.Era.Universal.Validate ( @@ -10,8 +9,7 @@ module Cardano.DbSync.Era.Universal.Validate ( ) where import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) -import Cardano.Db (DbLovelace, RewardSource) -import qualified Cardano.Db as Db +import qualified Cardano.Db as DB import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Ledger.Event import Cardano.DbSync.Types @@ -21,43 +19,22 @@ import Cardano.Ledger.Shelley.API (Network) import qualified Cardano.Ledger.Shelley.Rewards as Ledger import Cardano.Prelude hiding (from, on) import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.List as List import qualified Data.List.Extra as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Database.Esqueleto.Experimental ( - InnerJoin (InnerJoin), - SqlBackend, - Value (Value), - desc, - from, - not_, - on, - orderBy, - select, - table, - val, - where_, - (:&) ((:&)), - (==.), - (^.), - ) import GHC.Err (error) -{- HLINT ignore "Fuse on/on" -} -{- HLINT ignore "Reduce duplication" -} - validateEpochRewards :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> Network -> EpochNo -> EpochNo -> Map StakeCred (Set (Ledger.Reward StandardCrypto)) -> - ReaderT SqlBackend m () + DB.DbAction m () validateEpochRewards tracer network _earnedEpochNo spendableEpochNo rmap = do - actualCount <- Db.queryNormalEpochRewardCount (unEpochNo spendableEpochNo) + actualCount <- DB.queryNormalEpochRewardCount (unEpochNo spendableEpochNo) if actualCount /= expectedCount then do liftIO . logWarning tracer $ @@ -83,57 +60,44 @@ validateEpochRewards tracer network _earnedEpochNo spendableEpochNo rmap = do expectedCount = fromIntegral . sum $ map Set.size (Map.elems rmap) logFullRewardMap :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> EpochNo -> Network -> Generic.Rewards -> - ReaderT SqlBackend m () + DB.DbAction m () logFullRewardMap tracer epochNo network ledgerMap = do dbMap <- queryRewardMap epochNo when (Map.size dbMap > 0 && Map.size (Generic.unRewards ledgerMap) > 0) $ liftIO $ diffRewardMap tracer network dbMap (Map.mapKeys (Generic.stakingCredHash network) $ Map.map convert $ Generic.unRewards ledgerMap) where - convert :: Set Generic.Reward -> [(RewardSource, Coin)] + convert :: Set Generic.Reward -> [(DB.RewardSource, Coin)] convert = map (\rwd -> (Generic.rewardSource rwd, Generic.rewardAmount rwd)) . Set.toList -queryRewardMap :: - (MonadBaseControl IO m, MonadIO m) => - EpochNo -> - ReaderT SqlBackend m (Map ByteString [(RewardSource, DbLovelace)]) +queryRewardMap :: MonadIO m => EpochNo -> DB.DbAction m (Map ByteString [(DB.RewardSource, DB.DbLovelace)]) queryRewardMap (EpochNo epochNo) = do - res <- select $ do - (rwd :& saddr) <- - from - $ table @Db.Reward - `InnerJoin` table @Db.StakeAddress - `on` ( \(rwd :& saddr) -> - rwd ^. Db.RewardAddrId ==. saddr ^. Db.StakeAddressId - ) - where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) - where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdDepositRefund) - where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdTreasury) - where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdReserves) - orderBy [desc (saddr ^. Db.StakeAddressHashRaw)] - pure (saddr ^. Db.StakeAddressHashRaw, rwd ^. Db.RewardType, rwd ^. Db.RewardAmount) + results <- DB.queryRewardMapData epochNo + pure $ processRewardMapData results - pure . Map.fromList . map collapse $ List.groupOn fst (map convert res) +processRewardMapData :: [(ByteString, DB.RewardSource, DB.DbLovelace)] -> Map ByteString [(DB.RewardSource, DB.DbLovelace)] +processRewardMapData results = + Map.fromList . map collapse $ List.groupOn fst (map convert results) where - convert :: (Value ByteString, Value RewardSource, Value DbLovelace) -> (ByteString, (RewardSource, DbLovelace)) - convert (Value cred, Value source, Value amount) = (cred, (source, amount)) + convert :: (ByteString, DB.RewardSource, DB.DbLovelace) -> (ByteString, (DB.RewardSource, DB.DbLovelace)) + convert (cred, source, amount) = (cred, (source, amount)) - collapse :: [(ByteString, (RewardSource, DbLovelace))] -> (ByteString, [(RewardSource, DbLovelace)]) + collapse :: [(ByteString, (DB.RewardSource, DB.DbLovelace))] -> (ByteString, [(DB.RewardSource, DB.DbLovelace)]) collapse xs = case xs of - [] -> error "queryRewardMap.collapse: Unexpected empty list" -- Impossible + [] -> error "processRewardMapData.collapse: Unexpected empty list" x : _ -> (fst x, List.sort $ map snd xs) diffRewardMap :: Trace IO Text -> Network -> - Map ByteString [(RewardSource, DbLovelace)] -> - Map ByteString [(RewardSource, Coin)] -> + Map ByteString [(DB.RewardSource, DB.DbLovelace)] -> + Map ByteString [(DB.RewardSource, Coin)] -> IO () diffRewardMap tracer _nw dbMap ledgerMap = do when (Map.size diffMap > 0) $ do @@ -143,22 +107,22 @@ diffRewardMap tracer _nw dbMap ledgerMap = do keys :: [ByteString] keys = List.nubOrd (Map.keys dbMap ++ Map.keys ledgerMap) - diffMap :: Map ByteString ([(RewardSource, DbLovelace)], [(RewardSource, Coin)]) + diffMap :: Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)]) diffMap = List.foldl' mkDiff mempty keys mkDiff :: - Map ByteString ([(RewardSource, DbLovelace)], [(RewardSource, Coin)]) -> + Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)]) -> ByteString -> - Map ByteString ([(RewardSource, DbLovelace)], [(RewardSource, Coin)]) + Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)]) mkDiff !acc addr = case (Map.lookup addr dbMap, Map.lookup addr ledgerMap) of (Just xs, Just ys) -> - if fromIntegral (sum $ map (Db.unDbLovelace . snd) xs) == sum (map (unCoin . snd) ys) + if fromIntegral (sum $ map (DB.unDbLovelace . snd) xs) == sum (map (unCoin . snd) ys) then acc else Map.insert addr (xs, ys) acc (Nothing, Just ys) -> Map.insert addr ([], ys) acc (Just xs, Nothing) -> Map.insert addr (xs, []) acc (Nothing, Nothing) -> acc - render :: (ByteString, ([(RewardSource, DbLovelace)], [(RewardSource, Coin)])) -> Text + render :: (ByteString, ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)])) -> Text render (cred, (xs, ys)) = mconcat [" ", show cred, ": ", show xs, " /= ", show ys] diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs index e9a4a5430..1cfc36a76 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs @@ -18,7 +18,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text -liftLookupFail :: Monad m => Text -> m (Either DB.LookupFail a) -> ExceptT SyncNodeError m a +liftLookupFail :: Monad m => Text -> m (Either DB.DbError a) -> ExceptT SyncNodeError m a liftLookupFail loc = firstExceptT (\lf -> SNErrDefault $ mconcat [loc, " ", show lf]) . newExceptT 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/Ledger/Event.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs index 24c0e8617..7da5a2ccf 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs @@ -21,7 +21,7 @@ module Cardano.DbSync.Ledger.Event ( splitDeposits, ) where -import Cardano.Db hiding (AdaPots, EpochNo, SyncState, TreasuryWithdrawals, epochNo) +import Cardano.Db hiding (AdaPots, SyncState, TreasuryWithdrawals, epochNo) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Tx.Shelley import Cardano.DbSync.Types diff --git a/cardano-db-sync/src/Cardano/DbSync/Metrics.hs b/cardano-db-sync/src/Cardano/DbSync/Metrics.hs index 55815042e..ca625b373 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Metrics.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Metrics.hs @@ -30,7 +30,7 @@ data Metrics = Metrics { mNodeBlockHeight :: !Gauge -- ^ The block tip number of the remote node. , mDbQueueLength :: !Gauge - -- ^ The number of @DbAction@ remaining for the database. + -- ^ The number of @DbEvent@ remaining for the database. , mDbBlockHeight :: !Gauge -- ^ The block tip number in the database. , mDbSlotHeight :: !Gauge diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain.hs index b89201791..d180f760f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain.hs @@ -5,6 +5,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ApplicativeDo #-} module Cardano.DbSync.OffChain ( insertOffChainPoolResults, @@ -18,7 +19,6 @@ module Cardano.DbSync.OffChain ( ) where import Cardano.BM.Trace (Trace, logInfo) -import Cardano.Db (runIohkLogging) import qualified Cardano.Db as DB import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..)) @@ -34,14 +34,14 @@ import Control.Concurrent.Class.MonadSTM.Strict ( isEmptyTBQueue, writeTBQueue, ) -import Control.Monad.Extra (whenJust) -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Time.Clock.POSIX (POSIXTime) import qualified Data.Time.Clock.POSIX as Time -import Database.Persist.Postgresql (withPostgresqlConn) -import Database.Persist.Sql (SqlBackend) import qualified Network.HTTP.Client as Http import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Pipeline as HsqlP +import qualified Hasql.Connection as HsqlC +import GHC.IO.Exception (userError) --------------------------------------------------------------------------------------------------------------------------------- -- Load OffChain Work Queue @@ -49,14 +49,14 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) data LoadOffChainWorkQueue a m = LoadOffChainWorkQueue { lQueue :: StrictTBQueue IO a , lRetryTime :: a -> Retry - , lGetData :: MonadIO m => POSIXTime -> Int -> ReaderT SqlBackend m [a] + , lGetData :: MonadIO m => POSIXTime -> Int -> DB.DbAction m [a] } loadOffChainPoolWorkQueue :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> StrictTBQueue IO OffChainPoolWorkQueue -> - ReaderT SqlBackend m () + DB.DbAction m () loadOffChainPoolWorkQueue trce workQueue = loadOffChainWorkQueue trce @@ -67,10 +67,10 @@ loadOffChainPoolWorkQueue trce workQueue = } loadOffChainVoteWorkQueue :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> StrictTBQueue IO OffChainVoteWorkQueue -> - ReaderT SqlBackend m () + DB.DbAction m () loadOffChainVoteWorkQueue trce workQueue = loadOffChainWorkQueue trce @@ -82,10 +82,10 @@ loadOffChainVoteWorkQueue trce workQueue = loadOffChainWorkQueue :: forall a m. - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> LoadOffChainWorkQueue a m -> - ReaderT SqlBackend m () + DB.DbAction m () loadOffChainWorkQueue _trce offChainWorkQueue = do whenM (liftIO $ atomically (isEmptyTBQueue (lQueue offChainWorkQueue))) $ do now <- liftIO Time.getPOSIXTime @@ -102,10 +102,10 @@ loadOffChainWorkQueue _trce offChainWorkQueue = do -- Insert OffChain --------------------------------------------------------------------------------------------------------------------------------- insertOffChainPoolResults :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> StrictTBQueue IO OffChainPoolResult -> - ReaderT SqlBackend m () + DB.DbAction m () insertOffChainPoolResults trce resultQueue = do res <- liftIO . atomically $ flushTBQueue resultQueue unless (null res) $ do @@ -115,7 +115,7 @@ insertOffChainPoolResults trce resultQueue = do logInsertOffChainResults "Pool" resLength resErrorsLength mapM_ insert res where - insert :: (MonadBaseControl IO m, MonadIO m) => OffChainPoolResult -> ReaderT SqlBackend m () + insert :: MonadIO m => OffChainPoolResult -> DB.DbAction m () insert = \case OffChainPoolResultMetadata md -> void $ DB.insertCheckOffChainPoolData md OffChainPoolResultError fe -> void $ DB.insertCheckOffChainPoolFetchError fe @@ -126,38 +126,77 @@ insertOffChainPoolResults trce resultQueue = do OffChainPoolResultError {} -> True insertOffChainVoteResults :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => Trace IO Text -> StrictTBQueue IO OffChainVoteResult -> - ReaderT SqlBackend m () + DB.DbAction m () insertOffChainVoteResults trce resultQueue = do - res <- liftIO . atomically $ flushTBQueue resultQueue - unless (null res) $ do - let resLength = length res - resErrorsLength = length $ filter isFetchError res + results <- liftIO . atomically $ flushTBQueue resultQueue + unless (null results) $ do + let resLength = length results + resErrorsLength = length $ filter isFetchError results liftIO . logInfo trce $ logInsertOffChainResults "Voting Anchor" resLength resErrorsLength - mapM_ insert res + -- Process using a pipeline approach + processResultsBatched results where - insert :: (MonadBaseControl IO m, MonadIO m) => OffChainVoteResult -> ReaderT SqlBackend m () - insert = \case - OffChainVoteResultMetadata md accessors -> do - mocvdId <- DB.insertOffChainVoteData md - whenJust mocvdId $ \ocvdId -> do - whenJust (offChainVoteGovAction accessors ocvdId) $ \ocvga -> - void $ DB.insertOffChainVoteGovActionData ocvga - whenJust (offChainVoteDrep accessors ocvdId) $ \ocvdr -> - void $ DB.insertOffChainVoteDrepData ocvdr - DB.insertOffChainVoteAuthors $ offChainVoteAuthors accessors ocvdId - DB.insertOffChainVoteReference $ offChainVoteReferences accessors ocvdId - DB.insertOffChainVoteExternalUpdate $ offChainVoteExternalUpdates accessors ocvdId - OffChainVoteResultError fe -> void $ DB.insertOffChainVoteFetchError fe - isFetchError :: OffChainVoteResult -> Bool isFetchError = \case OffChainVoteResultMetadata {} -> False OffChainVoteResultError {} -> True + processResultsBatched :: MonadIO m => [OffChainVoteResult] -> DB.DbAction m () + processResultsBatched results = do + -- Split by type + let errors = [e | OffChainVoteResultError e <- results] + metadataWithAccessors = [(md, acc) | OffChainVoteResultMetadata md acc <- results] + -- Process errors in bulk if any + unless (null errors) $ + insertBulkOffChainVoteFetchErrors errors + -- Process metadata in a pipeline if any + unless (null metadataWithAccessors) $ do + -- First insert all metadata and collect the IDs + metadataIds <- insertMetadataWithIds metadataWithAccessors + -- Now prepare all the related data for bulk inserts + let allGovActions = catMaybes [offChainVoteGovAction acc id | (_, acc, id) <- metadataIds] + allDrepData = catMaybes [offChainVoteDrep acc id | (_, acc, id) <- metadataIds] + allAuthors = concatMap (\(_, acc, id) -> offChainVoteAuthors acc id) metadataIds + allReferences = concatMap (\(_, acc, id) -> offChainVoteReferences acc id) metadataIds + allExternalUpdates = concatMap (\(_, acc, id) -> offChainVoteExternalUpdates acc id) metadataIds + -- Execute all bulk inserts in a pipeline + DB.runDbSession (DB.mkCallInfo "insertRelatedDataPipeline") $ + HsqlSes.pipeline $ do + -- Insert all related data in one pipeline + unless (null allGovActions) $ + void $ HsqlP.statement allGovActions DB.insertBulkOffChainVoteGovActionDataStmt + unless (null allDrepData) $ + void $ HsqlP.statement allDrepData DB.insertBulkOffChainVoteDrepDataStmt + unless (null allAuthors) $ + void $ HsqlP.statement allAuthors DB.insertBulkOffChainVoteAuthorsStmt + unless (null allReferences) $ + void $ HsqlP.statement allReferences DB.insertBulkOffChainVoteReferencesStmt + unless (null allExternalUpdates) $ + void $ HsqlP.statement allExternalUpdates DB.insertBulkOffChainVoteExternalUpdatesStmt + pure () + + -- Helper function to insert metadata and get back IDs + insertMetadataWithIds :: MonadIO m => [(DB.OffChainVoteData, OffChainVoteAccessors)] -> DB.DbAction m [(DB.OffChainVoteData, OffChainVoteAccessors, DB.OffChainVoteDataId)] + insertMetadataWithIds metadataWithAccessors = do + -- Extract just the metadata for insert + let metadata = map fst metadataWithAccessors + -- Insert and get IDs + ids <- DB.runDbSession (DB.mkCallInfo "insertMetadataWithIds") $ + HsqlSes.statement metadata DB.insertBulkOffChainVoteDataStmt + + -- Return original data with IDs + pure $ zipWith (\(md, acc) id -> (md, acc, id)) metadataWithAccessors ids + + -- Bulk insert for errors (you'll need to create this statement) + insertBulkOffChainVoteFetchErrors :: MonadIO m => [DB.OffChainVoteFetchError] -> DB.DbAction m () + insertBulkOffChainVoteFetchErrors errors = + DB.runDbSession (DB.mkCallInfo "insertBulkOffChainVoteFetchErrors") $ + HsqlSes.statement errors DB.insertBulkOffChainVoteFetchErrorStmt + logInsertOffChainResults :: Text -> -- Pool of Vote Int -> -- length of tbQueue @@ -177,22 +216,56 @@ logInsertOffChainResults offChainType resLength resErrorsLength = --------------------------------------------------------------------------------------------------------------------------------- -- Run OffChain threads --------------------------------------------------------------------------------------------------------------------------------- -runFetchOffChainPoolThread :: SyncEnv -> IO () -runFetchOffChainPoolThread syncEnv = do - -- if dissable gov is active then don't run voting anchor thread +-- runFetchOffChainPoolThread :: SyncEnv -> IO () +-- runFetchOffChainPoolThread syncEnv = do +-- -- if dissable gov is active then don't run voting anchor thread +-- when (ioOffChainPoolData iopts) $ do +-- logInfo trce "Running Offchain Pool fetch thread" +-- runIohkLogging trce $ +-- withPostgresqlConn (envConnectionString syncEnv) $ +-- \backendPool -> liftIO $ +-- forever $ do +-- tDelay +-- -- load the offChain vote work queue using the db +-- _ <- runReaderT (loadOffChainPoolWorkQueue trce (envOffChainPoolWorkQueue syncEnv)) backendPool +-- poolq <- atomically $ flushTBQueue (envOffChainPoolWorkQueue syncEnv) +-- manager <- Http.newManager tlsManagerSettings +-- now <- liftIO Time.getPOSIXTime +-- mapM_ (queuePoolInsert <=< fetchOffChainPoolData trce manager now) poolq +-- where +-- trce = getTrace syncEnv +-- iopts = getInsertOptions syncEnv + +-- queuePoolInsert :: OffChainPoolResult -> IO () +-- queuePoolInsert = atomically . writeTBQueue (envOffChainPoolResultQueue syncEnv) + +runFetchOffChainPoolThread :: SyncEnv -> SyncNodeConfig -> IO () +runFetchOffChainPoolThread syncEnv syncNodeConfigFromFile = do + -- if disable gov is active then don't run voting anchor thread when (ioOffChainPoolData iopts) $ do logInfo trce "Running Offchain Pool fetch thread" - runIohkLogging trce $ - withPostgresqlConn (envConnectionString syncEnv) $ - \backendPool -> liftIO $ - forever $ do - tDelay - -- load the offChain vote work queue using the db - _ <- runReaderT (loadOffChainPoolWorkQueue trce (envOffChainPoolWorkQueue syncEnv)) backendPool - poolq <- atomically $ flushTBQueue (envOffChainPoolWorkQueue syncEnv) - manager <- Http.newManager tlsManagerSettings - now <- liftIO Time.getPOSIXTime - mapM_ (queuePoolInsert <=< fetchOffChainPoolData trce manager now) poolq + pgconfig <- DB.runOrThrowIO (DB.readPGPass DB.PGPassDefaultEnv) + connSetting <- case DB.toConnectionSetting pgconfig of + Left err -> throwIO $ userError err + Right setting -> pure setting + + bracket + (DB.acquireConnection [connSetting]) + HsqlC.release + (\dbConn -> forever $ do + -- Create a new DbEnv for this thread + let dbEnv = DB.DbEnv dbConn (dncEnableDbLogging syncNodeConfigFromFile) $ Just trce + -- Create a new SyncEnv with the new DbEnv but preserving all other fields + threadSyncEnv = syncEnv { envDbEnv = dbEnv } + tDelay + -- load the offChain vote work queue using the db + _ <- DB.runDbIohkLogging trce dbEnv $ + loadOffChainPoolWorkQueue trce (envOffChainPoolWorkQueue threadSyncEnv) + poolq <- atomically $ flushTBQueue (envOffChainPoolWorkQueue threadSyncEnv) + manager <- Http.newManager tlsManagerSettings + now <- liftIO Time.getPOSIXTime + mapM_ (queuePoolInsert <=< fetchOffChainPoolData trce manager now) poolq + ) where trce = getTrace syncEnv iopts = getInsertOptions syncEnv @@ -200,21 +273,34 @@ runFetchOffChainPoolThread syncEnv = do queuePoolInsert :: OffChainPoolResult -> IO () queuePoolInsert = atomically . writeTBQueue (envOffChainPoolResultQueue syncEnv) -runFetchOffChainVoteThread :: SyncEnv -> IO () -runFetchOffChainVoteThread syncEnv = do - -- if dissable gov is active then don't run voting anchor thread +runFetchOffChainVoteThread :: SyncEnv -> SyncNodeConfig -> IO () +runFetchOffChainVoteThread syncEnv syncNodeConfigFromFile = do + -- if disable gov is active then don't run voting anchor thread when (ioGov iopts) $ do logInfo trce "Running Offchain Vote Anchor fetch thread" - runIohkLogging trce $ - withPostgresqlConn (envConnectionString syncEnv) $ - \backendVote -> liftIO $ - forever $ do - tDelay - -- load the offChain vote work queue using the db - _ <- runReaderT (loadOffChainVoteWorkQueue trce (envOffChainVoteWorkQueue syncEnv)) backendVote - voteq <- atomically $ flushTBQueue (envOffChainVoteWorkQueue syncEnv) - now <- liftIO Time.getPOSIXTime - mapM_ (queueVoteInsert <=< fetchOffChainVoteData gateways now) voteq + pgconfig <- DB.runOrThrowIO (DB.readPGPass DB.PGPassDefaultEnv) + connSetting <- case DB.toConnectionSetting pgconfig of + Left err -> throwIO $ userError err + Right setting -> pure setting + + bracket + (DB.acquireConnection [connSetting]) + HsqlC.release + (\dbConn -> do + -- Create a new DbEnv for this thread + let dbEnv = DB.DbEnv dbConn (dncEnableDbLogging syncNodeConfigFromFile) $ Just trce + -- Create a new SyncEnv with the new DbEnv but preserving all other fields + let threadSyncEnv = syncEnv { envDbEnv = dbEnv } + -- Use the thread-specific SyncEnv for all operations + forever $ do + tDelay + -- load the offChain vote work queue using the db + _ <- DB.runDbIohkLogging trce dbEnv $ + loadOffChainVoteWorkQueue trce (envOffChainVoteWorkQueue threadSyncEnv) + voteq <- atomically $ flushTBQueue (envOffChainVoteWorkQueue threadSyncEnv) + now <- liftIO Time.getPOSIXTime + mapM_ (queueVoteInsert <=< fetchOffChainVoteData gateways now) voteq + ) where trce = getTrace syncEnv iopts = getInsertOptions syncEnv @@ -223,6 +309,29 @@ runFetchOffChainVoteThread syncEnv = do queueVoteInsert :: OffChainVoteResult -> IO () queueVoteInsert = atomically . writeTBQueue (envOffChainVoteResultQueue syncEnv) +-- runFetchOffChainVoteThread :: SyncEnv -> IO () +-- runFetchOffChainVoteThread syncEnv = do +-- -- if dissable gov is active then don't run voting anchor thread +-- when (ioGov iopts) $ do +-- logInfo trce "Running Offchain Vote Anchor fetch thread" +-- runIohkLogging trce $ +-- withPostgresqlConn (envConnectionString syncEnv) $ +-- \backendVote -> liftIO $ +-- forever $ do +-- tDelay +-- -- load the offChain vote work queue using the db +-- _ <- runReaderT (loadOffChainVoteWorkQueue trce (envOffChainVoteWorkQueue syncEnv)) backendVote +-- voteq <- atomically $ flushTBQueue (envOffChainVoteWorkQueue syncEnv) +-- now <- liftIO Time.getPOSIXTime +-- mapM_ (queueVoteInsert <=< fetchOffChainVoteData gateways now) voteq +-- where +-- trce = getTrace syncEnv +-- iopts = getInsertOptions syncEnv +-- gateways = dncIpfsGateway $ envSyncNodeConfig syncEnv + +-- queueVoteInsert :: OffChainVoteResult -> IO () +-- queueVoteInsert = atomically . writeTBQueue (envOffChainVoteResultQueue syncEnv) + -- 5 minute sleep in milliseconds tDelay :: IO () tDelay = threadDelay 300_000_000 diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs index 823cb5212..8fef277fd 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Cardano.DbSync.OffChain.Query ( getOffChainVoteData, @@ -9,7 +10,6 @@ module Cardano.DbSync.OffChain.Query ( import Cardano.Db ( AnchorType (..), - EntityField (..), OffChainPoolData, OffChainPoolFetchError, OffChainPoolFetchErrorId, @@ -33,40 +33,13 @@ import Cardano.Prelude hiding (from, groupBy, on, retry) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime) import qualified Data.Time.Clock.POSIX as Time -import Database.Esqueleto.Experimental ( - SqlBackend, - SqlExpr, - Value (..), - ValueList, - asc, - from, - groupBy, - in_, - innerJoin, - just, - limit, - max_, - notExists, - on, - orderBy, - select, - subList_select, - table, - val, - where_, - (!=.), - (:&) ((:&)), - (==.), - (^.), - ) import System.Random.Shuffle (shuffleM) - -{- HLINT ignore "Fuse on/on" -} +import qualified Cardano.Db as DB --------------------------------------------------------------------------------------------------------------------------------- -- Query OffChain VoteData --------------------------------------------------------------------------------------------------------------------------------- -getOffChainVoteData :: MonadIO m => POSIXTime -> Int -> ReaderT SqlBackend m [OffChainVoteWorkQueue] +getOffChainVoteData :: MonadIO m => POSIXTime -> Int -> DB.DbAction m [OffChainVoteWorkQueue] getOffChainVoteData now maxCount = do xs <- queryNewVoteWorkQueue now maxCount if length xs >= maxCount @@ -76,88 +49,43 @@ getOffChainVoteData now maxCount = do take maxCount . (xs ++) <$> liftIO (shuffleM ys) -- get all the voting anchors that don't already exist in OffChainVoteData or OffChainVoteFetchError -queryNewVoteWorkQueue :: MonadIO m => POSIXTime -> Int -> ReaderT SqlBackend m [OffChainVoteWorkQueue] +queryNewVoteWorkQueue :: MonadIO m => POSIXTime -> Int -> DB.DbAction m [OffChainVoteWorkQueue] queryNewVoteWorkQueue now maxCount = do - res <- select $ do - va <- from $ table @VotingAnchor - where_ - ( notExists $ - from (table @OffChainVoteData) >>= \ocvd -> - where_ (ocvd ^. OffChainVoteDataVotingAnchorId ==. va ^. VotingAnchorId) - ) - where_ (va ^. VotingAnchorType !=. val ConstitutionAnchor) - where_ - ( notExists $ - from (table @OffChainVoteFetchError) >>= \ocvfe -> - where_ (ocvfe ^. OffChainVoteFetchErrorVotingAnchorId ==. va ^. VotingAnchorId) - ) - limit $ fromIntegral maxCount - pure - ( va ^. VotingAnchorId - , va ^. VotingAnchorDataHash - , va ^. VotingAnchorUrl - , va ^. VotingAnchorType - ) - pure $ map convert res - where - convert :: (Value VotingAnchorId, Value ByteString, Value VoteUrl, Value AnchorType) -> OffChainVoteWorkQueue - convert (Value vaId, Value vaHash, Value url, Value tp) = - OffChainVoteWorkQueue - { oVoteWqMetaHash = VoteMetaHash vaHash - , oVoteWqReferenceId = vaId - , oVoteWqType = tp - , oVoteWqRetry = newRetry now - , oVoteWqUrl = url - } + results <- DB.queryNewVoteWorkQueueData maxCount + pure $ map (makeOffChainVoteWorkQueue now) results + +makeOffChainVoteWorkQueue :: + POSIXTime -> + (DB.VotingAnchorId, ByteString, VoteUrl, AnchorType) -> + OffChainVoteWorkQueue +makeOffChainVoteWorkQueue now (vaId, vaHash, url, tp) = + OffChainVoteWorkQueue + { oVoteWqMetaHash = VoteMetaHash vaHash + , oVoteWqReferenceId = vaId + , oVoteWqType = tp + , oVoteWqRetry = newRetry now + , oVoteWqUrl = url + } -queryOffChainVoteWorkQueue :: MonadIO m => UTCTime -> Int -> ReaderT SqlBackend m [OffChainVoteWorkQueue] +queryOffChainVoteWorkQueue :: MonadIO m => UTCTime -> Int -> DB.DbAction m [OffChainVoteWorkQueue] queryOffChainVoteWorkQueue _now maxCount = do - res <- select $ do - (va :& ocpfe) <- - from - $ table @VotingAnchor - `innerJoin` table @OffChainVoteFetchError - `on` (\(va :& ocpfe) -> ocpfe ^. OffChainVoteFetchErrorVotingAnchorId ==. va ^. VotingAnchorId) - orderBy [asc (ocpfe ^. OffChainVoteFetchErrorId)] - where_ (just (ocpfe ^. OffChainVoteFetchErrorId) `in_` latestRefs) - where_ (va ^. VotingAnchorType !=. val ConstitutionAnchor) - limit $ fromIntegral maxCount - pure - ( ocpfe ^. OffChainVoteFetchErrorFetchTime - , va ^. VotingAnchorId - , va ^. VotingAnchorDataHash - , va ^. VotingAnchorUrl - , va ^. VotingAnchorType - , ocpfe ^. OffChainVoteFetchErrorRetryCount - ) - pure $ map convert res - where - convert :: (Value UTCTime, Value VotingAnchorId, Value ByteString, Value VoteUrl, Value AnchorType, Value Word) -> OffChainVoteWorkQueue - convert (Value time, Value vaId, Value vaHash, Value url, Value tp, Value rCount) = - OffChainVoteWorkQueue - { oVoteWqMetaHash = VoteMetaHash vaHash - , oVoteWqReferenceId = vaId - , oVoteWqType = tp - , oVoteWqRetry = retryAgain (Time.utcTimeToPOSIXSeconds time) rCount - , oVoteWqUrl = url - } + results <- DB.queryOffChainVoteWorkQueueData maxCount + pure $ map convertToWorkQueue results - latestRefs :: SqlExpr (ValueList (Maybe OffChainVoteFetchErrorId)) - latestRefs = - subList_select $ do - ocvfe <- from (table @OffChainVoteFetchError) - groupBy (ocvfe ^. OffChainVoteFetchErrorVotingAnchorId) - where_ - ( notExists $ - from (table @OffChainVoteData) >>= \ocvd -> - where_ (ocvd ^. OffChainVoteDataVotingAnchorId ==. ocvfe ^. OffChainVoteFetchErrorVotingAnchorId) - ) - pure $ max_ (ocvfe ^. OffChainVoteFetchErrorId) +convertToWorkQueue :: (UTCTime, DB.VotingAnchorId, ByteString, VoteUrl, AnchorType, Word) -> OffChainVoteWorkQueue +convertToWorkQueue (time, vaId, vaHash, url, tp, rCount) = + OffChainVoteWorkQueue + { oVoteWqMetaHash = VoteMetaHash vaHash + , oVoteWqReferenceId = vaId + , oVoteWqType = tp + , oVoteWqRetry = retryAgain (Time.utcTimeToPOSIXSeconds time) rCount + , oVoteWqUrl = url + } --------------------------------------------------------------------------------------------------------------------------------- -- Query OffChain PoolData --------------------------------------------------------------------------------------------------------------------------------- -getOffChainPoolData :: MonadIO m => POSIXTime -> Int -> ReaderT SqlBackend m [OffChainPoolWorkQueue] +getOffChainPoolData :: MonadIO m => POSIXTime -> Int -> DB.DbAction m [OffChainPoolWorkQueue] getOffChainPoolData now maxCount = do -- Results from the query are shuffles so we don't continuously get the same entries. xs <- queryNewPoolWorkQueue now maxCount @@ -169,99 +97,32 @@ getOffChainPoolData now maxCount = do -- Get pool work queue data for new pools (ie pools that had OffChainPoolData entry and no -- OffChainPoolFetchError). -queryNewPoolWorkQueue :: MonadIO m => POSIXTime -> Int -> ReaderT SqlBackend m [OffChainPoolWorkQueue] +queryNewPoolWorkQueue :: MonadIO m => POSIXTime -> Int -> DB.DbAction m [OffChainPoolWorkQueue] queryNewPoolWorkQueue now maxCount = do - res <- select $ do - (ph :& pmr) <- - from - $ table @PoolHash - `innerJoin` table @PoolMetadataRef - `on` (\(ph :& pmr) -> ph ^. PoolHashId ==. pmr ^. PoolMetadataRefPoolId) - where_ (just (pmr ^. PoolMetadataRefId) `in_` latestRefs) - where_ - ( notExists $ - from (table @OffChainPoolData) >>= \pod -> - where_ (pod ^. OffChainPoolDataPmrId ==. pmr ^. PoolMetadataRefId) - ) - where_ - ( notExists $ - from (table @OffChainPoolFetchError) >>= \pofe -> - where_ (pofe ^. OffChainPoolFetchErrorPmrId ==. pmr ^. PoolMetadataRefId) - ) - limit $ fromIntegral maxCount - pure - ( ph ^. PoolHashId - , pmr ^. PoolMetadataRefId - , pmr ^. PoolMetadataRefUrl - , pmr ^. PoolMetadataRefHash - ) - pure $ map convert res - where - -- This assumes that the autogenerated `id` field is a reliable proxy for time, ie, higher - -- `id` was added later. This is a valid assumption because the primary keys are - -- monotonically increasing and never reused. - latestRefs :: SqlExpr (ValueList (Maybe PoolMetadataRefId)) - latestRefs = - subList_select $ do - pmr <- from $ table @PoolMetadataRef - groupBy (pmr ^. PoolMetadataRefPoolId) - pure $ max_ (pmr ^. PoolMetadataRefId) + results <- DB.queryNewPoolWorkQueueData maxCount + pure $ map (makeOffChainPoolWorkQueue now) results - convert :: - (Value PoolHashId, Value PoolMetadataRefId, Value PoolUrl, Value ByteString) -> - OffChainPoolWorkQueue - convert (Value phId, Value pmrId, Value url, Value pmh) = - OffChainPoolWorkQueue - { oPoolWqHashId = phId - , oPoolWqReferenceId = pmrId - , oPoolWqUrl = url - , oPoolWqMetaHash = PoolMetaHash pmh - , oPoolWqRetry = newRetry now - } +makeOffChainPoolWorkQueue :: POSIXTime -> (DB.PoolHashId, DB.PoolMetadataRefId, PoolUrl, ByteString) -> OffChainPoolWorkQueue +makeOffChainPoolWorkQueue now (phId, pmrId, url, pmh) = + OffChainPoolWorkQueue + { oPoolWqHashId = phId + , oPoolWqReferenceId = pmrId + , oPoolWqUrl = url + , oPoolWqMetaHash = PoolMetaHash pmh + , oPoolWqRetry = newRetry now + } --- Get pool fetch data for pools that have previously errored. -queryOffChainPoolWorkQueue :: MonadIO m => UTCTime -> Int -> ReaderT SqlBackend m [OffChainPoolWorkQueue] +queryOffChainPoolWorkQueue :: MonadIO m => UTCTime -> Int -> DB.DbAction m [OffChainPoolWorkQueue] queryOffChainPoolWorkQueue _now maxCount = do - res <- select $ do - (ph :& pmr :& pofe) <- - from - $ table @PoolHash - `innerJoin` table @PoolMetadataRef - `on` (\(ph :& pmr) -> ph ^. PoolHashId ==. pmr ^. PoolMetadataRefPoolId) - `innerJoin` table @OffChainPoolFetchError - `on` (\(_ph :& pmr :& pofe) -> pofe ^. OffChainPoolFetchErrorPmrId ==. pmr ^. PoolMetadataRefId) - where_ (just (pofe ^. OffChainPoolFetchErrorId) `in_` latestRefs) - orderBy [asc (pofe ^. OffChainPoolFetchErrorId)] - limit $ fromIntegral maxCount - pure - ( pofe ^. OffChainPoolFetchErrorFetchTime - , pofe ^. OffChainPoolFetchErrorPmrId - , pmr ^. PoolMetadataRefUrl - , pmr ^. PoolMetadataRefHash - , ph ^. PoolHashId - , pofe ^. OffChainPoolFetchErrorRetryCount - ) - pure $ map convert res - where - -- This assumes that the autogenerated `id` fiels is a reliable proxy for time, ie, higher - -- `id` was added later. This is a valid assumption because the primary keys are - -- monotonically increasing and never reused. - latestRefs :: SqlExpr (ValueList (Maybe OffChainPoolFetchErrorId)) - latestRefs = - subList_select $ do - pofe <- from (table @OffChainPoolFetchError) - where_ (notExists $ from (table @OffChainPoolData) >>= \pod -> where_ (pod ^. OffChainPoolDataPmrId ==. pofe ^. OffChainPoolFetchErrorPmrId)) - groupBy (pofe ^. OffChainPoolFetchErrorPoolId) - pure $ max_ (pofe ^. OffChainPoolFetchErrorId) + results <- DB.queryOffChainPoolWorkQueueData maxCount + pure $ map convertToOffChainPoolWorkQueue results - convert :: - (Value UTCTime, Value PoolMetadataRefId, Value PoolUrl, Value ByteString, Value PoolHashId, Value Word) -> - OffChainPoolWorkQueue - convert (Value time, Value pmrId, Value url, Value pmh, Value phId, Value rCount) = - OffChainPoolWorkQueue - { oPoolWqHashId = phId - , oPoolWqReferenceId = pmrId - , oPoolWqUrl = url - , oPoolWqMetaHash = PoolMetaHash pmh - , oPoolWqRetry = retryAgain (Time.utcTimeToPOSIXSeconds time) rCount - } +convertToOffChainPoolWorkQueue :: (UTCTime, DB.PoolMetadataRefId, PoolUrl, ByteString, DB.PoolHashId, Word) -> OffChainPoolWorkQueue +convertToOffChainPoolWorkQueue (time, pmrId, url, pmh, phId, rCount) = + OffChainPoolWorkQueue + { oPoolWqHashId = phId + , oPoolWqReferenceId = pmrId + , oPoolWqUrl = url + , oPoolWqMetaHash = PoolMetaHash pmh + , oPoolWqRetry = retryAgain (Time.utcTimeToPOSIXSeconds time) rCount + } diff --git a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs index 9124bae6d..01e2c0be5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs @@ -31,10 +31,10 @@ import Ouroboros.Network.Point -- Rollbacks are done in an Era generic way based on the 'Point' we are -- rolling back to. rollbackFromBlockNo :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => SyncEnv -> BlockNo -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () + ExceptT SyncNodeError (DB.DbAction m) () rollbackFromBlockNo syncEnv blkNo = do nBlocks <- lift $ DB.queryBlockCountAfterBlockNo (unBlockNo blkNo) True mres <- lift $ DB.queryBlockNoAndEpoch (unBlockNo blkNo) @@ -48,11 +48,11 @@ rollbackFromBlockNo syncEnv blkNo = do , textShow blkNo ] lift $ do - deletedBlockCount <- DB.deleteBlocksBlockId trce txOutTableType blockId epochNo (DB.pcmConsumedTxOut $ getPruneConsume syncEnv) + deletedBlockCount <- DB.deleteBlocksBlockId trce txOutVariantType blockId epochNo (DB.pcmConsumedTxOut $ getPruneConsume syncEnv) when (deletedBlockCount > 0) $ do -- We use custom constraints to improve input speeds when syncing. -- If they don't already exists we add them here as once a rollback has happened - -- we always need a the constraints. + -- we always need the constraints. addConstraintsIfNotExist syncEnv trce lift $ rollbackCache cache blockId @@ -61,15 +61,15 @@ rollbackFromBlockNo syncEnv blkNo = do where trce = getTrace syncEnv cache = envCache syncEnv - txOutTableType = getTxOutTableType syncEnv + txOutVariantType = getTxOutVariantType syncEnv 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 - action :: MonadIO m => ExceptT SyncNodeError (ReaderT SqlBackend m) Bool + action :: MonadIO m => ExceptT SyncNodeError (DB.DbAction m) Bool action = do case getPoint point of Origin -> do @@ -108,7 +108,7 @@ prepareRollback syncEnv point serverTip = pure False -- For testing and debugging. -unsafeRollback :: Trace IO Text -> DB.TxOutTableType -> DB.PGConfig -> SlotNo -> IO (Either SyncNodeError ()) -unsafeRollback trce txOutTableType config slotNo = do +unsafeRollback :: Trace IO Text -> DB.TxOutVariantType -> DB.PGConfig -> SlotNo -> IO (Either SyncNodeError ()) +unsafeRollback trce txOutVariantType config slotNo = do logWarning trce $ "Starting a forced rollback to slot: " <> textShow (unSlotNo slotNo) - Right <$> DB.runDbNoLogging (DB.PGPassCached config) (void $ DB.deleteBlocksSlotNo trce txOutTableType slotNo True) + Right <$> DB.runDbNoLogging (DB.PGPassCached config) (void $ DB.deleteBlocksSlotNo trce txOutVariantType slotNo True) diff --git a/cardano-db-sync/src/Cardano/DbSync/Sync.hs b/cardano-db-sync/src/Cardano/DbSync/Sync.hs index e8724185d..3f24344eb 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Sync.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Sync.hs @@ -31,7 +31,7 @@ import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (ConsistentLevel (..), LedgerEnv (..), SyncEnv (..), envLedgerEnv, envNetworkMagic, envOptions) import Cardano.DbSync.Config import Cardano.DbSync.Database -import Cardano.DbSync.DbAction +import Cardano.DbSync.DbEvent import Cardano.DbSync.LocalStateQuery import Cardano.DbSync.Metrics import Cardano.DbSync.Tracing.ToObjectOrphans () @@ -221,7 +221,7 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = ( chainSyncClientPeerPipelined $ chainSyncClient metricsSetters tracer (fst <$> latestPoints) currentTip tc ) - atomically $ writeDbActionQueue tc DbFinish + atomically $ writeDbEventQueue tc DbFinish -- We should return leftover bytes returned by 'runPipelinedPeer', but -- client application do not care about them (it's only important if one -- would like to restart a protocol on the same mux and thus bearer). @@ -350,8 +350,8 @@ chainSyncClient metricsSetters trce latestPoints currentTip tc = do setNodeBlockHeight metricsSetters (getTipBlockNo tip) newSize <- atomically $ do - writeDbActionQueue tc $ mkDbApply blk - lengthDbActionQueue tc + writeDbEventQueue tc $ mkDbApply blk + lengthDbEventQueue tc setDbQueueLength metricsSetters newSize diff --git a/cardano-db-sync/src/Cardano/DbSync/Util.hs b/cardano-db-sync/src/Cardano/DbSync/Util.hs index ef0523828..7ccf714bd 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Util.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Util.hs @@ -104,7 +104,7 @@ traverseMEither action xs = do action y >>= either (pure . Left) (const $ traverseMEither action ys) -- | Needed when debugging disappearing exceptions. -liftedLogException :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> Text -> m a -> m a +liftedLogException :: (MonadIO m, MonadBaseControl IO m) => Trace IO Text -> Text -> m a -> m a liftedLogException tracer txt action = action `catch` logger where @@ -116,7 +116,7 @@ liftedLogException tracer txt action = throwIO e -- | Log the runtime duration of an action. Mainly for debugging. -logActionDuration :: (MonadBaseControl IO m, MonadIO m) => Trace IO Text -> Text -> m a -> m a +logActionDuration :: MonadIO m => Trace IO Text -> Text -> m a -> m a logActionDuration tracer label action = do before <- liftIO Time.getCurrentTime a <- action diff --git a/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs b/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs index af266a6e2..3fa0b94ce 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Util/Constraint.hs @@ -1,143 +1,151 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.DbSync.Util.Constraint ( - constraintNameEpochStake, - constraintNameReward, - dbConstraintNamesExists, - queryIsJsonbInSchema, - addConstraintsIfNotExist, - addStakeConstraintsIfNotExist, - addRewardConstraintsIfNotExist, - addRewardTableConstraint, - addEpochStakeTableConstraint, -) where - -import Cardano.BM.Data.Trace (Trace) -import Cardano.BM.Trace (logInfo) -import Cardano.Db (ManualDbConstraints (..)) -import qualified Cardano.Db as DB -import Cardano.DbSync.Api.Types (SyncEnv (..)) -import Cardano.Prelude (MonadIO (..), Proxy (..), ReaderT (runReaderT), atomically) -import Control.Concurrent.Class.MonadSTM.Strict (readTVarIO, writeTVar) -import Control.Monad (unless) -import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Text (Text) -import Database.Persist.EntityDef.Internal (EntityDef (..)) -import Database.Persist.Names (ConstraintNameDB (..), EntityNameDB (..), FieldNameDB (..)) -import Database.Persist.Postgresql (PersistEntity (..), SqlBackend) - -constraintNameEpochStake :: ConstraintNameDB -constraintNameEpochStake = ConstraintNameDB "unique_epoch_stake" - -constraintNameReward :: ConstraintNameDB -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 - runReaderT queryRewardAndEpochStakeConstraints sqlBackend - -queryIsJsonbInSchema :: MonadIO m => SqlBackend -> m Bool -queryIsJsonbInSchema sqlBackend = do - runReaderT DB.queryJsonbInSchemaExists sqlBackend - -queryRewardAndEpochStakeConstraints :: - MonadIO m => - ReaderT SqlBackend m ManualDbConstraints -queryRewardAndEpochStakeConstraints = do - resEpochStake <- DB.queryHasConstraint constraintNameEpochStake - resReward <- DB.queryHasConstraint constraintNameReward - pure $ - ManualDbConstraints - { dbConstraintRewards = resReward - , dbConstraintEpochStake = resEpochStake - } - -addConstraintsIfNotExist :: - forall m. - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Trace IO Text -> - ReaderT SqlBackend m () -addConstraintsIfNotExist syncEnv trce = do - addStakeConstraintsIfNotExist syncEnv trce - addRewardConstraintsIfNotExist syncEnv trce - -addStakeConstraintsIfNotExist :: - forall m. - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Trace IO Text -> - ReaderT SqlBackend m () -addStakeConstraintsIfNotExist syncEnv trce = do - mdbc <- liftIO . readTVarIO $ envDbConstraints syncEnv - unless (dbConstraintEpochStake mdbc) (addEpochStakeTableConstraint trce) - liftIO - . atomically - $ writeTVar (envDbConstraints syncEnv) (mdbc {dbConstraintEpochStake = True}) - -addRewardConstraintsIfNotExist :: - forall m. - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Trace IO Text -> - ReaderT SqlBackend m () -addRewardConstraintsIfNotExist syncEnv trce = do - mdbc <- liftIO . readTVarIO $ envDbConstraints syncEnv - unless (dbConstraintRewards mdbc) (addRewardTableConstraint trce) - liftIO - . atomically - $ writeTVar (envDbConstraints syncEnv) (mdbc {dbConstraintRewards = True}) - -addRewardTableConstraint :: - forall m. - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - ReaderT SqlBackend m () -addRewardTableConstraint trce = do - let entityD = entityDef $ Proxy @DB.Reward - DB.alterTable - entityD - ( DB.AddUniqueConstraint - constraintNameReward - [ FieldNameDB "addr_id" - , FieldNameDB "type" - , FieldNameDB "earned_epoch" - , FieldNameDB "pool_id" - ] - ) - liftIO $ logNewConstraint trce entityD (unConstraintNameDB constraintNameReward) - -addEpochStakeTableConstraint :: - forall m. - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - ReaderT SqlBackend m () -addEpochStakeTableConstraint trce = do - let entityD = entityDef $ Proxy @DB.EpochStake - DB.alterTable - entityD - ( DB.AddUniqueConstraint - constraintNameEpochStake - [ FieldNameDB "epoch_no" - , FieldNameDB "addr_id" - , FieldNameDB "pool_id" - ] - ) - liftIO $ logNewConstraint trce entityD (unConstraintNameDB constraintNameEpochStake) - -logNewConstraint :: - Trace IO Text -> - EntityDef -> - Text -> - IO () -logNewConstraint trce table constraintName = - logInfo trce $ - "The table " - <> unEntityNameDB (entityDB table) - <> " was given a new unique constraint called " - <> constraintName +-- {-# LANGUAGE FlexibleContexts #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE RankNTypes #-} +-- {-# LANGUAGE TypeApplications #-} + +module Cardano.DbSync.Util.Constraint where +-- constraintNameEpochStake, +-- constraintNameReward, +-- dbConstraintNamesExists, +-- queryIsJsonbInSchema, +-- addConstraintsIfNotExist, +-- addStakeConstraintsIfNotExist, +-- addRewardConstraintsIfNotExist, +-- addRewardTableConstraint, +-- addEpochStakeTableConstraint, +-- ) where + +-- import Cardano.BM.Data.Trace (Trace) +-- import Cardano.BM.Trace (logInfo) +-- import Cardano.Db (ManualDbConstraints (..)) +-- import qualified Cardano.Db as DB +-- import Cardano.DbSync.Api.Types (SyncEnv (..)) +-- import Cardano.Prelude (MonadIO (..), Proxy (..), ReaderT (runReaderT), atomically) +-- import Control.Concurrent.Class.MonadSTM.Strict (readTVarIO, writeTVar) +-- import Control.Monad (unless) +-- import Control.Monad.Trans.Control (MonadBaseControl) +-- import Data.Text (Text) +-- import Database.Persist.EntityDef.Internal (EntityDef (..)) +-- import Database.Persist.Names (ConstraintNameDB (..), EntityNameDB (..), FieldNameDB (..)) +-- import Database.Persist.Postgresql (PersistEntity (..), SqlBackend) + +-- import Control.Concurrent.STM (TVar, atomically, readTVarIO, writeTVar) +-- import Control.Monad (unless) +-- import Control.Monad.IO.Class (MonadIO, liftIO) +-- import qualified DB.Constraint as DB +-- import Data.Proxy (Proxy (..)) +-- import qualified Data.Text as Text + +-- import qualified App.Types.DB as AppDB (EpochStake, Reward) +-- import DB.Core (DbEvent, DbInfo, tableName, validateColumn) + +-- -- | Tracks which manual constraints exist in the database +-- data ManualDbConstraints = ManualDbConstraints +-- { dbConstraintRewards :: !Bool +-- , dbConstraintEpochStake :: !Bool +-- } + +-- -- | Constraint name for EpochStake table +-- constraintNameEpochStake :: DB.ConstraintNameDB +-- constraintNameEpochStake = DB.ConstraintNameDB "unique_epoch_stake" + +-- -- | Constraint name for Reward table +-- constraintNameReward :: DB.ConstraintNameDB +-- constraintNameReward = DB.ConstraintNameDB "unique_reward" + +-- -- | Function to query which constraints exist +-- queryRewardAndEpochStakeConstraints :: MonadIO m => DbEvent m ManualDbConstraints +-- queryRewardAndEpochStakeConstraints = do +-- resEpochStake <- DB.queryHasConstraint constraintNameEpochStake +-- resReward <- DB.queryHasConstraint constraintNameReward +-- pure $ +-- ManualDbConstraints +-- { dbConstraintRewards = resReward +-- , dbConstraintEpochStake = resEpochStake +-- } + +-- -- | Check if jsonb type exists in the schema +-- -- This is a placeholder - implement according to your needs +-- queryIsJsonbInSchema :: MonadIO m => DbEvent m Bool +-- queryIsJsonbInSchema = pure True -- Implement with actual check + +-- -- | Generic function to create unique constraints for any DbInfo type +-- addUniqueConstraint :: +-- forall a m. +-- (DbInfo a, MonadIO m) => +-- -- | Constraint name +-- DB.ConstraintNameDB -> +-- -- | Column names to include in constraint +-- [Text.Text] -> +-- -- | Logger parameter +-- Text.Text -> +-- DbEvent m () +-- addUniqueConstraint constraintName columnsList logger = do +-- let tbl = tableName (Proxy @a) +-- -- Validate each column name against the DbInfo +-- fields = map (DB.FieldNameDB . validateColumn @a) columnsList +-- DB.alterTableAddConstraint tbl constraintName fields + +-- -- Logging would be implemented here + +-- -- | Add constraints for EpochStake table +-- addEpochStakeTableConstraint :: +-- MonadIO m => +-- -- | Logger parameter +-- Text.Text -> +-- DbEvent m () +-- addEpochStakeTableConstraint logger = +-- addUniqueConstraint @AppDB.EpochStake +-- constraintNameEpochStake +-- ["epoch_no", "addr_id", "pool_id"] +-- logger + +-- -- | Add constraints for Reward table +-- addRewardTableConstraint :: +-- MonadIO m => +-- -- | Logger parameter +-- Text.Text -> +-- DbEvent m () +-- addRewardTableConstraint logger = +-- addUniqueConstraint @AppDB.Reward +-- constraintNameReward +-- ["addr_id", "type", "earned_epoch", "pool_id"] +-- logger + +-- -- | Add all constraints if needed +-- addConstraintsIfNotExist :: +-- MonadIO m => +-- -- | TVar for tracking constraint state +-- TVar ManualDbConstraints -> +-- -- | Logger parameter +-- Text.Text -> +-- DbEvent m () +-- addConstraintsIfNotExist envDbConstraints logger = do +-- addStakeConstraintsIfNotExist envDbConstraints logger +-- addRewardConstraintsIfNotExist envDbConstraints logger + +-- -- | Add EpochStake constraints if not exist +-- addStakeConstraintsIfNotExist :: +-- MonadIO m => +-- TVar ManualDbConstraints -> +-- Text.Text -> +-- DbEvent m () +-- addStakeConstraintsIfNotExist envDbConstraints logger = do +-- mdbc <- liftIO $ readTVarIO envDbConstraints +-- unless (dbConstraintEpochStake mdbc) $ do +-- addEpochStakeTableConstraint logger +-- liftIO . atomically $ +-- writeTVar envDbConstraints (mdbc {dbConstraintEpochStake = True}) + +-- -- | Add Reward constraints if not exist +-- addRewardConstraintsIfNotExist :: +-- MonadIO m => +-- TVar ManualDbConstraints -> +-- Text.Text -> +-- DbEvent m () +-- addRewardConstraintsIfNotExist envDbConstraints logger = do +-- mdbc <- liftIO $ readTVarIO envDbConstraints +-- unless (dbConstraintRewards mdbc) $ do +-- addRewardTableConstraint logger +-- liftIO . atomically $ +-- writeTVar envDbConstraints (mdbc {dbConstraintRewards = True}) 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/app/cardano-db-tool.hs b/cardano-db-tool/app/cardano-db-tool.hs index 66690ac2f..2bc28b097 100644 --- a/cardano-db-tool/app/cardano-db-tool.hs +++ b/cardano-db-tool/app/cardano-db-tool.hs @@ -34,15 +34,15 @@ main = do -- ----------------------------------------------------------------------------- data Command - = CmdCreateMigration !MigrationDir !TxOutTableType - | CmdReport !Report !TxOutTableType - | CmdRollback !SlotNo !TxOutTableType - | CmdRunMigrations !MigrationDir !Bool !(Maybe LogFileDir) !TxOutTableType - | CmdTxOutMigration !TxOutTableType - | CmdUtxoSetAtBlock !Word64 !TxOutTableType + = CmdCreateMigration !MigrationDir !TxOutVariantType + | CmdReport !Report !TxOutVariantType + | CmdRollback !SlotNo !TxOutVariantType + | CmdRunMigrations !MigrationDir !Bool !(Maybe LogFileDir) !TxOutVariantType + | CmdTxOutMigration !TxOutVariantType + | CmdUtxoSetAtBlock !Word64 !TxOutVariantType | CmdPrepareSnapshot !PrepareSnapshotArgs - | CmdValidateDb !TxOutTableType - | CmdValidateAddressBalance !LedgerValidationParams !TxOutTableType + | CmdValidateDb !TxOutVariantType + | CmdValidateAddressBalance !LedgerValidationParams !TxOutVariantType | CmdVersion runCommand :: Command -> IO () @@ -60,24 +60,24 @@ runCommand cmd = when forceIndexes $ void $ runMigrations pgConfig False mdir mldir Indexes txOutTabletype - CmdTxOutMigration txOutTableType -> do - runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOutDbTool txOutTableType + CmdTxOutMigration txOutVariantType -> do + runWithConnectionNoLogging PGPassDefaultEnv $ migrateTxOutDbTool txOutVariantType CmdUtxoSetAtBlock blkid txOutAddressType -> utxoSetAtSlot txOutAddressType blkid CmdPrepareSnapshot pargs -> runPrepareSnapshot pargs CmdValidateDb txOutAddressType -> runDbValidation txOutAddressType CmdValidateAddressBalance params txOutAddressType -> runLedgerValidation params txOutAddressType CmdVersion -> runVersionCommand -runCreateMigration :: MigrationDir -> TxOutTableType -> IO () -runCreateMigration mdir txOutTableType = do - mfp <- createMigration PGPassDefaultEnv mdir txOutTableType +runCreateMigration :: MigrationDir -> TxOutVariantType -> IO () +runCreateMigration mdir txOutVariantType = do + mfp <- createMigration PGPassDefaultEnv mdir txOutVariantType case mfp of Nothing -> putStrLn "No migration needed." Just fp -> putStrLn $ "New migration '" ++ fp ++ "' created." -runRollback :: SlotNo -> TxOutTableType -> IO () -runRollback slotNo txOutTableType = - print =<< runDbNoLoggingEnv (deleteBlocksSlotNoNoTrace txOutTableType slotNo) +runRollback :: SlotNo -> TxOutVariantType -> IO () +runRollback slotNo txOutVariantType = + print =<< runDbNoLoggingEnv (deleteBlocksSlotNoNoTrace txOutVariantType slotNo) runVersionCommand :: IO () runVersionCommand = do @@ -111,7 +111,7 @@ pCommand = (Opt.progDesc "Create a database migration (only really used by devs).") , Opt.command "report" $ Opt.info - (CmdReport <$> pReport <*> pTxOutTableType) + (CmdReport <$> pReport <*> pTxOutVariantType) (Opt.progDesc "Run a report using data from the database.") , Opt.command "rollback" $ Opt.info @@ -130,7 +130,7 @@ pCommand = ) , Opt.command "tx_out-migration" $ Opt.info - (CmdTxOutMigration <$> pTxOutTableType) + (CmdTxOutMigration <$> pTxOutVariantType) ( Opt.progDesc $ mconcat [ "Runs the tx_out migration, which adds a new field" @@ -146,11 +146,11 @@ pCommand = (Opt.progDesc "Prepare to create a snapshot pair") , Opt.command "validate" $ Opt.info - (CmdValidateDb <$> pTxOutTableType) + (CmdValidateDb <$> pTxOutVariantType) (Opt.progDesc "Run validation checks against the database.") , Opt.command "validate-address-balance" $ Opt.info - (CmdValidateAddressBalance <$> pValidateLedgerParams <*> pTxOutTableType) + (CmdValidateAddressBalance <$> pValidateLedgerParams <*> pTxOutVariantType) (Opt.progDesc "Run validation checks against the database and the ledger Utxo set.") , Opt.command "version" $ Opt.info @@ -160,7 +160,7 @@ pCommand = where pCreateMigration :: Parser Command pCreateMigration = - CmdCreateMigration <$> pMigrationDir <*> pTxOutTableType + CmdCreateMigration <$> pMigrationDir <*> pTxOutVariantType pRunMigrations :: Parser Command pRunMigrations = @@ -168,7 +168,7 @@ pCommand = <$> pMigrationDir <*> pForceIndexes <*> optional pLogFileDir - <*> pTxOutTableType + <*> pTxOutVariantType pRollback :: Parser Command pRollback = @@ -177,7 +177,7 @@ pCommand = ( Opt.long "slot" <> Opt.help "The slot number to roll back to." ) - <*> pTxOutTableType + <*> pTxOutVariantType pUtxoSetAtBlock :: Parser Command pUtxoSetAtBlock = @@ -186,7 +186,7 @@ pCommand = ( Opt.long "slot-no" <> Opt.help "The SlotNo." ) - <*> pTxOutTableType + <*> pTxOutVariantType pPrepareSnapshot :: Parser Command pPrepareSnapshot = @@ -228,8 +228,8 @@ pForceIndexes = ) ) -pTxOutTableType :: Parser TxOutTableType -pTxOutTableType = +pTxOutVariantType :: Parser TxOutVariantType +pTxOutVariantType = Opt.flag TxOutCore TxOutVariantAddress diff --git a/cardano-db-tool/cardano-db-tool.cabal b/cardano-db-tool/cardano-db-tool.cabal index 3dc10238b..208b4ec6a 100644 --- a/cardano-db-tool/cardano-db-tool.cabal +++ b/cardano-db-tool/cardano-db-tool.cabal @@ -68,7 +68,6 @@ library , cardano-prelude , containers , contra-tracer - , esqueleto , extra , ouroboros-consensus , ouroboros-consensus-cardano diff --git a/cardano-db-tool/src/Cardano/DbTool/Report.hs b/cardano-db-tool/src/Cardano/DbTool/Report.hs index d65eb16e8..274df72fd 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report.hs @@ -4,7 +4,7 @@ module Cardano.DbTool.Report ( runReport, ) where -import Cardano.Db (TxOutTableType) +import Cardano.Db (TxOutVariantType) import Cardano.DbTool.Report.Balance (reportBalance) import Cardano.DbTool.Report.StakeReward ( reportEpochStakeRewards, @@ -23,12 +23,12 @@ data Report | ReportLatestRewards [Text] | ReportTransactions [Text] -runReport :: Report -> TxOutTableType -> IO () -runReport report txOutTableType = do +runReport :: Report -> TxOutVariantType -> IO () +runReport report txOutVariantType = do assertFullySynced case report of ReportAllRewards sas -> mapM_ reportStakeRewardHistory sas - ReportBalance sas -> reportBalance txOutTableType sas + ReportBalance sas -> reportBalance txOutVariantType sas ReportEpochRewards ep sas -> reportEpochStakeRewards ep sas ReportLatestRewards sas -> reportLatestStakeRewards sas - ReportTransactions sas -> reportTransactions txOutTableType sas + ReportTransactions sas -> reportTransactions txOutVariantType sas diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs index 7d76ac838..408f34c04 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs @@ -40,9 +40,9 @@ import Database.Esqueleto.Experimental ( {- HLINT ignore "Redundant ^." -} {- HLINT ignore "Fuse on/on" -} -reportBalance :: TxOutTableType -> [Text] -> IO () -reportBalance txOutTableType saddr = do - xs <- catMaybes <$> runDbNoLoggingEnv (mapM (queryStakeAddressBalance txOutTableType) saddr) +reportBalance :: TxOutVariantType -> [Text] -> IO () +reportBalance txOutVariantType saddr = do + xs <- catMaybes <$> runDbNoLoggingEnv (mapM (queryStakeAddressBalance txOutVariantType) saddr) renderBalances xs -- ------------------------------------------------------------------------------------------------- @@ -59,14 +59,14 @@ data Balance = Balance , balTotal :: !Ada } -queryStakeAddressBalance :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m (Maybe Balance) -queryStakeAddressBalance txOutTableType address = do +queryStakeAddressBalance :: MonadIO m => TxOutVariantType -> Text -> DB.DbAction m (Maybe Balance) +queryStakeAddressBalance txOutVariantType address = do mSaId <- queryStakeAddressId case mSaId of Nothing -> pure Nothing Just saId -> Just <$> queryBalance saId where - queryStakeAddressId :: MonadIO m => ReaderT SqlBackend m (Maybe StakeAddressId) + queryStakeAddressId :: MonadIO m => DB.DbAction m (Maybe StakeAddressId) queryStakeAddressId = do res <- select $ do saddr <- from $ table @StakeAddress @@ -74,7 +74,7 @@ queryStakeAddressBalance txOutTableType address = do pure (saddr ^. StakeAddressId) pure $ fmap unValue (listToMaybe res) - queryBalance :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m Balance + queryBalance :: MonadIO m => StakeAddressId -> DB.DbAction m Balance queryBalance saId = do inputs <- queryInputs saId (outputs, fees, deposit) <- queryOutputs saId @@ -93,9 +93,9 @@ queryStakeAddressBalance txOutTableType address = do , balTotal = inputs - outputs + rewards - withdrawals } - queryInputs :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m Ada - queryInputs saId = case txOutTableType of - TxOutCore -> do + queryInputs :: MonadIO m => StakeAddressId -> DB.DbAction m Ada + queryInputs saId = case txOutVariantType of + TxOutVariantCore -> do res <- select $ do txo <- from $ table @C.TxOut where_ (txo ^. C.TxOutStakeAddressId ==. just (val saId)) @@ -112,9 +112,9 @@ queryStakeAddressBalance txOutTableType address = do pure (sum_ (txo ^. V.TxOutValue)) pure $ unValueSumAda (listToMaybe res) - queryRewardsSum :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m Ada + queryRewardsSum :: MonadIO m => StakeAddressId -> DB.DbAction m Ada queryRewardsSum saId = do - currentEpoch <- queryLatestEpochNo + currentEpoch <- queryLatestEpochNoFromBlock res <- select $ do rwd <- from $ table @Reward where_ (rwd ^. RewardAddrId ==. val saId) @@ -122,7 +122,7 @@ queryStakeAddressBalance txOutTableType address = do pure (sum_ (rwd ^. RewardAmount)) pure $ unValueSumAda (listToMaybe res) - queryWithdrawals :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m Ada + queryWithdrawals :: MonadIO m => StakeAddressId -> DB.DbAction m Ada queryWithdrawals saId = do res <- select $ do wdrl <- from $ table @Withdrawal @@ -130,9 +130,9 @@ queryStakeAddressBalance txOutTableType address = do pure (sum_ (wdrl ^. WithdrawalAmount)) pure $ unValueSumAda (listToMaybe res) - queryOutputs :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m (Ada, Ada, Ada) - queryOutputs saId = case txOutTableType of - TxOutCore -> do + queryOutputs :: MonadIO m => StakeAddressId -> DB.DbAction m (Ada, Ada, Ada) + queryOutputs saId = case txOutVariantType of + TxOutVariantCore -> do res <- select $ do (txOut :& tx :& _txIn) <- from diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs index 2064ed8b4..e7193e96b 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs @@ -73,7 +73,7 @@ data EpochReward = EpochReward , erPercent :: !Double } -queryHistoryStakeRewards :: MonadIO m => Text -> ReaderT SqlBackend m [EpochReward] +queryHistoryStakeRewards :: MonadIO m => Text -> DB.DbAction m [EpochReward] queryHistoryStakeRewards address = do maxEpoch <- queryLatestMemberRewardEpochNo mapM queryReward =<< queryDelegation maxEpoch @@ -81,7 +81,7 @@ queryHistoryStakeRewards address = do queryDelegation :: MonadIO m => Word64 -> - ReaderT SqlBackend m [(StakeAddressId, Word64, UTCTime, DbLovelace, PoolHashId)] + DB.DbAction m [(StakeAddressId, Word64, UTCTime, DbLovelace, PoolHashId)] queryDelegation maxEpoch = do res <- select $ do (ep :& es :& saddr) <- @@ -105,7 +105,7 @@ queryHistoryStakeRewards address = do queryReward :: MonadIO m => (StakeAddressId, Word64, UTCTime, DbLovelace, PoolHashId) -> - ReaderT SqlBackend m EpochReward + DB.DbAction m EpochReward queryReward (saId, en, date, DbLovelace delegated, poolId) = do res <- select $ do (saddr :& rwd :& ep) <- @@ -144,7 +144,7 @@ queryHistoryStakeRewards address = do -- Find the latest epoch where member rewards have been distributed. -- Can't use the Reward table for this because that table may have been partially -- populated for the next epcoh. - queryLatestMemberRewardEpochNo :: MonadIO m => ReaderT SqlBackend m Word64 + queryLatestMemberRewardEpochNo :: MonadIO m => DB.DbAction m Word64 queryLatestMemberRewardEpochNo = do res <- select $ do blk <- from $ table @Block diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs index 4af910b63..a94948d6d 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs @@ -70,12 +70,12 @@ data EpochReward = EpochReward , erPercent :: !Double } -queryEpochStakeRewards :: MonadIO m => Word64 -> Text -> ReaderT SqlBackend m (Maybe EpochReward) +queryEpochStakeRewards :: MonadIO m => Word64 -> Text -> DB.DbAction m (Maybe EpochReward) queryEpochStakeRewards epochNum address = do mdel <- queryDelegation address epochNum maybe (pure Nothing) ((fmap . fmap) Just (queryReward epochNum address)) mdel -queryLatestStakeRewards :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe EpochReward) +queryLatestStakeRewards :: MonadIO m => Text -> DB.DbAction m (Maybe EpochReward) queryLatestStakeRewards address = do epochNum <- queryLatestMemberRewardEpochNo mdel <- queryDelegation address epochNum @@ -84,7 +84,7 @@ queryLatestStakeRewards address = do -- Find the latest epoch where member rewards have been distributed. -- Can't use the Reward table for this because that table may have been partially -- populated for the next epcoh. - queryLatestMemberRewardEpochNo :: MonadIO m => ReaderT SqlBackend m Word64 + queryLatestMemberRewardEpochNo :: MonadIO m => DB.DbAction m Word64 queryLatestMemberRewardEpochNo = do res <- select $ do blk <- from $ table @Block @@ -96,7 +96,7 @@ queryDelegation :: MonadIO m => Text -> Word64 -> - ReaderT SqlBackend m (Maybe (StakeAddressId, UTCTime, DbLovelace, PoolHashId)) + DB.DbAction m (Maybe (StakeAddressId, UTCTime, DbLovelace, PoolHashId)) queryDelegation address epochNum = do res <- select $ do (ep :& es :& saddr) <- @@ -124,7 +124,7 @@ queryReward :: Word64 -> Text -> (StakeAddressId, UTCTime, DbLovelace, PoolHashId) -> - ReaderT SqlBackend m EpochReward + DB.DbAction m EpochReward queryReward en address (saId, date, DbLovelace delegated, poolId) = do res <- select $ do (ep :& reward :& saddr) <- diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Synced.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Synced.hs index 09b2c5a95..38e93e825 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Synced.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Synced.hs @@ -41,7 +41,7 @@ assertFail mdiff = do -- ----------------------------------------------------------------------------- -queryLatestBlockTime :: MonadIO m => ReaderT SqlBackend m (Maybe UTCTime) +queryLatestBlockTime :: MonadIO m => DB.DbAction m (Maybe UTCTime) queryLatestBlockTime = do res <- select $ do blk <- from $ table @Db.Block diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs index 1deb1bdbe..c4cd2bca7 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs @@ -53,11 +53,11 @@ import Database.Esqueleto.Experimental ( {- HLINT ignore "Redundant ^." -} {- HLINT ignore "Fuse on/on" -} -reportTransactions :: TxOutTableType -> [Text] -> IO () -reportTransactions txOutTableType addrs = +reportTransactions :: TxOutVariantType -> [Text] -> IO () +reportTransactions txOutVariantType addrs = forM_ addrs $ \saddr -> do Text.putStrLn $ "\nTransactions for: " <> saddr <> "\n" - xs <- runDbNoLoggingEnv (queryStakeAddressTransactions txOutTableType saddr) + xs <- runDbNoLoggingEnv (queryStakeAddressTransactions txOutVariantType saddr) renderTransactions $ coaleseTxs xs -- ------------------------------------------------------------------------------------------------- @@ -85,14 +85,14 @@ instance Ord Transaction where GT -> GT EQ -> compare (trDirection tra) (trDirection trb) -queryStakeAddressTransactions :: MonadIO m => TxOutTableType -> Text -> ReaderT SqlBackend m [Transaction] -queryStakeAddressTransactions txOutTableType address = do +queryStakeAddressTransactions :: MonadIO m => TxOutVariantType -> Text -> DB.DbAction m [Transaction] +queryStakeAddressTransactions txOutVariantType address = do mSaId <- queryStakeAddressId case mSaId of Nothing -> pure [] Just saId -> queryTransactions saId where - queryStakeAddressId :: MonadIO m => ReaderT SqlBackend m (Maybe StakeAddressId) + queryStakeAddressId :: MonadIO m => DB.DbAction m (Maybe StakeAddressId) queryStakeAddressId = do res <- select $ do saddr <- from (table @StakeAddress) @@ -100,22 +100,22 @@ queryStakeAddressTransactions txOutTableType address = do pure (saddr ^. StakeAddressId) pure $ fmap unValue (listToMaybe res) - queryTransactions :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m [Transaction] + queryTransactions :: MonadIO m => StakeAddressId -> DB.DbAction m [Transaction] queryTransactions saId = do - inputs <- queryInputs txOutTableType saId - outputs <- queryOutputs txOutTableType saId + inputs <- queryInputs txOutVariantType saId + outputs <- queryOutputs txOutVariantType saId pure $ List.sort (inputs ++ outputs) queryInputs :: MonadIO m => - TxOutTableType -> + TxOutVariantType -> StakeAddressId -> - ReaderT SqlBackend m [Transaction] -queryInputs txOutTableType saId = do + DB.DbAction m [Transaction] +queryInputs txOutVariantType saId = do -- Standard UTxO inputs. - res1 <- case txOutTableType of + res1 <- case txOutVariantType of -- get the StakeAddressId from the Core TxOut table - TxOutCore -> select $ do + TxOutVariantCore -> select $ do (tx :& txOut :& blk) <- from $ table @Tx @@ -177,10 +177,10 @@ sumAmounts = Incoming -> acc + trAmount tr Outgoing -> acc - trAmount tr -queryOutputs :: MonadIO m => TxOutTableType -> StakeAddressId -> ReaderT SqlBackend m [Transaction] -queryOutputs txOutTableType saId = do - res <- case txOutTableType of - TxOutCore -> select $ do +queryOutputs :: MonadIO m => TxOutVariantType -> StakeAddressId -> DB.DbAction m [Transaction] +queryOutputs txOutVariantType saId = do + res <- case txOutVariantType of + TxOutVariantCore -> select $ do (txOut :& _txInTx :& _txIn :& txOutTx :& blk) <- from $ table @C.TxOut diff --git a/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs b/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs index 0f1db6346..136de1dae 100644 --- a/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs +++ b/cardano-db-tool/src/Cardano/DbTool/UtxoSet.hs @@ -20,9 +20,9 @@ import Data.Word (Word64) import System.Exit (exitSuccess) import System.IO (IOMode (..), withFile) -utxoSetAtSlot :: TxOutTableType -> Word64 -> IO () -utxoSetAtSlot txOutTableType slotNo = do - (genesisSupply, utxoSet, fees, eUtcTime) <- queryAtSlot txOutTableType slotNo +utxoSetAtSlot :: TxOutVariantType -> Word64 -> IO () +utxoSetAtSlot txOutVariantType slotNo = do + (genesisSupply, utxoSet, fees, eUtcTime) <- queryAtSlot txOutVariantType slotNo let supply = utxoSetSum utxoSet let aggregated = aggregateUtxos utxoSet @@ -82,13 +82,13 @@ partitionUtxos = accept (addr, _) = Text.length addr <= 180 && not (isRedeemTextAddress addr) -queryAtSlot :: TxOutTableType -> Word64 -> IO (Ada, [UtxoQueryResult], Ada, Either LookupFail UTCTime) -queryAtSlot txOutTableType slotNo = +queryAtSlot :: TxOutVariantType -> Word64 -> IO (Ada, [UtxoQueryResult], Ada, Either LookupFail UTCTime) +queryAtSlot txOutVariantType slotNo = -- Run the following queries in a single transaction. runDbNoLoggingEnv $ do (,,,) - <$> queryGenesisSupply txOutTableType - <*> queryUtxoAtSlotNo txOutTableType slotNo + <$> queryGenesisSupply txOutVariantType + <*> queryUtxoAtSlotNo txOutVariantType slotNo <*> queryFeesUpToSlotNo slotNo <*> querySlotUtcTime slotNo @@ -118,8 +118,8 @@ utxoSetSum xs = getTxOutValue :: TxOutW -> Word64 getTxOutValue wrapper = case wrapper of - CTxOutW txOut -> unDbLovelace $ C.txOutValue txOut - VTxOutW txOut _ -> unDbLovelace $ V.txOutValue txOut + VCTxOutW txOut -> unDbLovelace $ C.txOutValue txOut + VATxOutW txOut _ -> unDbLovelace $ V.txOutValue txOut writeUtxos :: FilePath -> [(Text, Word64)] -> IO () writeUtxos fname xs = do diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs index e59eff1e1..130732f3c 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs @@ -45,7 +45,7 @@ data Accounting = Accounting , accSumAdaPots :: Ada } -queryAdaPotsAccounting :: MonadIO m => ReaderT SqlBackend m [Accounting] +queryAdaPotsAccounting :: MonadIO m => DB.DbAction m [Accounting] queryAdaPotsAccounting = do -- AdaPots res <- select $ do diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockProperties.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockProperties.hs index a07d6450a..33b961fb8 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockProperties.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockProperties.hs @@ -116,7 +116,7 @@ validateTimestampsOrdered blkCount = do -- ------------------------------------------------------------------------------------------------- -queryBlockNoList :: MonadIO m => Word64 -> Word64 -> ReaderT SqlBackend m [Word64] +queryBlockNoList :: MonadIO m => Word64 -> Word64 -> DB.DbAction m [Word64] queryBlockNoList start count = do res <- select $ do blk <- from $ table @Block @@ -127,7 +127,7 @@ queryBlockNoList start count = do pure (blk ^. BlockBlockNo) pure $ mapMaybe unValue res -queryBlockTimestamps :: MonadIO m => Word64 -> Word64 -> ReaderT SqlBackend m [UTCTime] +queryBlockTimestamps :: MonadIO m => Word64 -> Word64 -> DB.DbAction m [UTCTime] queryBlockTimestamps start count = do res <- select $ do blk <- from $ table @Block @@ -138,7 +138,7 @@ queryBlockTimestamps start count = do pure (blk ^. BlockTime) pure $ map unValue res -queryBlocksTimeAfters :: MonadIO m => UTCTime -> ReaderT SqlBackend m [(Maybe Word64, Maybe Word64, UTCTime)] +queryBlocksTimeAfters :: MonadIO m => UTCTime -> DB.DbAction m [(Maybe Word64, Maybe Word64, UTCTime)] queryBlocksTimeAfters now = do res <- select $ do blk <- from $ table @Block diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs index e4e0a9849..2ff2d474e 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs @@ -71,7 +71,7 @@ validateBlockTxs epoch = do ++ show (veTxCountActual ve) ) -validateBlockCount :: MonadIO m => (Word64, Word64) -> ReaderT SqlBackend m (Either ValidateError ()) +validateBlockCount :: MonadIO m => (Word64, Word64) -> DB.DbAction m (Either ValidateError ()) validateBlockCount (blockNo, txCountExpected) = do txCountActual <- queryBlockTxCount blockNo pure $ @@ -80,7 +80,7 @@ validateBlockCount (blockNo, txCountExpected) = do else Left $ ValidateError blockNo txCountActual txCountExpected -- This queries by BlockNo, the one in Cardano.Db.Operations.Query queries by BlockId. -queryBlockTxCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 +queryBlockTxCount :: MonadIO m => Word64 -> DB.DbAction m Word64 queryBlockTxCount blockNo = do res <- select $ do (blk :& _tx) <- @@ -92,7 +92,7 @@ queryBlockTxCount blockNo = do pure countRows pure $ maybe 0 unValue (listToMaybe res) -queryEpochBlockNumbers :: MonadIO m => Word64 -> ReaderT SqlBackend m [(Word64, Word64)] +queryEpochBlockNumbers :: MonadIO m => Word64 -> DB.DbAction m [(Word64, Word64)] queryEpochBlockNumbers epoch = do res <- select $ do blk <- from $ table @Block diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs index 0572e5fdb..31d69d2ba 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Ledger.hs @@ -29,17 +29,17 @@ data LedgerValidationParams = LedgerValidationParams , vpAddressUtxo :: !Text } -validateLedger :: LedgerValidationParams -> DB.TxOutTableType -> IO () -validateLedger params txOutTableType = +validateLedger :: LedgerValidationParams -> DB.TxOutVariantType -> IO () +validateLedger params txOutVariantType = withIOManager $ \_ -> do enc <- readSyncNodeConfig (vpConfigFile params) genCfg <- runOrThrowIO $ runExceptT $ readCardanoGenesisConfig enc ledgerFiles <- listLedgerStateFilesOrdered (vpLedgerStateDir params) slotNo <- SlotNo <$> DB.runDbNoLoggingEnv DB.queryLatestSlotNo - validate params txOutTableType genCfg slotNo ledgerFiles + validate params txOutVariantType genCfg slotNo ledgerFiles -validate :: LedgerValidationParams -> DB.TxOutTableType -> GenesisConfig -> SlotNo -> [LedgerStateFile] -> IO () -validate params txOutTableType genCfg slotNo ledgerFiles = +validate :: LedgerValidationParams -> DB.TxOutVariantType -> GenesisConfig -> SlotNo -> [LedgerStateFile] -> IO () +validate params txOutVariantType genCfg slotNo ledgerFiles = go ledgerFiles True where go :: [LedgerStateFile] -> Bool -> IO () @@ -50,14 +50,14 @@ validate params txOutTableType genCfg slotNo ledgerFiles = then do -- TODO fix GenesisPoint. This is only used for logging Right state <- loadLedgerStateFromFile nullTracer (mkTopLevelConfig genCfg) False GenesisPoint ledgerFile - validateBalance txOutTableType ledgerSlot (vpAddressUtxo params) state + validateBalance txOutVariantType ledgerSlot (vpAddressUtxo params) state else do when logFailure . putStrLn $ redText "Ledger is newer than DB. Trying an older ledger." go rest False -validateBalance :: DB.TxOutTableType -> SlotNo -> Text -> CardanoLedgerState -> IO () -validateBalance txOutTableType slotNo addr st = do - balanceDB <- DB.runDbNoLoggingEnv $ DB.queryAddressBalanceAtSlot txOutTableType addr (unSlotNo slotNo) +validateBalance :: DB.TxOutVariantType -> SlotNo -> Text -> CardanoLedgerState -> IO () +validateBalance txOutVariantType slotNo addr st = do + balanceDB <- DB.runDbNoLoggingEnv $ DB.queryAddressBalanceAtSlot txOutVariantType addr (unSlotNo slotNo) let eiBalanceLedger = DB.word64ToAda <$> ledgerAddrBalance addr (ledgerState $ clsState st) case eiBalanceLedger of Left str -> putStrLn $ redText $ show str diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/PoolOwner.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/PoolOwner.hs index 80c683869..18f4e3579 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/PoolOwner.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/PoolOwner.hs @@ -35,7 +35,7 @@ validateAllPoolsHaveOwners = do -- select * from pool_hash -- where not exists (select * from pool_owner where pool_owner.pool_hash_id = pool_hash.id) ; -queryPoolsWithoutOwners :: MonadIO m => ReaderT SqlBackend m Int +queryPoolsWithoutOwners :: MonadIO m => DB.DbAction m Int queryPoolsWithoutOwners = do res <- select $ do pupd <- from $ table @PoolUpdate diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs index b466587b6..5e80a3dcb 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/TotalSupply.hs @@ -22,38 +22,38 @@ data TestParams = TestParams , genesisSupply :: Ada } -genTestParameters :: TxOutTableType -> IO TestParams -genTestParameters txOutTableType = do +genTestParameters :: TxOutVariantType -> IO TestParams +genTestParameters txOutVariantType = do mlatest <- runDbNoLoggingEnv queryLatestBlockNo case mlatest of Nothing -> error "Cardano.DbTool.Validation: Empty database" Just latest -> TestParams <$> randomRIO (1, latest - 1) - <*> runDbNoLoggingEnv (queryGenesisSupply txOutTableType) + <*> runDbNoLoggingEnv (queryGenesisSupply txOutVariantType) -queryInitialSupply :: TxOutTableType -> Word64 -> IO Accounting -queryInitialSupply txOutTableType blkNo = +queryInitialSupply :: TxOutVariantType -> Word64 -> IO Accounting +queryInitialSupply txOutVariantType blkNo = -- Run all queries in a single transaction. runDbNoLoggingEnv $ Accounting <$> queryFeesUpToBlockNo blkNo <*> queryDepositUpToBlockNo blkNo <*> queryWithdrawalsUpToBlockNo blkNo - <*> fmap2 utxoSetSum (queryUtxoAtBlockNo txOutTableType) blkNo + <*> fmap2 utxoSetSum (queryUtxoAtBlockNo txOutVariantType) blkNo -- | Validate that the total supply is decreasing. -- This is only true for the Byron error where transaction fees are burnt. -validateTotalSupplyDecreasing :: TxOutTableType -> IO () -validateTotalSupplyDecreasing txOutTableType = do - test <- genTestParameters txOutTableType +validateTotalSupplyDecreasing :: TxOutVariantType -> IO () +validateTotalSupplyDecreasing txOutVariantType = do + test <- genTestParameters txOutVariantType putStrF $ "Total supply + fees + deposit - withdrawals at block " ++ show (testBlockNo test) ++ " is same as genesis supply: " - accounting <- queryInitialSupply txOutTableType (testBlockNo test) + accounting <- queryInitialSupply txOutVariantType (testBlockNo test) let total = accSupply accounting + accFees accounting + accDeposit accounting - accWithdrawals accounting diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs index d229f045e..988a5fa5b 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.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC import Cardano.DbTool.Validate.Util import Control.Monad (replicateM, when) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -45,8 +45,8 @@ import qualified System.Random as Random {- HLINT ignore "Fuse on/on" -} -validateTxAccounting :: TxOutTableType -> IO () -validateTxAccounting getTxOutTableType = do +validateTxAccounting :: TxOutVariantType -> IO () +validateTxAccounting getTxOutVariantType = do txIdRange <- runDbNoLoggingEnv queryTestTxIds putStrF $ "For " @@ -55,7 +55,7 @@ validateTxAccounting getTxOutTableType = do ++ show (snd txIdRange) ++ " accounting is: " ids <- randomTxIds testCount txIdRange - res <- runExceptT $ traverse (validateAccounting getTxOutTableType) ids + res <- runExceptT $ traverse (validateAccounting getTxOutVariantType) ids case res of Left err -> error $ redText (reportError err) Right _ -> putStrLn $ greenText "ok" @@ -113,16 +113,16 @@ showTxOut txo = ] where (txId, value) = case txo of - CTxOutW cTxOut -> (C.txOutTxId cTxOut, C.txOutValue cTxOut) - VTxOutW vTxOut _ -> (V.txOutTxId vTxOut, V.txOutValue vTxOut) + VCTxOutW cTxOut -> (VC.txOutTxId cTxOut, VC.txOutValue cTxOut) + VATxOutW vTxOut _ -> (VA.txOutTxId vTxOut, VA.txOutValue vTxOut) -- For a given TxId, validate the input/output accounting. -validateAccounting :: TxOutTableType -> Word64 -> ExceptT ValidateError IO () -validateAccounting txOutTableType txId = do +validateAccounting :: TxOutVariantType -> Word64 -> ExceptT ValidateError IO () +validateAccounting txOutVariantType txId = do (fee, deposit) <- liftIO $ runDbNoLoggingEnv (queryTxFeeDeposit txId) withdrawal <- liftIO $ runDbNoLoggingEnv (queryTxWithdrawal txId) - ins <- liftIO $ runDbNoLoggingEnv (queryTxInputs txOutTableType txId) - outs <- liftIO $ runDbNoLoggingEnv (queryTxOutputs txOutTableType txId) + ins <- liftIO $ runDbNoLoggingEnv (queryTxInputs txOutVariantType txId) + outs <- liftIO $ runDbNoLoggingEnv (queryTxOutputs txOutVariantType txId) -- A refund is a negative deposit. when (deposit >= 0 && sumValues ins + withdrawal /= fee + adaDeposit deposit + sumValues outs) $ left (ValidateError txId fee deposit withdrawal ins outs) @@ -140,12 +140,12 @@ sumValues = word64ToAda . sum . map txOutValue where txOutValue = unDbLovelace . \case - CTxOutW cTxOut -> C.txOutValue cTxOut - VTxOutW vTxOut _ -> V.txOutValue vTxOut + VCTxOutW cTxOut -> VC.txOutValue cTxOut + VATxOutW vTxOut _ -> VA.txOutValue vTxOut -- ------------------------------------------------------------------------------------------------- -queryTestTxIds :: MonadIO m => ReaderT SqlBackend m (Word64, Word64) +queryTestTxIds :: MonadIO m => DB.DbAction m (Word64, Word64) queryTestTxIds = do -- Exclude all 'faked' generated TxId values from the genesis block (block_id == 1). lower <- @@ -156,7 +156,7 @@ queryTestTxIds = do upper <- select $ from (table @Tx) >> pure countRows pure (maybe 0 (unTxId . unValue) (listToMaybe lower), maybe 0 unValue (listToMaybe upper)) -queryTxFeeDeposit :: MonadIO m => Word64 -> ReaderT SqlBackend m (Ada, Int64) +queryTxFeeDeposit :: MonadIO m => Word64 -> DB.DbAction m (Ada, Int64) queryTxFeeDeposit txId = do res <- select $ do tx <- from $ table @Tx @@ -167,12 +167,12 @@ queryTxFeeDeposit txId = do convert :: (Value DbLovelace, Value (Maybe Int64)) -> (Ada, Int64) convert (Value (DbLovelace w64), d) = (word64ToAda w64, fromMaybe 0 (unValue d)) -queryTxInputs :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [TxOutW] -queryTxInputs txOutTableType txId = case txOutTableType of - TxOutCore -> map CTxOutW <$> queryInputsBody @'TxOutCore txId - TxOutVariantAddress -> map (`VTxOutW` Nothing) <$> queryInputsBody @'TxOutVariantAddress txId +queryTxInputs :: MonadIO m => TxOutVariantType -> Word64 -> DB.DbAction m [TxOutW] +queryTxInputs txOutVariantType txId = case txOutVariantType of + TxOutVariantCore -> map VCTxOutW <$> queryInputsBody @'TxOutCore txId + TxOutVariantAddress -> map (`VATxOutW` Nothing) <$> queryInputsBody @'TxOutVariantAddress txId -queryInputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> ReaderT SqlBackend m [TxOutTable a] +queryInputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> DB.DbAction m [TxOutTable a] queryInputsBody txId = do res <- select $ do (tx :& txin :& txout) <- @@ -187,12 +187,12 @@ queryInputsBody txId = do pure txout pure $ entityVal <$> res -queryTxOutputs :: MonadIO m => TxOutTableType -> Word64 -> ReaderT SqlBackend m [TxOutW] -queryTxOutputs txOutTableType txId = case txOutTableType of - TxOutCore -> map CTxOutW <$> queryTxOutputsBody @'TxOutCore txId - TxOutVariantAddress -> map (`VTxOutW` Nothing) <$> queryTxOutputsBody @'TxOutVariantAddress txId +queryTxOutputs :: MonadIO m => TxOutVariantType -> Word64 -> DB.DbAction m [TxOutW] +queryTxOutputs txOutVariantType txId = case txOutVariantType of + TxOutVariantCore -> map VCTxOutW <$> queryTxOutputsBody @'TxOutCore txId + TxOutVariantAddress -> map (`VATxOutW` Nothing) <$> queryTxOutputsBody @'TxOutVariantAddress txId -queryTxOutputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> ReaderT SqlBackend m [TxOutTable a] +queryTxOutputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> DB.DbAction m [TxOutTable a] queryTxOutputsBody txId = do res <- select $ do (tx :& txout) <- @@ -204,7 +204,7 @@ queryTxOutputsBody txId = do pure txout pure $ entityVal <$> res -queryTxWithdrawal :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada +queryTxWithdrawal :: MonadIO m => Word64 -> DB.DbAction m Ada queryTxWithdrawal txId = do res <- select $ do withdraw <- from $ table @Withdrawal diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Withdrawal.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Withdrawal.hs index e5404baaf..bc00cd6f1 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Withdrawal.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Withdrawal.hs @@ -63,7 +63,7 @@ reportError ai = ] -- For a given StakeAddressId, validate that sum rewards >= sum withdrawals. -validateAccounting :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m (Either AddressInfo ()) +validateAccounting :: MonadIO m => StakeAddressId -> DB.DbAction m (Either AddressInfo ()) validateAccounting addrId = do ai <- queryAddressInfo addrId pure $ @@ -71,38 +71,16 @@ validateAccounting addrId = do then Left ai else Right () --- ------------------------------------------------------------------------------------------------- - --- Get all stake addresses with have seen a withdrawal, and return them in shuffled order. -queryWithdrawalAddresses :: MonadIO m => ReaderT SqlBackend m [StakeAddressId] -queryWithdrawalAddresses = do - res <- select . distinct $ do - wd <- from (table @Withdrawal) - pure (wd ^. WithdrawalAddrId) - liftIO $ shuffleM (map unValue res) - -queryAddressInfo :: MonadIO m => StakeAddressId -> ReaderT SqlBackend m AddressInfo +queryAddressInfo :: MonadIO m => StakeAddressId -> DbAction m AddressInfo queryAddressInfo addrId = do - rwds <- - select $ - from (table @Reward) >>= \rwd -> do - where_ (rwd ^. RewardAddrId ==. val addrId) - pure (sum_ $ rwd ^. RewardAmount) - wdls <- select $ do - wdl <- from (table @Withdrawal) - where_ (wdl ^. WithdrawalAddrId ==. val addrId) - pure (sum_ (wdl ^. WithdrawalAmount)) - view <- select $ do - saddr <- from $ table @StakeAddress - where_ (saddr ^. StakeAddressId ==. val addrId) - pure (saddr ^. StakeAddressView) - pure $ convert (listToMaybe rwds) (listToMaybe wdls) (listToMaybe view) - where - convert :: Maybe (Value (Maybe Micro)) -> Maybe (Value (Maybe Micro)) -> Maybe (Value Text) -> AddressInfo - convert rAmount wAmount mview = - AddressInfo - { aiStakeAddressId = addrId - , aiStakeAddress = maybe "unknown" unValue mview - , aiSumRewards = unValueSumAda rAmount - , aiSumWithdrawals = unValueSumAda wAmount - } + result <- queryAddressInfoData addrId + pure $ makeAddressInfo addrId result + +makeAddressInfo :: StakeAddressId -> (Ada, Ada, Maybe Text) -> AddressInfo +makeAddressInfo addrId (rewards, withdrawals, view) = + AddressInfo + { aiStakeAddressId = addrId + , aiStakeAddress = fromMaybe "unknown" view + , aiSumRewards = rewards + , aiSumWithdrawals = withdrawals + } diff --git a/cardano-db-tool/src/Cardano/DbTool/Validation.hs b/cardano-db-tool/src/Cardano/DbTool/Validation.hs index 78d23a01b..89fe2c316 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validation.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validation.hs @@ -4,7 +4,7 @@ module Cardano.DbTool.Validation ( runLedgerValidation, ) where -import Cardano.Db (TxOutTableType) +import Cardano.Db (TxOutVariantType) import Cardano.DbTool.Validate.AdaPots (validateSumAdaPots) import Cardano.DbTool.Validate.BlockProperties (validateBlockProperties) import Cardano.DbTool.Validate.BlockTxs (validateEpochBlockTxs) @@ -15,12 +15,12 @@ import Cardano.DbTool.Validate.TotalSupply (validateTotalSupplyDecreasing) import Cardano.DbTool.Validate.TxAccounting (validateTxAccounting) import Cardano.DbTool.Validate.Withdrawal (validateWithdrawals) -runDbValidation :: TxOutTableType -> IO () -runDbValidation txOutTableType = do +runDbValidation :: TxOutVariantType -> IO () +runDbValidation txOutVariantType = do fastValidations - slowValidations txOutTableType + slowValidations txOutVariantType -runLedgerValidation :: LedgerValidationParams -> TxOutTableType -> IO () +runLedgerValidation :: LedgerValidationParams -> TxOutVariantType -> IO () runLedgerValidation = validateLedger @@ -32,10 +32,10 @@ fastValidations = do validateBlockProperties validateSumAdaPots -slowValidations :: TxOutTableType -> IO () -slowValidations txOutTableType = do - validateTxAccounting txOutTableType +slowValidations :: TxOutVariantType -> IO () +slowValidations txOutVariantType = do + validateTxAccounting txOutVariantType validateWithdrawals validateEpochTable validateEpochBlockTxs - validateTotalSupplyDecreasing txOutTableType + validateTotalSupplyDecreasing txOutVariantType diff --git a/cardano-db/app/gen-schema-docs.hs b/cardano-db/app/gen-schema-docs.hs deleted file mode 100644 index 3f9cd7bd0..000000000 --- a/cardano-db/app/gen-schema-docs.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Cardano.Db (schemaDocs) -import Cardano.Db.Schema.Core.TxOut (schemaDocsTxOutCore) -import Cardano.Db.Schema.Variant.TxOut (schemaDocsTxOutVariant) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Version (showVersion) -import Database.Persist.Documentation (markdownTableRenderer, render) -import Paths_cardano_db (version) -import System.Environment (getArgs, getProgName) -import System.Exit (ExitCode (..)) -import System.IO (IOMode (..), withFile) -import System.Process (readProcessWithExitCode) - --- There are a number of reasons why we generate schema documentation like this. --- * Having the schema docs with the schema definition in the Haskell file means that the schema --- documentation library will error out if a field is deleted from the schema but not the --- documentation. If a field is added but not documented, the documentation library will still --- add it to the generated documentation but with a blank comment. --- * Schema documentation can be generated at any time, but the updated `doc/schema.md` file --- should only be committed as part of the release process, so that documentation in the Github --- matches the schema version people are likley to be running in the field. - -main :: IO () -main = do - args <- getArgs - gitBranch <- readGitBranch - case args of - [] -> do - Text.putStrLn $ docHeader gitBranch - Text.putStrLn docBody - [file] -> withFile file WriteMode $ \h -> do - Text.hPutStrLn h $ docHeader gitBranch - Text.hPutStrLn h docBody - _otherwise -> usageExit - where - usageExit :: IO () - usageExit = do - pname <- getProgName - putStrLn $ - mconcat - [ "\nUsage: " - , pname - , " \n\n" - , "If no filename is provided, the output will be printed to stdout.\n" - ] - -docHeader :: Text -> Text -docHeader branchName = - mconcat - [ "# Schema Documentation for cardano-db-sync\n\n" - , "Schema version: " - , Text.pack (showVersion version) - , if "release" `Text.isPrefixOf` branchName - then mempty - else - mconcat - [ " (from branch **" - , branchName - , "** which may not accurately reflect the version number)" - ] - , "\n" - , "**Note:** This file is auto-generated from the documentation in cardano-db/src/Cardano/Db/Schema/BaseSchema.hs\ - \ by the command `cabal run -- gen-schema-docs doc/schema.md`. This document should only be updated\ - \ during the release process and updated on the release branch." - , "\n" - ] - -docBody :: Text -docBody = do - coreDocBody <> variantDivider <> variantDocBody - where - coreDocBody = cleanUp $ render markdownTableRenderer (schemaDocs <> schemaDocsTxOutCore) - variantDocBody = cleanUp $ render markdownTableRenderer schemaDocsTxOutVariant - cleanUp = Text.replace "ID:" "Id:" . Text.replace "#" "###" - variantDivider = - mconcat - [ "# Variant Schema\n\n" - , "When using the `use_address_table` [configuration](https://github.com/IntersectMBO/cardano-db-sync/blob/master/doc/configuration.md#tx-out), the `tx_out` table is split into two tables: `tx_out` and `address`.\n" - , "Bellow are the table documentation for this variaton. \n\n" - ] - -readGitBranch :: IO Text -readGitBranch = do - (exitCode, output, _) <- readProcessWithExitCode "git" ["branch", "--show-current"] "" - pure $ case exitCode of - ExitSuccess -> Text.strip (Text.pack output) - ExitFailure _ -> "unknown" diff --git a/cardano-db/cardano-db.cabal b/cardano-db/cardano-db.cabal index d8afa1a33..fe100290a 100644 --- a/cardano-db/cardano-db.cabal +++ b/cardano-db/cardano-db.cabal @@ -30,8 +30,10 @@ 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 + Cardano.Db.Schema.Variants.TxOutAddress + Cardano.Db.Schema.Variants.TxOutCore other-modules: Cardano.Db.Error Cardano.Db.Git.RevFromGit @@ -39,23 +41,40 @@ library Cardano.Db.Migration Cardano.Db.Migration.Haskell Cardano.Db.Migration.Version - Cardano.Db.Operations.AlterTable - Cardano.Db.Operations.Delete - Cardano.Db.Operations.Insert - Cardano.Db.Operations.Other.MinId - Cardano.Db.Operations.Query Cardano.Db.Operations.QueryHelper - Cardano.Db.Operations.Types - Cardano.Db.Operations.Other.ConsumedTxOut - Cardano.Db.Operations.Other.JsonbQuery - Cardano.Db.Operations.TxOut.TxOutDelete - Cardano.Db.Operations.TxOut.TxOutInsert - 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.MinIds Cardano.Db.Schema.Orphans Cardano.Db.Schema.Types + Cardano.Db.Schema.Variants.TxOutUtxoHd + Cardano.Db.Schema.Variants.TxOutUtxoHdAddress + Cardano.Db.Statement + Cardano.Db.Statement.Base + Cardano.Db.Statement.Constraint + Cardano.Db.Statement.ConsumedTxOut + Cardano.Db.Statement.EpochAndProtocol + Cardano.Db.Statement.Function.Core + Cardano.Db.Statement.Function.Delete + Cardano.Db.Statement.Function.Insert + Cardano.Db.Statement.Function.Query + Cardano.Db.Statement.GovernanceAndVoting + Cardano.Db.Statement.JsonB + Cardano.Db.Statement.MultiAsset + Cardano.Db.Statement.OffChain + Cardano.Db.Statement.Pool + Cardano.Db.Statement.Rollback + Cardano.Db.Statement.StakeDeligation + Cardano.Db.Statement.Types + Cardano.Db.Statement.Variants.TxOut Cardano.Db.Types build-depends: aeson @@ -66,33 +85,28 @@ library , cardano-crypto-class , cardano-ledger-core , cardano-prelude - , cardano-slotting - , containers , conduit-extra + , containers , contra-tracer + , contravariant-extras , cryptonite , directory - , esqueleto , extra , fast-logger - , filepath , file-embed + , filepath + , hasql , iohk-monitoring - , lifted-base , memory - , monad-control , monad-logger , persistent - , persistent-documentation - , persistent-postgresql - , postgresql-simple , process , quiet - , resourcet , resource-pool + , resourcet , scientific - , text , template-haskell + , text , time , transformers -- This is never intended to run on non-POSIX systems. @@ -129,9 +143,7 @@ test-suite test , cardano-ledger-byron , cardano-ledger-core , cardano-ledger-mary - , persistent , hedgehog - , text , wide-word test-suite test-db @@ -164,40 +176,10 @@ test-suite test-db , directory , extra , filepath - , monad-control - , persistent , tasty , tasty-hunit , text , time - , transformers - -executable gen-schema-docs - default-language: Haskell2010 - main-is: gen-schema-docs.hs - hs-source-dirs: app - - ghc-options: -O2 - -Wall - -Werror - -Wcompat - -Wredundant-constraints - -Wincomplete-patterns - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wunused-imports - -Wunused-packages - -Wno-unsafe - -threaded - -with-rtsopts=-N3 - - other-modules: Paths_cardano_db - - build-depends: base - , cardano-db - , persistent-documentation - , process - , text test-suite schema-rollback default-language: Haskell2010 diff --git a/cardano-db/src/Cardano/Db.hs b/cardano-db/src/Cardano/Db.hs index 630df6f2a..96e53963a 100644 --- a/cardano-db/src/Cardano/Db.hs +++ b/cardano-db/src/Cardano/Db.hs @@ -12,20 +12,11 @@ import Cardano.Db.Error as X 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.Ids 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..e4c0a22de 100644 --- a/cardano-db/src/Cardano/Db/Error.hs +++ b/cardano-db/src/Cardano/Db/Error.hs @@ -1,63 +1,40 @@ -{-# 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) +import qualified Hasql.Session as HsqlSes -instance Exception LookupFail +data DbError = DbError + { dbErrorCallSite :: !CallSite + , dbErrorMessage :: !Text + , dbErrorCause :: !(Maybe HsqlSes.SessionError) -- Now a Maybe + } + deriving (Show, Eq) -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 +instance Exception DbError + +data CallSite = CallSite + { csModule :: !Text + , csFile :: !Text + , csLine :: !Int + } + deriving (Show, Eq) base16encode :: ByteString -> Text base16encode = Text.decodeUtf8 . Base16.encode @@ -69,7 +46,58 @@ 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 throwIO $ userError $ show msg + +-- 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 diff --git a/cardano-db/src/Cardano/Db/Migration.hs b/cardano-db/src/Cardano/Db/Migration.hs index be65062c1..0ade3269e 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 (TxOutVariantType (..)) +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) @@ -106,8 +97,8 @@ data MigrationToRun = Initial | Full | Indexes -- | Run the migrations in the provided 'MigrationDir' and write date stamped log file -- to 'LogFileDir'. It returns a list of file names of all non-official schema migration files. -runMigrations :: PGConfig -> Bool -> MigrationDir -> Maybe LogFileDir -> MigrationToRun -> TxOutTableType -> IO (Bool, [FilePath]) -runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutTableType = do +runMigrations :: PGConfig -> Bool -> MigrationDir -> Maybe LogFileDir -> MigrationToRun -> TxOutVariantType -> IO (Bool, [FilePath]) +runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutVariantType = do allScripts <- getMigrationScripts migrationDir ranAll <- case (mLogfiledir, allScripts) of (_, []) -> @@ -148,17 +139,17 @@ runMigrations pgconfig quiet migrationDir mLogfiledir mToRun txOutTableType = do pure (filter filterIndexes scripts, False) filterIndexesFull (mv, _) = do - case txOutTableType of - TxOutCore -> True + case txOutVariantType of + TxOutVariantCore -> True TxOutVariantAddress -> not $ mvStage mv == 4 && mvVersion mv == 1 filterInitial (mv, _) = mvStage mv < 4 filterIndexes (mv, _) = do - case txOutTableType of - TxOutCore -> mvStage mv == 4 + case txOutVariantType of + TxOutVariantCore -> mvStage mv == 4 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'. -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 +-- | Create a database migration. +-- NOTE: This functionality will need to be reimplemented without Persistent. +-- For now, this serves as a placeholder. +createMigration :: PGPassSource -> MigrationDir -> TxOutVariantType -> IO (Maybe FilePath) +createMigration _source (MigrationDir _migdir) _txOutVariantType = 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..be82afa7f 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 (DB.DbAction m ()) +-- migrationMap = +-- Map.fromList +-- [ (MigrationVersion 2 1 20190731, migration0001) +-- ] --------------------------------------------------------------------------------- +-- -------------------------------------------------------------------------------- -migration0001 :: MonadLogger m => ReaderT SqlBackend m () -migration0001 = - -- Place holder. - pure () +-- migration0001 :: MonadLogger m => DB.DbAction m () +-- migration0001 = +-- -- Place holder. +-- pure () --------------------------------------------------------------------------------- +-- -------------------------------------------------------------------------------- diff --git a/cardano-db/src/Cardano/Db/Operations/AlterTable.hs b/cardano-db/src/Cardano/Db/Operations/AlterTable.hs index adefd1de4..a0ad5c79c 100644 --- a/cardano-db/src/Cardano/Db/Operations/AlterTable.hs +++ b/cardano-db/src/Cardano/Db/Operations/AlterTable.hs @@ -6,141 +6,142 @@ {-# OPTIONS_GHC -Wno-unused-local-binds #-} module Cardano.Db.Operations.AlterTable ( - AlterTable (..), - DbAlterTableException (..), - ManualDbConstraints (..), - alterTable, - queryHasConstraint, -) where + ) where -import Control.Exception.Lifted (Exception, handle, throwIO) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Data.Text as Text -import Database.Persist.EntityDef.Internal (entityDB) -import Database.Persist.Postgresql (ConstraintNameDB (..), EntityDef, EntityNameDB (..), FieldNameDB (..), Single (..), SqlBackend, fieldDB, getEntityFields, rawExecute, rawSql) -import Database.PostgreSQL.Simple (ExecStatus (..), SqlError (..)) +-- AlterTable (..), +-- DbAlterTableException (..), +-- ManualDbConstraints (..), +-- alterTable, +-- queryHasConstraint, --- The ability to `ALTER TABLE` currently dealing with `CONSTRAINT` but can be extended -data AlterTable - = AddUniqueConstraint ConstraintNameDB [FieldNameDB] - | DropUniqueConstraint ConstraintNameDB - deriving (Show) +-- import Control.Exception.Lifted (Exception, handle, throwIO) +-- import Control.Monad.IO.Class (MonadIO, liftIO) +-- import Control.Monad.Trans.Control (MonadBaseControl) +-- import Control.Monad.Trans.Reader (ReaderT) +-- import qualified Data.Text as Text +-- import Database.Persist.EntityDef.Internal (entityDB) +-- import Database.Persist.Postgresql (ConstraintNameDB (..), EntityDef, EntityNameDB (..), FieldNameDB (..), Single (..), SqlBackend, fieldDB, getEntityFields, rawExecute, rawSql) +-- import Database.PostgreSQL.Simple (ExecStatus (..), SqlError (..)) -data DbAlterTableException - = DbAlterTableException String SqlError - deriving (Show) +-- -- The ability to `ALTER TABLE` currently dealing with `CONSTRAINT` but can be extended +-- data AlterTable +-- = AddUniqueConstraint ConstraintNameDB [FieldNameDB] +-- | DropUniqueConstraint ConstraintNameDB +-- deriving (Show) -instance Exception DbAlterTableException +-- data DbAlterTableException +-- = DbAlterTableException String SqlError +-- deriving (Show) -data ManualDbConstraints = ManualDbConstraints - { dbConstraintRewards :: !Bool - , dbConstraintEpochStake :: !Bool - } +-- instance Exception DbAlterTableException --- this allows us to add and drop unique constraints to tables -alterTable :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - EntityDef -> - AlterTable -> - ReaderT SqlBackend m () -alterTable entity (AddUniqueConstraint cname cols) = - alterTableAddUniqueConstraint entity cname cols -alterTable entity (DropUniqueConstraint cname) = - alterTableDropUniqueConstraint entity cname +-- data ManualDbConstraints = ManualDbConstraints +-- { dbConstraintRewards :: !Bool +-- , dbConstraintEpochStake :: !Bool +-- } -alterTableAddUniqueConstraint :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - EntityDef -> - ConstraintNameDB -> - [FieldNameDB] -> - ReaderT SqlBackend m () -alterTableAddUniqueConstraint entity cname cols = do - if checkAllFieldsValid entity cols - then handle alterTableExceptHandler (rawExecute queryAddConstraint []) - else throwErr "Some of the unique values which that are being added to the constraint don't correlate with what exists" - where - queryAddConstraint :: Text.Text - queryAddConstraint = - Text.concat - [ "ALTER TABLE " - , unEntityNameDB (entityDB entity) - , " ADD CONSTRAINT " - , unConstraintNameDB cname - , " UNIQUE(" - , Text.intercalate "," $ map unFieldNameDB cols - , ")" - ] +-- -- this allows us to add and drop unique constraints to tables +-- alterTable :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- EntityDef -> +-- AlterTable -> +-- DB.DbAction m () +-- alterTable entity (AddUniqueConstraint cname cols) = +-- alterTableAddUniqueConstraint entity cname cols +-- alterTable entity (DropUniqueConstraint cname) = +-- alterTableDropUniqueConstraint entity cname - throwErr :: forall m'. MonadIO m' => [Char] -> ReaderT SqlBackend m' () - throwErr e = liftIO $ throwIO (DbAlterTableException e sqlError) +-- alterTableAddUniqueConstraint :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- EntityDef -> +-- ConstraintNameDB -> +-- [FieldNameDB] -> +-- DB.DbAction m () +-- alterTableAddUniqueConstraint entity cname cols = do +-- if checkAllFieldsValid entity cols +-- then handle alterTableExceptHandler (rawExecute queryAddConstraint []) +-- else throwErr "Some of the unique values which that are being added to the constraint don't correlate with what exists" +-- where +-- queryAddConstraint :: Text.Text +-- queryAddConstraint = +-- Text.concat +-- [ "ALTER TABLE " +-- , unEntityNameDB (entityDB entity) +-- , " ADD CONSTRAINT " +-- , unConstraintNameDB cname +-- , " UNIQUE(" +-- , Text.intercalate "," $ map unFieldNameDB cols +-- , ")" +-- ] -alterTableDropUniqueConstraint :: - forall m. - ( MonadBaseControl IO m - , MonadIO m - ) => - EntityDef -> - ConstraintNameDB -> - ReaderT SqlBackend m () -alterTableDropUniqueConstraint entity cname = - handle alterTableExceptHandler (rawExecute query []) - where - query :: Text.Text - query = - Text.concat - [ "ALTER TABLE " - , unEntityNameDB (entityDB entity) - , " DROP CONSTRAINT IF EXISTS " - , unConstraintNameDB cname - ] +-- throwErr :: forall m'. MonadIO m' => [Char] -> DB.DbAction m' () +-- throwErr e = liftIO $ throwIO (DbAlterTableException e sqlError) --- check if a constraint is already present -queryHasConstraint :: - MonadIO m => - ConstraintNameDB -> - ReaderT SqlBackend m Bool -queryHasConstraint cname = do - constraintRes :: [Single Int] <- rawSql queryCheckConstraint [] - if constraintRes == [Single 1] - then pure True - else pure False - where - queryCheckConstraint :: Text.Text - queryCheckConstraint = - Text.concat - [ "SELECT COUNT(*) FROM pg_constraint WHERE conname ='" - , unConstraintNameDB cname - , "'" - ] +-- alterTableDropUniqueConstraint :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- EntityDef -> +-- ConstraintNameDB -> +-- DB.DbAction m () +-- alterTableDropUniqueConstraint entity cname = +-- handle alterTableExceptHandler (rawExecute query []) +-- where +-- query :: Text.Text +-- query = +-- Text.concat +-- [ "ALTER TABLE " +-- , unEntityNameDB (entityDB entity) +-- , " DROP CONSTRAINT IF EXISTS " +-- , unConstraintNameDB cname +-- ] --- check to see that the field inputs exist -checkAllFieldsValid :: Foldable t => EntityDef -> t FieldNameDB -> Bool -checkAllFieldsValid entity cols = do - let fieldDef = getEntityFields entity - fieldDbs = map fieldDB fieldDef - all (`elem` fieldDbs) cols +-- -- check if a constraint is already present +-- queryHasConstraint :: +-- MonadIO m => +-- ConstraintNameDB -> +-- DB.DbAction m Bool +-- queryHasConstraint cname = do +-- constraintRes :: [Single Int] <- rawSql queryCheckConstraint [] +-- if constraintRes == [Single 1] +-- then pure True +-- else pure False +-- where +-- queryCheckConstraint :: Text.Text +-- queryCheckConstraint = +-- Text.concat +-- [ "SELECT COUNT(*) FROM pg_constraint WHERE conname ='" +-- , unConstraintNameDB cname +-- , "'" +-- ] -alterTableExceptHandler :: - forall m a. - MonadIO m => - SqlError -> - ReaderT SqlBackend m a -alterTableExceptHandler e = liftIO $ throwIO (DbAlterTableException "" e) +-- -- check to see that the field inputs exist +-- checkAllFieldsValid :: Foldable t => EntityDef -> t FieldNameDB -> Bool +-- checkAllFieldsValid entity cols = do +-- let fieldDef = getEntityFields entity +-- fieldDbs = map fieldDB fieldDef +-- all (`elem` fieldDbs) cols -sqlError :: SqlError -sqlError = - SqlError - { sqlState = "" - , sqlExecStatus = FatalError - , sqlErrorMsg = "" - , sqlErrorDetail = "" - , sqlErrorHint = "" - } +-- alterTableExceptHandler :: +-- forall m a. +-- MonadIO m => +-- SqlError -> +-- DB.DbAction m a +-- alterTableExceptHandler e = liftIO $ throwIO (DbAlterTableException "" e) + +-- sqlError :: SqlError +-- sqlError = +-- SqlError +-- { sqlState = "" +-- , sqlExecStatus = FatalError +-- , sqlErrorMsg = "" +-- , sqlErrorDetail = "" +-- , sqlErrorHint = "" +-- } diff --git a/cardano-db/src/Cardano/Db/Operations/Delete.hs b/cardano-db/src/Cardano/Db/Operations/Delete.hs index e84c71cec..317fefe58 100644 --- a/cardano-db/src/Cardano/Db/Operations/Delete.hs +++ b/cardano-db/src/Cardano/Db/Operations/Delete.hs @@ -9,389 +9,383 @@ {-# 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 (TxOutVariantType (..)) +-- 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. -deleteBlocksSlotNo :: - MonadIO m => - Trace IO Text -> - TxOutTableType -> - SlotNo -> - Bool -> - ReaderT SqlBackend m Bool -deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) isConsumedTxOut = do - mBlockId <- queryNearestBlockSlotNo slotNo - case mBlockId of - Nothing -> do - liftIO $ logWarning trce $ "deleteBlocksSlotNo: No block contains the the slot: " <> pack (show slotNo) - pure False - Just (blockId, epochN) -> do - void $ deleteBlocksBlockId trce txOutTableType blockId epochN isConsumedTxOut - pure True +-- deleteBlocksSlotNo :: +-- MonadIO m => +-- Trace IO Text -> +-- TxOutVariantType -> +-- SlotNo -> +-- Bool -> +-- DB.DbAction m Bool +-- deleteBlocksSlotNo trce txOutVariantType (SlotNo slotNo) isConsumedTxOut = do +-- mBlockId <- queryNearestBlockSlotNo slotNo +-- case mBlockId of +-- Nothing -> do +-- liftIO $ logWarning trce $ "deleteBlocksSlotNo: No block contains the the slot: " <> pack (show slotNo) +-- pure False +-- Just (blockId, epochN) -> do +-- void $ deleteBlocksBlockId trce txOutVariantType 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' - - 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 +-- deleteBlocksBlockId :: +-- MonadIO m => +-- Trace IO Text -> +-- TxOutVariantType -> +-- BlockId -> +-- -- | The 'EpochNo' of the block to delete. +-- Word64 -> +-- -- | Is ConsumeTxout +-- Bool -> +-- DB.DbAction m Int64 +-- deleteBlocksBlockId trce txOutVariantType blockId epochN isConsumedTxOut = do +-- mMinIds <- fmap (textToMinIds txOutVariantType =<<) <$> 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 txOutVariantType blockId mTxId minIds +-- setNullLogs <- +-- if isConsumedTxOut +-- then querySetNullTxOut txOutVariantType 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 -> DB.DbAction 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' -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 +-- 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 -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] - ] +-- deleteUsingEpochNo :: MonadIO m => Word64 -> DB.DbAction 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 - -- 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 - ] +-- TODO: CMDV +-- deleteTablesAfterBlockId :: +-- MonadIO m => +-- TxOutVariantType -> +-- BlockId -> +-- Maybe TxId -> +-- MinIdsWrapper -> +-- DB.DbAction m (Int64, [(Text, Int64)]) +-- deleteTablesAfterBlockId txOutVariantType blkId mtxId minIdsW = do +-- initialLogs <- +-- concat +-- <$> sequence +-- [ onlyDelete "AdaPots" [AdaPotsBlockId >=. blkId] +-- , onlyDelete "ReverseIndex" [ReverseIndexBlockId >=. blkId] +-- , onlyDelete "EpochParam" [EpochParamBlockId >=. blkId] +-- ] - 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) +-- -- 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 +-- ] -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 +-- 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 txOutVariantType mtxId minIdsW +-- -- Final block deletions +-- blockLogs <- onlyDelete "Block" [BlockId >=. blkId] +-- -- Aggregate and return all logs +-- pure (sum $ map snd blockLogs, initialLogs <> blockLogs <> offChainLogs <> afterTxIdLogs) -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] +-- deleteTablesAfterTxId :: +-- MonadIO m => +-- TxOutVariantType -> +-- Maybe TxId -> +-- MinIdsWrapper -> +-- DB.DbAction m [(Text, Int64)] +-- deleteTablesAfterTxId txOutVariantType 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 txOutVariantType of +-- TxOutVariantCore -> 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 -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)] +-- queryDelete :: +-- forall m record field. +-- (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => +-- EntityField record field -> +-- field -> +-- DB.DbAction m () +-- queryDelete fieldIdField fieldId = do +-- mRecordId <- queryMinRefId fieldIdField fieldId +-- case mRecordId of +-- Nothing -> pure () +-- Just recordId -> deleteWhere [persistIdField @record >=. recordId] -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)] +-- queryDeleteAndLog :: +-- forall m record field. +-- (MonadIO m, PersistEntity record, PersistField field, PersistEntityBackend record ~ SqlBackend) => +-- Text -> +-- EntityField record field -> +-- field -> +-- DB.DbAction 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)] -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 -> +-- DB.DbAction 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 -> DB.DbAction 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 => TxOutVariantType -> SlotNo -> DB.DbAction m Bool +-- deleteBlocksSlotNoNoTrace txOutVariantType slotNo = deleteBlocksSlotNo nullTracer txOutVariantType 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 => TxOutVariantType -> BlockId -> Word64 -> DB.DbAction m () +-- deleteBlocksForTests txOutVariantType blockId epochN = do +-- void $ deleteBlocksBlockId nullTracer txOutVariantType 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 => TxOutVariantType -> Block -> DB.DbAction m Bool +-- deleteBlock txOutVariantType block = do +-- mBlockId <- queryBlockHash block +-- case mBlockId of +-- Nothing -> pure False +-- Just (blockId, epochN) -> do +-- void $ deleteBlocksBlockId nullTracer txOutVariantType 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..ef46547a8 100644 --- a/cardano-db/src/Cardano/Db/Operations/Insert.hs +++ b/cardano-db/src/Cardano/Db/Operations/Insert.hs @@ -5,156 +5,162 @@ {-# 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, (!=.), (=.), (==.), (>.)) -import Database.Persist.Class ( - AtLeastOneUniqueKey, - PersistEntity, - PersistEntityBackend, - SafeToInsert, - checkUnique, - insert, - insertBy, - replaceUnique, - ) -import Database.Persist.EntityDef.Internal (entityDB, entityUniques) -import Database.Persist.Postgresql (upsertWhere) -import Database.Persist.Sql ( - OnlyOneUniqueKey, - PersistRecordBackend, - SqlBackend, - UniqueDef, - entityDef, - insertMany, - rawExecute, - rawSql, - replace, - toPersistFields, - toPersistValue, - uniqueDBName, - uniqueFields, - updateWhereCount, - ) -import qualified Database.Persist.Sql.Util as Util -import Database.Persist.Types ( - ConstraintNameDB (..), - Entity (..), - EntityNameDB (..), - FieldNameDB (..), - PersistValue, - entityKey, - ) -import Database.PostgreSQL.Simple (SqlError) + ) 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, +-- PersistEntityBackend, +-- SafeToInsert, +-- checkUnique, +-- insert, +-- insertBy, +-- replaceUnique, +-- ) +-- import Database.Persist.EntityDef.Internal (entityDB, entityUniques) + +-- -- import Database.Persist.Postgresql (upsertWhere) +-- import Database.Persist.Sql ( +-- OnlyOneUniqueKey, +-- PersistRecordBackend, +-- SqlBackend, +-- UniqueDef, +-- entityDef, +-- insertMany, +-- rawExecute, +-- rawSql, +-- replace, +-- toPersistFields, +-- toPersistValue, +-- uniqueDBName, +-- uniqueFields, +-- updateWhereCount, +-- ) + +-- -- import qualified Database.Persist.Sql.Util as Util +-- import Database.Persist.Types ( +-- ConstraintNameDB (..), +-- Entity (..), +-- EntityNameDB (..), +-- FieldNameDB (..), +-- PersistValue, +-- entityKey, +-- ) + +-- import Database.PostgreSQL.Simple (SqlError) +-- import Hasql.Statement (Statement) -- The original naive way of inserting rows into Postgres was: -- --- insertByReturnKey :: record -> ReaderT SqlBackend m recordId +-- insertByReturnKey :: record -> DB.DbAction m recordId -- res <- getByValue value -- case res of -- Nothing -> insertBy value @@ -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 :: +-- MonadIO m => +-- -- | Does constraint already exists +-- Bool -> +-- ConstraintNameDB -> +-- [EpochStake] -> +-- DB.DbAction m () +-- insertManyEpochStakes = insertManyWithManualUnique "Many EpochStake" + +-- insertManyRewards :: +-- MonadIO m => +-- -- | Does constraint already exists +-- Bool -> +-- ConstraintNameDB -> +-- [Reward] -> +-- DB.DbAction m () +-- insertManyRewards = insertManyWithManualUnique "Many Rewards" + +-- insertManyRewardRests :: +-- MonadIO m => +-- [RewardRest] -> +-- DB.DbAction m () +-- insertManyRewardRests = insertManyUnique "Many Rewards Rest" Nothing + +-- insertManyDrepDistr :: +-- MonadIO m => +-- [DrepDistr] -> +-- DB.DbAction m () +-- insertManyDrepDistr = insertManyCheckUnique "Many DrepDistr" + +-- updateSetComplete :: MonadIO m => Word64 -> DB.DbAction m () +-- updateSetComplete epoch = do +-- upsertWhere (EpochStakeProgress epoch True) [EpochStakeProgressCompleted Database.Persist.=. True] [EpochStakeProgressEpochNo Database.Persist.==. epoch] + +-- replaceAdaPots :: MonadIO m => BlockId -> AdaPots -> DB.DbAction 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] -> +-- DB.DbAction m [Key record] +-- insertMany' vtype records = handle exceptHandler (insertMany records) +-- where +-- exceptHandler :: SqlError -> DB.DbAction 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] -> +-- DB.DbAction 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 -> DB.DbAction 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] -> +-- DB.DbAction 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] -> +-- -- DB.DbAction 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 -> +-- DB.DbAction 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 -> DB.DbAction 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 -> +-- DB.DbAction 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 -> DB.DbAction 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 -> +-- DB.DbAction m (Key record) +-- insertUnchecked vtype = +-- handle exceptHandler . insert +-- where +-- exceptHandler :: MonadIO m => SqlError -> DB.DbAction 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 :: MonadIO m => Block -> DB.DbAction 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..c28753b3d 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, TxOutVariantType (..), 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 => +-- TxOutVariantType -> +-- Maybe TxId -> +-- DB.DbAction m (Text, Int64) +-- querySetNullTxOut txOutVariantType 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 -> DB.DbAction m [TxOutIdW] +-- getTxOutConsumedAfter txId = +-- case txOutVariantType of +-- TxOutVariantCore -> wrapTxOutIds VCTxOutIdW (queryConsumedTxOutIds @'TxOutCore txId) +-- TxOutVariantAddress -> wrapTxOutIds VATxOutIdW (queryConsumedTxOutIds @'TxOutVariantAddress txId) +-- where +-- wrapTxOutIds constructor = fmap (map constructor) + +-- queryConsumedTxOutIds :: +-- forall a m. +-- (TxOutFields a, MonadIO m) => +-- TxId -> +-- DB.DbAction 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 -> DB.DbAction m () +-- setNullTxOutConsumedAfter txOutId = +-- case txOutVariantType of +-- TxOutVariantCore -> setNull +-- TxOutVariantAddress -> setNull +-- where +-- setNull :: +-- MonadIO m => +-- DB.DbAction m () +-- setNull = do +-- case txOutId of +-- VCTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Nothing] +-- VATxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Nothing] + +-- runConsumedTxOutMigrations :: MonadIO m => Trace IO Text -> TxOutVariantType -> Word64 -> PruneConsumeMigration -> DB.DbAction m () +-- runConsumedTxOutMigrations trce txOutVariantType blockNoDiff pcm = do +-- ems <- queryAllExtraMigrations +-- isTxOutNull <- queryTxOutIsNull txOutVariantType +-- let migrationValues = processMigrationValues ems pcm +-- isTxOutVariant = isTxOutVariantAddress txOutVariantType +-- 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 "runConsumedTxOutMigrations: 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 "runConsumedTxOutMigrations: 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 :: MonadIO m => MigrationValues -> DB.DbAction m () +-- handleMigration migrationValues@MigrationValues {..} = do +-- let PruneConsumeMigration {..} = pruneConsumeMigration +-- case (isConsumeTxOutPreviouslySet, pcmConsumedTxOut, pcmPruneTxOut) of +-- -- No Migration Needed +-- (False, False, False) -> do +-- liftIO $ logInfo trce "runConsumedTxOutMigrations: No extra migration specified" +-- -- Already migrated +-- (True, True, False) -> do +-- liftIO $ logInfo trce "runConsumedTxOutMigrations: Extra migration consumed_tx_out already executed" +-- -- Invalid State +-- (True, False, False) -> liftIO $ logAndThrowIO trce "runConsumedTxOutMigrations: consumed-tx-out or prune-tx-out is not set, but consumed migration is found." +-- -- Consume TxOut +-- (False, True, False) -> do +-- liftIO $ logInfo trce "runConsumedTxOutMigrations: Running extra migration consumed_tx_out" +-- insertExtraMigration ConsumeTxOutPreviouslySet +-- migrateTxOut trce txOutVariantType $ Just migrationValues +-- -- Prune TxOut +-- (_, _, True) -> do +-- unless isPruneTxOutPreviouslySet $ insertExtraMigration PruneTxOutFlagPreviouslySet +-- if isConsumeTxOutPreviouslySet +-- then do +-- liftIO $ logInfo trce "runConsumedTxOutMigrations: Running extra migration prune tx_out" +-- deleteConsumedTxOut trce txOutVariantType blockNoDiff +-- else deleteAndUpdateConsumedTxOut trce txOutVariantType migrationValues blockNoDiff + +-- queryWrongConsumedBy :: TxOutVariantType -> MonadIO m => DB.DbAction m Word64 +-- queryWrongConsumedBy = \case +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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 :: TxOutVariantType -> MonadIO m => DB.DbAction m Word64 +-- queryTxOutConsumedNullCount = \case +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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 :: TxOutVariantType -> MonadIO m => DB.DbAction m Word64 +-- queryTxOutConsumedCount = \case +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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 :: TxOutVariantType -> MonadIO m => DB.DbAction m Bool +-- queryTxOutIsNull = \case +-- TxOutVariantCore -> pure False +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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)] -> DB.DbAction m () +-- updateListTxOutConsumedByTxId ls = do +-- mapM_ (uncurry updateTxOutConsumedByTxId) ls +-- where +-- updateTxOutConsumedByTxId :: MonadIO m => TxOutIdW -> TxId -> DB.DbAction m () +-- updateTxOutConsumedByTxId txOutId txId = +-- case txOutId of +-- VCTxOutIdW txOutId' -> update txOutId' [C.TxOutConsumedByTxId =. Just txId] +-- VATxOutIdW txOutId' -> update txOutId' [V.TxOutConsumedByTxId =. Just txId] + +-- migrateTxOut :: +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- Trace IO Text -> +-- TxOutVariantType -> +-- Maybe MigrationValues -> +-- DB.DbAction m () +-- migrateTxOut trce txOutVariantType 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) txOutVariantType 0 + +-- migrateNextPageTxOut :: MonadIO m => Maybe (Trace IO Text) -> TxOutVariantType -> Word64 -> DB.DbAction m () +-- migrateNextPageTxOut mTrce txOutVariantType offst = do +-- whenJust mTrce $ \trce -> +-- liftIO $ logInfo trce $ "migrateNextPageTxOut: Handling input offset " <> textShow offst +-- page <- getInputPage offst pageSize +-- updatePageEntries txOutVariantType page +-- when (fromIntegral (length page) == pageSize) $ +-- migrateNextPageTxOut mTrce txOutVariantType $! +-- (offst + pageSize) + +-- -------------------------------------------------------------------------------------------------- +-- -- Delete + Update +-- -- -------------------------------------------------------------------------------------------------- +-- deleteAndUpdateConsumedTxOut :: +-- forall m. +-- (MonadIO m, MonadBaseControl IO m) => +-- Trace IO Text -> +-- TxOutVariantType -> +-- MigrationValues -> +-- Word64 -> +-- DB.DbAction m () +-- deleteAndUpdateConsumedTxOut trce txOutVariantType 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 txOutVariantType $ Just migrationValues +-- insertExtraMigration ConsumeTxOutPreviouslySet +-- Right mTxId -> do +-- migrateNextPage mTxId False 0 +-- where +-- migrateNextPage :: TxId -> Bool -> Word64 -> DB.DbAction m () +-- migrateNextPage maxTxId ranCreateConsumedTxOut offst = do +-- pageEntries <- getInputPage offst pageSize +-- resPageEntries <- splitAndProcessPageEntries trce txOutVariantType 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 -> +-- TxOutVariantType -> +-- Bool -> +-- TxId -> +-- [ConsumedTriplet] -> +-- DB.DbAction m Bool +-- splitAndProcessPageEntries trce txOutVariantType 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 txOutVariantType xs +-- pure False +-- -- the whole list is greater that maxTxInId +-- ([], ys) -> do +-- shouldCreateConsumedTxOut trce ranCreateConsumedTxOut +-- updatePageEntries txOutVariantType ys +-- pure True +-- -- the list has both bellow and above maxTxInId +-- (xs, ys) -> do +-- deletePageEntries txOutVariantType xs +-- shouldCreateConsumedTxOut trce ranCreateConsumedTxOut +-- updatePageEntries txOutVariantType ys +-- pure True + +-- shouldCreateConsumedTxOut :: +-- (MonadIO m, MonadBaseControl IO m) => +-- Trace IO Text -> +-- Bool -> +-- DB.DbAction m () +-- shouldCreateConsumedTxOut trce rcc = +-- unless rcc $ do +-- liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." +-- createConsumedIndexTxOut + +-- -- | Update +-- updatePageEntries :: +-- MonadIO m => +-- TxOutVariantType -> +-- [ConsumedTriplet] -> +-- DB.DbAction m () +-- updatePageEntries txOutVariantType = mapM_ (updateTxOutConsumedByTxIdUnique txOutVariantType) + +-- updateTxOutConsumedByTxIdUnique :: MonadIO m => TxOutVariantType -> ConsumedTriplet -> DB.DbAction m () +-- updateTxOutConsumedByTxIdUnique txOutVariantType ConsumedTriplet {ctTxOutTxId, ctTxOutIndex, ctTxInTxId} = +-- case txOutVariantType of +-- TxOutVariantCore -> 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 => +-- TxOutVariantType -> +-- [ConsumedTriplet] -> +-- DB.DbAction m () +-- deletePageEntries txOutVariantType = mapM_ (\ConsumedTriplet {ctTxOutTxId, ctTxOutIndex} -> deleteTxOutConsumed txOutVariantType ctTxOutTxId ctTxOutIndex) + +-- deleteTxOutConsumed :: MonadIO m => TxOutVariantType -> TxId -> Word64 -> DB.DbAction m () +-- deleteTxOutConsumed txOutVariantType txOutId index = case txOutVariantType of +-- TxOutVariantCore -> 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 +-- ) => +-- DB.DbAction 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 -> DB.DbAction m a +-- exceptHandler e = +-- liftIO $ throwIO (DBPruneConsumed $ show e) + +-- createPruneConstraintTxOut :: +-- forall m. +-- ( MonadBaseControl IO m +-- , MonadIO m +-- ) => +-- DB.DbAction 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 -> DB.DbAction 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 -> +-- DB.DbAction 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 -> DB.DbAction m a +-- exceptHandler e = +-- liftIO $ throwIO (DBPruneConsumed $ show e) + +-- -------------------------------------------------------------------------------------------------- +-- -- Delete +-- -------------------------------------------------------------------------------------------------- +-- deleteConsumedTxOut :: +-- forall m. +-- MonadIO m => +-- Trace IO Text -> +-- TxOutVariantType -> +-- Word64 -> +-- DB.DbAction m () +-- deleteConsumedTxOut trce txOutVariantType blockNoDiff = do +-- maxTxInId <- findMaxTxInId blockNoDiff +-- case maxTxInId of +-- Left errMsg -> liftIO $ logInfo trce $ "No tx_out was deleted: " <> errMsg +-- Right mxtid -> deleteConsumedBeforeTx trce txOutVariantType mxtid + +-- deleteConsumedBeforeTx :: MonadIO m => Trace IO Text -> TxOutVariantType -> TxId -> DB.DbAction m () +-- deleteConsumedBeforeTx trce txOutVariantType txId = do +-- countDeleted <- case txOutVariantType of +-- TxOutVariantCore -> 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) => TxOutVariantType -> DB.DbAction m () +-- migrateTxOutDbTool txOutVariantType = do +-- _ <- createConsumedIndexTxOut +-- migrateNextPageTxOut Nothing txOutVariantType 0 + +-- findMaxTxInId :: forall m. MonadIO m => Word64 -> DB.DbAction m (Either Text TxId) +-- findMaxTxInId blockNoDiff = do +-- mBlockHeight <- queryBlockHeight +-- maybe (pure $ Left "No blocks found") findConsumed mBlockHeight +-- where +-- findConsumed :: Word64 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 => DB.DbAction m Word64 +-- countTxIn = do +-- res <- select $ do +-- _ <- from $ table @TxIn +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- countConsumed :: +-- MonadIO m => +-- TxOutVariantType -> +-- DB.DbAction m Word64 +-- countConsumed = \case +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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..311e5d635 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) +-- import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..), TxOutVariantType (..)) +-- 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 :: TxOutVariantType) = 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 :: TxOutVariantType -> Text -> Maybe MinIdsWrapper +-- textToMinIds txOutVariantType txt = +-- case txOutVariantType of +-- TxOutVariantCore -> 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 +-- completeMinId :: +-- (MonadIO m) => +-- Maybe TxId -> +-- MinIdsWrapper -> +-- DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> +-- DB.DbAction 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..5be57d0a7 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, +-- queryBlocksForCurrentEpochNo, +-- queryNormalEpochRewardCount, +-- queryGenesis, +-- queryLatestBlock, +-- queryLatestPoints, +-- queryLatestEpochNoFromBlock, +-- 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,1035 +178,1027 @@ 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 => DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 - --- | Count the number of epochs in Epoch table. -queryEpochCount :: MonadIO m => ReaderT SqlBackend m Word -queryEpochCount = do - res <- select $ from (table @Epoch) >> pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryTxWithBlocks :: - MonadIO m => - Word64 -> - [(Value Word64, Value (Maybe UTCTime), Value (Maybe UTCTime))] -> - ReaderT SqlBackend m Epoch -queryTxWithBlocks epochNum blockResult = do - txRes <- select $ do - (tx :& blk) <- - from - $ table @Tx - `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (blk ^. BlockEpochNo ==. just (val epochNum)) - pure (sum_ (tx ^. TxOutSum), sum_ (tx ^. TxFee), count (tx ^. TxOutSum)) - case (listToMaybe blockResult, listToMaybe txRes) of - (Just blk, Just tx) -> pure $ parseAndCalulateNewEpoch epochNum (unValue3 blk) (unValue3 tx) - (Just blk, Nothing) -> pure $ convertBlk epochNum (unValue3 blk) - _otherwise -> pure $ emptyEpoch epochNum - -parseAndCalulateNewEpoch :: - Word64 -> - (Word64, Maybe UTCTime, Maybe UTCTime) -> - (Maybe Rational, Maybe Rational, Word64) -> - Epoch -parseAndCalulateNewEpoch epochNum (blkCount, minBlockTime, maxBlockTime) (sumTxOut, sumTxFee, txCount) = - case (minBlockTime, maxBlockTime, sumTxOut, sumTxFee) of - (Just start, Just end, Just outSum, Just fees) -> - Epoch - (fromIntegral $ numerator outSum) - (DbLovelace . fromIntegral $ numerator fees) - txCount - blkCount - epochNum - start - end - (Just start, Just end, Nothing, Nothing) -> - Epoch 0 (DbLovelace 0) txCount blkCount epochNum start end - _otherwise -> - emptyEpoch epochNum - -convertBlk :: Word64 -> (Word64, Maybe UTCTime, Maybe UTCTime) -> Epoch -convertBlk epochNum (blkCount, b, c) = - case (b, c) of - (Just start, Just end) -> Epoch 0 (DbLovelace 0) 0 blkCount epochNum start end - _otherwise -> emptyEpoch epochNum - --- We only return this when something has screwed up. -emptyEpoch :: Word64 -> Epoch -emptyEpoch epochNum = - Epoch - { epochOutSum = 0 - , epochFees = DbLovelace 0 - , epochTxCount = 0 - , epochBlkCount = 0 - , epochNo = epochNum - , epochStartTime = defaultUTCTime - , epochEndTime = defaultUTCTime - } - -queryCurrentEpochNo :: MonadIO m => ReaderT SqlBackend m (Maybe Word64) -queryCurrentEpochNo = do - res <- select $ do - blk <- from $ table @Block - pure $ max_ (blk ^. BlockEpochNo) - pure $ join (unValue =<< listToMaybe res) - -queryNormalEpochRewardCount :: - MonadIO m => - Word64 -> - ReaderT SqlBackend m Word64 -queryNormalEpochRewardCount epochNum = do - res <- select $ do - rwd <- from $ table @Reward - where_ (rwd ^. RewardSpendableEpoch ==. val epochNum) - where_ (rwd ^. RewardType `in_` valList [RwdMember, RwdLeader]) - 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 - --- | Get the latest block. -queryLatestBlock :: MonadIO m => ReaderT SqlBackend m (Maybe Block) -queryLatestBlock = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockSlotNo) - orderBy [desc (blk ^. BlockSlotNo)] - limit 1 - pure blk - pure $ fmap entityVal (listToMaybe res) - -queryLatestPoints :: MonadIO m => ReaderT SqlBackend m [(Maybe Word64, ByteString)] -queryLatestPoints = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockSlotNo) - orderBy [desc (blk ^. BlockSlotNo)] - limit 5 - pure (blk ^. BlockSlotNo, blk ^. BlockHash) - pure $ fmap unValue2 res - -queryLatestEpochNo :: MonadIO m => ReaderT SqlBackend m Word64 -queryLatestEpochNo = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockSlotNo) - orderBy [desc (blk ^. BlockEpochNo)] - limit 1 - pure (blk ^. BlockEpochNo) - pure $ fromMaybe 0 (unValue =<< listToMaybe res) - --- | Get 'BlockId' of the latest block. -queryLatestBlockId :: MonadIO m => ReaderT SqlBackend m (Maybe BlockId) -queryLatestBlockId = do - res <- select $ do - blk <- from $ table @Block - orderBy [desc (blk ^. BlockSlotNo)] - limit 1 - pure (blk ^. BlockId) - pure $ fmap unValue (listToMaybe res) +-- queryNearestBlockSlotNo :: MonadIO m => Word64 -> DB.DbAction 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 -> DB.DbAction 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 => DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 -> DB.DbAction 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 => DB.DbAction 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 => DB.DbAction m Word +-- queryEpochCount = do +-- res <- select $ from (table @Epoch) >> pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryTxWithBlocks :: +-- MonadIO m => +-- Word64 -> +-- [(Value Word64, Value (Maybe UTCTime), Value (Maybe UTCTime))] -> +-- DB.DbAction m Epoch +-- queryTxWithBlocks epochNum blockResult = do +-- txRes <- select $ do +-- (tx :& blk) <- +-- from +-- $ table @Tx +-- `innerJoin` table @Block +-- `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (blk ^. BlockEpochNo ==. just (val epochNum)) +-- pure (sum_ (tx ^. TxOutSum), sum_ (tx ^. TxFee), count (tx ^. TxOutSum)) +-- case (listToMaybe blockResult, listToMaybe txRes) of +-- (Just blk, Just tx) -> pure $ parseAndCalulateNewEpoch epochNum (unValue3 blk) (unValue3 tx) +-- (Just blk, Nothing) -> pure $ convertBlk epochNum (unValue3 blk) +-- _otherwise -> pure $ emptyEpoch epochNum + +-- parseAndCalulateNewEpoch :: +-- Word64 -> +-- (Word64, Maybe UTCTime, Maybe UTCTime) -> +-- (Maybe Rational, Maybe Rational, Word64) -> +-- Epoch +-- parseAndCalulateNewEpoch epochNum (blkCount, minBlockTime, maxBlockTime) (sumTxOut, sumTxFee, txCount) = +-- case (minBlockTime, maxBlockTime, sumTxOut, sumTxFee) of +-- (Just start, Just end, Just outSum, Just fees) -> +-- Epoch +-- (fromIntegral $ numerator outSum) +-- (DbLovelace . fromIntegral $ numerator fees) +-- txCount +-- blkCount +-- epochNum +-- start +-- end +-- (Just start, Just end, Nothing, Nothing) -> +-- Epoch 0 (DbLovelace 0) txCount blkCount epochNum start end +-- _otherwise -> +-- emptyEpoch epochNum + +-- convertBlk :: Word64 -> (Word64, Maybe UTCTime, Maybe UTCTime) -> Epoch +-- convertBlk epochNum (blkCount, b, c) = +-- case (b, c) of +-- (Just start, Just end) -> Epoch 0 (DbLovelace 0) 0 blkCount epochNum start end +-- _otherwise -> emptyEpoch epochNum + +-- -- We only return this when something has screwed up. +-- emptyEpoch :: Word64 -> Epoch +-- emptyEpoch epochNum = +-- Epoch +-- { epochOutSum = 0 +-- , epochFees = DbLovelace 0 +-- , epochTxCount = 0 +-- , epochBlkCount = 0 +-- , epochNo = epochNum +-- , epochStartTime = defaultUTCTime +-- , epochEndTime = defaultUTCTime +-- } + +-- queryBlocksForCurrentEpochNo :: MonadIO m => DB.DbAction m (Maybe Word64) +-- queryBlocksForCurrentEpochNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- pure $ max_ (blk ^. BlockEpochNo) +-- pure $ join (unValue =<< listToMaybe res) + +-- queryNormalEpochRewardCount :: +-- MonadIO m => +-- Word64 -> +-- DB.DbAction m Word64 +-- queryNormalEpochRewardCount epochNum = do +-- res <- select $ do +-- rwd <- from $ table @Reward +-- where_ (rwd ^. RewardSpendableEpoch ==. val epochNum) +-- where_ (rwd ^. RewardType `in_` valList [RwdMember, RwdLeader]) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryGenesis :: MonadIO m => DB.DbAction 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 => DB.DbAction m (Maybe Block) +-- queryLatestBlock = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockSlotNo) +-- orderBy [desc (blk ^. BlockSlotNo)] +-- limit 1 +-- pure blk +-- pure $ fmap entityVal (listToMaybe res) + +-- queryLatestPoints :: MonadIO m => DB.DbAction m [(Maybe Word64, ByteString)] +-- queryLatestPoints = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockSlotNo) +-- orderBy [desc (blk ^. BlockSlotNo)] +-- limit 5 +-- pure (blk ^. BlockSlotNo, blk ^. BlockHash) +-- pure $ fmap unValue2 res + +-- queryLatestEpochNoFromBlock :: MonadIO m => DB.DbAction m Word64 +-- queryLatestEpochNoFromBlock = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockSlotNo) +-- orderBy [desc (blk ^. BlockEpochNo)] +-- limit 1 +-- pure (blk ^. BlockEpochNo) +-- pure $ fromMaybe 0 (unValue =<< listToMaybe res) + +-- -- | Get 'BlockId' of the latest block. +-- queryLatestBlockId :: MonadIO m => DB.DbAction m (Maybe BlockId) +-- queryLatestBlockId = do +-- res <- select $ do +-- blk <- from $ table @Block +-- orderBy [desc (blk ^. BlockSlotNo)] +-- limit 1 +-- pure (blk ^. BlockId) +-- pure $ fmap unValue (listToMaybe res) -- | Get the latest slot number -queryLatestSlotNo :: MonadIO m => ReaderT SqlBackend m Word64 -queryLatestSlotNo = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockSlotNo) - orderBy [desc (blk ^. BlockSlotNo)] - limit 1 - pure $ blk ^. BlockSlotNo - pure $ fromMaybe 0 (unValue =<< listToMaybe res) - -{-# 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 - -queryScript :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe ScriptId) -queryScript hsh = do - xs <- select $ do - script <- from $ table @Script - where_ (script ^. ScriptHash ==. val hsh) - pure (script ^. ScriptId) - pure $ unValue <$> listToMaybe xs - -queryDatum :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe DatumId) -queryDatum hsh = do - xs <- select $ do - datum <- from $ table @Datum - where_ (datum ^. DatumHash ==. val hsh) - pure (datum ^. DatumId) - pure $ unValue <$> listToMaybe xs - -queryRedeemerData :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe RedeemerDataId) -queryRedeemerData hsh = do - xs <- select $ do - rdmrDt <- from $ table @RedeemerData - where_ (rdmrDt ^. RedeemerDataHash ==. val hsh) - pure (rdmrDt ^. RedeemerDataId) - pure $ unValue <$> listToMaybe xs - -querySlotHash :: MonadIO m => SlotNo -> ReaderT SqlBackend m [(SlotNo, ByteString)] -querySlotHash slotNo = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockSlotNo ==. just (val $ unSlotNo slotNo)) - pure (blk ^. BlockHash) - pure $ (\vh -> (slotNo, unValue vh)) <$> res - -queryMultiAssetId :: MonadIO m => ByteString -> ByteString -> ReaderT SqlBackend m (Maybe MultiAssetId) -queryMultiAssetId policy assetName = do - res <- select $ do - ma <- from $ table @MultiAsset - where_ (ma ^. MultiAssetPolicy ==. val policy &&. ma ^. MultiAssetName ==. val assetName) - pure (ma ^. MultiAssetId) - pure $ unValue <$> listToMaybe res - -queryCountSlotNosGreaterThan :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 -queryCountSlotNosGreaterThan slotNo = do - res <- select $ do - blk <- from $ table @Block - where_ (blk ^. BlockSlotNo >. just (val slotNo)) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --- | Like 'queryCountSlotNosGreaterThan', but returns all slots in the same order. -queryCountSlotNo :: MonadIO m => ReaderT SqlBackend m Word64 -queryCountSlotNo = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockSlotNo) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - --- | Count the number of transactions in the Tx table. -queryTxCount :: MonadIO m => ReaderT SqlBackend m Word -queryTxCount = do - res <- select $ do - _ <- from $ table @Tx - pure countRows - pure $ maybe 0 unValue (listToMaybe res) +-- queryLatestSlotNo :: MonadIO m => DB.DbAction m Word64 +-- queryLatestSlotNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockSlotNo) +-- orderBy [desc (blk ^. BlockSlotNo)] +-- limit 1 +-- pure $ blk ^. BlockSlotNo +-- pure $ fromMaybe 0 (unValue =<< listToMaybe res) + +-- {-# INLINEABLE queryMeta #-} + +-- -- | Get the network metadata. +-- queryMeta :: MonadIO m => DB.DbAction m (Either LookupFail Meta) +-- queryMeta = do +-- res <- select . from $ table @Meta +-- pure $ case res of +-- [] -> Left DbMetaEmpty +-- [m] -> Right $ entityVal m +-- _ -> Left DbMetaMultipleRows + +-- queryScriptWithId :: MonadIO m => ByteString -> DB.DbAction m (Maybe ScriptId) +-- queryScriptWithId hsh = do +-- xs <- select $ do +-- script <- from $ table @Script +-- where_ (script ^. ScriptHash ==. val hsh) +-- pure (script ^. ScriptId) +-- pure $ unValue <$> listToMaybe xs + +-- queryDatum :: MonadIO m => ByteString -> DB.DbAction m (Maybe DatumId) +-- queryDatum hsh = do +-- xs <- select $ do +-- datum <- from $ table @Datum +-- where_ (datum ^. DatumHash ==. val hsh) +-- pure (datum ^. DatumId) +-- pure $ unValue <$> listToMaybe xs + +-- queryRedeemerData :: MonadIO m => ByteString -> DB.DbAction m (Maybe RedeemerDataId) +-- queryRedeemerData hsh = do +-- xs <- select $ do +-- rdmrDt <- from $ table @RedeemerData +-- where_ (rdmrDt ^. RedeemerDataHash ==. val hsh) +-- pure (rdmrDt ^. RedeemerDataId) +-- pure $ unValue <$> listToMaybe xs + +-- querySlotHash :: MonadIO m => SlotNo -> DB.DbAction m [(SlotNo, ByteString)] +-- querySlotHash slotNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockSlotNo ==. just (val $ unSlotNo slotNo)) +-- pure (blk ^. BlockHash) +-- pure $ (\vh -> (slotNo, unValue vh)) <$> res + +-- queryMultiAssetId :: MonadIO m => ByteString -> ByteString -> DB.DbAction m (Maybe MultiAssetId) +-- queryMultiAssetId policy assetName = do +-- res <- select $ do +-- ma <- from $ table @MultiAsset +-- where_ (ma ^. MultiAssetPolicy ==. val policy &&. ma ^. MultiAssetName ==. val assetName) +-- pure (ma ^. MultiAssetId) +-- pure $ unValue <$> listToMaybe res + +-- queryCountSlotNosGreaterThan :: MonadIO m => Word64 -> DB.DbAction m Word64 +-- queryCountSlotNosGreaterThan slotNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockSlotNo >. just (val slotNo)) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- -- | Like 'queryCountSlotNosGreaterThan', but returns all slots in the same order. +-- queryCountSlotNo :: MonadIO m => DB.DbAction m Word64 +-- queryCountSlotNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockSlotNo) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- -- | Count the number of transactions in the Tx table. +-- queryTxCount :: MonadIO m => DB.DbAction m Word +-- queryTxCount = do +-- res <- select $ do +-- _ <- from $ table @Tx +-- pure countRows +-- 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) - -queryEpochStakeCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 -queryEpochStakeCount epoch = do - res <- select $ do - epochStake <- from $ table @EpochStake - where_ (epochStake ^. EpochStakeEpochNo ==. val epoch) - pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryMinRefId :: - forall m field record. - (MonadIO m, PersistEntity record, PersistField field) => - EntityField record field -> - field -> - ReaderT SqlBackend m (Maybe (Key record)) -queryMinRefId txIdField txId = do - res <- select $ do - rec <- from $ table @record - where_ (rec ^. txIdField >=. val txId) - orderBy [asc (rec ^. persistIdField)] - limit 1 - pure $ rec ^. persistIdField - pure $ unValue <$> listToMaybe res - -queryMinRefIdNullable :: - forall m field record. - (MonadIO m, PersistEntity record, PersistField field) => - EntityField record (Maybe field) -> - field -> - ReaderT SqlBackend m (Maybe (Key record)) -queryMinRefIdNullable txIdField txId = do - res <- select $ do - rec <- from $ table @record - where_ (isJust (rec ^. txIdField)) - where_ (rec ^. txIdField >=. just (val txId)) - orderBy [asc (rec ^. persistIdField)] - limit 1 - pure $ rec ^. persistIdField - pure $ unValue <$> listToMaybe res - -queryMaxRefId :: - forall m field record. - (MonadIO m, PersistEntity record, PersistField field) => - EntityField record field -> - field -> - Bool -> - ReaderT SqlBackend m (Maybe (Key record)) -queryMaxRefId txIdField txId eq = do - res <- select $ do - rec <- from $ table @record - if eq - then where_ (rec ^. txIdField <=. val txId) - else where_ (rec ^. txIdField <. val txId) - orderBy [desc (rec ^. persistIdField)] - limit 1 - pure $ rec ^. persistIdField - pure $ unValue <$> listToMaybe res - -existsPoolHashId :: MonadIO m => PoolHashId -> ReaderT SqlBackend m Bool -existsPoolHashId phid = do - res <- select $ do - poolHash <- from $ table @PoolHash - where_ (poolHash ^. PoolHashId ==. val phid) - limit 1 - pure (poolHash ^. PoolHashId) - pure $ not (null res) - --- db-sync -existsPoolMetadataRefId :: MonadIO m => PoolMetadataRefId -> ReaderT SqlBackend m Bool -existsPoolMetadataRefId pmrid = do - res <- select $ do - pmr <- from $ table @PoolMetadataRef - where_ (pmr ^. PoolMetadataRefId ==. val pmrid) - limit 1 - pure (pmr ^. PoolMetadataRefId) - pure $ not (null res) - -existsVotingAnchorId :: MonadIO m => VotingAnchorId -> ReaderT SqlBackend m Bool -existsVotingAnchorId vaId = do - res <- select $ do - votingAnchor <- from $ table @VotingAnchor - where_ (votingAnchor ^. VotingAnchorId ==. val vaId) - limit 1 - 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 +-- queryTxId :: MonadIO m => ByteString -> DB.DbAction 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 -> DB.DbAction m Word64 +-- queryEpochStakeCount epoch = do +-- res <- select $ do +-- epochStake <- from $ table @EpochStake +-- where_ (epochStake ^. EpochStakeEpochNo ==. val epoch) +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryMinRefId :: +-- forall m field record. +-- (MonadIO m, PersistEntity record, PersistField field) => +-- EntityField record field -> +-- field -> +-- DB.DbAction m (Maybe (Key record)) +-- queryMinRefId txIdField txId = do +-- res <- select $ do +-- rec <- from $ table @record +-- where_ (rec ^. txIdField >=. val txId) +-- orderBy [asc (rec ^. persistIdField)] +-- limit 1 +-- pure $ rec ^. persistIdField +-- pure $ unValue <$> listToMaybe res + +-- queryMinRefIdNullable :: +-- forall m field record. +-- (MonadIO m, PersistEntity record, PersistField field) => +-- EntityField record (Maybe field) -> +-- field -> +-- DB.DbAction m (Maybe (Key record)) +-- queryMinRefIdNullable txIdField txId = do +-- res <- select $ do +-- rec <- from $ table @record +-- where_ (isJust (rec ^. txIdField)) +-- where_ (rec ^. txIdField >=. just (val txId)) +-- orderBy [asc (rec ^. persistIdField)] +-- limit 1 +-- pure $ rec ^. persistIdField +-- pure $ unValue <$> listToMaybe res + +-- queryMaxRefId :: +-- forall m field record. +-- (MonadIO m, PersistEntity record, PersistField field) => +-- EntityField record field -> +-- field -> +-- Bool -> +-- DB.DbAction m (Maybe (Key record)) +-- queryMaxRefId txIdField txId eq = do +-- res <- select $ do +-- rec <- from $ table @record +-- if eq +-- then where_ (rec ^. txIdField <=. val txId) +-- else where_ (rec ^. txIdField <. val txId) +-- orderBy [desc (rec ^. persistIdField)] +-- limit 1 +-- pure $ rec ^. persistIdField +-- pure $ unValue <$> listToMaybe res + +-- existsPoolHashId :: MonadIO m => PoolHashId -> DB.DbAction m Bool +-- existsPoolHashId phid = do +-- res <- select $ do +-- poolHash <- from $ table @PoolHash +-- where_ (poolHash ^. PoolHashId ==. val phid) +-- limit 1 +-- pure (poolHash ^. PoolHashId) +-- pure $ not (null res) + +-- -- db-sync +-- existsPoolMetadataRefId :: MonadIO m => PoolMetadataRefId -> DB.DbAction m Bool +-- existsPoolMetadataRefId pmrid = do +-- res <- select $ do +-- pmr <- from $ table @PoolMetadataRef +-- where_ (pmr ^. PoolMetadataRefId ==. val pmrid) +-- limit 1 +-- pure (pmr ^. PoolMetadataRefId) +-- pure $ not (null res) + +-- existsVotingAnchorId :: MonadIO m => VotingAnchorId -> DB.DbAction m Bool +-- existsVotingAnchorId vaId = do +-- res <- select $ do +-- votingAnchor <- from $ table @VotingAnchor +-- where_ (votingAnchor ^. VotingAnchorId ==. val vaId) +-- limit 1 +-- pure (votingAnchor ^. VotingAnchorId) +-- pure $ not (null res) -- | Get the current block height. -queryBlockHeight :: MonadIO m => ReaderT SqlBackend m (Maybe Word64) -queryBlockHeight = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockBlockNo) - orderBy [desc (blk ^. BlockBlockNo)] - limit 1 - pure (blk ^. BlockBlockNo) - pure $ unValue =<< listToMaybe res - -queryAllExtraMigrations :: MonadIO m => ReaderT SqlBackend m [ExtraMigration] -queryAllExtraMigrations = do - res <- select $ do - ems <- from $ table @ExtraMigrations - pure (ems ^. ExtraMigrationsToken) - pure $ read . unpack . unValue <$> res - -queryMinMaxEpochStake :: MonadIO m => ReaderT SqlBackend m (Maybe Word64, Maybe Word64) -queryMinMaxEpochStake = do - maxEpoch <- select $ do - es <- from $ table @EpochStake - orderBy [desc (es ^. EpochStakeId)] - limit 1 - pure (es ^. EpochStakeEpochNo) - minEpoch <- select $ do - es <- from $ table @EpochStake - orderBy [asc (es ^. EpochStakeId)] - limit 1 - 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) - -queryDrepHashAlwaysAbstain :: MonadIO m => ReaderT SqlBackend m (Maybe DrepHashId) -queryDrepHashAlwaysAbstain = do - res <- select $ do - dh <- from $ table @DrepHash - where_ (isNothing (dh ^. DrepHashRaw)) - where_ (dh ^. DrepHashView ==. val hardcodedAlwaysAbstain) - pure $ dh ^. DrepHashId - pure $ unValue <$> listToMaybe res - -queryDrepHashAlwaysNoConfidence :: MonadIO m => ReaderT SqlBackend m (Maybe DrepHashId) -queryDrepHashAlwaysNoConfidence = do - res <- select $ do - dh <- from $ table @DrepHash - where_ (isNothing (dh ^. DrepHashRaw)) - where_ (dh ^. DrepHashView ==. val hardcodedAlwaysNoConfidence) - pure $ dh ^. DrepHashId - pure $ unValue <$> listToMaybe res - -queryCommitteeHash :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe CommitteeHashId) -queryCommitteeHash hash = do - res <- select $ do - ch <- from $ table @CommitteeHash - where_ (ch ^. CommitteeHashRaw ==. val hash) - pure $ ch ^. CommitteeHashId - pure $ unValue <$> listToMaybe res - -queryProposalConstitution :: MonadIO m => Maybe GovActionProposalId -> ReaderT SqlBackend m [ConstitutionId] -queryProposalConstitution mgapId = do - res <- select $ do - c <- from $ table @Constitution - where_ (bl c) - pure $ c ^. ConstitutionId - pure $ unValue <$> res - where - bl c = case mgapId of - Nothing -> isNothing (c ^. ConstitutionGovActionProposalId) - Just vl -> c ^. ConstitutionGovActionProposalId ==. val (Just vl) - -queryProposalCommittee :: MonadIO m => Maybe GovActionProposalId -> ReaderT SqlBackend m [CommitteeId] -queryProposalCommittee mgapId = do - res <- select $ do - c <- from $ table @Committee - where_ (bl c) - pure $ c ^. CommitteeId - pure $ unValue <$> res - where - bl c = case mgapId of - Nothing -> isNothing (c ^. CommitteeGovActionProposalId) - Just vl -> c ^. CommitteeGovActionProposalId ==. val (Just vl) - -queryPoolHashId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe PoolHashId) -queryPoolHashId hash = do - res <- select $ do - phash <- from $ table @PoolHash - where_ (phash ^. PoolHashHashRaw ==. val hash) - 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) - -queryStakeRefPtr :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddressId) -queryStakeRefPtr (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do - res <- select $ do - (blk :& tx :& sr) <- - from - $ table @Block - `innerJoin` table @Tx - `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) - `innerJoin` table @StakeRegistration - `on` (\(_blk :& tx :& sr) -> sr ^. StakeRegistrationTxId ==. tx ^. TxId) - - where_ (blk ^. BlockSlotNo ==. just (val slot)) - where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx)) - where_ (sr ^. StakeRegistrationCertIndex ==. val (fromIntegral certIx)) - -- Need to order by DelegationSlotNo descending for correct behavior when there are two - -- or more delegation certificates in a single epoch. - orderBy [desc (blk ^. BlockSlotNo)] - limit 1 - pure (sr ^. StakeRegistrationAddrId) - pure $ unValue <$> listToMaybe res +-- queryBlockHeight :: MonadIO m => DB.DbAction m (Maybe Word64) +-- queryBlockHeight = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockBlockNo) +-- orderBy [desc (blk ^. BlockBlockNo)] +-- limit 1 +-- pure (blk ^. BlockBlockNo) +-- pure $ unValue =<< listToMaybe res + +-- queryAllExtraMigrations :: MonadIO m => DB.DbAction m [ExtraMigration] +-- queryAllExtraMigrations = do +-- res <- select $ do +-- ems <- from $ table @ExtraMigrations +-- pure (ems ^. ExtraMigrationsToken) +-- pure $ read . unpack . unValue <$> res + +-- queryMinMaxEpochStake :: MonadIO m => DB.DbAction m (Maybe Word64, Maybe Word64) +-- queryMinMaxEpochStake = do +-- maxEpoch <- select $ do +-- es <- from $ table @EpochStake +-- orderBy [desc (es ^. EpochStakeId)] +-- limit 1 +-- pure (es ^. EpochStakeEpochNo) +-- minEpoch <- select $ do +-- es <- from $ table @EpochStake +-- orderBy [asc (es ^. EpochStakeId)] +-- limit 1 +-- pure (es ^. EpochStakeEpochNo) +-- pure (unValue <$> listToMaybe minEpoch, unValue <$> listToMaybe maxEpoch) + +-- queryGovActionProposalId :: MonadIO m => TxId -> Word64 -> DB.DbAction 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 => DB.DbAction m (Maybe DrepHashId) +-- queryDrepHashAlwaysAbstain = do +-- res <- select $ do +-- dh <- from $ table @DrepHash +-- where_ (isNothing (dh ^. DrepHashRaw)) +-- where_ (dh ^. DrepHashView ==. val hardcodedAlwaysAbstain) +-- pure $ dh ^. DrepHashId +-- pure $ unValue <$> listToMaybe res + +-- queryDrepHashAlwaysNoConfidence :: MonadIO m => DB.DbAction m (Maybe DrepHashId) +-- queryDrepHashAlwaysNoConfidence = do +-- res <- select $ do +-- dh <- from $ table @DrepHash +-- where_ (isNothing (dh ^. DrepHashRaw)) +-- where_ (dh ^. DrepHashView ==. val hardcodedAlwaysNoConfidence) +-- pure $ dh ^. DrepHashId +-- pure $ unValue <$> listToMaybe res + +-- queryCommitteeHash :: MonadIO m => ByteString -> DB.DbAction m (Maybe CommitteeHashId) +-- queryCommitteeHash hash = do +-- res <- select $ do +-- ch <- from $ table @CommitteeHash +-- where_ (ch ^. CommitteeHashRaw ==. val hash) +-- pure $ ch ^. CommitteeHashId +-- pure $ unValue <$> listToMaybe res + +-- queryProposalConstitution :: MonadIO m => Maybe GovActionProposalId -> DB.DbAction m [ConstitutionId] +-- queryProposalConstitution mgapId = do +-- res <- select $ do +-- c <- from $ table @Constitution +-- where_ (bl c) +-- pure $ c ^. ConstitutionId +-- pure $ unValue <$> res +-- where +-- bl c = case mgapId of +-- Nothing -> isNothing (c ^. ConstitutionGovActionProposalId) +-- Just vl -> c ^. ConstitutionGovActionProposalId ==. val (Just vl) + +-- queryProposalCommittee :: MonadIO m => Maybe GovActionProposalId -> DB.DbAction m [CommitteeId] +-- queryProposalCommittee mgapId = do +-- res <- select $ do +-- c <- from $ table @Committee +-- where_ (bl c) +-- pure $ c ^. CommitteeId +-- pure $ unValue <$> res +-- where +-- bl c = case mgapId of +-- Nothing -> isNothing (c ^. CommitteeGovActionProposalId) +-- Just vl -> c ^. CommitteeGovActionProposalId ==. val (Just vl) + +-- queryPoolHashId :: MonadIO m => ByteString -> DB.DbAction m (Maybe PoolHashId) +-- queryPoolHashId hash = do +-- res <- select $ do +-- phash <- from $ table @PoolHash +-- where_ (phash ^. PoolHashHashRaw ==. val hash) +-- pure (phash ^. PoolHashId) +-- pure $ unValue <$> listToMaybe res + +-- queryStakeAddress :: +-- MonadIO m => +-- ByteString -> +-- (ByteString -> Text) -> +-- DB.DbAction 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 -> DB.DbAction m (Maybe StakeAddressId) +-- queryStakeRefPtr (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do +-- res <- select $ do +-- (blk :& tx :& sr) <- +-- from +-- $ table @Block +-- `innerJoin` table @Tx +-- `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) +-- `innerJoin` table @StakeRegistration +-- `on` (\(_blk :& tx :& sr) -> sr ^. StakeRegistrationTxId ==. tx ^. TxId) + +-- where_ (blk ^. BlockSlotNo ==. just (val slot)) +-- where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx)) +-- where_ (sr ^. StakeRegistrationCertIndex ==. val (fromIntegral certIx)) +-- -- Need to order by DelegationSlotNo descending for correct behavior when there are two +-- -- or more delegation certificates in a single epoch. +-- orderBy [desc (blk ^. BlockSlotNo)] +-- limit 1 +-- pure (sr ^. StakeRegistrationAddrId) +-- pure $ unValue <$> listToMaybe res -- Check if there are other PoolUpdates in the same blocks for the same pool -queryPoolUpdateByBlock :: MonadIO m => BlockId -> PoolHashId -> ReaderT SqlBackend m Bool -queryPoolUpdateByBlock blkId poolHashId = do - res <- select $ do - (blk :& _tx :& poolUpdate) <- - from - $ table @Block - `innerJoin` table @Tx - `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) - `innerJoin` table @PoolUpdate - `on` (\(_blk :& tx :& poolUpdate) -> tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId) - where_ (poolUpdate ^. PoolUpdateHashId ==. val poolHashId) - where_ (blk ^. BlockId ==. val blkId) - limit 1 - pure (blk ^. BlockEpochNo) - pure $ not (null res) +-- queryPoolUpdateByBlock :: MonadIO m => BlockId -> PoolHashId -> DB.DbAction m Bool +-- queryPoolUpdateByBlock blkId poolHashId = do +-- res <- select $ do +-- (blk :& _tx :& poolUpdate) <- +-- from +-- $ table @Block +-- `innerJoin` table @Tx +-- `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) +-- `innerJoin` table @PoolUpdate +-- `on` (\(_blk :& tx :& poolUpdate) -> tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId) +-- where_ (poolUpdate ^. PoolUpdateHashId ==. val poolHashId) +-- where_ (blk ^. BlockId ==. val blkId) +-- limit 1 +-- pure (blk ^. BlockEpochNo) +-- pure $ not (null res) {-------------------------------------------- Queries use in SMASH ----------------------------------------------} -queryOffChainPoolData :: MonadIO m => ByteString -> ByteString -> ReaderT SqlBackend m (Maybe (Text, ByteString)) -queryOffChainPoolData poolHash poolMetadataHash = do - res <- select $ do - (pod :& ph) <- - from - $ table @OffChainPoolData - `innerJoin` table @PoolHash - `on` (\(pod :& ph) -> pod ^. OffChainPoolDataPoolId ==. ph ^. PoolHashId) - where_ (ph ^. PoolHashHashRaw ==. val poolHash) - where_ (pod ^. OffChainPoolDataHash ==. val poolMetadataHash) - limit 1 - pure (pod ^. OffChainPoolDataTickerName, pod ^. OffChainPoolDataBytes) - pure $ unValue2 <$> listToMaybe res - -queryPoolRegister :: MonadIO m => Maybe ByteString -> ReaderT SqlBackend m [PoolCert] -queryPoolRegister mPoolHash = do - res <- select $ do - (poolUpdate :& poolHash :& poolMeta :& tx :& blk) <- - from - $ table @PoolUpdate - `innerJoin` table @PoolHash - `on` (\(poolUpdate :& poolHash) -> poolUpdate ^. PoolUpdateHashId ==. poolHash ^. PoolHashId) - `innerJoin` table @PoolMetadataRef - `on` (\(poolUpdate :& _poolHash :& poolMeta) -> poolUpdate ^. PoolUpdateMetaId ==. just (poolMeta ^. PoolMetadataRefId)) - `innerJoin` table @Tx - `on` (\(poolUpdate :& _poolHash :& _poolMeta :& tx) -> poolUpdate ^. PoolUpdateRegisteredTxId ==. tx ^. TxId) - `innerJoin` table @Block - `on` (\(_poolUpdate :& _poolHash :& _poolMeta :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - - whenJust mPoolHash $ \ph -> - where_ (poolHash ^. PoolHashHashRaw ==. val ph) - pure - ( poolHash ^. PoolHashHashRaw - , poolMeta ^. PoolMetadataRefHash - , blk ^. BlockBlockNo - , tx ^. TxBlockIndex - , poolUpdate ^. PoolUpdateCertIndex - ) - pure $ toUpdateInfo . unValue5 <$> res - where - toUpdateInfo (poolHash, metaHash, blkNo, txIndex, retIndex) = - PoolCert - { pcHash = poolHash - , pcCertAction = Register metaHash - , pcCertNo = CertNo blkNo txIndex retIndex - } - -queryRetiredPools :: MonadIO m => Maybe ByteString -> ReaderT SqlBackend m [PoolCert] -queryRetiredPools mPoolHash = do - res <- select $ do - (retired :& poolHash :& tx :& blk) <- - from - $ table @PoolRetire - `innerJoin` table @PoolHash - `on` (\(retired :& poolHash) -> retired ^. PoolRetireHashId ==. poolHash ^. PoolHashId) - `innerJoin` table @Tx - `on` (\(retired :& _poolHash :& tx) -> retired ^. PoolRetireAnnouncedTxId ==. tx ^. TxId) - `innerJoin` table @Block - `on` (\(_retired :& _poolHash :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - whenJust mPoolHash $ \ph -> - where_ (poolHash ^. PoolHashHashRaw ==. val ph) - pure - ( poolHash ^. PoolHashHashRaw - , retired ^. PoolRetireRetiringEpoch - , blk ^. BlockBlockNo - , tx ^. TxBlockIndex - , retired ^. PoolRetireCertIndex - ) - pure $ toRetirementInfo . unValue5 <$> res - where - toRetirementInfo (hsh, retEpoch, blkNo, txIndex, retIndex) = - PoolCert - { pcHash = hsh - , pcCertAction = Retirement retEpoch - , pcCertNo = CertNo blkNo txIndex retIndex - } - -queryUsedTicker :: MonadIO m => ByteString -> ByteString -> ReaderT SqlBackend m (Maybe Text) -queryUsedTicker poolHash metaHash = do - res <- select $ do - (pod :& ph) <- - from - $ table @OffChainPoolData - `innerJoin` table @PoolHash - `on` (\(pod :& ph) -> ph ^. PoolHashId ==. pod ^. OffChainPoolDataPoolId) - where_ (ph ^. PoolHashHashRaw ==. val poolHash) - where_ (pod ^. OffChainPoolDataHash ==. val metaHash) - pure $ pod ^. OffChainPoolDataTickerName - pure $ unValue <$> listToMaybe res - -queryReservedTicker :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe ByteString) -queryReservedTicker tickerName = do - res <- select $ do - ticker <- from $ table @ReservedPoolTicker - where_ (ticker ^. ReservedPoolTickerName ==. val tickerName) - pure $ ticker ^. ReservedPoolTickerPoolHash - pure $ unValue <$> listToMaybe res - -queryReservedTickers :: MonadIO m => ReaderT SqlBackend m [ReservedPoolTicker] -queryReservedTickers = - fmap entityVal <$> selectList [] [] +-- queryOffChainPoolData :: MonadIO m => ByteString -> ByteString -> DB.DbAction m (Maybe (Text, ByteString)) +-- queryOffChainPoolData poolHash poolMetadataHash = do +-- res <- select $ do +-- (pod :& ph) <- +-- from +-- $ table @OffChainPoolData +-- `innerJoin` table @PoolHash +-- `on` (\(pod :& ph) -> pod ^. OffChainPoolDataPoolId ==. ph ^. PoolHashId) +-- where_ (ph ^. PoolHashHashRaw ==. val poolHash) +-- where_ (pod ^. OffChainPoolDataHash ==. val poolMetadataHash) +-- limit 1 +-- pure (pod ^. OffChainPoolDataTickerName, pod ^. OffChainPoolDataBytes) +-- pure $ unValue2 <$> listToMaybe res + +-- queryPoolRegister :: MonadIO m => Maybe ByteString -> DB.DbAction m [PoolCert] +-- queryPoolRegister mPoolHash = do +-- res <- select $ do +-- (poolUpdate :& poolHash :& poolMeta :& tx :& blk) <- +-- from +-- $ table @PoolUpdate +-- `innerJoin` table @PoolHash +-- `on` (\(poolUpdate :& poolHash) -> poolUpdate ^. PoolUpdateHashId ==. poolHash ^. PoolHashId) +-- `innerJoin` table @PoolMetadataRef +-- `on` (\(poolUpdate :& _poolHash :& poolMeta) -> poolUpdate ^. PoolUpdateMetaId ==. just (poolMeta ^. PoolMetadataRefId)) +-- `innerJoin` table @Tx +-- `on` (\(poolUpdate :& _poolHash :& _poolMeta :& tx) -> poolUpdate ^. PoolUpdateRegisteredTxId ==. tx ^. TxId) +-- `innerJoin` table @Block +-- `on` (\(_poolUpdate :& _poolHash :& _poolMeta :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + +-- whenJust mPoolHash $ \ph -> +-- where_ (poolHash ^. PoolHashHashRaw ==. val ph) +-- pure +-- ( poolHash ^. PoolHashHashRaw +-- , poolMeta ^. PoolMetadataRefHash +-- , blk ^. BlockBlockNo +-- , tx ^. TxBlockIndex +-- , poolUpdate ^. PoolUpdateCertIndex +-- ) +-- pure $ toUpdateInfo . unValue5 <$> res +-- where +-- toUpdateInfo (poolHash, metaHash, blkNo, txIndex, retIndex) = +-- PoolCert +-- { pcHash = poolHash +-- , pcCertAction = Register metaHash +-- , pcCertNo = CertNo blkNo txIndex retIndex +-- } + +-- queryRetiredPools :: MonadIO m => Maybe ByteString -> DB.DbAction m [PoolCert] +-- queryRetiredPools mPoolHash = do +-- res <- select $ do +-- (retired :& poolHash :& tx :& blk) <- +-- from +-- $ table @PoolRetire +-- `innerJoin` table @PoolHash +-- `on` (\(retired :& poolHash) -> retired ^. PoolRetireHashId ==. poolHash ^. PoolHashId) +-- `innerJoin` table @Tx +-- `on` (\(retired :& _poolHash :& tx) -> retired ^. PoolRetireAnnouncedTxId ==. tx ^. TxId) +-- `innerJoin` table @Block +-- `on` (\(_retired :& _poolHash :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- whenJust mPoolHash $ \ph -> +-- where_ (poolHash ^. PoolHashHashRaw ==. val ph) +-- pure +-- ( poolHash ^. PoolHashHashRaw +-- , retired ^. PoolRetireRetiringEpoch +-- , blk ^. BlockBlockNo +-- , tx ^. TxBlockIndex +-- , retired ^. PoolRetireCertIndex +-- ) +-- pure $ toRetirementInfo . unValue5 <$> res +-- where +-- toRetirementInfo (hsh, retEpoch, blkNo, txIndex, retIndex) = +-- PoolCert +-- { pcHash = hsh +-- , pcCertAction = Retirement retEpoch +-- , pcCertNo = CertNo blkNo txIndex retIndex +-- } + +-- queryUsedTicker :: MonadIO m => ByteString -> ByteString -> DB.DbAction m (Maybe Text) +-- queryUsedTicker poolHash metaHash = do +-- res <- select $ do +-- (pod :& ph) <- +-- from +-- $ table @OffChainPoolData +-- `innerJoin` table @PoolHash +-- `on` (\(pod :& ph) -> ph ^. PoolHashId ==. pod ^. OffChainPoolDataPoolId) +-- where_ (ph ^. PoolHashHashRaw ==. val poolHash) +-- where_ (pod ^. OffChainPoolDataHash ==. val metaHash) +-- pure $ pod ^. OffChainPoolDataTickerName +-- pure $ unValue <$> listToMaybe res + +-- queryReservedTicker :: MonadIO m => Text -> DB.DbAction m (Maybe ByteString) +-- queryReservedTicker tickerName = do +-- res <- select $ do +-- ticker <- from $ table @ReservedPoolTicker +-- where_ (ticker ^. ReservedPoolTickerName ==. val tickerName) +-- pure $ ticker ^. ReservedPoolTickerPoolHash +-- pure $ unValue <$> listToMaybe res + +-- queryReservedTickers :: MonadIO m => DB.DbAction m [ReservedPoolTicker] +-- queryReservedTickers = +-- fmap entityVal <$> selectList [] [] -- Return delisted Pool hashes. -queryDelistedPools :: MonadIO m => ReaderT SqlBackend m [ByteString] -queryDelistedPools = do - res <- select $ do - delistedPool <- from $ table @DelistedPool - pure $ delistedPool ^. DelistedPoolHashRaw - pure $ unValue <$> res +-- queryDelistedPools :: MonadIO m => DB.DbAction m [ByteString] +-- queryDelistedPools = do +-- res <- select $ do +-- delistedPool <- from $ table @DelistedPool +-- pure $ delistedPool ^. DelistedPoolHashRaw +-- pure $ unValue <$> res -- Returns also the metadata hash -queryOffChainPoolFetchError :: MonadIO m => ByteString -> Maybe UTCTime -> ReaderT SqlBackend m [(OffChainPoolFetchError, ByteString)] -queryOffChainPoolFetchError hash Nothing = do - res <- select $ do - (offChainPoolFetchError :& poolHash :& poolMetadataRef) <- - from - $ table @OffChainPoolFetchError - `innerJoin` table @PoolHash - `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) - `innerJoin` table @PoolMetadataRef - `on` (\(offChainPoolFetchError :& _ :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) - - where_ (poolHash ^. PoolHashHashRaw ==. val hash) - orderBy [desc (offChainPoolFetchError ^. OffChainPoolFetchErrorFetchTime)] - limit 10 - pure (offChainPoolFetchError, poolMetadataRef ^. PoolMetadataRefHash) - pure $ fmap extract res - where - extract (fetchErr, metadataHash) = (entityVal fetchErr, unValue metadataHash) -queryOffChainPoolFetchError hash (Just fromTime) = do - res <- select $ do - (offChainPoolFetchError :& poolHash :& poolMetadataRef) <- - from - $ table @OffChainPoolFetchError - `innerJoin` table @PoolHash - `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) - `innerJoin` table @PoolMetadataRef - `on` (\(offChainPoolFetchError :& _poolHash :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) - where_ - ( poolHash - ^. PoolHashHashRaw - ==. val hash - &&. offChainPoolFetchError - ^. OffChainPoolFetchErrorFetchTime - >=. val fromTime - ) - orderBy [desc (offChainPoolFetchError ^. OffChainPoolFetchErrorFetchTime)] - limit 10 - pure (offChainPoolFetchError, poolMetadataRef ^. PoolMetadataRefHash) - pure $ fmap extract res - where - extract (fetchErr, metadataHash) = (entityVal fetchErr, unValue metadataHash) - -existsDelistedPool :: MonadIO m => ByteString -> ReaderT SqlBackend m Bool -existsDelistedPool ph = do - res <- select $ do - delistedPool <- from $ table @DelistedPool - where_ (delistedPool ^. DelistedPoolHashRaw ==. val ph) - limit 1 - pure (delistedPool ^. DelistedPoolId) - pure $ not (null res) +-- queryOffChainPoolFetchError :: MonadIO m => ByteString -> Maybe UTCTime -> DB.DbAction m [(OffChainPoolFetchError, ByteString)] +-- queryOffChainPoolFetchError hash Nothing = do +-- res <- select $ do +-- (offChainPoolFetchError :& poolHash :& poolMetadataRef) <- +-- from +-- $ table @OffChainPoolFetchError +-- `innerJoin` table @PoolHash +-- `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) +-- `innerJoin` table @PoolMetadataRef +-- `on` (\(offChainPoolFetchError :& _ :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) + +-- where_ (poolHash ^. PoolHashHashRaw ==. val hash) +-- orderBy [desc (offChainPoolFetchError ^. OffChainPoolFetchErrorFetchTime)] +-- limit 10 +-- pure (offChainPoolFetchError, poolMetadataRef ^. PoolMetadataRefHash) +-- pure $ fmap extract res +-- where +-- extract (fetchErr, metadataHash) = (entityVal fetchErr, unValue metadataHash) +-- queryOffChainPoolFetchError hash (Just fromTime) = do +-- res <- select $ do +-- (offChainPoolFetchError :& poolHash :& poolMetadataRef) <- +-- from +-- $ table @OffChainPoolFetchError +-- `innerJoin` table @PoolHash +-- `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) +-- `innerJoin` table @PoolMetadataRef +-- `on` (\(offChainPoolFetchError :& _poolHash :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) +-- where_ +-- ( poolHash +-- ^. PoolHashHashRaw +-- ==. val hash +-- &&. offChainPoolFetchError +-- ^. OffChainPoolFetchErrorFetchTime +-- >=. val fromTime +-- ) +-- orderBy [desc (offChainPoolFetchError ^. OffChainPoolFetchErrorFetchTime)] +-- limit 10 +-- pure (offChainPoolFetchError, poolMetadataRef ^. PoolMetadataRefHash) +-- pure $ fmap extract res +-- where +-- extract (fetchErr, metadataHash) = (entityVal fetchErr, unValue metadataHash) + +-- existsDelistedPool :: MonadIO m => ByteString -> DB.DbAction m Bool +-- existsDelistedPool ph = do +-- res <- select $ do +-- delistedPool <- from $ table @DelistedPool +-- where_ (delistedPool ^. DelistedPoolHashRaw ==. val ph) +-- limit 1 +-- pure (delistedPool ^. DelistedPoolId) +-- pure $ not (null res) {--------------------------------------------------------- Queries use in Tools (valiadtion and snapshot creation) ----------------------------------------------------------} -queryDepositUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada -queryDepositUpToBlockNo blkNo = do - res <- select $ do - (tx :& blk) <- - from - $ table @Tx - `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (blk ^. BlockBlockNo <=. just (val blkNo)) - 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) - --- | Get the fees paid in all block from genesis up to and including the specified block. -queryFeesUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada -queryFeesUpToBlockNo blkNo = do - res <- select $ do - (tx :& blk) <- - from - $ table @Tx - `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (blk ^. BlockBlockNo <=. just (val blkNo)) - pure $ sum_ (tx ^. TxFee) - pure $ unValueSumAda (listToMaybe res) - -queryFeesUpToSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada -queryFeesUpToSlotNo slotNo = do - res <- select $ do - (tx :& blk) <- - from - $ table @Tx - `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (isJust $ blk ^. BlockSlotNo) - where_ (blk ^. BlockSlotNo <=. just (val slotNo)) - pure $ sum_ (tx ^. TxFee) - pure $ unValueSumAda (listToMaybe res) - -queryLatestCachedEpochNo :: MonadIO m => ReaderT SqlBackend m (Maybe Word64) -queryLatestCachedEpochNo = do - res <- select $ do - epoch <- from $ table @Epoch - orderBy [desc (epoch ^. EpochNo)] - limit 1 - pure (epoch ^. EpochNo) - pure $ unValue <$> listToMaybe res +-- queryDepositUpToBlockNo :: MonadIO m => Word64 -> DB.DbAction m Ada +-- queryDepositUpToBlockNo blkNo = do +-- res <- select $ do +-- (tx :& blk) <- +-- from +-- $ table @Tx +-- `innerJoin` table @Block +-- `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (blk ^. BlockBlockNo <=. just (val blkNo)) +-- pure $ sum_ (tx ^. TxDeposit) +-- pure $ unValueSumAda (listToMaybe res) + +-- queryEpochEntry :: MonadIO m => Word64 -> DB.DbAction 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) + +-- -- | Calculate the slot time (as UTCTime) for a given slot number. +-- -- This will fail if the slot is empty. +-- querySlotUtcTime :: MonadIO m => Word64 -> DB.DbAction 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) + +-- -- | Get the fees paid in all block from genesis up to and including the specified block. +-- queryFeesUpToBlockNo :: MonadIO m => Word64 -> DB.DbAction m Ada +-- queryFeesUpToBlockNo blkNo = do +-- res <- select $ do +-- (tx :& blk) <- +-- from +-- $ table @Tx +-- `innerJoin` table @Block +-- `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (blk ^. BlockBlockNo <=. just (val blkNo)) +-- pure $ sum_ (tx ^. TxFee) +-- pure $ unValueSumAda (listToMaybe res) + +-- queryFeesUpToSlotNo :: MonadIO m => Word64 -> DB.DbAction m Ada +-- queryFeesUpToSlotNo slotNo = do +-- res <- select $ do +-- (tx :& blk) <- +-- from +-- $ table @Tx +-- `innerJoin` table @Block +-- `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (isJust $ blk ^. BlockSlotNo) +-- where_ (blk ^. BlockSlotNo <=. just (val slotNo)) +-- pure $ sum_ (tx ^. TxFee) +-- pure $ unValueSumAda (listToMaybe res) + +-- queryLatestCachedEpochNo :: MonadIO m => DB.DbAction m (Maybe Word64) +-- queryLatestCachedEpochNo = do +-- res <- select $ do +-- epoch <- from $ table @Epoch +-- orderBy [desc (epoch ^. EpochNo)] +-- limit 1 +-- pure (epoch ^. EpochNo) +-- pure $ unValue <$> listToMaybe res -- | Get the 'BlockNo' of the latest block. -queryLatestBlockNo :: MonadIO m => ReaderT SqlBackend m (Maybe Word64) -queryLatestBlockNo = do - res <- select $ do - blk <- from $ table @Block - where_ (isJust $ blk ^. BlockBlockNo) - orderBy [desc (blk ^. BlockBlockNo)] - limit 1 - pure $ blk ^. BlockBlockNo - pure $ listToMaybe (mapMaybe unValue res) - -querySlotNosGreaterThan :: MonadIO m => Word64 -> ReaderT SqlBackend m [SlotNo] -querySlotNosGreaterThan slotNo = do - res <- select $ do - blk <- from $ table @Block - -- Want all BlockNos where the block satisfies this predicate. - where_ (blk ^. BlockSlotNo >. just (val slotNo)) - -- Return them in descending order so we can delete the highest numbered - -- ones first. - orderBy [desc (blk ^. BlockSlotNo)] - pure (blk ^. BlockSlotNo) - pure $ mapMaybe (fmap SlotNo . unValue) res - --- | Like 'querySlotNosGreaterThan', but returns all slots in the same order. -querySlotNos :: MonadIO m => ReaderT SqlBackend m [SlotNo] -querySlotNos = do - res <- select $ do - blk <- from $ table @Block - -- Return them in descending order so we can delete the highest numbered - -- ones first. - orderBy [desc (blk ^. BlockSlotNo)] - 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) - -queryWithdrawalsUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada -queryWithdrawalsUpToBlockNo blkNo = do - res <- select $ do - (_tx :& wdrl :& blk) <- - from - $ table @Tx - `innerJoin` table @Withdrawal - `on` (\(tx :& wdrl) -> tx ^. TxId ==. wdrl ^. WithdrawalTxId) - `innerJoin` table @Block - `on` (\(tx :& _wdrl :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) - where_ (blk ^. BlockBlockNo <=. val (Just $ fromIntegral blkNo)) - pure $ sum_ (wdrl ^. WithdrawalAmount) - pure $ unValueSumAda (listToMaybe res) - -queryAdaPots :: MonadIO m => BlockId -> ReaderT SqlBackend m (Maybe AdaPots) -queryAdaPots blkId = do - res <- select $ do - adaPots <- from $ table @AdaPots - where_ (adaPots ^. AdaPotsBlockId ==. val blkId) - pure adaPots - pure $ fmap entityVal (listToMaybe res) +-- queryLatestBlockNo :: MonadIO m => DB.DbAction m (Maybe Word64) +-- queryLatestBlockNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- where_ (isJust $ blk ^. BlockBlockNo) +-- orderBy [desc (blk ^. BlockBlockNo)] +-- limit 1 +-- pure $ blk ^. BlockBlockNo +-- pure $ listToMaybe (mapMaybe unValue res) + +-- querySlotNosGreaterThan :: MonadIO m => Word64 -> DB.DbAction m [SlotNo] +-- querySlotNosGreaterThan slotNo = do +-- res <- select $ do +-- blk <- from $ table @Block +-- -- Want all BlockNos where the block satisfies this predicate. +-- where_ (blk ^. BlockSlotNo >. just (val slotNo)) +-- -- Return them in descending order so we can delete the highest numbered +-- -- ones first. +-- orderBy [desc (blk ^. BlockSlotNo)] +-- pure (blk ^. BlockSlotNo) +-- pure $ mapMaybe (fmap SlotNo . unValue) res + +-- -- | Like 'querySlotNosGreaterThan', but returns all slots in the same order. +-- querySlotNos :: MonadIO m => DB.DbAction m [SlotNo] +-- querySlotNos = do +-- res <- select $ do +-- blk <- from $ table @Block +-- -- Return them in descending order so we can delete the highest numbered +-- -- ones first. +-- orderBy [desc (blk ^. BlockSlotNo)] +-- pure (blk ^. BlockSlotNo) +-- pure $ mapMaybe (fmap SlotNo . unValue) res + +-- queryWithdrawalsUpToBlockNo :: MonadIO m => Word64 -> DB.DbAction m Ada +-- queryWithdrawalsUpToBlockNo blkNo = do +-- res <- select $ do +-- (_tx :& wdrl :& blk) <- +-- from +-- $ table @Tx +-- `innerJoin` table @Withdrawal +-- `on` (\(tx :& wdrl) -> tx ^. TxId ==. wdrl ^. WithdrawalTxId) +-- `innerJoin` table @Block +-- `on` (\(tx :& _wdrl :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) +-- where_ (blk ^. BlockBlockNo <=. val (Just $ fromIntegral blkNo)) +-- pure $ sum_ (wdrl ^. WithdrawalAmount) +-- pure $ unValueSumAda (listToMaybe res) + +-- queryAdaPots :: MonadIO m => BlockId -> DB.DbAction m (Maybe AdaPots) +-- queryAdaPots blkId = do +-- res <- select $ do +-- adaPots <- from $ table @AdaPots +-- where_ (adaPots ^. AdaPotsBlockId ==. val blkId) +-- pure adaPots +-- pure $ fmap entityVal (listToMaybe res) {----------------------- Queries use in tests ------------------------} -queryRewardCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryRewardCount = do - res <- select $ do - _ <- from $ table @Reward - pure countRows - pure $ maybe 0 unValue (listToMaybe res) +-- queryRewardCount :: MonadIO m => DB.DbAction m Word64 +-- queryRewardCount = do +-- res <- select $ do +-- _ <- from $ table @Reward +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) -queryRewardRestCount :: MonadIO m => ReaderT SqlBackend m Word64 -queryRewardRestCount = do - res <- select $ do - _ <- from $ table @RewardRest - pure countRows - pure $ maybe 0 unValue (listToMaybe res) +-- queryRewardRestCount :: MonadIO m => DB.DbAction m Word64 +-- queryRewardRestCount = do +-- res <- select $ do +-- _ <- from $ table @RewardRest +-- pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) -- | Count the number of transactions in the Tx table. -queryTxInCount :: MonadIO m => ReaderT SqlBackend m Word -queryTxInCount = do - res <- select $ from (table @TxIn) >> pure countRows - pure $ maybe 0 unValue (listToMaybe res) - -queryCostModel :: MonadIO m => ReaderT SqlBackend m [CostModelId] -queryCostModel = - fmap entityKey <$> selectList [] [Asc CostModelId] - -queryTxInRedeemer :: MonadIO m => ReaderT SqlBackend m [TxIn] -queryTxInRedeemer = do - res <- select $ do - tx_in <- from $ table @TxIn - where_ (isJust $ tx_in ^. TxInRedeemerId) - pure tx_in - pure $ entityVal <$> res +-- queryTxInCount :: MonadIO m => DB.DbAction m Word +-- queryTxInCount = do +-- res <- select $ from (table @TxIn) >> pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryCostModel :: MonadIO m => DB.DbAction m [CostModelId] +-- queryCostModel = +-- fmap entityKey <$> selectList [] [Asc CostModelId] + +-- queryTxInRedeemer :: MonadIO m => DB.DbAction m [TxIn] +-- queryTxInRedeemer = do +-- res <- select $ do +-- tx_in <- from $ table @TxIn +-- where_ (isJust $ tx_in ^. TxInRedeemerId) +-- pure tx_in +-- pure $ entityVal <$> res -- | Gets all the 'TxIn' of invalid txs -queryTxInFailedTx :: MonadIO m => ReaderT SqlBackend m [TxIn] -queryTxInFailedTx = do - res <- select $ do - (tx_in :& tx) <- - from - $ table @TxIn - `innerJoin` table @Tx - `on` (\(tx_in :& tx) -> tx_in ^. TxInTxInId ==. tx ^. TxId) - where_ (tx ^. TxValidContract ==. val False) - pure tx_in - pure $ entityVal <$> res - -queryInvalidTx :: MonadIO m => ReaderT SqlBackend m [Tx] -queryInvalidTx = do - res <- select $ do - tx <- from $ table @Tx - where_ (tx ^. TxValidContract ==. val False) - pure tx - pure $ entityVal <$> res - -queryDeregistrationScript :: MonadIO m => ReaderT SqlBackend m [StakeDeregistration] -queryDeregistrationScript = do - res <- select $ do - dereg <- from $ table @StakeDeregistration - where_ (isJust $ dereg ^. StakeDeregistrationRedeemerId) - pure dereg - pure $ entityVal <$> res - -queryDelegationScript :: MonadIO m => ReaderT SqlBackend m [Delegation] -queryDelegationScript = do - res <- select $ do - deleg <- from $ table @Delegation - where_ (isJust $ deleg ^. DelegationRedeemerId) - pure deleg - pure $ entityVal <$> res - -queryWithdrawalScript :: MonadIO m => ReaderT SqlBackend m [Withdrawal] -queryWithdrawalScript = do - res <- select $ do - wtdr <- from $ table @Withdrawal - where_ (isJust $ wtdr ^. WithdrawalRedeemerId) - pure wtdr - pure $ entityVal <$> res - -queryStakeAddressScript :: MonadIO m => ReaderT SqlBackend m [StakeAddress] -queryStakeAddressScript = do - res <- select $ do - st_addr <- from $ table @StakeAddress - where_ (isJust $ st_addr ^. StakeAddressScriptHash) - pure st_addr - pure $ entityVal <$> res - -querySchemaVersion :: MonadIO m => ReaderT SqlBackend m (Maybe SchemaVersion) -querySchemaVersion = do - res <- select $ do - sch <- from $ table @SchemaVersion - orderBy [desc (sch ^. SchemaVersionStageOne)] - limit 1 - pure (sch ^. SchemaVersionStageOne, sch ^. SchemaVersionStageTwo, sch ^. SchemaVersionStageThree) - pure $ uncurry3 SchemaVersion . unValue3 <$> listToMaybe res +-- queryTxInFailedTx :: MonadIO m => DB.DbAction m [TxIn] +-- queryTxInFailedTx = do +-- res <- select $ do +-- (tx_in :& tx) <- +-- from +-- $ table @TxIn +-- `innerJoin` table @Tx +-- `on` (\(tx_in :& tx) -> tx_in ^. TxInTxInId ==. tx ^. TxId) +-- where_ (tx ^. TxValidContract ==. val False) +-- pure tx_in +-- pure $ entityVal <$> res + +-- queryInvalidTx :: MonadIO m => DB.DbAction m [Tx] +-- queryInvalidTx = do +-- res <- select $ do +-- tx <- from $ table @Tx +-- where_ (tx ^. TxValidContract ==. val False) +-- pure tx +-- pure $ entityVal <$> res + +-- queryDeregistrationScript :: MonadIO m => DB.DbAction m [StakeDeregistration] +-- queryDeregistrationScript = do +-- res <- select $ do +-- dereg <- from $ table @StakeDeregistration +-- where_ (isJust $ dereg ^. StakeDeregistrationRedeemerId) +-- pure dereg +-- pure $ entityVal <$> res + +-- queryDelegationScript :: MonadIO m => DB.DbAction m [Delegation] +-- queryDelegationScript = do +-- res <- select $ do +-- deleg <- from $ table @Delegation +-- where_ (isJust $ deleg ^. DelegationRedeemerId) +-- pure deleg +-- pure $ entityVal <$> res + +-- queryWithdrawalScript :: MonadIO m => DB.DbAction m [Withdrawal] +-- queryWithdrawalScript = do +-- res <- select $ do +-- wtdr <- from $ table @Withdrawal +-- where_ (isJust $ wtdr ^. WithdrawalRedeemerId) +-- pure wtdr +-- pure $ entityVal <$> res + +-- queryStakeAddressScript :: MonadIO m => DB.DbAction m [StakeAddress] +-- queryStakeAddressScript = do +-- res <- select $ do +-- st_addr <- from $ table @StakeAddress +-- where_ (isJust $ st_addr ^. StakeAddressScriptHash) +-- pure st_addr +-- pure $ entityVal <$> res + +-- querySchemaVersion :: MonadIO m => DB.DbAction m (Maybe SchemaVersion) +-- querySchemaVersion = do +-- res <- select $ do +-- sch <- from $ table @SchemaVersion +-- orderBy [desc (sch ^. SchemaVersionStageOne)] +-- limit 1 +-- pure (sch ^. SchemaVersionStageOne, sch ^. SchemaVersionStageTwo, sch ^. SchemaVersionStageThree) +-- pure $ uncurry3 SchemaVersion . unValue3 <$> listToMaybe res -- | Given a 'SlotNo' return the 'SlotNo' of the previous block. -queryPreviousSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe Word64) -queryPreviousSlotNo slotNo = do - res <- select $ do - (blk :& pblk) <- - from - $ table @Block - `innerJoin` table @Block - `on` (\(blk :& pblk) -> blk ^. BlockPreviousId ==. just (pblk ^. BlockId)) - where_ (blk ^. BlockSlotNo ==. just (val slotNo)) - pure $ pblk ^. BlockSlotNo - pure $ unValue =<< listToMaybe res +-- queryPreviousSlotNo :: MonadIO m => Word64 -> DB.DbAction m (Maybe Word64) +-- queryPreviousSlotNo slotNo = do +-- res <- select $ do +-- (blk :& pblk) <- +-- from +-- $ table @Block +-- `innerJoin` table @Block +-- `on` (\(blk :& pblk) -> blk ^. BlockPreviousId ==. just (pblk ^. BlockId)) +-- where_ (blk ^. BlockSlotNo ==. just (val slotNo)) +-- pure $ pblk ^. BlockSlotNo +-- pure $ unValue =<< listToMaybe res diff --git a/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs b/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs index 64da0a70f..492d4451b 100644 --- a/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs +++ b/cardano-db/src/Cardano/Db/Operations/QueryHelper.hs @@ -5,86 +5,87 @@ 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) -txLessEqual blkid = - subList_select $ - from (table @Tx) >>= \tx -> do - where_ $ tx ^. TxBlockId `in_` blockLessEqual - pure $ tx ^. TxId - where - -- every block made before or at the snapshot time - blockLessEqual :: SqlExpr (ValueList BlockId) - blockLessEqual = - subList_select $ - from (table @Block) >>= \blk -> do - where_ $ blk ^. BlockId <=. val blkid - pure $ blk ^. BlockId +-- txLessEqual :: BlockId -> SqlExpr (ValueList TxId) +-- txLessEqual blkid = +-- subList_select $ +-- from (table @Tx) >>= \tx -> do +-- where_ $ tx ^. TxBlockId `in_` blockLessEqual +-- pure $ tx ^. TxId +-- where +-- -- every block made before or at the snapshot time +-- blockLessEqual :: SqlExpr (ValueList BlockId) +-- blockLessEqual = +-- subList_select $ +-- from (table @Block) >>= \blk -> do +-- 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 +-- 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..e46e3a31f 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 -> DB.DbAction 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 -> DB.DbAction 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 => TxOutVariantType -> DB.DbAction m Int64 +-- deleteTxOut = \case +-- TxOutVariantCore -> 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..6377c2695 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 :: MonadIO m => CollateralTxOutW -> DB.DbAction 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..5f8db5fcb 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 (..), TxOutVariantType (..), 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 TxOutVariantType 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 => +-- TxOutVariantType -> +-- (ByteString, Word64) -> +-- DB.DbAction m (Either LookupFail (TxId, TxOutIdW)) +-- queryTxOutId txOutVariantType hashIndex = +-- case txOutVariantType of +-- TxOutVariantCore -> wrapTxOutId VCTxOutIdW (queryTxOutId' @'TxOutCore hashIndex) +-- TxOutVariantAddress -> wrapTxOutId VATxOutIdW (queryTxOutId' @'TxOutVariantAddress hashIndex) +-- where +-- wrapTxOutId constructor = fmap (fmap (second constructor)) + +-- queryTxOutId' :: +-- forall a m. +-- (TxOutFields a, MonadIO m) => +-- (ByteString, Word64) -> +-- DB.DbAction 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) => +-- TxOutVariantType -> +-- (ByteString, Word64) -> +-- DB.DbAction m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) +-- queryTxOutIdValue getTxOutVariantType hashIndex = do +-- case getTxOutVariantType of +-- TxOutVariantCore -> wrapTxOutId VCTxOutIdW (queryTxOutIdValue' @'TxOutCore hashIndex) +-- TxOutVariantAddress -> wrapTxOutId VATxOutIdW (queryTxOutIdValue' @'TxOutVariantAddress hashIndex) +-- where +-- wrapTxOutId constructor = +-- fmap (fmap (\(txId, txOutId, lovelace) -> (txId, constructor txOutId, lovelace))) + +-- queryTxOutIdValue' :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- (ByteString, Word64) -> +-- DB.DbAction 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 => +-- TxOutVariantType -> +-- (ByteString, Word64) -> +-- DB.DbAction m (Either LookupFail (Maybe ByteString, Bool)) +-- queryTxOutCredentials txOutVariantType (hash, index) = +-- case txOutVariantType of +-- TxOutVariantCore -> queryTxOutCredentialsCore (hash, index) +-- TxOutVariantAddress -> queryTxOutCredentialsVariant (hash, index) + +-- queryTxOutCredentialsCore :: MonadIO m => (ByteString, Word64) -> DB.DbAction 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) -> DB.DbAction 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 -> DB.DbAction 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) => +-- TxOutVariantType -> +-- DB.DbAction m Ada +-- queryTotalSupply txOutVariantType = +-- case txOutVariantType of +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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) => +-- TxOutVariantType -> +-- DB.DbAction m Ada +-- queryGenesisSupply txOutVariantType = +-- case txOutVariantType of +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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 => TxOutVariantType -> DB.DbAction m Ada +-- queryShelleyGenesisSupply txOutVariantType = +-- case txOutVariantType of +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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 => TxOutVariantType -> Word64 -> DB.DbAction m [UtxoQueryResult] +-- queryUtxoAtBlockNo txOutVariantType blkNo = do +-- eblkId <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockBlockNo ==. just (val blkNo)) +-- pure (blk ^. BlockId) +-- maybe (pure []) (queryUtxoAtBlockId txOutVariantType . unValue) (listToMaybe eblkId) + +-- -------------------------------------------------------------------------------- +-- -- queryUtxoAtSlotNo +-- -------------------------------------------------------------------------------- +-- queryUtxoAtSlotNo :: MonadIO m => TxOutVariantType -> Word64 -> DB.DbAction m [UtxoQueryResult] +-- queryUtxoAtSlotNo txOutVariantType slotNo = do +-- eblkId <- select $ do +-- blk <- from $ table @Block +-- where_ (blk ^. BlockSlotNo ==. just (val slotNo)) +-- pure (blk ^. BlockId) +-- maybe (pure []) (queryUtxoAtBlockId txOutVariantType . unValue) (listToMaybe eblkId) + +-- -------------------------------------------------------------------------------- +-- -- queryUtxoAtBlockId +-- -------------------------------------------------------------------------------- +-- queryUtxoAtBlockId :: MonadIO m => TxOutVariantType -> BlockId -> DB.DbAction m [UtxoQueryResult] +-- queryUtxoAtBlockId txOutVariantType blkid = +-- case txOutVariantType of +-- TxOutVariantCore -> queryUtxoAtBlockIdCore blkid +-- TxOutVariantAddress -> queryUtxoAtBlockIdVariant blkid + +-- queryUtxoAtBlockIdCore :: MonadIO m => BlockId -> DB.DbAction 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 -> DB.DbAction 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 = VCTxOutW $ 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 = VATxOutW (entityVal out) (Just (entityVal address)) +-- , utxoAddress = V.addressAddress $ entityVal address +-- , utxoTxHash = hash' +-- } +-- convertVariant _ = Nothing + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryAddressBalanceAtSlot +-- -- -------------------------------------------------------------------------------- +-- queryAddressBalanceAtSlot :: MonadIO m => TxOutVariantType -> Text -> Word64 -> DB.DbAction m Ada +-- queryAddressBalanceAtSlot txOutVariantType 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 -> DB.DbAction 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 txOutVariantType of +-- TxOutVariantCore -> 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 => TxOutVariantType -> DB.DbAction m [TxOutW] +-- queryScriptOutputs txOutVariantType = +-- case txOutVariantType of +-- TxOutVariantCore -> fmap (map VCTxOutW) queryScriptOutputsCore +-- TxOutVariantAddress -> queryScriptOutputsVariant + +-- queryScriptOutputsCore :: MonadIO m => DB.DbAction 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 => DB.DbAction 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 = +-- VATxOutW (entityVal txOut) (Just (entityVal address)) + +-- -- -------------------------------------------------------------------------------- +-- -- -- queryAddressOutputs +-- -- -------------------------------------------------------------------------------- +-- queryAddressOutputs :: MonadIO m => TxOutVariantType -> Text -> DB.DbAction m DbLovelace +-- queryAddressOutputs txOutVariantType addr = do +-- res <- case txOutVariantType of +-- TxOutVariantCore -> 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 => +-- TxOutVariantType -> +-- DB.DbAction m Word +-- queryTxOutCount txOutVariantType = do +-- case txOutVariantType of +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction m Word +-- query = do +-- res <- select $ from (table @(TxOutTable a)) >> pure countRows +-- pure $ maybe 0 unValue (listToMaybe res) + +-- queryTxOutUnspentCount :: +-- MonadIO m => +-- TxOutVariantType -> +-- DB.DbAction m Word64 +-- queryTxOutUnspentCount txOutVariantType = +-- case txOutVariantType of +-- TxOutVariantCore -> query @'TxOutCore +-- TxOutVariantAddress -> query @'TxOutVariantAddress +-- where +-- query :: +-- forall (a :: TxOutVariantType) m. +-- (MonadIO m, TxOutFields a) => +-- DB.DbAction 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..b5b95d9dd 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 TxOutVariantType = TxOutVariantCore | TxOutVariantAddress +-- deriving (Eq, Show) + +-- -------------------------------------------------------------------------------- +-- -- TxOut +-- -------------------------------------------------------------------------------- + +-- -- | A wrapper for TxOut that allows us to handle both Core and Variant TxOuts +-- data TxOutW +-- = VCTxOutW !C.TxOut +-- | VATxOutW !V.TxOut !(Maybe V.Address) + +-- -- | A wrapper for TxOutId +-- data TxOutIdW +-- = VCTxOutIdW !C.TxOutId +-- | VATxOutIdW !V.TxOutId +-- deriving (Show) + +-- -- TxOut fields for a given TxOutVariantType +-- class (PersistEntity (TxOutTable a), PersistField (TxOutIdFor a)) => TxOutFields (a :: TxOutVariantType) 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) + +-- -- TxOutVariantCore 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 :: TxOutVariantType) 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 TxOutVariantType +-- class (PersistEntity (MaTxOutTable a)) => MaTxOutFields (a :: TxOutVariantType) 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 + +-- -- TxOutVariantCore 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 TxOutVariantType +-- -------------------------------------------------------------------------------- +-- 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 :: TxOutVariantType) 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 (VCTxOutW txOut) = txOut +-- -- this will never error as we can only have either CoreTxOut or VariantTxOut +-- extractCoreTxOut (VATxOutW _ _) = error "Unexpected VTxOut in CoreTxOut list" + +-- extractVariantTxOut :: TxOutW -> V.TxOut +-- extractVariantTxOut (VATxOutW txOut _) = txOut +-- -- this will never error as we can only have either CoreTxOut or VariantTxOut +-- extractVariantTxOut (VCTxOutW _) = error "Unexpected CTxOut in VariantTxOut list" + +-- convertTxOutIdCore :: [TxOutIdW] -> [C.TxOutId] +-- convertTxOutIdCore = mapMaybe unwrapCore +-- where +-- unwrapCore (VCTxOutIdW txOutid) = Just txOutid +-- unwrapCore _ = Nothing + +-- convertTxOutIdVariant :: [TxOutIdW] -> [V.TxOutId] +-- convertTxOutIdVariant = mapMaybe unwrapVariant +-- where +-- unwrapVariant (VATxOutIdW 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 :: TxOutVariantType -> Bool +-- isTxOutCore TxOutVariantCore = True +-- isTxOutCore TxOutVariantAddress = False + +-- isTxOutVariantAddress :: TxOutVariantType -> Bool +-- isTxOutVariantAddress TxOutVariantAddress = True +-- isTxOutVariantAddress TxOutVariantCore = 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..2e61d344e 100644 --- a/cardano-db/src/Cardano/Db/Run.hs +++ b/cardano-db/src/Cardano/Db/Run.hs @@ -2,24 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} -module Cardano.Db.Run ( - getBackendGhci, - ghciDebugQuery, - runDbHandleLogger, - runDbIohkLogging, - runDbIohkNoLogging, - runDbNoLogging, - runDbNoLoggingEnv, - runDbStdoutLogging, - runIohkLogging, - transactionCommit, - runWithConnectionLogging, - runWithConnectionNoLogging, - - -- * Connection Pool variants - runPoolDbIohkLogging, -) where +module Cardano.Db.Run where import Cardano.BM.Data.LogItem ( LOContent (..), @@ -29,105 +15,87 @@ 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 Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger ( LogLevel (..), LogSource, 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.Text (Text) +import Data.Pool (Pool, withResource, newPool, defaultPoolConfig) 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 qualified Hasql.Session as HsqlSes import Language.Haskell.TH.Syntax (Loc) -import System.IO (Handle, stdout) import System.Log.FastLogger (LogStr, fromLogStr) +import Cardano.Prelude +import Prelude (userError, error) --- | 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 - where - runHandleLoggerT :: LoggingT m a -> m a - runHandleLoggerT action = - runLoggingT action 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 - +import Cardano.Db.Types (DbAction (..), DbEnv (..)) +import Cardano.Db.Error (runOrThrowIO) +import Cardano.Db.PGConfig +import Cardano.Db.Statement.Function.Core (runDbSession, mkCallInfo) + +----------------------------------------------------------------------------------------- +-- Transactions +----------------------------------------------------------------------------------------- +-- | Execute a transaction start +startTransaction :: MonadIO m => HsqlCon.Connection -> m () +startTransaction conn = liftIO $ + HsqlSes.run beginTransaction conn >>= \case + Left err -> throwIO $ userError $ "Error starting transaction: " <> show err + Right _ -> pure () + +-- | Commit a transaction +commitAction :: MonadIO m => HsqlCon.Connection -> m () +commitAction conn = liftIO $ + HsqlSes.run commitTransaction conn >>= \case + Left err -> throwIO $ userError $ "Error committing: " <> show err + Right _ -> pure () + +-- | Rollback a transaction +rollbackAction :: MonadIO m => HsqlCon.Connection -> m () +rollbackAction conn = liftIO $ + HsqlSes.run rollbackTransaction conn >>= \case + Left err -> throwIO $ userError $ "Error rolling back: " <> show err + Right _ -> pure () + +----------------------------------------------------------------------------------------- +-- Run DB actions +----------------------------------------------------------------------------------------- -- | 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 +runDbIohkLogging :: MonadUnliftIO m => Trace IO Text -> DbEnv -> DbAction (LoggingT m) a -> m a +runDbIohkLogging tracer dbEnv@DbEnv{..} action = do + runIohkLogging tracer $ do + -- Start transaction + startTransaction dbConnection + -- Run action + result <- runReaderT (runExceptT (runDbAction action)) dbEnv + -- Commit or rollback + case result of + Left err -> do + rollbackAction dbConnection + throwIO err + Right val -> do + commitAction dbConnection + pure val -- | 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 - +runPoolDbIohkLogging :: + (MonadUnliftIO m) => + Pool HsqlCon.Connection -> + Trace IO Text -> + DbAction (LoggingT m) a -> m a +runPoolDbIohkLogging connPool tracer action = do + conn <- liftIO $ withResource connPool pure + let dbEnv = DbEnv conn True (Just tracer) + runDbIohkLogging tracer dbEnv action + +-- | Run a DB action with loggingT. runIohkLogging :: Trace IO Text -> LoggingT m a -> m a runIohkLogging tracer action = runLoggingT action toIohkLog @@ -151,50 +119,118 @@ runIohkLogging tracer action = LevelError -> Error LevelOther _ -> Error +-- | Run a DB action with NoLoggingT. +runDbIohkNoLogging :: MonadIO m => DbEnv -> DbAction (NoLoggingT m) a -> m a +runDbIohkNoLogging dbEnv@DbEnv{..} action = do + runNoLoggingT $ do + -- Start transaction + startTransaction dbConnection + -- Run action + result <- runReaderT (runExceptT (runDbAction action)) dbEnv + -- Commit or rollback + case result of + Left err -> do + rollbackAction dbConnection + throwIO err + Right val -> do + commitAction dbConnection + pure val + +createTransactionCheckpoint :: MonadIO m => DbAction m () +createTransactionCheckpoint = + runDbSession (mkCallInfo "createTransactionCheckpoint") beginTransaction + -- | Run a DB action without any logging, mainly for tests. -runDbNoLoggingEnv :: - (MonadBaseControl IO m, MonadUnliftIO m) => - ReaderT SqlBackend (NoLoggingT m) a -> - m a +runDbNoLoggingEnv :: MonadIO m => DbAction m a -> m a runDbNoLoggingEnv = runDbNoLogging PGPassDefaultEnv -runDbNoLogging :: - (MonadBaseControl IO m, MonadUnliftIO m) => - PGPassSource -> - ReaderT SqlBackend (NoLoggingT m) a -> - m a +runDbNoLogging :: MonadIO m => PGPassSource -> 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 (readPGPass source) + connSetting <- liftIO $ case toConnectionSetting pgconfig of + Left err -> error err + Right setting -> pure setting + connection <- liftIO $ acquireConnection [connSetting] + let dbEnv = DbEnv connection False Nothing + -- Start transaction + startTransaction connection + -- Run action with exception handling + actionResult <- runReaderT (runExceptT (runDbAction action)) dbEnv + -- Process results, handle transaction completion + case actionResult of + Left err -> do + -- On error, rollback and rethrow + rollbackAction connection + liftIO $ HsqlCon.release connection + throwIO err + Right val -> do + -- On success, commit and return value + commitAction connection + liftIO $ HsqlCon.release connection + pure val + +runWithConnectionNoLogging :: PGPassSource -> DbAction (NoLoggingT IO) a -> IO a +runWithConnectionNoLogging source action = do + pgConfig <- runOrThrowIO (readPGPass source) + connSetting <- case toConnectionSetting pgConfig of + Left err -> throwIO $ userError err + Right setting -> pure setting + bracket + (acquireConnection [connSetting]) + HsqlCon.release + (\connection -> do + let dbEnv = DbEnv connection False Nothing + runNoLoggingT $ do + -- Start transaction + startTransaction connection + -- Run action + result <- runReaderT (runExceptT (runDbAction action)) dbEnv + -- Commit or rollback + case result of + Left err -> do + rollbackAction connection + throwIO err + Right val -> do + commitAction connection + 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 + +-- Function to create a connection pool +createHasqlConnectionPool :: [HsqlConS.Setting] -> Int -> IO (Pool HsqlCon.Connection) +createHasqlConnectionPool settings numConnections = do + newPool poolConfig + where + poolConfig = + defaultPoolConfig + acquireConn + releaseConn + 30.0 -- cacheTTL (seconds) + numConnections -- maxResources + acquireConn = do + result <- HsqlCon.acquire settings + case result of + Left err -> throwIO $ userError $ "Connection error: " <> show err + Right conn -> pure conn + releaseConn = HsqlCon.release + +----------------------------------------------------------------------------------------- +-- Transaction Sql +----------------------------------------------------------------------------------------- +beginTransaction :: HsqlSes.Session () +beginTransaction = HsqlSes.sql "BEGIN ISOLATION LEVEL SERIALIZABLE" + +commitTransaction :: HsqlSes.Session () +commitTransaction = HsqlSes.sql "COMMIT" + +rollbackTransaction :: HsqlSes.Session () +rollbackTransaction = HsqlSes.sql "ROLLBACK" + +checkpointTransaction :: HsqlSes.Session () +checkpointTransaction = HsqlSes.sql "COMMIT; BEGIN ISOLATION LEVEL SERIALIZABLE" 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..8f56e4f2e --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core.hs @@ -0,0 +1,19 @@ +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, + module Cardano.Db.Schema.MinIds, +) 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 +import Cardano.Db.Schema.MinIds 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..74817f5b7 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/Base.hs @@ -0,0 +1,948 @@ +{-# 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, + ) +import qualified Cardano.Db.Schema.Ids as Id + +-- 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 BlockId) -- 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 + <*> maybeIdDecoder BlockId -- 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 >$< maybeIdEncoder getBlockId + , 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 PoolHashId) -- 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 + <*> Id.maybeIdDecoder Id.PoolHashId -- 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 >$< Id.maybeIdEncoder Id.getPoolHashId + , 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..b91eef9ff --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/GovernanceAndVoting.hs @@ -0,0 +1,958 @@ +{-# 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 qualified Cardano.Db.Schema.Ids as Id +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 = Id.DrepHashId +instance DbInfo DrepHash where + uniqueFields _ = ["raw", "has_script"] + +entityDrepHashDecoder :: D.Row (Entity DrepHash) +entityDrepHashDecoder = + Entity + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.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 :: !Id.TxId -- noreference + , drepRegistrationCertIndex :: !Word16 + , drepRegistrationDeposit :: !(Maybe Int64) + , drepRegistrationDrepHashId :: !Id.DrepHashId -- noreference + , drepRegistrationVotingAnchorId :: !(Maybe Id.VotingAnchorId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key DrepRegistration = Id.DrepRegistrationId +instance DbInfo DrepRegistration + +entityDrepRegistrationDecoder :: D.Row (Entity DrepRegistration) +entityDrepRegistrationDecoder = + Entity + <$> Id.idDecoder Id.DrepRegistrationId -- entityKey + <*> drepRegistrationDecoder -- entityVal + +drepRegistrationDecoder :: D.Row DrepRegistration +drepRegistrationDecoder = + DrepRegistration + <$> Id.idDecoder Id.TxId -- drepRegistrationTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- drepRegistrationCertIndex + <*> D.column (D.nullable D.int8) -- drepRegistrationDeposit + <*> Id.idDecoder Id.DrepHashId -- drepRegistrationId.DrepHashId + <*> Id.maybeIdDecoder Id.VotingAnchorId -- drepRegistrationVotingAnchorId + +entityDrepRegistrationEncoder :: E.Params (Entity DrepRegistration) +entityDrepRegistrationEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.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 >$< Id.idEncoder Id.getDrepHashId + , drepRegistrationVotingAnchorId >$< Id.maybeIdEncoder Id.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 :: !Id.DrepHashId -- noreference + , drepDistrAmount :: !Word64 + , drepDistrEpochNo :: !Word64 -- sqltype=word31type + , drepDistrActiveUntil :: !(Maybe Word64) -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key DrepDistr = Id.DrepDistrId +instance DbInfo DrepDistr where + uniqueFields _ = ["hash_id", "epoch_no"] + +entityDrepDistrDecoder :: D.Row (Entity DrepDistr) +entityDrepDistrDecoder = + Entity + <$> Id.idDecoder Id.DrepDistrId -- entityKey + <*> drepDistrDecoder -- entityVal + +drepDistrDecoder :: D.Row DrepDistr +drepDistrDecoder = + DrepDistr + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getDrepDistrId + , entityVal >$< drepDistrEncoder + ] + +drepDistrEncoder :: E.Params DrepDistr +drepDistrEncoder = + mconcat + [ drepDistrHashId >$< Id.idEncoder Id.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 :: !Id.StakeAddressId -- noreference + , delegationVoteCertIndex :: !Word16 + , delegationVoteDrepHashId :: !Id.DrepHashId -- noreference + , delegationVoteTxId :: !Id.TxId -- noreference + , delegationVoteRedeemerId :: !(Maybe Id.RedeemerId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key DelegationVote = Id.DelegationVoteId +instance DbInfo DelegationVote + +entityDelegationVoteDecoder :: D.Row (Entity DelegationVote) +entityDelegationVoteDecoder = + Entity + <$> Id.idDecoder Id.DelegationVoteId -- entityKey + <*> delegationVoteDecoder -- entityVal + +delegationVoteDecoder :: D.Row DelegationVote +delegationVoteDecoder = + DelegationVote + <$> Id.idDecoder Id.StakeAddressId -- delegationVoteAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- delegationVoteCertIndex + <*> Id.idDecoder Id.DrepHashId -- delegationVoteId.DrepHashId + <*> Id.idDecoder Id.TxId -- delegationVoteTxId + <*> Id.maybeIdDecoder Id.RedeemerId -- delegationVoteRedeemerId + +entityDelegationVoteEncoder :: E.Params (Entity DelegationVote) +entityDelegationVoteEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getDelegationVoteId + , entityVal >$< delegationVoteEncoder + ] + +delegationVoteEncoder :: E.Params DelegationVote +delegationVoteEncoder = + mconcat + [ delegationVoteAddrId >$< Id.idEncoder Id.getStakeAddressId + , delegationVoteCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , delegationVoteDrepHashId >$< Id.idEncoder Id.getDrepHashId + , delegationVoteTxId >$< Id.idEncoder Id.getTxId + , delegationVoteRedeemerId >$< Id.maybeIdEncoder Id.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 :: !Id.TxId -- noreference + , govActionProposalIndex :: !Word64 + , govActionProposalPrevGovActionProposal :: !(Maybe Id.GovActionProposalId) -- noreference + , govActionProposalDeposit :: !DbLovelace -- sqltype=lovelace + , govActionProposalReturnAddress :: !Id.StakeAddressId -- noreference + , govActionProposalExpiration :: !(Maybe Word64) -- sqltype=word31type + , govActionProposalVotingAnchorId :: !(Maybe Id.VotingAnchorId) -- noreference + , govActionProposalType :: !GovActionType -- sqltype=govactiontype + , govActionProposalDescription :: !Text -- sqltype=jsonb + , govActionProposalParamProposal :: !(Maybe Id.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 = Id.GovActionProposalId +instance DbInfo GovActionProposal + +entityGovActionProposalDecoder :: D.Row (Entity GovActionProposal) +entityGovActionProposalDecoder = + Entity + <$> Id.idDecoder Id.GovActionProposalId -- entityKey + <*> govActionProposalDecoder -- entityVal + +govActionProposalDecoder :: D.Row GovActionProposal +govActionProposalDecoder = + GovActionProposal + <$> Id.idDecoder Id.TxId -- govActionProposalTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- govActionProposalIndex + <*> Id.maybeIdDecoder Id.GovActionProposalId -- govActionProposalPrevGovActionProposal + <*> dbLovelaceDecoder -- govActionProposalDeposit + <*> Id.idDecoder Id.StakeAddressId -- govActionProposalReturnAddress + <*> D.column (D.nullable $ fromIntegral <$> D.int8) -- govActionProposalExpiration + <*> Id.maybeIdDecoder Id.VotingAnchorId -- govActionProposalVotingAnchorId + <*> D.column (D.nonNullable govActionTypeDecoder) -- govActionProposalType + <*> D.column (D.nonNullable D.text) -- govActionProposalDescription + <*> Id.maybeIdDecoder Id.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 >$< Id.idEncoder Id.getGovActionProposalId + , entityVal >$< govActionProposalEncoder + ] + +govActionProposalEncoder :: E.Params GovActionProposal +govActionProposalEncoder = + mconcat + [ govActionProposalTxId >$< Id.idEncoder Id.getTxId + , govActionProposalIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , govActionProposalPrevGovActionProposal >$< Id.maybeIdEncoder Id.getGovActionProposalId + , govActionProposalDeposit >$< dbLovelaceEncoder + , govActionProposalReturnAddress >$< Id.idEncoder Id.getStakeAddressId + , govActionProposalExpiration >$< E.param (E.nullable $ fromIntegral >$< E.int8) + , govActionProposalVotingAnchorId >$< Id.maybeIdEncoder Id.getVotingAnchorId + , govActionProposalType >$< E.param (E.nonNullable govActionTypeEncoder) + , govActionProposalDescription >$< E.param (E.nonNullable E.text) + , govActionProposalParamProposal >$< Id.maybeIdEncoder Id.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 :: !Id.TxId -- noreference + , votingProcedureIndex :: !Word16 + , votingProcedureGovActionProposalId :: !Id.GovActionProposalId -- noreference + , votingProcedureVoterRole :: !VoterRole -- sqltype=voterrole + , votingProcedureDrepVoter :: !(Maybe Id.DrepHashId) -- noreference + , votingProcedurePoolVoter :: !(Maybe Id.PoolHashId) -- noreference + , votingProcedureVote :: !Vote -- sqltype=vote + , votingProcedureVotingAnchorId :: !(Maybe Id.VotingAnchorId) -- noreference + , votingProcedureCommitteeVoter :: !(Maybe Id.CommitteeHashId) -- noreference + , votingProcedureInvalid :: !(Maybe Id.EventInfoId) -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key VotingProcedure = Id.VotingProcedureId +instance DbInfo VotingProcedure + +entityVotingProcedureDecoder :: D.Row (Entity VotingProcedure) +entityVotingProcedureDecoder = + Entity + <$> Id.idDecoder Id.VotingProcedureId -- entityKey + <*> votingProcedureDecoder -- entityVal + +votingProcedureDecoder :: D.Row VotingProcedure +votingProcedureDecoder = + VotingProcedure + <$> Id.idDecoder Id.TxId -- votingProcedureTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- votingProcedureIndex + <*> Id.idDecoder Id.GovActionProposalId -- votingProcedureGovActionProposalId + <*> D.column (D.nonNullable voterRoleDecoder) -- votingProcedureVoterRole + <*> Id.maybeIdDecoder Id.DrepHashId -- votingProcedureDrepVoter + <*> Id.maybeIdDecoder Id.PoolHashId -- votingProcedurePoolVoter + <*> D.column (D.nonNullable voteDecoder) -- votingProcedureVote + <*> Id.maybeIdDecoder Id.VotingAnchorId -- votingProcedureVotingAnchorId + <*> Id.maybeIdDecoder Id.CommitteeHashId -- votingProcedureCommitteeVoter + <*> Id.maybeIdDecoder Id.EventInfoId -- votingProcedureInvalid + +entityVotingProcedureEncoder :: E.Params (Entity VotingProcedure) +entityVotingProcedureEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getVotingProcedureId + , entityVal >$< votingProcedureEncoder + ] + +votingProcedureEncoder :: E.Params VotingProcedure +votingProcedureEncoder = + mconcat + [ votingProcedureTxId >$< Id.idEncoder Id.getTxId + , votingProcedureIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , votingProcedureGovActionProposalId >$< Id.idEncoder Id.getGovActionProposalId + , votingProcedureVoterRole >$< E.param (E.nonNullable voterRoleEncoder) + , votingProcedureDrepVoter >$< Id.maybeIdEncoder Id.getDrepHashId + , votingProcedurePoolVoter >$< Id.maybeIdEncoder Id.getPoolHashId + , votingProcedureVote >$< E.param (E.nonNullable voteEncoder) + , votingProcedureVotingAnchorId >$< Id.maybeIdEncoder Id.getVotingAnchorId + , votingProcedureCommitteeVoter >$< Id.maybeIdEncoder Id.getCommitteeHashId + , votingProcedureInvalid >$< Id.maybeIdEncoder Id.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 :: !Id.BlockId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key VotingAnchor = Id.VotingAnchorId +instance DbInfo VotingAnchor where + uniqueFields _ = ["data_hash", "url", "type"] + +entityVotingAnchorDecoder :: D.Row (Entity VotingAnchor) +entityVotingAnchorDecoder = + Entity + <$> Id.idDecoder Id.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 + <*> Id.idDecoder Id.BlockId -- votingAnchorBlockId + +entityVotingAnchorEncoder :: E.Params (Entity VotingAnchor) +entityVotingAnchorEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.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 >$< Id.idEncoder Id.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 Id.GovActionProposalId) -- noreference + , constitutionVotingAnchorId :: !Id.VotingAnchorId -- noreference + , constitutionScriptHash :: !(Maybe ByteString) -- sqltype=hash28type + } + deriving (Eq, Show, Generic) + +type instance Key Constitution = Id.ConstitutionId +instance DbInfo Constitution + +entityConstitutionDecoder :: D.Row (Entity Constitution) +entityConstitutionDecoder = + Entity + <$> Id.idDecoder Id.ConstitutionId -- entityKey + <*> constitutionDecoder -- entityVal + +constitutionDecoder :: D.Row Constitution +constitutionDecoder = + Constitution + <$> Id.maybeIdDecoder Id.GovActionProposalId -- constitutionGovActionProposalId + <*> Id.idDecoder Id.VotingAnchorId -- constitutionVotingAnchorId + <*> D.column (D.nullable D.bytea) -- constitutionScriptHash + +entityConstitutionEncoder :: E.Params (Entity Constitution) +entityConstitutionEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getConstitutionId + , entityVal >$< constitutionEncoder + ] + +constitutionEncoder :: E.Params Constitution +constitutionEncoder = + mconcat + [ constitutionGovActionProposalId >$< Id.maybeIdEncoder Id.getGovActionProposalId + , constitutionVotingAnchorId >$< Id.idEncoder Id.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 Id.GovActionProposalId) -- noreference + , committeeQuorumNumerator :: !Word64 + , committeeQuorumDenominator :: !Word64 + } + deriving (Eq, Show, Generic) + +type instance Key Committee = Id.CommitteeId +instance DbInfo Committee + +entityCommitteeDecoder :: D.Row (Entity Committee) +entityCommitteeDecoder = + Entity + <$> Id.idDecoder Id.CommitteeId -- entityKey + <*> committeeDecoder -- entityVal + +committeeDecoder :: D.Row Committee +committeeDecoder = + Committee + <$> Id.maybeIdDecoder Id.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 >$< Id.idEncoder Id.getCommitteeId + , entityVal >$< committeeEncoder + ] + +committeeEncoder :: E.Params Committee +committeeEncoder = + mconcat + [ committeeGovActionProposalId >$< Id.maybeIdEncoder Id.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 = Id.CommitteeHashId +instance DbInfo CommitteeHash where + uniqueFields _ = ["raw", "has_script"] + +entityCommitteeHashDecoder :: D.Row (Entity CommitteeHash) +entityCommitteeHashDecoder = + Entity + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.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 :: !Id.CommitteeId -- OnDeleteCascade -- here intentionally we use foreign keys + , committeeMemberCommitteeHashId :: !Id.CommitteeHashId -- noreference + , committeeMemberExpirationEpoch :: !Word64 -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeMember = Id.CommitteeMemberId +instance DbInfo CommitteeMember + +entityCommitteeMemberDecoder :: D.Row (Entity CommitteeMember) +entityCommitteeMemberDecoder = + Entity + <$> Id.idDecoder Id.CommitteeMemberId -- entityKey + <*> committeeMemberDecoder -- entityVal + +committeeMemberDecoder :: D.Row CommitteeMember +committeeMemberDecoder = + CommitteeMember + <$> Id.idDecoder Id.CommitteeId -- committeeMemberCommitteeId + <*> Id.idDecoder Id.CommitteeHashId -- committeeMemberCommitteeHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- committeeMemberExpirationEpoch + +entityCommitteeMemberEncoder :: E.Params (Entity CommitteeMember) +entityCommitteeMemberEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getCommitteeMemberId + , entityVal >$< committeeMemberEncoder + ] + +committeeMemberEncoder :: E.Params CommitteeMember +committeeMemberEncoder = + mconcat + [ committeeMemberCommitteeId >$< Id.idEncoder Id.getCommitteeId + , committeeMemberCommitteeHashId >$< Id.idEncoder Id.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 :: !Id.TxId -- noreference + , committeeRegistrationCertIndex :: !Word16 + , committeeRegistrationColdKeyId :: !Id.CommitteeHashId -- noreference + , committeeRegistrationHotKeyId :: !Id.CommitteeHashId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeRegistration = Id.CommitteeRegistrationId +instance DbInfo CommitteeRegistration + +entityCommitteeRegistrationDecoder :: D.Row (Entity CommitteeRegistration) +entityCommitteeRegistrationDecoder = + Entity + <$> Id.idDecoder Id.CommitteeRegistrationId -- entityKey + <*> committeeRegistrationDecoder -- entityVal + +committeeRegistrationDecoder :: D.Row CommitteeRegistration +committeeRegistrationDecoder = + CommitteeRegistration + <$> Id.idDecoder Id.TxId -- committeeRegistrationTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- committeeRegistrationCertIndex + <*> Id.idDecoder Id.CommitteeHashId -- committeeRegistrationColdKeyId + <*> Id.idDecoder Id.CommitteeHashId -- committeeRegistrationHotKeyId + +entityCommitteeRegistrationEncoder :: E.Params (Entity CommitteeRegistration) +entityCommitteeRegistrationEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getCommitteeRegistrationId + , entityVal >$< committeeRegistrationEncoder + ] + +committeeRegistrationEncoder :: E.Params CommitteeRegistration +committeeRegistrationEncoder = + mconcat + [ committeeRegistrationTxId >$< Id.idEncoder Id.getTxId + , committeeRegistrationCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , committeeRegistrationColdKeyId >$< Id.idEncoder Id.getCommitteeHashId + , committeeRegistrationHotKeyId >$< Id.idEncoder Id.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 :: !Id.TxId -- noreference + , committeeDeRegistration_CertIndex :: !Word16 + , committeeDeRegistration_VotingAnchorId :: !(Maybe Id.VotingAnchorId) -- noreference + , committeeDeRegistration_ColdKeyId :: !Id.CommitteeHashId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key CommitteeDeRegistration = Id.CommitteeDeRegistrationId +instance DbInfo CommitteeDeRegistration + +entityCommitteeDeRegistrationDecoder :: D.Row (Entity CommitteeDeRegistration) +entityCommitteeDeRegistrationDecoder = + Entity + <$> Id.idDecoder Id.CommitteeDeRegistrationId -- entityKey + <*> committeeDeRegistrationDecoder -- entityVal + +committeeDeRegistrationDecoder :: D.Row CommitteeDeRegistration +committeeDeRegistrationDecoder = + CommitteeDeRegistration + <$> Id.idDecoder Id.TxId -- committeeDeRegistration_TxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- committeeDeRegistration_CertIndex + <*> Id.maybeIdDecoder Id.VotingAnchorId -- committeeDeRegistration_VotingAnchorId + <*> Id.idDecoder Id.CommitteeHashId -- committeeDeRegistration_ColdKeyId + +entityCommitteeDeRegistrationEncoder :: E.Params (Entity CommitteeDeRegistration) +entityCommitteeDeRegistrationEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getCommitteeDeRegistrationId + , entityVal >$< committeeDeRegistrationEncoder + ] + +committeeDeRegistrationEncoder :: E.Params CommitteeDeRegistration +committeeDeRegistrationEncoder = + mconcat + [ committeeDeRegistration_TxId >$< Id.idEncoder Id.getTxId + , committeeDeRegistration_CertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , committeeDeRegistration_VotingAnchorId >$< Id.maybeIdEncoder Id.getVotingAnchorId + , committeeDeRegistration_ColdKeyId >$< Id.idEncoder Id.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 Id.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 :: !Id.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 = Id.ParamProposalId +instance DbInfo ParamProposal + +entityParamProposalDecoder :: D.Row (Entity ParamProposal) +entityParamProposalDecoder = + Entity + <$> Id.idDecoder Id.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 + <*> Id.maybeIdDecoder Id.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 + <*> Id.idDecoder Id.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 >$< Id.idEncoder Id.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 >$< Id.maybeIdEncoder Id.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 >$< Id.idEncoder Id.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 :: !Id.GovActionProposalId -- noreference + , treasuryWithdrawalStakeAddressId :: !Id.StakeAddressId -- noreference + , treasuryWithdrawalAmount :: !DbLovelace -- sqltype=lovelace + } + deriving (Eq, Show, Generic) + +type instance Key TreasuryWithdrawal = Id.TreasuryWithdrawalId +instance DbInfo TreasuryWithdrawal + +entityTreasuryWithdrawalDecoder :: D.Row (Entity TreasuryWithdrawal) +entityTreasuryWithdrawalDecoder = + Entity + <$> Id.idDecoder Id.TreasuryWithdrawalId -- entityKey + <*> treasuryWithdrawalDecoder -- entityVal + +treasuryWithdrawalDecoder :: D.Row TreasuryWithdrawal +treasuryWithdrawalDecoder = + TreasuryWithdrawal + <$> Id.idDecoder Id.GovActionProposalId -- treasuryWithdrawalGovActionProposalId + <*> Id.idDecoder Id.StakeAddressId -- treasuryWithdrawalStakeAddressId + <*> dbLovelaceDecoder -- treasuryWithdrawalAmount + +entityTreasuryWithdrawalEncoder :: E.Params (Entity TreasuryWithdrawal) +entityTreasuryWithdrawalEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getTreasuryWithdrawalId + , entityVal >$< treasuryWithdrawalEncoder + ] + +treasuryWithdrawalEncoder :: E.Params TreasuryWithdrawal +treasuryWithdrawalEncoder = + mconcat + [ treasuryWithdrawalGovActionProposalId >$< Id.idEncoder Id.getGovActionProposalId + , treasuryWithdrawalStakeAddressId >$< Id.idEncoder Id.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 Id.TxId) -- noreference + , eventInfoEpoch :: !Word64 -- sqltype=word31type + , eventInfoType :: !Text + , eventInfoExplanation :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key EventInfo = Id.EventInfoId +instance DbInfo EventInfo + +entityEventInfoDecoder :: D.Row (Entity EventInfo) +entityEventInfoDecoder = + Entity + <$> Id.idDecoder Id.EventInfoId -- entityKey + <*> eventInfoDecoder -- entityVal + +eventInfoDecoder :: D.Row EventInfo +eventInfoDecoder = + EventInfo + <$> Id.maybeIdDecoder Id.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 >$< Id.idEncoder Id.getEventInfoId + , entityVal >$< eventInfoEncoder + ] + +eventInfoEncoder :: E.Params EventInfo +eventInfoEncoder = + mconcat + [ eventInfoTxId >$< Id.maybeIdEncoder Id.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..014038c35 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/OffChain.hs @@ -0,0 +1,560 @@ +{-# 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, contrazip8, contrazip4) +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 qualified Cardano.Db.Schema.Ids as Id +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 :: !Id.PoolHashId -- noreference + , offChainPoolDataTickerName :: !Text + , offChainPoolDataHash :: !ByteString -- sqltype=hash32type + , offChainPoolDataJson :: !Text -- sqltype=jsonb + , offChainPoolDataBytes :: !ByteString -- sqltype=bytea + , offChainPoolDataPmrId :: !Id.PoolMetadataRefId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key OffChainPoolData = Id.OffChainPoolDataId +instance DbInfo OffChainPoolData where + uniqueFields _ = ["pool_id", "prm_id"] + +entityOffChainPoolDataDecoder :: D.Row (Entity OffChainPoolData) +entityOffChainPoolDataDecoder = + Entity + <$> Id.idDecoder Id.OffChainPoolDataId + <*> offChainPoolDataDecoder + +offChainPoolDataDecoder :: D.Row OffChainPoolData +offChainPoolDataDecoder = + OffChainPoolData + <$> Id.idDecoder Id.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 + <*> Id.idDecoder Id.PoolMetadataRefId -- offChainPoolDataPmrId + +entityOffChainPoolDataEncoder :: E.Params (Entity OffChainPoolData) +entityOffChainPoolDataEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getOffChainPoolDataId + , entityVal >$< offChainPoolDataEncoder + ] + +offChainPoolDataEncoder :: E.Params OffChainPoolData +offChainPoolDataEncoder = + mconcat + [ offChainPoolDataPoolId >$< Id.idEncoder Id.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 >$< Id.idEncoder Id.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 :: !Id.PoolHashId -- noreference + , offChainPoolFetchErrorFetchTime :: !UTCTime -- sqltype=timestamp + , offChainPoolFetchErrorPmrId :: !Id.PoolMetadataRefId -- noreference + , offChainPoolFetchErrorFetchError :: !Text + , offChainPoolFetchErrorRetryCount :: !Word -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key OffChainPoolFetchError = Id.OffChainPoolFetchErrorId +instance DbInfo OffChainPoolFetchError where + uniqueFields _ = ["pool_id", "fetch_time", "retry_count"] + +entityOffChainPoolFetchErrorDecoder :: D.Row (Entity OffChainPoolFetchError) +entityOffChainPoolFetchErrorDecoder = + Entity + <$> Id.idDecoder Id.OffChainPoolFetchErrorId + <*> offChainPoolFetchErrorDecoder + +offChainPoolFetchErrorDecoder :: D.Row OffChainPoolFetchError +offChainPoolFetchErrorDecoder = + OffChainPoolFetchError + <$> Id.idDecoder Id.PoolHashId -- offChainPoolFetchErrorPoolId + <*> D.column (D.nonNullable D.timestamptz) -- offChainPoolFetchErrorFetchTime + <*> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainPoolFetchErrorId + , entityVal >$< offChainPoolFetchErrorEncoder + ] + +offChainPoolFetchErrorEncoder :: E.Params OffChainPoolFetchError +offChainPoolFetchErrorEncoder = + mconcat + [ offChainPoolFetchErrorPoolId >$< Id.idEncoder Id.getPoolHashId + , offChainPoolFetchErrorFetchTime >$< E.param (E.nonNullable E.timestamptz) + , offChainPoolFetchErrorPmrId >$< Id.idEncoder Id.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 :: !Id.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 = Id.OffChainVoteDataId +instance DbInfo OffChainVoteData where + uniqueFields _ = ["hash", "voting_anchor_id"] + +entityOffChainVoteDataDecoder :: D.Row (Entity OffChainVoteData) +entityOffChainVoteDataDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteDataId + <*> offChainVoteDataDecoder + +offChainVoteDataDecoder :: D.Row OffChainVoteData +offChainVoteDataDecoder = + OffChainVoteData + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainVoteDataId + , entityVal >$< offChainVoteDataEncoder + ] + +offChainVoteDataEncoder :: E.Params OffChainVoteData +offChainVoteDataEncoder = + mconcat + [ offChainVoteDataVotingAnchorId >$< Id.idEncoder Id.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) + ] + +offChainVoteDataBulkEncoder :: E.Params ([Id.VotingAnchorId], [ByteString], [Text], [Maybe Text], [Text], [ByteString], [Maybe Text], [Maybe Bool]) +offChainVoteDataBulkEncoder = + contrazip8 + (bulkEncoder (Id.idBulkEncoder Id.getVotingAnchorId)) + (bulkEncoder (E.nonNullable E.bytea)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nonNullable E.bytea)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nullable E.bool)) + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: off_chain_vote_gov_action_data +-- Description: +----------------------------------------------------------------------------------------------------------------------------------- +data OffChainVoteGovActionData = OffChainVoteGovActionData + { offChainVoteGovActionDataOffChainVoteDataId :: !Id.OffChainVoteDataId -- noreference + , offChainVoteGovActionDataTitle :: !Text + , offChainVoteGovActionDataAbstract :: !Text + , offChainVoteGovActionDataMotivation :: !Text + , offChainVoteGovActionDataRationale :: !Text + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteGovActionData = Id.OffChainVoteGovActionDataId +instance DbInfo OffChainVoteGovActionData + +entityOffChainVoteGovActionDataDecoder :: D.Row (Entity OffChainVoteGovActionData) +entityOffChainVoteGovActionDataDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteGovActionDataId + <*> offChainVoteGovActionDataDecoder + +offChainVoteGovActionDataDecoder :: D.Row OffChainVoteGovActionData +offChainVoteGovActionDataDecoder = + OffChainVoteGovActionData + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainVoteGovActionDataId + , entityVal >$< offChainVoteGovActionDataEncoder + ] + +offChainVoteGovActionDataEncoder :: E.Params OffChainVoteGovActionData +offChainVoteGovActionDataEncoder = + mconcat + [ offChainVoteGovActionDataOffChainVoteDataId >$< Id.idEncoder Id.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) + ] + +offChainVoteGovActionDataBulkEncoder :: E.Params ([Id.OffChainVoteDataId], [Text], [Text], [Text], [Text]) +offChainVoteGovActionDataBulkEncoder = + contrazip5 + (bulkEncoder (Id.idBulkEncoder Id.getOffChainVoteDataId)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nonNullable E.text)) + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: off_chain_vote_drep_data +-- Description: +----------------------------------------------------------------------------------------------------------------------------------- +data OffChainVoteDrepData = OffChainVoteDrepData + { offChainVoteDrepDataOffChainVoteDataId :: !Id.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 = Id.OffChainVoteDrepDataId +instance DbInfo OffChainVoteDrepData + +entityOffChainVoteDrepDataDecoder :: D.Row (Entity OffChainVoteDrepData) +entityOffChainVoteDrepDataDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteDrepDataId + <*> offChainVoteDrepDataDecoder + +offChainVoteDrepDataDecoder :: D.Row OffChainVoteDrepData +offChainVoteDrepDataDecoder = + OffChainVoteDrepData + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainVoteDrepDataId + , entityVal >$< offChainVoteDrepDataEncoder + ] + +offChainVoteDrepDataEncoder :: E.Params OffChainVoteDrepData +offChainVoteDrepDataEncoder = + mconcat + [ offChainVoteDrepDataOffChainVoteDataId >$< Id.idEncoder Id.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) + ] + +offChainVoteDrepDataBulkEncoder :: E.Params ([Id.OffChainVoteDataId], [Maybe Text], [Text], [Maybe Text], [Maybe Text], [Maybe Text], [Maybe Text], [Maybe Text]) +offChainVoteDrepDataBulkEncoder = + contrazip8 + (bulkEncoder (Id.idBulkEncoder Id.getOffChainVoteDataId)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nullable E.text)) + (bulkEncoder (E.nullable E.text)) + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: off_chain_vote_author +-- Description: +----------------------------------------------------------------------------------------------------------------------------------- +data OffChainVoteAuthor = OffChainVoteAuthor + { offChainVoteAuthorOffChainVoteDataId :: !Id.OffChainVoteDataId -- noreference + , offChainVoteAuthorName :: !(Maybe Text) + , offChainVoteAuthorWitnessAlgorithm :: !Text + , offChainVoteAuthorPublicKey :: !Text + , offChainVoteAuthorSignature :: !Text + , offChainVoteAuthorWarning :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteAuthor = Id.OffChainVoteAuthorId +instance DbInfo OffChainVoteAuthor + +entityOffChainVoteAuthorDecoder :: D.Row (Entity OffChainVoteAuthor) +entityOffChainVoteAuthorDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteAuthorId + <*> offChainVoteAuthorDecoder + +offChainVoteAuthorDecoder :: D.Row OffChainVoteAuthor +offChainVoteAuthorDecoder = + OffChainVoteAuthor + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainVoteAuthorId + , entityVal >$< offChainVoteAuthorEncoder + ] + +offChainVoteAuthorEncoder :: E.Params OffChainVoteAuthor +offChainVoteAuthorEncoder = + mconcat + [ offChainVoteAuthorOffChainVoteDataId >$< Id.idEncoder Id.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 ([Id.OffChainVoteDataId], [Maybe Text], [Text], [Text], [Text], [Maybe Text]) +offChainVoteAuthorBulkEncoder = + contrazip6 + (bulkEncoder $ Id.idBulkEncoder Id.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 :: !Id.OffChainVoteDataId -- noreference + , offChainVoteReferenceLabel :: !Text + , offChainVoteReferenceUri :: !Text + , offChainVoteReferenceHashDigest :: !(Maybe Text) + , offChainVoteReferenceHashAlgorithm :: !(Maybe Text) + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteReference = Id.OffChainVoteReferenceId +instance DbInfo OffChainVoteReference + +entityOffChainVoteReferenceDecoder :: D.Row (Entity OffChainVoteReference) +entityOffChainVoteReferenceDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteReferenceId + <*> offChainVoteReferenceDecoder + +offChainVoteReferenceDecoder :: D.Row OffChainVoteReference +offChainVoteReferenceDecoder = + OffChainVoteReference + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainVoteReferenceId + , entityVal >$< offChainVoteReferenceEncoder + ] + +offChainVoteReferenceEncoder :: E.Params OffChainVoteReference +offChainVoteReferenceEncoder = + mconcat + [ offChainVoteReferenceOffChainVoteDataId >$< Id.idEncoder Id.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 ([Id.OffChainVoteDataId], [Text], [Text], [Maybe Text], [Maybe Text]) +offChainVoteReferenceBulkEncoder = + contrazip5 + (bulkEncoder $ Id.idBulkEncoder Id.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 :: !Id.OffChainVoteDataId -- noreference + , offChainVoteExternalUpdateTitle :: !Text + , offChainVoteExternalUpdateUri :: !Text + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteExternalUpdate = Id.OffChainVoteExternalUpdateId +instance DbInfo OffChainVoteExternalUpdate + +entityOffChainVoteExternalUpdateDecoder :: D.Row (Entity OffChainVoteExternalUpdate) +entityOffChainVoteExternalUpdateDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteExternalUpdateId + <*> offChainVoteExternalUpdateDecoder + +offChainVoteExternalUpdateDecoder :: D.Row OffChainVoteExternalUpdate +offChainVoteExternalUpdateDecoder = + OffChainVoteExternalUpdate + <$> Id.idDecoder Id.OffChainVoteDataId -- offChainVoteExternalUpdateOffChainVoteDataId + <*> D.column (D.nonNullable D.text) -- offChainVoteExternalUpdateTitle + <*> D.column (D.nonNullable D.text) -- offChainVoteExternalUpdateUri + +entityOffChainVoteExternalUpdateEncoder :: E.Params (Entity OffChainVoteExternalUpdate) +entityOffChainVoteExternalUpdateEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getOffChainVoteExternalUpdateId + , entityVal >$< offChainVoteExternalUpdateEncoder + ] + +offChainVoteExternalUpdateEncoder :: E.Params OffChainVoteExternalUpdate +offChainVoteExternalUpdateEncoder = + mconcat + [ offChainVoteExternalUpdateOffChainVoteDataId >$< Id.idEncoder Id.getOffChainVoteDataId + , offChainVoteExternalUpdateTitle >$< E.param (E.nonNullable E.text) + , offChainVoteExternalUpdateUri >$< E.param (E.nonNullable E.text) + ] + +offChainVoteExternalUpdatesEncoder :: E.Params ([Id.OffChainVoteDataId], [Text], [Text]) +offChainVoteExternalUpdatesEncoder = + contrazip3 + (bulkEncoder $ Id.idBulkEncoder Id.getOffChainVoteDataId) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + +offChainVoteExternalUpdatesBulkEncoder :: E.Params ([Id.OffChainVoteDataId], [Text], [Text]) +offChainVoteExternalUpdatesBulkEncoder = + contrazip3 + (bulkEncoder $ Id.idBulkEncoder Id.getOffChainVoteDataId) + (bulkEncoder $ E.nonNullable E.text) + (bulkEncoder $ E.nonNullable E.text) + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: off_chain_vote_fetch_error +-- Description: +----------------------------------------------------------------------------------------------------------------------------------- +data OffChainVoteFetchError = OffChainVoteFetchError + { offChainVoteFetchErrorVotingAnchorId :: !Id.VotingAnchorId -- noreference + , offChainVoteFetchErrorFetchError :: !Text + , offChainVoteFetchErrorFetchTime :: !UTCTime -- sqltype=timestamp + , offChainVoteFetchErrorRetryCount :: !Word -- sqltype=word31type + } + deriving (Eq, Show, Generic) + +type instance Key OffChainVoteFetchError = Id.OffChainVoteFetchErrorId +instance DbInfo OffChainVoteFetchError where + uniqueFields _ = ["voting_anchor_id", "retry_count"] + +entityOffChainVoteFetchErrorDecoder :: D.Row (Entity OffChainVoteFetchError) +entityOffChainVoteFetchErrorDecoder = + Entity + <$> Id.idDecoder Id.OffChainVoteFetchErrorId + <*> offChainVoteFetchErrorDecoder + +offChainVoteFetchErrorDecoder :: D.Row OffChainVoteFetchError +offChainVoteFetchErrorDecoder = + OffChainVoteFetchError + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getOffChainVoteFetchErrorId + , entityVal >$< offChainVoteFetchErrorEncoder + ] + +offChainVoteFetchErrorEncoder :: E.Params OffChainVoteFetchError +offChainVoteFetchErrorEncoder = + mconcat + [ offChainVoteFetchErrorVotingAnchorId >$< Id.idEncoder Id.getVotingAnchorId + , offChainVoteFetchErrorFetchError >$< E.param (E.nonNullable E.text) + , offChainVoteFetchErrorFetchTime >$< E.param (E.nonNullable E.timestamptz) + , offChainVoteFetchErrorRetryCount >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + ] + +offChainVoteFetchErrorBulkEncoder :: E.Params ([Id.VotingAnchorId], [Text], [UTCTime], [Word]) +offChainVoteFetchErrorBulkEncoder = + contrazip4 + (bulkEncoder (Id.idBulkEncoder Id.getVotingAnchorId)) + (bulkEncoder (E.nonNullable E.text)) + (bulkEncoder (E.nonNullable E.timestamptz)) + (bulkEncoder (E.nonNullable (fromIntegral >$< E.int4))) 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..fcd2d0aaa --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Core/Pool.hs @@ -0,0 +1,465 @@ +{-# 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 Contravariant.Extras (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 qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.Orphans () +import Cardano.Db.Schema.Types ( + PoolUrl (..), + unPoolUrl, + ) +import Cardano.Db.Statement.Function.Core (bulkEncoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), Key) +import Cardano.Db.Types ( + DbLovelace (..), + DbWord64 (..), + dbLovelaceDecoder, + dbLovelaceEncoder, + ) + +----------------------------------------------------------------------------------------------------------------------------------- +-- 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 = Id.PoolHashId +instance DbInfo PoolHash where + uniqueFields _ = ["hash_raw"] + +entityPoolHashDecoder :: D.Row (Entity PoolHash) +entityPoolHashDecoder = + Entity + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.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 :: !Id.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 = Id.PoolStatId +instance DbInfo PoolStat + +entityPoolStatDecoder :: D.Row (Entity PoolStat) +entityPoolStatDecoder = + Entity + <$> Id.idDecoder Id.PoolStatId + <*> poolStatDecoder + +poolStatDecoder :: D.Row PoolStat +poolStatDecoder = + PoolStat + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getPoolStatId + , entityVal >$< poolStatEncoder + ] + +poolStatEncoder :: E.Params PoolStat +poolStatEncoder = + mconcat + [ poolStatPoolHashId >$< Id.idEncoder Id.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 ([Id.PoolHashId], [Word64], [DbWord64], [DbWord64], [DbWord64], [Maybe DbWord64]) +poolStatBulkEncoder = + contrazip6 + (bulkEncoder $ E.nonNullable $ Id.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 :: !Id.PoolHashId -- noreference + , poolUpdateCertIndex :: !Word16 + , poolUpdateVrfKeyHash :: !ByteString -- sqltype=hash32type + , poolUpdatePledge :: !DbLovelace -- sqltype=lovelace + , poolUpdateRewardAddrId :: !Id.StakeAddressId -- noreference + , poolUpdateActiveEpochNo :: !Word64 + , poolUpdateMetaId :: !(Maybe Id.PoolMetadataRefId) -- noreference + , poolUpdateMargin :: !Double -- sqltype=percentage???? + , poolUpdateFixedCost :: !DbLovelace -- sqltype=lovelace + , poolUpdateDeposit :: !(Maybe DbLovelace) -- sqltype=lovelace + , poolUpdateRegisteredTxId :: !Id.TxId -- noreference -- Slot number in which the pool was registered. + } + deriving (Eq, Show, Generic) + +type instance Key PoolUpdate = Id.PoolUpdateId +instance DbInfo PoolUpdate + +entityPoolUpdateDecoder :: D.Row (Entity PoolUpdate) +entityPoolUpdateDecoder = + Entity + <$> Id.idDecoder Id.PoolUpdateId + <*> poolUpdateDecoder + +poolUpdateDecoder :: D.Row PoolUpdate +poolUpdateDecoder = + PoolUpdate + <$> Id.idDecoder Id.PoolHashId -- poolUpdateHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- poolUpdateCertIndex (Word16) + <*> D.column (D.nonNullable D.bytea) -- poolUpdateVrfKeyHash + <*> dbLovelaceDecoder -- poolUpdatePledge + <*> Id.idDecoder Id.StakeAddressId -- poolUpdateRewardAddrId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- poolUpdateActiveEpochNo + <*> Id.maybeIdDecoder Id.PoolMetadataRefId -- poolUpdateMetaId + <*> D.column (D.nonNullable D.float8) -- poolUpdateMargin + <*> dbLovelaceDecoder -- poolUpdateFixedCost + <*> D.column (D.nullable $ DbLovelace . fromIntegral <$> D.int8) -- poolUpdateDeposit + <*> Id.idDecoder Id.TxId -- poolUpdateRegisteredTxId + +entityPoolUpdateEncoder :: E.Params (Entity PoolUpdate) +entityPoolUpdateEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getPoolUpdateId + , entityVal >$< poolUpdateEncoder + ] + +poolUpdateEncoder :: E.Params PoolUpdate +poolUpdateEncoder = + mconcat + [ poolUpdateHashId >$< Id.idEncoder Id.getPoolHashId + , poolUpdateCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , poolUpdateVrfKeyHash >$< E.param (E.nonNullable E.bytea) + , poolUpdatePledge >$< dbLovelaceEncoder + , poolUpdateRewardAddrId >$< Id.idEncoder Id.getStakeAddressId + , poolUpdateActiveEpochNo >$< E.param (E.nonNullable $ fromIntegral >$< E.int8) + , poolUpdateMetaId >$< Id.maybeIdEncoder Id.getPoolMetadataRefId + , poolUpdateMargin >$< E.param (E.nonNullable E.float8) + , poolUpdateFixedCost >$< dbLovelaceEncoder + , poolUpdateDeposit >$< E.param (E.nullable $ fromIntegral . unDbLovelace >$< E.int8) + , poolUpdateRegisteredTxId >$< Id.idEncoder Id.getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: pool_metadata_ref +-- Description: A table containing references to pool metadata. +----------------------------------------------------------------------------------------------------------------------------------- +data PoolMetadataRef = PoolMetadataRef + { poolMetadataRefPoolId :: !Id.PoolHashId -- noreference + , poolMetadataRefUrl :: !PoolUrl -- sqltype=varchar + , poolMetadataRefHash :: !ByteString -- sqltype=hash32type + , poolMetadataRefRegisteredTxId :: !Id.TxId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key PoolMetadataRef = Id.PoolMetadataRefId +instance DbInfo PoolMetadataRef + +entityPoolMetadataRefDecoder :: D.Row (Entity PoolMetadataRef) +entityPoolMetadataRefDecoder = + Entity + <$> Id.idDecoder Id.PoolMetadataRefId + <*> poolMetadataRefDecoder + +poolMetadataRefDecoder :: D.Row PoolMetadataRef +poolMetadataRefDecoder = + PoolMetadataRef + <$> Id.idDecoder Id.PoolHashId -- poolMetadataRefPoolId + <*> D.column (D.nonNullable (PoolUrl <$> D.text)) -- poolMetadataRefUrl + <*> D.column (D.nonNullable D.bytea) -- poolMetadataRefHash + <*> Id.idDecoder Id.TxId -- poolMetadataRefRegisteredTxId + +entityPoolMetadataRefEncoder :: E.Params (Entity PoolMetadataRef) +entityPoolMetadataRefEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getPoolMetadataRefId + , entityVal >$< poolMetadataRefEncoder + ] + +poolMetadataRefEncoder :: E.Params PoolMetadataRef +poolMetadataRefEncoder = + mconcat + [ poolMetadataRefPoolId >$< Id.idEncoder Id.getPoolHashId + , poolMetadataRefUrl >$< E.param (E.nonNullable (unPoolUrl >$< E.text)) + , poolMetadataRefHash >$< E.param (E.nonNullable E.bytea) + , poolMetadataRefRegisteredTxId >$< Id.idEncoder Id.getTxId + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: pool_owner +-- Description: A table containing information about pool owners. +----------------------------------------------------------------------------------------------------------------------------------- +data PoolOwner = PoolOwner + { poolOwnerAddrId :: !Id.StakeAddressId -- noreference + , poolOwnerPoolUpdateId :: !Id.PoolUpdateId -- noreference + } + deriving (Eq, Show, Generic) + +type instance Key PoolOwner = Id.PoolOwnerId +instance DbInfo PoolOwner + +entityPoolOwnerDecoder :: D.Row (Entity PoolOwner) +entityPoolOwnerDecoder = + Entity + <$> Id.idDecoder Id.PoolOwnerId + <*> poolOwnerDecoder + +poolOwnerDecoder :: D.Row PoolOwner +poolOwnerDecoder = + PoolOwner + <$> Id.idDecoder Id.StakeAddressId -- poolOwnerAddrId + <*> Id.idDecoder Id.PoolUpdateId -- poolOwnerPoolUpdateId + +entityPoolOwnerEncoder :: E.Params (Entity PoolOwner) +entityPoolOwnerEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getPoolOwnerId + , entityVal >$< poolOwnerEncoder + ] + +poolOwnerEncoder :: E.Params PoolOwner +poolOwnerEncoder = + mconcat + [ poolOwnerAddrId >$< Id.idEncoder Id.getStakeAddressId + , poolOwnerPoolUpdateId >$< Id.idEncoder Id.getPoolUpdateId + ] + +----------------------------------------------------------------------------------------------------------------------------------- +-- Table Name: pool_retire +-- Description: A table containing information about pool retirements. +----------------------------------------------------------------------------------------------------------------------------------- +data PoolRetire = PoolRetire + { poolRetireHashId :: !Id.PoolHashId -- noreference + , poolRetireCertIndex :: !Word16 + , poolRetireAnnouncedTxId :: !Id.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 = Id.PoolRetireId +instance DbInfo PoolRetire + +entityPoolRetireDecoder :: D.Row (Entity PoolRetire) +entityPoolRetireDecoder = + Entity + <$> Id.idDecoder Id.PoolRetireId + <*> poolRetireDecoder + +poolRetireDecoder :: D.Row PoolRetire +poolRetireDecoder = + PoolRetire + <$> Id.idDecoder Id.PoolHashId -- poolRetireHashId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int2) -- poolRetireCertIndex + <*> Id.idDecoder Id.TxId -- poolRetireAnnouncedTxId + <*> D.column (D.nonNullable $ fromIntegral <$> D.int8) -- poolRetireRetiringEpoch + +entityPoolRetireEncoder :: E.Params (Entity PoolRetire) +entityPoolRetireEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.getPoolRetireId + , entityVal >$< poolRetireEncoder + ] + +poolRetireEncoder :: E.Params PoolRetire +poolRetireEncoder = + mconcat + [ poolRetireHashId >$< Id.idEncoder Id.getPoolHashId + , poolRetireCertIndex >$< E.param (E.nonNullable $ fromIntegral >$< E.int2) + , poolRetireAnnouncedTxId >$< Id.idEncoder Id.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 :: !Id.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 = Id.PoolRelayId +instance DbInfo PoolRelay + +entityPoolRelayDecoder :: D.Row (Entity PoolRelay) +entityPoolRelayDecoder = + Entity + <$> Id.idDecoder Id.PoolRelayId + <*> poolRelayDecoder + +poolRelayDecoder :: D.Row PoolRelay +poolRelayDecoder = + PoolRelay + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.getPoolRelayId + , entityVal >$< poolRelayEncoder + ] + +poolRelayEncoder :: E.Params PoolRelay +poolRelayEncoder = + mconcat + [ poolRelayUpdateId >$< Id.idEncoder Id.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 = Id.DelistedPoolId +instance DbInfo DelistedPool where + uniqueFields _ = ["hash_raw"] + +entityDelistedPoolDecoder :: D.Row (Entity DelistedPool) +entityDelistedPoolDecoder = + Entity + <$> Id.idDecoder Id.DelistedPoolId + <*> delistedPoolDecoder + +delistedPoolDecoder :: D.Row DelistedPool +delistedPoolDecoder = + DelistedPool + <$> D.column (D.nonNullable D.bytea) -- delistedPoolHashRaw + +entityDelistedPoolEncoder :: E.Params (Entity DelistedPool) +entityDelistedPoolEncoder = + mconcat + [ entityKey >$< Id.idEncoder Id.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 = Id.ReservedPoolTickerId +instance DbInfo ReservedPoolTicker where + uniqueFields _ = ["name"] + +entityReservedPoolTickerDecoder :: D.Row (Entity ReservedPoolTicker) +entityReservedPoolTickerDecoder = + Entity + <$> Id.idDecoder Id.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 >$< Id.idEncoder Id.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..1811b9ad2 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Ids.hs @@ -0,0 +1,317 @@ +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) + +idBulkDecoder :: (Int64 -> a) -> D.Result [a] +idBulkDecoder f = D.rowList $ D.column (D.nonNullable $ 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/MinIds.hs b/cardano-db/src/Cardano/Db/Schema/MinIds.hs new file mode 100644 index 000000000..a38e88445 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/MinIds.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.Db.Schema.MinIds where + +import Cardano.Prelude +import qualified Data.Text as Text +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import Text.Read (read) + +import Cardano.Db.Schema.Core.Base (TxIn) +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.Variants (MaTxOutIdW (..), TxOutIdW (..), TxOutVariantType (..)) +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC +import qualified Cardano.Db.Schema.Variants.TxOutAddress as VA +import Cardano.Db.Statement.Function.Query (queryMinRefId) +import Cardano.Db.Statement.Types (DbInfo, Key) +import Cardano.Db.Types (DbAction) + +-------------------------------------------------------------------------------- +-- MinIds and MinIdsWrapper +-------------------------------------------------------------------------------- +data MinIds = MinIds + { minTxInId :: !(Maybe Id.TxInId) + , minTxOutId :: !(Maybe TxOutIdW) + , minMaTxOutId :: !(Maybe MaTxOutIdW) + } + +instance Monoid MinIds where + mempty = MinIds Nothing Nothing Nothing + +instance Semigroup MinIds where + mn1 <> mn2 = + MinIds + { minTxInId = minJust (minTxInId mn1) (minTxInId mn2) + , minTxOutId = minJustBy compareTxOutIds (minTxOutId mn1) (minTxOutId mn2) + , minMaTxOutId = minJustBy compareMaTxOutIds (minMaTxOutId mn1) (minMaTxOutId mn2) + } + +data MinIdsWrapper + = CMinIdsWrapper !MinIds + | VMinIdsWrapper !MinIds + +instance Monoid MinIdsWrapper where + mempty = CMinIdsWrapper mempty + +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 + +-------------------------------------------------------------------------------- +-- Helper functions for MinIds +-------------------------------------------------------------------------------- +compareTxOutIds :: TxOutIdW -> TxOutIdW -> Ordering +compareTxOutIds (VCTxOutIdW a) (VCTxOutIdW b) = compare (Id.getTxOutCoreId a) (Id.getTxOutCoreId b) +compareTxOutIds (VATxOutIdW a) (VATxOutIdW b) = compare (Id.getTxOutAddressId a) (Id.getTxOutAddressId b) +compareTxOutIds _ _ = EQ -- Different types can't be compared meaningfully + +compareMaTxOutIds :: MaTxOutIdW -> MaTxOutIdW -> Ordering +compareMaTxOutIds (CMaTxOutIdW a) (CMaTxOutIdW b) = compare (Id.getMaTxOutCoreId a) (Id.getMaTxOutCoreId b) +compareMaTxOutIds (VMaTxOutIdW a) (VMaTxOutIdW b) = compare (Id.getMaTxOutAddressId a) (Id.getMaTxOutAddressId b) +compareMaTxOutIds _ _ = EQ + +minJustBy :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Maybe a +minJustBy _ Nothing y = y +minJustBy _ x Nothing = x +minJustBy cmp (Just x) (Just y) = Just (if cmp x y == LT then x else y) + +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) + +extractCoreTxOutId :: Maybe TxOutIdW -> Maybe Id.TxOutCoreId +extractCoreTxOutId = + ( >>= + \case + VCTxOutIdW id -> Just id + _otherwise -> Nothing + ) + +extractVariantTxOutId :: Maybe TxOutIdW -> Maybe Id.TxOutAddressId +extractVariantTxOutId = + ( >>= + \case + VATxOutIdW id -> Just id + _otherwise -> Nothing + ) + +extractCoreMaTxOutId :: Maybe MaTxOutIdW -> Maybe Id.MaTxOutCoreId +extractCoreMaTxOutId = + ( >>= + \case + CMaTxOutIdW id -> Just id + _otherwise -> Nothing + ) + +extractVariantMaTxOutId :: Maybe MaTxOutIdW -> Maybe Id.MaTxOutAddressId +extractVariantMaTxOutId = + ( >>= + \case + VMaTxOutIdW id -> Just id + _otherwise -> Nothing + ) + +-------------------------------------------------------------------------------- +-- Text serialization for MinIds +-------------------------------------------------------------------------------- +minIdsCoreToText :: MinIds -> Text +minIdsCoreToText minIds = + Text.intercalate + ":" + [ maybe "" (Text.pack . show . Id.getTxInId) $ minTxInId minIds + , maybe "" txOutIdCoreToText $ minTxOutId minIds + , maybe "" maTxOutIdCoreToText $ minMaTxOutId minIds + ] + where + txOutIdCoreToText :: TxOutIdW -> Text + txOutIdCoreToText (VCTxOutIdW txOutId) = Text.pack . show $ Id.getTxOutCoreId txOutId + txOutIdCoreToText _ = "" -- Skip non-core IDs + + maTxOutIdCoreToText :: MaTxOutIdW -> Text + maTxOutIdCoreToText (CMaTxOutIdW maTxOutId) = Text.pack . show $ Id.getMaTxOutCoreId maTxOutId + maTxOutIdCoreToText _ = "" -- Skip non-core IDs + +minIdsAddressToText :: MinIds -> Text +minIdsAddressToText minIds = + Text.intercalate + ":" + [ maybe "" (Text.pack . show . Id.getTxInId) $ minTxInId minIds + , maybe "" txOutIdAddressToText $ minTxOutId minIds + , maybe "" maTxOutIdAddressToText $ minMaTxOutId minIds + ] + where + txOutIdAddressToText :: TxOutIdW -> Text + txOutIdAddressToText (VATxOutIdW txOutId) = Text.pack . show $ Id.getTxOutAddressId txOutId + txOutIdAddressToText _ = "" -- Skip non-variant IDs + + maTxOutIdAddressToText :: MaTxOutIdW -> Text + maTxOutIdAddressToText (VMaTxOutIdW maTxOutId) = Text.pack . show $ Id.getMaTxOutAddressId maTxOutId + maTxOutIdAddressToText _ = "" -- Skip non-variant IDs + +-------------------------------------------------------------------------------- +minIdsToText :: MinIdsWrapper -> Text +minIdsToText (CMinIdsWrapper minIds) = minIdsToTextHelper minIds "C" +minIdsToText (VMinIdsWrapper minIds) = minIdsToTextHelper minIds "V" + +minIdsToTextHelper :: MinIds -> Text -> Text +minIdsToTextHelper minIds prefix = + Text.intercalate + ":" + [ txInIdText + , txOutIdText + , maTxOutIdText + , prefix -- Add type identifier + ] + where + txInIdText = maybe "" (Text.pack . show . Id.getTxInId) $ minTxInId minIds + + txOutIdText = case minTxOutId minIds of + Nothing -> "" + Just (VCTxOutIdW id) -> "C" <> Text.pack (show (Id.getTxOutCoreId id)) + Just (VATxOutIdW id) -> "V" <> Text.pack (show (Id.getTxOutAddressId id)) + + maTxOutIdText = case minMaTxOutId minIds of + Nothing -> "" + Just (CMaTxOutIdW id) -> "C" <> Text.pack (show (Id.getMaTxOutCoreId id)) + Just (VMaTxOutIdW id) -> "V" <> Text.pack (show (Id.getMaTxOutAddressId id)) + +-------------------------------------------------------------------------------- +textToMinIds :: TxOutVariantType -> Text -> Maybe MinIdsWrapper +textToMinIds txOutVariantType txt = + case Text.split (== ':') txt of + [tminTxInId, tminTxOutId, tminMaTxOutId, typeId] -> + let + mTxInId = + if Text.null tminTxInId + then Nothing + else Just $ Id.TxInId $ read $ Text.unpack tminTxInId + + mTxOutId = + if Text.null tminTxOutId + then Nothing + else case Text.head tminTxOutId of + 'C' -> + Just $ + VCTxOutIdW $ + Id.TxOutCoreId $ + read $ + Text.unpack $ + Text.tail tminTxOutId + 'V' -> + Just $ + VATxOutIdW $ + Id.TxOutAddressId $ + read $ + Text.unpack $ + Text.tail tminTxOutId + _ -> Nothing + + mMaTxOutId = + if Text.null tminMaTxOutId + then Nothing + else case Text.head tminMaTxOutId of + 'C' -> + Just $ + CMaTxOutIdW $ + Id.MaTxOutCoreId $ + read $ + Text.unpack $ + Text.tail tminMaTxOutId + 'V' -> + Just $ + VMaTxOutIdW $ + Id.MaTxOutAddressId $ + read $ + Text.unpack $ + Text.tail tminMaTxOutId + _ -> Nothing + + minIds = MinIds mTxInId mTxOutId mMaTxOutId + in + case (txOutVariantType, typeId) of + (TxOutVariantCore, "C") -> Just $ CMinIdsWrapper minIds + (TxOutVariantAddress, "V") -> Just $ VMinIdsWrapper minIds + _otherwise -> Nothing + _otherwise -> Nothing + +-------------------------------------------------------------------------------- +-- CompleteMinId +-------------------------------------------------------------------------------- +completeMinId :: + (MonadIO m) => + Maybe Id.TxId -> + MinIdsWrapper -> + DbAction m MinIdsWrapper +completeMinId mTxId mIdW = case mIdW of + CMinIdsWrapper minIds -> CMinIdsWrapper <$> completeMinIdCore mTxId minIds + VMinIdsWrapper minIds -> VMinIdsWrapper <$> completeMinIdVariant mTxId minIds + +completeMinIdCore :: MonadIO m => Maybe Id.TxId -> MinIds -> DbAction m MinIds +completeMinIdCore mTxId minIds = do + case mTxId of + Nothing -> pure mempty + Just txId -> do + mTxInId <- + whenNothingQueryMinRefId @TxIn + (minTxInId minIds) + "tx_in_id" + txId + (Id.idEncoder Id.getTxId) + (Id.idDecoder Id.TxInId) + + mTxOutId <- + whenNothingQueryMinRefId @VC.TxOutCore + (extractCoreTxOutId $ minTxOutId minIds) + "tx_id" + txId + (Id.idEncoder Id.getTxId) + (Id.idDecoder Id.TxOutCoreId) + + mMaTxOutId <- case mTxOutId of + Nothing -> pure Nothing + Just txOutId -> + whenNothingQueryMinRefId @VC.MaTxOutCore + (extractCoreMaTxOutId $ minMaTxOutId minIds) + "tx_out_id" + txOutId + (Id.idEncoder Id.getTxOutCoreId) + (Id.idDecoder Id.MaTxOutCoreId) + + pure $ + MinIds + { minTxInId = mTxInId + , minTxOutId = VCTxOutIdW <$> mTxOutId + , minMaTxOutId = CMaTxOutIdW <$> mMaTxOutId + } + +completeMinIdVariant :: MonadIO m => Maybe Id.TxId -> MinIds -> DbAction m MinIds +completeMinIdVariant mTxId minIds = do + case mTxId of + Nothing -> pure mempty + Just txId -> do + mTxInId <- + whenNothingQueryMinRefId @TxIn + (minTxInId minIds) + "tx_in_id" + txId + (Id.idEncoder Id.getTxId) + (Id.idDecoder Id.TxInId) + + mTxOutId <- + whenNothingQueryMinRefId @VA.TxOutAddress + (extractVariantTxOutId $ minTxOutId minIds) + "tx_id" + txId + (Id.idEncoder Id.getTxId) + (Id.idDecoder Id.TxOutAddressId) + + mMaTxOutId <- case mTxOutId of + Nothing -> pure Nothing + Just txOutId -> + whenNothingQueryMinRefId @VA.MaTxOutAddress + (extractVariantMaTxOutId $ minMaTxOutId minIds) + "tx_out_id" + txOutId + (Id.idEncoder Id.getTxOutAddressId) + (Id.idDecoder Id.MaTxOutAddressId) + + pure $ + MinIds + { minTxInId = mTxInId + , minTxOutId = VATxOutIdW <$> mTxOutId + , minMaTxOutId = VMaTxOutIdW <$> mMaTxOutId + } + +whenNothingQueryMinRefId :: + forall a b m. + (DbInfo a, MonadIO m) => + Maybe (Key a) -> -- Existing key value + Text -> -- Field name + b -> -- Value to compare + HsqlE.Params b -> -- Encoder for value + HsqlD.Row (Key a) -> -- Decoder for key + DbAction m (Maybe (Key a)) +whenNothingQueryMinRefId mKey fieldName value encoder keyDecoder = + case mKey of + Just k -> pure $ Just k + Nothing -> queryMinRefId fieldName value encoder keyDecoder 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/Types.hs b/cardano-db/src/Cardano/Db/Schema/Types.hs index 9395ed55b..6d4b99bb2 100644 --- a/cardano-db/src/Cardano/Db/Schema/Types.hs +++ b/cardano-db/src/Cardano/Db/Schema/Types.hs @@ -1,17 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -module Cardano.Db.Schema.Types ( - AddressHash (..), - PaymentAddrHash (..), - PoolMetaHash (..), - PoolUrl (..), -) where +module Cardano.Db.Schema.Types where import Data.ByteString.Char8 (ByteString) import Data.Text (Text) import GHC.Generics (Generic) import Quiet (Quiet (..)) +import qualified Hasql.Decoders as HsqlD newtype AddressHash -- Length (28 bytes) enforced by Postgres = AddressHash {unAddressHash :: ByteString} @@ -37,3 +33,6 @@ newtype PoolMetaHash = PoolMetaHash {unPoolMetaHash :: ByteString} newtype PoolUrl = PoolUrl {unPoolUrl :: Text} deriving (Eq, Ord, Generic) deriving (Show) via (Quiet PoolUrl) + +poolUrlDecoder :: HsqlD.Value PoolUrl +poolUrlDecoder = PoolUrl <$> HsqlD.text 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..952e317c5 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants.hs @@ -0,0 +1,122 @@ +module Cardano.Db.Schema.Variants where + +import qualified Cardano.Db.Schema.Ids as Id +import qualified Cardano.Db.Schema.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC +import Cardano.Prelude (ByteString, Text) + +-------------------------------------------------------------------------------- +-- TxOutVariantType +-------------------------------------------------------------------------------- +data TxOutVariantType = TxOutVariantCore | TxOutVariantAddress + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- TxOutW +-------------------------------------------------------------------------------- +data TxOutW + = VCTxOutW !VC.TxOutCore + | VATxOutW !VA.TxOutAddress !(Maybe VA.Address) + deriving (Eq, Show) + +data TxOutIdW + = VCTxOutIdW !Id.TxOutCoreId + | VATxOutIdW !Id.TxOutAddressId + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- MaTxOutW +-------------------------------------------------------------------------------- +data MaTxOutW + = CMaTxOutW !VC.MaTxOutCore + | VMaTxOutW !VA.MaTxOutAddress + deriving (Eq, Show) + +data MaTxOutIdW + = CMaTxOutIdW !Id.MaTxOutCoreId + | VMaTxOutIdW !Id.MaTxOutAddressId + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- CollateralTxOutW +-------------------------------------------------------------------------------- +data CollateralTxOutW + = CCollateralTxOutW !VC.CollateralTxOutCore + | VCollateralTxOutW !VA.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 unwrapTxOutIdCore + +unwrapTxOutIdCore :: TxOutIdW -> Maybe Id.TxOutCoreId +unwrapTxOutIdCore (VCTxOutIdW txOutid) = Just txOutid +unwrapTxOutIdCore _ = Nothing + +-- -------------------------------------------------------------------------------- +-- convertTxOutIdAddress :: [TxOutIdW] -> [Id.TxOutAddressId] +-- convertTxOutIdAddress = mapMaybe unwrapTxOutIdAddress + +unwrapTxOutIdAddress :: TxOutIdW -> Maybe Id.TxOutAddressId +unwrapTxOutIdAddress (VATxOutIdW txOutid) = Just txOutid +unwrapTxOutIdAddress _ = Nothing + +-- -------------------------------------------------------------------------------- +-- convertMaTxOutIdCore :: [MaTxOutIdW] -> [Id.MaTxOutCoreId] +-- convertMaTxOutIdCore = mapMaybe unwrapMaTxOutIdCore + +unwrapMaTxOutIdCore :: MaTxOutIdW -> Maybe Id.MaTxOutCoreId +unwrapMaTxOutIdCore (CMaTxOutIdW maTxOutId) = Just maTxOutId +unwrapMaTxOutIdCore _ = Nothing + +-- -------------------------------------------------------------------------------- +-- convertMaTxOutIdAddress :: [MaTxOutIdW] -> [Id.MaTxOutAddressId] +-- convertMaTxOutIdAddress = mapMaybe unwrapMaTxOutIdAddress + +unwrapMaTxOutIdAddress :: MaTxOutIdW -> Maybe Id.MaTxOutAddressId +unwrapMaTxOutIdAddress (VMaTxOutIdW maTxOutId) = Just maTxOutId +unwrapMaTxOutIdAddress _ = Nothing + +-- -------------------------------------------------------------------------------- +-- convertCollateralTxOutIdCore :: [CollateralTxOutIdW] -> [Id.CollateralTxOutCoreId] +-- convertCollateralTxOutIdCore = mapMaybe unwrapCollateralTxOutIdCore + +unwrapCollateralTxOutIdCore :: CollateralTxOutIdW -> Maybe Id.CollateralTxOutCoreId +unwrapCollateralTxOutIdCore (CCollateralTxOutIdW iD) = Just iD +unwrapCollateralTxOutIdCore _ = Nothing + +-- -------------------------------------------------------------------------------- +-- convertCollateralTxOutIdAddress :: [CollateralTxOutIdW] -> [Id.CollateralTxOutAddressId] +-- convertCollateralTxOutIdAddress = mapMaybe unwrapCollateralTxOutIdAddress + +unwrapCollateralTxOutIdAddress :: CollateralTxOutIdW -> Maybe Id.CollateralTxOutAddressId +unwrapCollateralTxOutIdAddress (VCollateralTxOutIdW iD) = Just iD +unwrapCollateralTxOutIdAddress _ = Nothing + +-------------------------------------------------------------------------------- +isTxOutCore :: TxOutVariantType -> Bool +isTxOutCore TxOutVariantCore = True +isTxOutCore _ = False + +isTxOutAddress :: TxOutVariantType -> Bool +isTxOutAddress TxOutVariantAddress = 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..670eb0bc1 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Schema/Variants/TxOutAddress.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Schema.Variants.TxOutAddress where + +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 + +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) + +----------------------------------------------------------------------------------------------- +-- 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.TxOutAddressId + } + 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.TxOutAddressId -- 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.getTxOutAddressId + ] + +maTxOutAddressBulkEncoder :: E.Params ([Id.MultiAssetId], [DbWord64], [Id.TxOutAddressId]) +maTxOutAddressBulkEncoder = + contrazip3 + (bulkEncoder $ E.nonNullable $ Id.getMultiAssetId >$< E.int8) -- maTxOutAddressIdent + (bulkEncoder $ E.nonNullable $ fromIntegral . unDbWord64 >$< E.int8) -- maTxOutAddressQuantity + (bulkEncoder $ E.nonNullable $ Id.getTxOutAddressId >$< 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..698a6353f --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement.hs @@ -0,0 +1,35 @@ +module Cardano.Db.Statement ( + module Cardano.Db.Statement.Base, + module Cardano.Db.Statement.Constraint, + module Cardano.Db.Statement.ConsumedTxOut, + module Cardano.Db.Statement.EpochAndProtocol, + module Cardano.Db.Statement.Function.Core, + module Cardano.Db.Statement.Function.Delete, + module Cardano.Db.Statement.Function.Insert, + module Cardano.Db.Statement.Function.Query, + module Cardano.Db.Statement.GovernanceAndVoting, + module Cardano.Db.Statement.JsonB, + 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.Variants.TxOut, +) where + +import Cardano.Db.Statement.Base +import Cardano.Db.Statement.Constraint +import Cardano.Db.Statement.ConsumedTxOut +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.JsonB +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 +import Cardano.Db.Statement.Variants.TxOut 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..f53d5bbba --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Base.hs @@ -0,0 +1,1615 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Base where + +import Cardano.BM.Data.Trace (Trace) +import Cardano.BM.Trace (logInfo, logWarning, nullTracer) +import Cardano.Ledger.BaseTypes (SlotNo (..)) +import Cardano.Prelude (ByteString, Int64, MonadError (..), MonadIO (..), Proxy (..), Word64, textShow, void) +import Data.Functor.Contravariant (Contravariant (..), (>$<)) +import Data.List (partition) +import Data.Maybe (isJust) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import Data.Time (UTCTime) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Pipeline as HsqlPipeL +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import Cardano.Db.Error (DbError (..)) +import qualified Cardano.Db.Schema.Core as SC +import qualified Cardano.Db.Schema.Core.Base as SCB +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.MinIds (MinIds (..), MinIdsWrapper (..), completeMinId, textToMinIds) +import Cardano.Db.Schema.Variants (TxOutVariantType) +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, mkCallSite, runDbSession) +import Cardano.Db.Statement.Function.Delete (deleteWhereCount) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk, insertCheckUnique) +import Cardano.Db.Statement.Function.Query (adaSumDecoder, countAll, parameterisedCountWhere, queryMinRefId) +import Cardano.Db.Statement.GovernanceAndVoting (setNullDroppedStmt, setNullEnactedStmt, setNullExpiredStmt, setNullRatifiedStmt) +import Cardano.Db.Statement.Rollback (deleteTablesAfterBlockId) +import Cardano.Db.Statement.Types (DbInfo, Entity (..), tableName, validateColumn) +import Cardano.Db.Statement.Variants.TxOut (querySetNullTxOut) +import Cardano.Db.Types (Ada (..), DbAction, DbCallInfo (..), DbWord64, ExtraMigration, extraDescription) + +-------------------------------------------------------------------------------- +-- 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 + +insertCheckUniqueBlockStmt :: HsqlStmt.Statement SCB.Block (Entity SCB.Block) +insertCheckUniqueBlockStmt = + insertCheckUnique + SCB.blockEncoder + (WithResult $ HsqlD.singleRow SCB.entityBlockDecoder) + +insertCheckUniqueBlock :: MonadIO m => SCB.Block -> DbAction m Id.BlockId +insertCheckUniqueBlock stakeAddress = + runDbSession (mkCallInfo "insertCheckUniqueBlock") $ do + entity <- + HsqlSes.statement stakeAddress insertCheckUniqueBlockStmt + 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 (Maybe Id.BlockId) +queryBlockId hash = do + runDbSession callInfo $ HsqlSes.statement hash queryBlockIdStmt + where + callInfo = mkCallInfo "queryBlockId" + +-------------------------------------------------------------------------------- +queryBlocksForCurrentEpochNoStmt :: HsqlStmt.Statement () (Maybe Word64) +queryBlocksForCurrentEpochNoStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT MAX(epoch_no)" + , " FROM block" + ] + + decoder = + HsqlD.singleRow $ + HsqlD.column (HsqlD.nullable $ fromIntegral <$> HsqlD.int8) + +queryBlocksForCurrentEpochNo :: MonadIO m => DbAction m (Maybe Word64) +queryBlocksForCurrentEpochNo = + runDbSession (mkCallInfo "queryBlocksForCurrentEpochNo") $ + HsqlSes.statement () queryBlocksForCurrentEpochNoStmt + +-------------------------------------------------------------------------------- +queryLatestBlockStmt :: HsqlStmt.Statement () (Maybe SCB.Block) +queryLatestBlockStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM block" + , " WHERE slot_no IS NOT NULL" + , " ORDER BY slot_no DESC" + , " LIMIT 1" + ] + decoder = HsqlD.rowMaybe SCB.blockDecoder + +queryLatestBlock :: MonadIO m => DbAction m (Maybe SCB.Block) +queryLatestBlock = + runDbSession (mkCallInfo "queryLatestBlock") $ + HsqlSes.statement () queryLatestBlockStmt + +-------------------------------------------------------------------------------- +queryLatestEpochNoFromBlockStmt :: HsqlStmt.Statement () Word64 +queryLatestEpochNoFromBlockStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(epoch_no, 0)::bigint" + , " FROM block" + , " WHERE slot_no IS NOT NULL" + , " ORDER BY epoch_no DESC" + , " LIMIT 1" + ] + + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +queryLatestEpochNoFromBlock :: MonadIO m => DbAction m Word64 +queryLatestEpochNoFromBlock = + runDbSession (mkCallInfo "queryLatestEpochNoFromBlock") $ + HsqlSes.statement () queryLatestEpochNoFromBlockStmt + +-------------------------------------------------------------------------------- +queryLatestBlockIdStmt :: HsqlStmt.Statement () (Maybe Id.BlockId) +queryLatestBlockIdStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + decoder = HsqlD.rowMaybe (Id.idDecoder Id.BlockId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM block" + , " ORDER BY slot_no DESC" + , " LIMIT 1" + ] + +-- | Get 'BlockId' of the latest block. +queryLatestBlockId :: MonadIO m => DbAction m (Maybe Id.BlockId) +queryLatestBlockId = + runDbSession (mkCallInfo "queryLatestBlockId") $ + HsqlSes.statement () queryLatestBlockIdStmt + +-------------------------------------------------------------------------------- +queryDepositUpToBlockNoStmt :: HsqlStmt.Statement Word64 Ada +queryDepositUpToBlockNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + txTable = tableName (Proxy @SC.Tx) + blockTable = tableName (Proxy @SC.Block) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(SUM(tx.deposit), 0) " + , "FROM " + , txTable + , " tx " + , "INNER JOIN " + , blockTable + , " blk ON tx.block_id = blk.id " + , "WHERE blk.block_no <= $1" + ] + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.singleRow adaSumDecoder + +queryDepositUpToBlockNo :: MonadIO m => Word64 -> DbAction m Ada +queryDepositUpToBlockNo blkNo = + runDbSession (mkCallInfo "queryDepositUpToBlockNo") $ + HsqlSes.statement blkNo queryDepositUpToBlockNoStmt + +-------------------------------------------------------------------------------- +queryLatestSlotNoStmt :: HsqlStmt.Statement () Word64 +queryLatestSlotNoStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + blockTable = tableName (Proxy @SC.Block) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(slot_no, 0)::bigint" + , " FROM " <> blockTable + , " WHERE slot_no IS NOT NULL" + , " ORDER BY slot_no DESC" + , " LIMIT 1" + ] + + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +queryLatestSlotNo :: MonadIO m => DbAction m Word64 +queryLatestSlotNo = + runDbSession (mkCallInfo "queryLatestSlotNo") $ + HsqlSes.statement () queryLatestSlotNoStmt + +-------------------------------------------------------------------------------- +queryLatestPointsStmt :: HsqlStmt.Statement () [(Maybe Word64, ByteString)] +queryLatestPointsStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + blockTable = tableName (Proxy @SC.Block) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT slot_no, hash" + , " FROM " <> blockTable + , " WHERE slot_no IS NOT NULL" + , " ORDER BY slot_no DESC" + , " LIMIT 5" + ] + + decoder = HsqlD.rowList $ do + slotNo <- HsqlD.column (HsqlD.nullable $ fromIntegral <$> HsqlD.int8) + hash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + pure (slotNo, hash) + +queryLatestPoints :: MonadIO m => DbAction m [(Maybe Word64, ByteString)] +queryLatestPoints = + runDbSession (mkCallInfo "queryLatestPoints") $ + HsqlSes.statement () queryLatestPointsStmt + +----------------------------------------------------------------------------------- +querySlotHashStmt :: HsqlStmt.Statement Word64 [ByteString] +querySlotHashStmt = + HsqlStmt.Statement sql encoder decoder True + where + blockTable = tableName (Proxy @SC.Block) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT hash" + , " FROM " <> blockTable + , " WHERE slot_no = $1" + ] + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = HsqlD.rowList (HsqlD.column (HsqlD.nonNullable HsqlD.bytea)) + +querySlotHash :: MonadIO m => SlotNo -> DbAction m [(SlotNo, ByteString)] +querySlotHash slotNo = do + hashes <- + runDbSession (mkCallInfo "querySlotHash") $ + HsqlSes.statement (unSlotNo slotNo) querySlotHashStmt + pure $ map (\hash -> (slotNo, hash)) hashes + +----------------------------------------------------------------------------------- +queryCountSlotNosGreaterThanStmt :: HsqlStmt.Statement Word64 Word64 +queryCountSlotNosGreaterThanStmt = + HsqlStmt.Statement sql encoder decoder True + where + blockTable = tableName (Proxy @SC.Block) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> blockTable + , " WHERE slot_no > $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +queryCountSlotNosGreaterThan :: MonadIO m => Word64 -> DbAction m Word64 +queryCountSlotNosGreaterThan slotNo = + runDbSession (mkCallInfo "queryCountSlotNosGreaterThan") $ + HsqlSes.statement slotNo queryCountSlotNosGreaterThanStmt + +----------------------------------------------------------------------------------- +queryCountSlotNoStmt :: HsqlStmt.Statement () Word64 +queryCountSlotNoStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + blockTable = tableName (Proxy @SC.Block) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> blockTable + , " WHERE slot_no IS NOT NULL" + ] + + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +-- | Like 'queryCountSlotNosGreaterThan', but returns all slots in the same order. +queryCountSlotNo :: MonadIO m => DbAction m Word64 +queryCountSlotNo = + runDbSession (mkCallInfo "queryCountSlotNo") $ + HsqlSes.statement () queryCountSlotNoStmt + +----------------------------------------------------------------------------------- +queryBlockHeightStmt :: forall a. (DbInfo a) => Text.Text -> HsqlStmt.Statement () (Maybe Word64) +queryBlockHeightStmt colName = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @a) + validCol = validateColumn @a colName + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT " + , validCol + , " FROM " + , table + , " WHERE " + , validCol + , " IS NOT NULL" + , " ORDER BY " + , validCol + , " DESC" + , " LIMIT 1" + ] + + decoder = HsqlD.rowMaybe $ do + blockNo <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ fromIntegral blockNo + +queryBlockHeight :: MonadIO m => DbAction m (Maybe Word64) +queryBlockHeight = + runDbSession (mkCallInfo "queryBlockHeight") $ + HsqlSes.statement () $ + queryBlockHeightStmt @SC.Block "block_no" + +----------------------------------------------------------------------------------- +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 + +----------------------------------------------------------------------------------- +queryLatestBlockNoStmt :: HsqlStmt.Statement () (Maybe Word64) +queryLatestBlockNoStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT block_no" + , " FROM block" + , " WHERE block_no IS NOT NULL" + , " ORDER BY block_no DESC" + , " LIMIT 1" + ] + + decoder = HsqlD.rowMaybe $ do + blockNo <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ fromIntegral blockNo + +queryLatestBlockNo :: MonadIO m => DbAction m (Maybe Word64) +queryLatestBlockNo = + runDbSession (mkCallInfo "queryLatestBlockNo") $ + HsqlSes.statement () queryLatestBlockNoStmt + +----------------------------------------------------------------------------------- +querySlotNosGreaterThanStmt :: HsqlStmt.Statement Word64 [SlotNo] +querySlotNosGreaterThanStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT slot_no" + , " FROM block" + , " WHERE slot_no > $1" + , " ORDER BY slot_no DESC" + ] + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.rowList $ do + slotValue <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ SlotNo (fromIntegral slotValue) + +querySlotNosGreaterThan :: MonadIO m => Word64 -> DbAction m [SlotNo] +querySlotNosGreaterThan slotNo = + runDbSession (mkCallInfo "querySlotNosGreaterThan") $ + HsqlSes.statement slotNo querySlotNosGreaterThanStmt + +----------------------------------------------------------------------------------- + +-- | Like 'querySlotNosGreaterThan', but returns all slots in the same order. +querySlotNosStmt :: HsqlStmt.Statement () [SlotNo] +querySlotNosStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT slot_no" + , " FROM block" + , " WHERE slot_no IS NOT NULL" + , " ORDER BY slot_no DESC" + ] + decoder = HsqlD.rowList $ do + slotValue <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ SlotNo (fromIntegral slotValue) + +querySlotNos :: MonadIO m => DbAction m [SlotNo] +querySlotNos = + runDbSession (mkCallInfo "querySlotNos") $ + HsqlSes.statement () querySlotNosStmt + +----------------------------------------------------------------------------------- +queryPreviousSlotNoStmt :: HsqlStmt.Statement Word64 (Maybe Word64) +queryPreviousSlotNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + blockTableN = tableName (Proxy @SCB.Block) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT prev_block.slot_no" + , " FROM " <> blockTableN <> " block" + , " INNER JOIN " <> blockTableN <> " prev_block" + , " ON block.previous_id = prev_block.id" + , " WHERE block.slot_no = $1" + ] + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.rowMaybe $ do + slotNo <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ fromIntegral slotNo + +queryPreviousSlotNo :: MonadIO m => Word64 -> DbAction m (Maybe Word64) +queryPreviousSlotNo slotNo = + runDbSession (mkCallInfo "queryPreviousSlotNo") $ + HsqlSes.statement slotNo queryPreviousSlotNoStmt + +-- | DELETE -------------------------------------------------------------------- +deleteBlocksBlockIdStmt :: HsqlStmt.Statement (Id.BlockId, Word64, Bool) Int64 +deleteBlocksBlockIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + encoder = + contramap (\(a, _, _) -> a) (Id.idEncoder Id.getBlockId) + <> contramap (\(_, b, _) -> b) (HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8)) + <> contramap (\(_, _, c) -> c) (HsqlE.param (HsqlE.nonNullable HsqlE.bool)) + decoder = HsqlD.singleRow (HsqlD.column (HsqlD.nonNullable HsqlD.int8)) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH deleted AS (" + , " DELETE FROM block" + , " WHERE id >= $1" + , " RETURNING *" + , ")" + , "SELECT COUNT(*)::bigint FROM deleted" + ] + +deleteBlocksBlockId :: + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + Id.BlockId -> + -- | The 'EpochNo' of the block to delete. + Word64 -> + -- | Is ConsumeTxout + Bool -> + DbAction m Int64 +deleteBlocksBlockId trce txOutVariantType blockId epochN isConsumedTxOut = do + mMinIds <- fmap (textToMinIds txOutVariantType =<<) <$> queryReverseIndexBlockId blockId + (cminIds, completed) <- findMinIdsRec mMinIds mempty + mTxId <- + queryMinRefId @SCB.Tx + "block_id" + blockId + (Id.idEncoder Id.getBlockId) + (Id.idDecoder Id.TxId) + minIds <- if completed then pure cminIds else completeMinId mTxId cminIds + + deleteEpochLogs <- deleteUsingEpochNo epochN + (deleteBlockCount, blockDeleteLogs) <- deleteTablesAfterBlockId txOutVariantType blockId mTxId minIds + + setNullLogs <- + if isConsumedTxOut + then querySetNullTxOut txOutVariantType 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 -> DbAction 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 + +mkRollbackSummary :: [(Text.Text, Int64)] -> (Text.Text, Int64) -> Text.Text +mkRollbackSummary logs setNullLogs = + "\n----------------------- Rollback Summary: ----------------------- \n" + <> formattedLog + <> zeroDeletedEntry + <> formatSetNullLog setNullLogs + <> "\n" + where + (zeroDeletes, nonZeroDeletes) = partition ((== 0) . snd) logs + formattedLog = Text.intercalate "\n" (map formatEntry nonZeroDeletes) + zeroDeletedEntry + | null zeroDeletes = "" + | otherwise = "\n\nNo Deletes in tables: " <> Text.intercalate ", " (map fst zeroDeletes) + formatEntry (tName, rowCount) = + "Table: " <> tName <> " - Count: " <> Text.pack (show rowCount) + formatSetNullLog (nullMessage, nullCount) = + if nullCount == 0 + then "\n\nSet Null: " <> nullMessage + else "\n\nSet Null: " <> nullMessage <> " - Count: " <> Text.pack (show nullCount) + +--------------------------------------------------------------------------------- +-- Custom type for holding all the results +data DeleteResults = DeleteResults + { epochCount :: !Int64 + , drepDistrCount :: !Int64 + , rewardRestCount :: !Int64 + , poolStatCount :: !Int64 + , enactedNullCount :: !Int64 + , ratifiedNullCount :: !Int64 + , droppedNullCount :: !Int64 + , expiredNullCount :: !Int64 + } + +deleteUsingEpochNo :: (MonadIO m) => Word64 -> DbAction m [(Text.Text, Int64)] +deleteUsingEpochNo epochN = do + let callInfo = mkCallInfo "deleteUsingEpochNo" + epochEncoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + epochInt64 = fromIntegral epochN + + -- Execute batch deletes in a pipeline + results <- runDbSession callInfo $ + HsqlSes.pipeline $ do + c1 <- HsqlPipeL.statement epochN (deleteWhereCount @SC.Epoch "no" "=" epochEncoder) + c2 <- HsqlPipeL.statement epochN (deleteWhereCount @SC.DrepDistr "epoch_no" ">" epochEncoder) + c3 <- HsqlPipeL.statement epochN (deleteWhereCount @SC.RewardRest "spendable_epoch" ">" epochEncoder) + c4 <- HsqlPipeL.statement epochN (deleteWhereCount @SC.PoolStat "epoch_no" ">" epochEncoder) + + -- Null operations + n1 <- HsqlPipeL.statement epochInt64 setNullEnactedStmt + n2 <- HsqlPipeL.statement epochInt64 setNullRatifiedStmt + n3 <- HsqlPipeL.statement epochInt64 setNullDroppedStmt + n4 <- HsqlPipeL.statement epochInt64 setNullExpiredStmt + + pure $ DeleteResults c1 c2 c3 c4 n1 n2 n3 n4 + + -- Collect results + let + countLogs = + [ ("Epoch", epochCount results) + , ("DrepDistr", drepDistrCount results) + , ("RewardRest", rewardRestCount results) + , ("PoolStat", poolStatCount results) + ] + + nullTotal = + sum + [ enactedNullCount results + , ratifiedNullCount results + , droppedNullCount results + , expiredNullCount results + ] + + nullLogs = [("GovActionProposal Nulled", nullTotal)] + pure $ countLogs <> nullLogs + +-------------------------------------------------------------------------------- +deleteBlocksSlotNo :: + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + SlotNo -> + Bool -> + DbAction m Bool +deleteBlocksSlotNo trce txOutVariantType (SlotNo slotNo) isConsumedTxOut = do + mBlockEpoch <- queryNearestBlockSlotNo slotNo + case mBlockEpoch of + Nothing -> do + liftIO $ logWarning trce $ "deleteBlocksSlotNo: No block contains the the slot: " <> Text.pack (show slotNo) + pure False + Just (blockId, epochN) -> do + void $ deleteBlocksBlockId trce txOutVariantType blockId epochN isConsumedTxOut + pure True + +-------------------------------------------------------------------------------- +deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutVariantType -> SlotNo -> DbAction m Bool +deleteBlocksSlotNoNoTrace txOutVariantType slotNo = deleteBlocksSlotNo nullTracer txOutVariantType slotNo True + +-------------------------------------------------------------------------------- +deleteBlocksForTests :: MonadIO m => TxOutVariantType -> Id.BlockId -> Word64 -> DbAction m () +deleteBlocksForTests txOutVariantType blockId epochN = do + void $ deleteBlocksBlockId nullTracer txOutVariantType 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 => TxOutVariantType -> SC.Block -> DbAction m Bool +deleteBlock txOutVariantType block = do + mBlockId <- queryBlockHash block + case mBlockId of + Nothing -> pure False + Just (blockId, epochN) -> do + void $ deleteBlocksBlockId nullTracer txOutVariantType blockId epochN False + pure True + +-------------------------------------------------------------------------------- +-- Datum +-------------------------------------------------------------------------------- + +-- | INSERT -------------------------------------------------------------------- +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 + +-- | QUERY --------------------------------------------------------------------- + +queryDatumStmt :: HsqlStmt.Statement ByteString (Maybe Id.DatumId) +queryDatumStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT id" + , " FROM datum" + , " WHERE hash = $1" + ] + encoder = id >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe $ Id.idDecoder Id.DatumId + +queryDatum :: MonadIO m => ByteString -> DbAction m (Maybe Id.DatumId) +queryDatum hash = + runDbSession (mkCallInfo "queryDatum") $ + HsqlSes.statement hash queryDatumStmt + +-------------------------------------------------------------------------------- +-- ExtraMigration +-------------------------------------------------------------------------------- +queryAllExtraMigrationsStmt :: forall a. (DbInfo a) => Text.Text -> HsqlStmt.Statement () [ExtraMigration] +queryAllExtraMigrationsStmt colName = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @a) + validCol = validateColumn @a colName + + sql = + TextEnc.encodeUtf8 $ + Text.concat + ["SELECT ", validCol, " FROM ", table] + + decoder = + HsqlD.rowList $ + HsqlD.column $ + HsqlD.nonNullable $ + read . Text.unpack <$> HsqlD.text + +queryAllExtraMigrations :: MonadIO m => DbAction m [ExtraMigration] +queryAllExtraMigrations = + runDbSession (mkCallInfo "queryAllExtraMigrations") $ + HsqlSes.statement () $ + queryAllExtraMigrationsStmt @SC.ExtraMigrations "token" + +-------------------------------------------------------------------------------- +-- 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" + ] + +{-# INLINEABLE queryMeta #-} +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 + +-------------------------------------------------------------------------------- +-- RedeemerData +-------------------------------------------------------------------------------- +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 + +-------------------------------------------------------------------------------- +queryRedeemerDataStmt :: HsqlStmt.Statement ByteString (Maybe Id.RedeemerDataId) +queryRedeemerDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM redeemer_data" + , " WHERE hash = $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.RedeemerDataId) + +queryRedeemerData :: MonadIO m => ByteString -> DbAction m (Maybe Id.RedeemerDataId) +queryRedeemerData hash = + runDbSession (mkCallInfo "queryRedeemerData") $ + HsqlSes.statement hash queryRedeemerDataStmt + +-------------------------------------------------------------------------------- +-- 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 + +-------------------------------------------------------------------------------- + +-- | SchemaVersion + +-------------------------------------------------------------------------------- +querySchemaVersionStmt :: HsqlStmt.Statement () (Maybe SCB.SchemaVersion) +querySchemaVersionStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SCB.SchemaVersion) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT stage_one, stage_two, stage_three" + , " FROM " <> tableN + , " ORDER BY stage_one DESC" + , " LIMIT 1" + ] + decoder = HsqlD.rowMaybe SCB.schemaVersionDecoder + +querySchemaVersion :: MonadIO m => DbAction m (Maybe SCB.SchemaVersion) +querySchemaVersion = + runDbSession (mkCallInfo "querySchemaVersion") $ + HsqlSes.statement () querySchemaVersionStmt + +-------------------------------------------------------------------------------- +-- Script +-------------------------------------------------------------------------------- + +-- | INSERTS +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 + +-- | QUERIES + +-------------------------------------------------------------------------------- +queryScriptWithIdStmt :: HsqlStmt.Statement ByteString (Maybe Id.ScriptId) +queryScriptWithIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM script" + , " WHERE hash = $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.ScriptId) + +queryScriptWithId :: MonadIO m => ByteString -> DbAction m (Maybe Id.ScriptId) +queryScriptWithId hash = + runDbSession (mkCallInfo "queryScriptWithId") $ + HsqlSes.statement hash queryScriptWithIdStmt + +-------------------------------------------------------------------------------- +-- 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 +-------------------------------------------------------------------------------- + +-- | INSERTS ------------------------------------------------------------------- +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 ------------------------------------------------------------------ + +-- | Count the number of transactions in the Tx table. +queryTxCount :: MonadIO m => DbAction m Word64 +queryTxCount = + runDbSession (mkCallInfo "queryTxCount") $ + HsqlSes.statement () $ + countAll @SCB.Tx + +-------------------------------------------------------------------------------- +queryWithdrawalsUpToBlockNoStmt :: HsqlStmt.Statement Word64 Ada +queryWithdrawalsUpToBlockNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + txTableN = tableName (Proxy @SCB.Tx) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT SUM(withdrawal.amount)" + , " FROM " <> txTableN + , " INNER JOIN withdrawal ON tx.id = withdrawal.tx_id" + , " INNER JOIN block ON tx.block_id = block.id" + , " WHERE block.block_no <= $1" + ] + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.singleRow adaSumDecoder + +queryWithdrawalsUpToBlockNo :: MonadIO m => Word64 -> DbAction m Ada +queryWithdrawalsUpToBlockNo blkNo = + runDbSession (mkCallInfo "queryWithdrawalsUpToBlockNo") $ + HsqlSes.statement blkNo queryWithdrawalsUpToBlockNoStmt + +-------------------------------------------------------------------------------- +queryTxIdStmt :: HsqlStmt.Statement ByteString (Maybe Id.TxId) +queryTxIdStmt = do + HsqlStmt.Statement sql encoder decoder True + where + table = tableName (Proxy @SCB.Tx) + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.rowMaybe (Id.idDecoder Id.TxId) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM " <> table + , " 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) + +-------------------------------------------------------------------------------- +queryFeesUpToBlockNoStmt :: HsqlStmt.Statement Word64 Ada +queryFeesUpToBlockNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + txTableN = tableName (Proxy @SCB.Tx) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT SUM(tx.fee)" + , " FROM " <> txTableN + , " INNER JOIN block ON tx.block_id = block.id" + , " WHERE block.block_no <= $1" + ] + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.singleRow adaSumDecoder + +queryFeesUpToBlockNo :: MonadIO m => Word64 -> DbAction m Ada +queryFeesUpToBlockNo blkNo = + runDbSession (mkCallInfo "queryFeesUpToBlockNo") $ + HsqlSes.statement blkNo queryFeesUpToBlockNoStmt + +-------------------------------------------------------------------------------- +queryFeesUpToSlotNoStmt :: HsqlStmt.Statement Word64 Ada +queryFeesUpToSlotNoStmt = + HsqlStmt.Statement sql encoder decoder True + where + txTableN = tableName (Proxy @SCB.Tx) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT SUM(tx.fee)" + , " FROM " <> txTableN + , " INNER JOIN block ON tx.block_id = block.id" + , " WHERE block.slot_no IS NOT NULL" + , " AND block.slot_no <= $1" + ] + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + decoder = HsqlD.singleRow adaSumDecoder + +queryFeesUpToSlotNo :: MonadIO m => Word64 -> DbAction m Ada +queryFeesUpToSlotNo slotNo = + runDbSession (mkCallInfo "queryFeesUpToSlotNo") $ + HsqlSes.statement slotNo queryFeesUpToSlotNoStmt + +-------------------------------------------------------------------------------- +queryInvalidTxStmt :: HsqlStmt.Statement () [SCB.Tx] +queryInvalidTxStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + txTableN = tableName (Proxy @SCB.Tx) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM " <> txTableN + , " WHERE valid_contract = FALSE" + ] + decoder = HsqlD.rowList SCB.txDecoder + +queryInvalidTx :: MonadIO m => DbAction m [SCB.Tx] +queryInvalidTx = + runDbSession (mkCallInfo "queryInvalidTx") $ + HsqlSes.statement () queryInvalidTxStmt + +-------------------------------------------------------------------------------- +-- 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 + +-------------------------------------------------------------------------------- +queryTxInCount :: MonadIO m => DbAction m Word64 +queryTxInCount = + runDbSession (mkCallInfo "queryTxInCount") $ + HsqlSes.statement () $ + countAll @SCB.TxIn + +-------------------------------------------------------------------------------- +queryTxInRedeemerStmt :: HsqlStmt.Statement () [SCB.TxIn] +queryTxInRedeemerStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SCB.TxIn) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM " <> tableN + , " WHERE redeemer_id IS NOT NULL" + ] + decoder = HsqlD.rowList SCB.txInDecoder + +queryTxInRedeemer :: MonadIO m => DbAction m [SCB.TxIn] +queryTxInRedeemer = + runDbSession (mkCallInfo "queryTxInRedeemer") $ + HsqlSes.statement () queryTxInRedeemerStmt + +-------------------------------------------------------------------------------- + +-- | Gets all the 'TxIn' of invalid txs +queryTxInFailedTxStmt :: HsqlStmt.Statement () [SCB.TxIn] +queryTxInFailedTxStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + txInTableN = tableName (Proxy @SCB.TxIn) + txTableN = tableName (Proxy @SCB.Tx) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_in.*" + , " FROM " <> txInTableN <> " tx_in" + , " INNER JOIN " <> txTableN <> " tx" + , " ON tx_in.tx_in_id = tx.id" + , " WHERE tx.valid_contract = FALSE" + ] + decoder = HsqlD.rowList SCB.txInDecoder + +queryTxInFailedTx :: MonadIO m => DbAction m [SCB.TxIn] +queryTxInFailedTx = + runDbSession (mkCallInfo "queryTxInFailedTx") $ + HsqlSes.statement () queryTxInFailedTxStmt + +-------------------------------------------------------------------------------- +-- 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 + +-------------------------------------------------------------------------------- +-- Statement for querying withdrawals with non-null redeemer_id +queryWithdrawalScriptStmt :: HsqlStmt.Statement () [SCB.Withdrawal] +queryWithdrawalScriptStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SCB.Withdrawal) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM " <> tableN + , " WHERE redeemer_id IS NOT NULL" + ] + decoder = HsqlD.rowList SCB.withdrawalDecoder + +queryWithdrawalScript :: MonadIO m => DbAction m [SCB.Withdrawal] +queryWithdrawalScript = + runDbSession (mkCallInfo "queryWithdrawalScript") $ + HsqlSes.statement () queryWithdrawalScriptStmt + +-------------------------------------------------------------------------------- + +-- Get all stake addresses with have seen a withdrawal, and return them in shuffled order. +queryWithdrawalAddressesStmt :: HsqlStmt.Statement () [Id.StakeAddressId] +queryWithdrawalAddressesStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + withdrawalTableN = tableName (Proxy @SCB.Withdrawal) + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT DISTINCT addr_id" + , " FROM " <> withdrawalTableN + , " ORDER BY addr_id ASC" + ] + + decoder = HsqlD.rowList $ + HsqlD.column (HsqlD.nonNullable (Id.StakeAddressId <$> HsqlD.int8)) + +queryWithdrawalAddresses :: MonadIO m => DbAction m [Id.StakeAddressId] +queryWithdrawalAddresses = + runDbSession (mkCallInfo "queryWithdrawalAddresses") $ + HsqlSes.statement () queryWithdrawalAddressesStmt + + + +-- 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/Constraint.hs b/cardano-db/src/Cardano/Db/Statement/Constraint.hs new file mode 100644 index 000000000..485dbd0c7 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Constraint.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.Constraint ( + -- * Types + ConstraintNameDB (..), + FieldNameDB (..), + AlterTable (..), + + -- * Statement functions + queryHasConstraintStmt, + addConstraintStmt, + dropConstraintStmt, + + -- * Session functions + queryHasConstraint, + alterTableAddConstraint, + alterTableDropConstraint, +) where + +import Cardano.Db.Statement.Function.Core (mkCallInfo, runDbSession) +import Cardano.Db.Types (DbAction) +import Control.Monad.IO.Class (MonadIO) +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 HsqlStmt + +-- | Name of a database constraint +newtype ConstraintNameDB = ConstraintNameDB + { unConstraintNameDB :: Text.Text + } + deriving (Eq, Show) + +-- | Name of a database field/column +newtype FieldNameDB = FieldNameDB + { unFieldNameDB :: Text.Text + } + deriving (Eq, Show) + +-- | Alter table operations +data AlterTable + = AddUniqueConstraint ConstraintNameDB [FieldNameDB] + | DropUniqueConstraint ConstraintNameDB + deriving (Show) + +-- | Helper function for Text parameter encoding +textParam :: HsqlE.Params Text.Text +textParam = HsqlE.param (HsqlE.nonNullable HsqlE.text) + +-- | Helper for encoding constraint name +constraintNameParam :: HsqlE.Params ConstraintNameDB +constraintNameParam = HsqlE.param (HsqlE.nonNullable (unConstraintNameDB >$< HsqlE.text)) + +-- | Helper for encoding field list as comma-separated string +fieldListParam :: HsqlE.Params [FieldNameDB] +fieldListParam = HsqlE.param (HsqlE.nonNullable (fieldListToText >$< HsqlE.text)) + where + fieldListToText = Text.intercalate "," . map unFieldNameDB + +-- | Statement for checking if a constraint exists +queryHasConstraintStmt :: HsqlStmt.Statement ConstraintNameDB Bool +queryHasConstraintStmt = + HsqlStmt.Statement sql constraintNameParam decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT EXISTS (SELECT 1 FROM pg_constraint WHERE conname = $1)" + ] + + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.bool) + +-- | Data type for add constraint parameters +data AddConstraintParams = AddConstraintParams + { acpTableName :: !Text.Text + , acpConstraintName :: !ConstraintNameDB + , acpFields :: ![FieldNameDB] + } + +-- | Data type for drop constraint parameters +data DropConstraintParams = DropConstraintParams + { dcpTableName :: !Text.Text + , dcpConstraintName :: !ConstraintNameDB + } + +-- | Encoder for AddConstraintParams +addConstraintParamsEncoder :: HsqlE.Params AddConstraintParams +addConstraintParamsEncoder = + mconcat + [ acpTableName >$< textParam + , acpConstraintName >$< constraintNameParam + , acpFields >$< fieldListParam + ] + +-- | Encoder for DropConstraintParams +dropConstraintParamsEncoder :: HsqlE.Params DropConstraintParams +dropConstraintParamsEncoder = + mconcat + [ dcpTableName >$< textParam + , dcpConstraintName >$< constraintNameParam + ] + +-- | Statement for adding a unique constraint +addConstraintStmt :: HsqlStmt.Statement AddConstraintParams () +addConstraintStmt = + HsqlStmt.Statement sql addConstraintParamsEncoder HsqlD.noResult True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "ALTER TABLE $1 ADD CONSTRAINT $2 UNIQUE($3)" + ] + +-- | Statement for dropping a constraint +dropConstraintStmt :: HsqlStmt.Statement DropConstraintParams () +dropConstraintStmt = + HsqlStmt.Statement sql dropConstraintParamsEncoder HsqlD.noResult True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "ALTER TABLE $1 DROP CONSTRAINT IF EXISTS $2" + ] + +-- | Check if a constraint exists +queryHasConstraint :: MonadIO m => ConstraintNameDB -> DbAction m Bool +queryHasConstraint cname = + runDbSession (mkCallInfo "queryHasConstraint") $ + HsqlSess.statement cname queryHasConstraintStmt + +-- | Add a unique constraint to a table +alterTableAddConstraint :: + MonadIO m => + -- | Table name + Text.Text -> + -- | Constraint name + ConstraintNameDB -> + -- | Field names + [FieldNameDB] -> + DbAction m () +alterTableAddConstraint tableName cname fields = + runDbSession (mkCallInfo "alterTableAddConstraint") $ + HsqlSess.statement params addConstraintStmt + where + params = + AddConstraintParams + { acpTableName = tableName + , acpConstraintName = cname + , acpFields = fields + } + +-- | Drop a constraint from a table +alterTableDropConstraint :: + MonadIO m => + -- | Table name + Text.Text -> + -- | Constraint name + ConstraintNameDB -> + DbAction m () +alterTableDropConstraint tableName cname = + runDbSession (mkCallInfo "alterTableDropConstraint") $ + HsqlSess.statement params dropConstraintStmt + where + params = + DropConstraintParams + { dcpTableName = tableName + , dcpConstraintName = cname + } diff --git a/cardano-db/src/Cardano/Db/Statement/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Statement/ConsumedTxOut.hs new file mode 100644 index 000000000..c9d60a533 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/ConsumedTxOut.hs @@ -0,0 +1,823 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.ConsumedTxOut where + +import Cardano.BM.Trace (Trace, logInfo) +import Cardano.Prelude (Int64, textShow) +import Contravariant.Extras (contrazip2, contrazip3) +import Control.Exception (throwIO) +import Control.Monad (unless, when) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Functor.Contravariant (Contravariant (..), (>$<)) +import Data.Proxy (Proxy (..)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import Data.Word (Word64) +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 (..), logAndThrowIO) +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.Variants (TxOutIdW (..), TxOutVariantType (..)) +import qualified Cardano.Db.Schema.Variants.TxOutAddress as V +import qualified Cardano.Db.Schema.Variants.TxOutCore as C +import Cardano.Db.Statement.Base (insertExtraMigration, queryAllExtraMigrations) +import Cardano.Db.Statement.Function.Core (bulkEncoder, mkCallInfo, mkCallSite, runDbSession) +import Cardano.Db.Statement.Types (DbInfo (..)) +import Cardano.Db.Types (DbAction, ExtraMigration (..), MigrationValues (..), PruneConsumeMigration (..), processMigrationValues) +import Cardano.Db.Schema.Variants.TxOutAddress (TxOutAddress) + +data ConsumedTriplet = ConsumedTriplet + { ctTxOutTxId :: !Id.TxId -- The txId of the txOut + , ctTxOutIndex :: !Word64 -- Tx index of the txOut + , ctTxInTxId :: !Id.TxId -- The txId of the txId + } + +consumedTripletDecoder :: HsqlD.Row ConsumedTriplet +consumedTripletDecoder = + ConsumedTriplet + <$> Id.idDecoder Id.TxId -- ctTxOutTxId + <*> HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) -- ctTxOutIndex + <*> Id.idDecoder Id.TxId -- ctTxInTxId + +consumedTripletEncoder :: HsqlE.Params ConsumedTriplet +consumedTripletEncoder = + mconcat + [ ctTxOutTxId >$< Id.idEncoder Id.getTxId + , ctTxOutIndex >$< HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + , ctTxInTxId >$< Id.idEncoder Id.getTxId + ] + +encodeConsumedTripletBulk :: HsqlE.Params ([Id.TxId], [Word64], [Id.TxId]) +encodeConsumedTripletBulk = + contrazip3 + (bulkEncoder $ HsqlE.nonNullable $ Id.getTxId >$< HsqlE.int8) + (bulkEncoder $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + (bulkEncoder $ HsqlE.nonNullable $ Id.getTxId >$< HsqlE.int8) + +-------------------------------------------------------------------------------- + +pageSize :: Word64 +pageSize = 100_000 + +-------------------------------------------------------------------------------- + +-- | Run extra migrations for the database +runConsumedTxOutMigrations :: + MonadIO m => + -- | Tracer for logging + Trace IO Text.Text -> + -- | TxOut table type being used + TxOutVariantType -> + -- | Block number difference + Word64 -> + -- | Prune/consume migration config + PruneConsumeMigration -> + DbAction m () +runConsumedTxOutMigrations trce txOutVariantType blockNoDiff pcm = do + ems <- queryAllExtraMigrations + isTxOutNull <- queryTxOutIsNull txOutVariantType + let migrationValues = processMigrationValues ems pcm + isTxOutVariant = txOutVariantType == TxOutVariantAddress + 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) $ do + let msg = msgName <> "The use of the config 'tx_out.use_address_table' can only be carried out on a non populated database." + liftIO $ throwIO $ DbError mkCallSite msg Nothing + + -- Make sure the config "use_address_table" is there if the migration wasn't previously set in the past + when (not isTxOutVariant && isTxOutAddressSet) $ do + let msg = msgName <> "The configuration option 'tx_out.use_address_table' was previously set and the database updated. Unfortunately reverting this isn't possible." + liftIO $ throwIO $ DbError mkCallSite msg Nothing + + -- 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)) $ do + let msg = msgName <> "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." + liftIO $ throwIO $ DbError mkCallSite msg Nothing + + handleMigration migrationValues + where + msgName = "runConsumedTxOutMigrations: " + handleMigration :: MonadIO m => MigrationValues -> DbAction m () + handleMigration migrationValues@MigrationValues {..} = do + let PruneConsumeMigration {..} = pruneConsumeMigration + + case (isConsumeTxOutPreviouslySet, pcmConsumedTxOut, pcmPruneTxOut) of + -- No Migration Needed + (False, False, False) -> do + liftIO $ logInfo trce $ msgName <> "No extra migration specified" + + -- Already migrated + (True, True, False) -> do + liftIO $ logInfo trce $ msgName <> "Extra migration consumed_tx_out already executed" + + -- Invalid State + (True, False, False) -> + liftIO $ logAndThrowIO trce $ msgName <> "consumed-tx-out or prune-tx-out is not set, but consumed migration is found." + -- Consume TxOut + (False, True, False) -> do + liftIO $ logInfo trce $ msgName <> "Running extra migration consumed_tx_out" + insertExtraMigration ConsumeTxOutPreviouslySet + migrateTxOut trce txOutVariantType $ Just migrationValues + + -- Prune TxOut + (_, _, True) -> do + unless isPruneTxOutPreviouslySet $ + insertExtraMigration PruneTxOutFlagPreviouslySet + if isConsumeTxOutPreviouslySet + then do + liftIO $ logInfo trce $ msgName <> "Running extra migration prune tx_out" + deleteConsumedTxOut trce txOutVariantType blockNoDiff + else deleteAndUpdateConsumedTxOut trce txOutVariantType migrationValues blockNoDiff + +-------------------------------------------------------------------------------- + +-- | Statement to check if tx_out is null for specified table type +queryTxOutIsNullStmt :: Text.Text -> HsqlStmt.Statement () Bool +queryTxOutIsNullStmt tName = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT NOT EXISTS (SELECT 1 FROM " + , tName + , " LIMIT 1)" + ] + + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.bool) + +-- | Check if the tx_out table is empty (null) +queryTxOutIsNull :: MonadIO m => TxOutVariantType -> DbAction m Bool +queryTxOutIsNull = \case + TxOutVariantCore -> pure False + TxOutVariantAddress -> queryTxOutIsNullImpl @TxOutAddress + +-- | Implementation of queryTxOutIsNull using DbInfo +queryTxOutIsNullImpl :: forall a m. (DbInfo a, MonadIO m) => DbAction m Bool +queryTxOutIsNullImpl = do + let tName = tableName (Proxy @a) + stmt = queryTxOutIsNullStmt tName + runDbSession (mkCallInfo "queryTxOutIsNull") $ + HsqlSes.statement () stmt + +-------------------------------------------------------------------------------- + +-- | Update tx_out tables and create address table +updateTxOutAndCreateAddress :: + MonadIO m => + Trace IO Text.Text -> + DbAction m () +updateTxOutAndCreateAddress trce = do + runStep "Dropped views" dropViewsQuery + runStep "Altered tx_out" alterTxOutQuery + runStep "Altered collateral_tx_out" alterCollateralTxOutQuery + runStep "Created address table" createAddressTableQuery + runStep "Created index payment_cred" createIndexPaymentCredQuery + runStep "Created index raw" createIndexRawQuery + liftIO $ logInfo trce "updateTxOutAndCreateAddress: Completed" + where + -- Helper to run a step with proper logging and error handling + runStep :: MonadIO m => Text.Text -> Text.Text -> DbAction m () + runStep stepDesc sql = do + let sqlBS = TextEnc.encodeUtf8 sql + runDbSession (mkCallInfo "updateTxOutAndCreateAddress") $ HsqlSes.sql sqlBS + liftIO $ logInfo trce $ "updateTxOutAndCreateAddress: " <> stepDesc + + 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);" + +-------------------------------------------------------------------------------- + +-- | Migrate tx_out data +migrateTxOut :: + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + Maybe MigrationValues -> + DbAction m () +migrateTxOut trce txOutVariantType mMvs = do + whenJust mMvs $ \mvs -> do + when (pcmConsumedTxOut (pruneConsumeMigration mvs) && not (isTxOutAddressPreviouslySet mvs)) $ do + liftIO $ logInfo trce "migrateTxOut: adding consumed-by-id Index" + createConsumedIndexTxOut + when (pcmPruneTxOut (pruneConsumeMigration mvs)) $ do + liftIO $ logInfo trce "migrateTxOut: adding prune contraint on tx_out table" + createPruneConstraintTxOut + migrateNextPageTxOut (Just trce) txOutVariantType 0 + +-- | Process the tx_out table in pages for migration +migrateNextPageTxOut :: + MonadIO m => + Maybe (Trace IO Text.Text) -> + TxOutVariantType -> + Word64 -> + DbAction m () +migrateNextPageTxOut mTrce txOutVariantType offst = do + whenJust mTrce $ \trce -> + liftIO $ logInfo trce $ "migrateNextPageTxOut: Handling input offset " <> textShow offst + page <- getInputPage offst + updatePageEntries txOutVariantType page + when (fromIntegral (length page) == pageSize) $ + migrateNextPageTxOut mTrce txOutVariantType $! + (offst + pageSize) + +-------------------------------------------------------------------------------- + +-- | Statement to update tx_out consumed_by_tx_id field +updateTxOutConsumedStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement ConsumedTriplet () +updateTxOutConsumedStmt = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + table = tableName (Proxy @a) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE " + , table + , " SET consumed_by_tx_id = $3" + , " WHERE tx_id = $1" + , " AND index = $2" + ] + + -- Encoder using ConsumedTriplet + txIdEncoder = HsqlE.param $ HsqlE.nonNullable $ Id.getTxId >$< HsqlE.int8 + word64Encoder = HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8 + + encoder = + contramap ctTxOutTxId txIdEncoder + <> contramap ctTxOutIndex word64Encoder + <> contramap ctTxInTxId txIdEncoder + +-- | Update a tx_out record to set consumed_by_tx_id based on transaction info +updateTxOutConsumedByTxIdUnique :: + MonadIO m => + TxOutVariantType -> + ConsumedTriplet -> + DbAction m () +updateTxOutConsumedByTxIdUnique txOutVariantType triplet = do + let callInfo = mkCallInfo "updateTxOutConsumedByTxIdUnique" + + case txOutVariantType of + TxOutVariantCore -> + runDbSession callInfo $ + HsqlSes.statement triplet (updateTxOutConsumedStmt @C.TxOutCore) + TxOutVariantAddress -> + runDbSession callInfo $ + HsqlSes.statement triplet (updateTxOutConsumedStmt @V.TxOutAddress) + +-- | Update page entries from a list of ConsumedTriplet +updatePageEntries :: + MonadIO m => + TxOutVariantType -> + [ConsumedTriplet] -> + DbAction m () +updatePageEntries txOutVariantType = mapM_ (updateTxOutConsumedByTxIdUnique txOutVariantType) + +-------------------------------------------------------------------------------- + +-- | Statement for creating the consumed_by_tx_id index +createConsumedIndexTxOutStmt :: HsqlStmt.Statement () () +createConsumedIndexTxOutStmt = + HsqlStmt.Statement sql HsqlE.noParams HsqlD.noResult True + where + sql = + TextEnc.encodeUtf8 + "CREATE INDEX IF NOT EXISTS idx_tx_out_consumed_by_tx_id ON tx_out (consumed_by_tx_id)" + +-- | Create index on consumed_by_tx_id in tx_out table +createConsumedIndexTxOut :: + MonadIO m => + DbAction m () +createConsumedIndexTxOut = + runDbSession (mkCallInfo "createConsumedIndexTxOut") $ + HsqlSes.statement () createConsumedIndexTxOutStmt + +-------------------------------------------------------------------------------- + +-- | Statement for creating the pruning constraint +createPruneConstraintTxOutStmt :: HsqlStmt.Statement () () +createPruneConstraintTxOutStmt = + HsqlStmt.Statement sql HsqlE.noParams HsqlD.noResult True + where + sql = + TextEnc.encodeUtf8 $ + 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 $$;" + ] + +-- | Create constraint for pruning tx_out +createPruneConstraintTxOut :: + MonadIO m => + DbAction m () +createPruneConstraintTxOut = + runDbSession (mkCallInfo "createPruneConstraintTxOut") $ + HsqlSes.statement () createPruneConstraintTxOutStmt + +-------------------------------------------------------------------------------- + +-- | Get a page of consumed TX inputs +getInputPage :: + MonadIO m => + -- | Offset + Word64 -> + DbAction m [ConsumedTriplet] +getInputPage offset = + runDbSession (mkCallInfo "getInputPage") $ + HsqlSes.statement offset getInputPageStmt + +-- | Statement to get a page of inputs from tx_in table +getInputPageStmt :: HsqlStmt.Statement Word64 [ConsumedTriplet] +getInputPageStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_out_id, tx_out_index, tx_in_id" + , " FROM tx_in" + , " ORDER BY id" + , " LIMIT " + , Text.pack (show pageSize) + , " OFFSET $1" + ] + + encoder = HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8 + + decoder = HsqlD.rowList $ do + txOutId <- Id.idDecoder Id.TxId + txOutIndex <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + txInId <- Id.idDecoder Id.TxId + pure $ + ConsumedTriplet + { ctTxOutTxId = txOutId + , ctTxOutIndex = txOutIndex + , ctTxInTxId = txInId + } + +-------------------------------------------------------------------------------- + +-- Statement function for finding max TxInId by block difference +findMaxTxInIdStmt :: HsqlStmt.Statement Word64 (Either Text.Text Id.TxId) +findMaxTxInIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH tip AS (" + , " SELECT MAX(block_no) AS max_block_no FROM block" + , ")" + , ", target_block AS (" + , " SELECT id FROM block WHERE block_no = (SELECT max_block_no - $1 FROM tip)" + , ")" + , ", max_tx AS (" + , " SELECT MAX(id) AS max_tx_id FROM tx" + , " WHERE block_id <= (SELECT id FROM target_block)" + , ")" + , "SELECT max_tx_id FROM max_tx" + ] + + encoder = fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8) + + decoder = HsqlD.singleRow $ do + mTxId <- Id.maybeIdDecoder Id.TxId + let result = case mTxId of + Nothing -> Left "No transactions found before the specified block" + Just txId -> Right txId + pure result + +findMaxTxInId :: MonadIO m => Word64 -> DbAction m (Either Text.Text Id.TxId) +findMaxTxInId blockNoDiff = + runDbSession (mkCallInfo "findMaxTxInId") $ + HsqlSes.statement blockNoDiff findMaxTxInIdStmt + +-------------------------------------------------------------------------------- + +-- Delete consumed tx outputs before a specified tx +deleteConsumedBeforeTxStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement (Maybe Id.TxId) Int64 +deleteConsumedBeforeTxStmt = + HsqlStmt.Statement sql encoder decoder True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "DELETE FROM " <> tableN + , " WHERE consumed_by_tx_id <= $1" + , " RETURNING 1" + ] + + encoder = HsqlE.param $ HsqlE.nullable $ Id.getTxId >$< HsqlE.int8 + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.int8) + +-- Function to run delete operation +deleteConsumedBeforeTx :: + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + Id.TxId -> + DbAction m () +deleteConsumedBeforeTx trce txOutVariantType txId = + runDbSession (mkCallInfo "deleteConsumedBeforeTx") $ do + countDeleted <- case txOutVariantType of + TxOutVariantCore -> + HsqlSes.statement (Just txId) (deleteConsumedBeforeTxStmt @C.TxOutCore) + TxOutVariantAddress -> + HsqlSes.statement (Just txId) (deleteConsumedBeforeTxStmt @V.TxOutAddress) + liftIO $ logInfo trce $ "Deleted " <> textShow countDeleted <> " tx_out" + +-- Delete consumed tx outputs +deleteConsumedTxOut :: + forall m. + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + Word64 -> + DbAction m () +deleteConsumedTxOut trce txOutVariantType blockNoDiff = do + maxTxIdResult <- findMaxTxInId blockNoDiff + case maxTxIdResult of + Left errMsg -> liftIO $ logInfo trce $ "No tx_out was deleted: " <> errMsg + Right txId -> deleteConsumedBeforeTx trce txOutVariantType txId + +-------------------------------------------------------------------------------- + +-- Statement for deleting TxOut entries +deletePageEntriesStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement [ConsumedTriplet] () +deletePageEntriesStmt = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH entries AS (" + , " SELECT unnest($1::bigint[]) as tx_out_tx_id," + , " unnest($2::int[]) as tx_out_index" + , ")" + , "DELETE FROM " <> tableN + , "WHERE (tx_id, index) IN (SELECT tx_out_tx_id, tx_out_index FROM entries)" + ] + + encoder = contramap extract encodePartialBulk + + extract :: [ConsumedTriplet] -> ([Id.TxId], [Word64]) + extract xs = + ( map ctTxOutTxId xs + , map ctTxOutIndex xs + ) + + encodePartialBulk :: HsqlE.Params ([Id.TxId], [Word64]) + encodePartialBulk = + contrazip2 + (bulkEncoder $ HsqlE.nonNullable $ Id.getTxId >$< HsqlE.int8) + (bulkEncoder $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int4) + +-- Function to delete page entries +deletePageEntries :: + MonadIO m => + TxOutVariantType -> + [ConsumedTriplet] -> + DbAction m () +deletePageEntries txOutVariantType entries = + unless (null entries) $ + runDbSession (mkCallInfo "deletePageEntries") $ do + case txOutVariantType of + TxOutVariantCore -> + HsqlSes.statement entries (deletePageEntriesStmt @C.TxOutCore) + TxOutVariantAddress -> + HsqlSes.statement entries (deletePageEntriesStmt @V.TxOutAddress) + +-------------------------------------------------------------------------------- + +-- Statement for updating TxOut entries with consumed_by_tx_id +updatePageEntriesStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement [ConsumedTriplet] () +updatePageEntriesStmt = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH entries AS (" + , " SELECT unnest($1::bigint[]) as tx_out_tx_id," + , " unnest($2::int[]) as tx_out_index," + , " unnest($3::bigint[]) as tx_in_tx_id" + , ")" + , "UPDATE " <> tableN + , "SET consumed_by_tx_id = entries.tx_in_tx_id" + , "WHERE (tx_id, index) IN (SELECT tx_out_tx_id, tx_out_index FROM entries)" + ] + + encoder = contramap extract encodeConsumedTripletBulk + + extract :: [ConsumedTriplet] -> ([Id.TxId], [Word64], [Id.TxId]) + extract xs = + ( map ctTxOutTxId xs + , map ctTxOutIndex xs + , map ctTxInTxId xs + ) + +-------------------------------------------------------------------------------- + +-- Helper function for creating consumed index if needed +shouldCreateConsumedTxOut :: + MonadIO m => + Trace IO Text.Text -> + Bool -> + DbAction m () +shouldCreateConsumedTxOut trce rcc = + unless rcc $ do + liftIO $ logInfo trce "Created ConsumedTxOut when handling page entries." + createConsumedIndexTxOut + +-------------------------------------------------------------------------------- + +-- Split and process page entries +splitAndProcessPageEntries :: + forall m. + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + Bool -> + Id.TxId -> + [ConsumedTriplet] -> + DbAction m Bool +splitAndProcessPageEntries trce txOutVariantType 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 than maxTxInId + (xs, []) -> do + deletePageEntries txOutVariantType xs + pure False + -- the whole list is greater than maxTxInId + ([], ys) -> do + shouldCreateConsumedTxOut trce ranCreateConsumedTxOut + updatePageEntries txOutVariantType ys + pure True + -- the list has both below and above maxTxInId + (xs, ys) -> do + deletePageEntries txOutVariantType xs + shouldCreateConsumedTxOut trce ranCreateConsumedTxOut + updatePageEntries txOutVariantType ys + pure True + +-------------------------------------------------------------------------------- + +-- Main function for delete and update +deleteAndUpdateConsumedTxOut :: + forall m. + MonadIO m => + Trace IO Text.Text -> + TxOutVariantType -> + MigrationValues -> + Word64 -> + DbAction m () +deleteAndUpdateConsumedTxOut trce txOutVariantType migrationValues blockNoDiff = do + maxTxIdResult <- findMaxTxInId blockNoDiff + case maxTxIdResult 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 txOutVariantType $ Just migrationValues + insertExtraMigration ConsumeTxOutPreviouslySet + Right maxTxId -> do + migrateNextPage maxTxId False 0 + where + migrateNextPage :: Id.TxId -> Bool -> Word64 -> DbAction m () + migrateNextPage maxTxId ranCreateConsumedTxOut offst = do + pageEntries <- getInputPage offst + resPageEntries <- splitAndProcessPageEntries trce txOutVariantType ranCreateConsumedTxOut maxTxId pageEntries + when (fromIntegral (length pageEntries) == pageSize) $ + migrateNextPage maxTxId resPageEntries $! + offst + pageSize + +-------------------------------------------------------------------------------- + +migrateTxOutDbTool :: MonadIO m => TxOutVariantType -> DbAction m () +migrateTxOutDbTool txOutVariantType = do + createConsumedIndexTxOut + migrateNextPageTxOut Nothing txOutVariantType 0 + +-------------------------------------------------------------------------------- + +-- | Update a list of TxOut consumed by TxId mappings +updateListTxOutConsumedByTxId :: MonadIO m => [(TxOutIdW, Id.TxId)] -> DbAction m () +updateListTxOutConsumedByTxId = mapM_ (uncurry updateTxOutConsumedByTxId) + where + updateTxOutConsumedByTxId :: MonadIO m => TxOutIdW -> Id.TxId -> DbAction m () + updateTxOutConsumedByTxId txOutId txId = + case txOutId of + VCTxOutIdW txOutCoreId -> + runDbSession (mkCallInfo "updateTxOutConsumedByTxId") $ + HsqlSes.statement (txOutCoreId, Just txId) updateTxOutConsumedByTxIdCore + VATxOutIdW txOutAddressId -> + runDbSession (mkCallInfo "updateTxOutConsumedByTxId") $ + HsqlSes.statement (txOutAddressId, Just txId) updateTxOutConsumedByTxIdAddress + +-- | Statement to update Core TxOut consumed_by_tx_id field by ID +updateTxOutConsumedByTxIdCore :: + HsqlStmt.Statement (Id.TxOutCoreId, Maybe Id.TxId) () +updateTxOutConsumedByTxIdCore = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + tableN = tableName (Proxy @C.TxOutCore) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE " <> tableN + , " SET consumed_by_tx_id = $2" + , " WHERE id = $1" + ] + + encoder = + mconcat + [ fst >$< HsqlE.param (HsqlE.nonNullable $ Id.getTxOutCoreId >$< HsqlE.int8) + , snd >$< HsqlE.param (HsqlE.nullable $ Id.getTxId >$< HsqlE.int8) + ] + +-- | Statement to update Address TxOut consumed_by_tx_id field by ID +updateTxOutConsumedByTxIdAddress :: + HsqlStmt.Statement (Id.TxOutAddressId, Maybe Id.TxId) () +updateTxOutConsumedByTxIdAddress = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + tableN = tableName (Proxy @V.TxOutAddress) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "UPDATE " <> tableN + , " SET consumed_by_tx_id = $2" + , " WHERE id = $1" + ] + + encoder = + mconcat + [ fst >$< HsqlE.param (HsqlE.nonNullable $ Id.getTxOutAddressId >$< HsqlE.int8) + , snd >$< HsqlE.param (HsqlE.nullable $ Id.getTxId >$< HsqlE.int8) + ] + +-------------------------------------------------------------------------------- + +-- | Count of TxOuts with null consumed_by_tx_id +queryTxOutConsumedNullCountStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement () Word64 +queryTxOutConsumedNullCountStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> tableN + , " WHERE consumed_by_tx_id IS NULL" + ] + + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + +-- | Query for count of TxOuts with null consumed_by_tx_id +queryTxOutConsumedNullCount :: MonadIO m => TxOutVariantType -> DbAction m Word64 +queryTxOutConsumedNullCount = \case + TxOutVariantCore -> + runDbSession (mkCallInfo "queryTxOutConsumedNullCount") $ + HsqlSes.statement () (queryTxOutConsumedNullCountStmt @C.TxOutCore) + TxOutVariantAddress -> + runDbSession (mkCallInfo "queryTxOutConsumedNullCount") $ + HsqlSes.statement () (queryTxOutConsumedNullCountStmt @V.TxOutAddress) + +-------------------------------------------------------------------------------- + +-- | Count of TxOuts with non-null consumed_by_tx_id +queryTxOutConsumedCountStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement () Word64 +queryTxOutConsumedCountStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> tableN + , " WHERE consumed_by_tx_id IS NOT NULL" + ] + + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + +-------------------------------------------------------------------------------- + +-- | Statement for querying TxOuts where consumed_by_tx_id equals tx_id +queryWrongConsumedByStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement () Word64 +queryWrongConsumedByStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM " <> tableN + , " WHERE tx_id = consumed_by_tx_id" + ] + + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + +-- | Query for count of TxOuts with consumed_by_tx_id equal to tx_id (which is wrong) +queryWrongConsumedBy :: MonadIO m => TxOutVariantType -> DbAction m Word64 +queryWrongConsumedBy = \case + TxOutVariantCore -> + runDbSession (mkCallInfo "queryWrongConsumedBy") $ + HsqlSes.statement () (queryWrongConsumedByStmt @C.TxOutCore) + TxOutVariantAddress -> + runDbSession (mkCallInfo "queryWrongConsumedBy") $ + HsqlSes.statement () (queryWrongConsumedByStmt @V.TxOutAddress) 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..49a4c0b05 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/EpochAndProtocol.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.EpochAndProtocol where + +import Cardano.Prelude (MonadError (..), MonadIO (..), Proxy (..), Word64, void) +import Data.Functor.Contravariant ((>$<)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import Data.Time (UTCTime) +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.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 (countAll, replace, selectByField) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..)) +import Cardano.Db.Types (DbAction (..), DbCallInfo (..), DbLovelace (..)) + +-------------------------------------------------------------------------------- +-- 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") $ HsqlSes.statement costModel costModelStmt + pure $ entityKey entity + +queryCostModelStmt :: HsqlStmt.Statement () [Id.CostModelId] +queryCostModelStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SEnP.CostModel) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM " <> tableN + , " ORDER BY id ASC" + ] + decoder = + HsqlD.rowList $ + Id.idDecoder Id.CostModelId + +queryCostModel :: MonadIO m => DbAction m [Id.CostModelId] +queryCostModel = + runDbSession (mkCallInfo "queryCostModel") $ + HsqlSes.statement () queryCostModelStmt + +-------------------------------------------------------------------------------- +-- 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") $ HsqlSes.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") $ + HsqlSes.statement blockId queryAdaPotsIdStmt + +-- AdaPots query function used in tests +queryAdaPotsIdTest :: MonadIO m => Id.BlockId -> DbAction m (Maybe SEnP.AdaPots) +queryAdaPotsIdTest blockId = do + mEntityAdaPots <- runDbSession (mkCallInfo "queryAdaPotsId") $ + HsqlSes.statement blockId queryAdaPotsIdStmt + pure $ entityVal <$> mEntityAdaPots + +-------------------------------------------------------------------------------- +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") $ + HsqlSes.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") $ + HsqlSes.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") $ HsqlSes.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") $ HsqlSes.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") $ HsqlSes.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 $ HsqlSes.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") $ + HsqlSes.statement epochNum queryCalcEpochEntryStmt + +-------------------------------------------------------------------------------- +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") $ + HsqlSes.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") $ + HsqlSes.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") $ + HsqlSes.statement () queryLatestEpochStmt + +-------------------------------------------------------------------------------- +queryEpochCount :: MonadIO m => DbAction m Word64 +queryEpochCount = + runDbSession (mkCallInfo "queryEpochCount") $ + HsqlSes.statement () (countAll @SEnP.Epoch) + +-------------------------------------------------------------------------------- +queryLatestCachedEpochNoStmt :: HsqlStmt.Statement () (Maybe Word64) +queryLatestCachedEpochNoStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT no" + , " FROM epoch" + , " ORDER BY no DESC" + , " LIMIT 1" + ] + + decoder = HsqlD.rowMaybe $ do + epochNo <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ fromIntegral epochNo + +queryLatestCachedEpochNo :: MonadIO m => DbAction m (Maybe Word64) +queryLatestCachedEpochNo = + runDbSession (mkCallInfo "queryLatestCachedEpochNo") $ + HsqlSes.statement () queryLatestCachedEpochNoStmt + +-------------------------------------------------------------------------------- +replaceEpochStmt :: HsqlStmt.Statement (Id.EpochId, SEnP.Epoch) () +replaceEpochStmt = + replace + (Id.idEncoder Id.getEpochId) + SEnP.epochEncoder + +replaceEpoch :: MonadIO m => Id.EpochId -> SEnP.Epoch -> DbAction m () +replaceEpoch epochId epoch = + runDbSession (mkCallInfo "replaceEpoch") $ + HsqlSes.statement (epochId, epoch) replaceEpochStmt + +-------------------------------------------------------------------------------- +-- 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") $ +-- HsqlSes.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") $ HsqlSes.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") $ + HsqlSes.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") $ HsqlSes.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") $ HsqlSes.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..475c5372a --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Core.hs @@ -0,0 +1,137 @@ +{-# 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] + +-- | The bulk insert result type +data ResultTypeBulk a where + NoResultBulk :: ResultTypeBulk () -- No results returned + WithResultBulk :: HsqlD.Result [a] -> ResultTypeBulk [a] -- Return generated IDs + +-- | 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/Delete.hs b/cardano-db/src/Cardano/Db/Statement/Function/Delete.hs new file mode 100644 index 000000000..61501585b --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Delete.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Function.Delete where + +import Cardano.Prelude (Int64, Proxy (..)) +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.Statement as HsqlS + +import Cardano.Db.Statement.Types (DbInfo (..), validateColumn) + +-- | Creates a statement to delete rows that match a condition on a column +-- +-- === Example +-- @ +-- deleteInvalidRecords :: MonadIO m => DbAction m () +-- deleteInvalidRecords = +-- runDbSession (mkCallInfo "deleteInvalidRecords") $ +-- HsqlSes.statement () (deleteWhere @Record "status" "= 'INVALID'") +-- @ +deleteWhere :: + forall a. + (DbInfo a) => + -- | Column name to filter on + Text.Text -> + -- | SQL condition to apply (e.g., "IS NULL", ">= $1", "= 'INVALID'") + Text.Text -> + -- | Returns a statement that deletes matching rows + HsqlS.Statement () () +deleteWhere colName condition = + HsqlS.Statement sql HsqlE.noParams HsqlD.noResult True + where + -- Validate the column name + validCol = validateColumn @a colName + + -- SQL statement to delete rows matching the condition + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "DELETE FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " " <> condition + ] + +-- | Helper function for parameterized DELETE queries +parameterisedDeleteWhere :: + forall a p. + (DbInfo a) => + -- | Column name + Text.Text -> + -- | Condition with placeholder + Text.Text -> + -- | Parameter encoder + HsqlE.Params p -> + HsqlS.Statement p () +parameterisedDeleteWhere colName condition encoder = + HsqlS.Statement sql encoder HsqlD.noResult True + where + validCol = validateColumn @a colName + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "DELETE FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " " <> condition + ] + +-- | Creates a statement to delete rows and return the count of deleted rows +-- +-- === Example +-- @ +-- deleteTxOutRecords :: MonadIO m => DbAction m Int64 +-- deleteTxOutRecords = +-- runDbSession (mkCallInfo "deleteTxOutRecords") $ +-- HsqlSes.statement () (deleteWhereCount @TxOutCore "id" ">=" HsqlE.noParams) +-- @ +deleteWhereCount :: + forall a b. + (DbInfo a) => + -- | Column name to filter on + Text.Text -> + -- | SQL condition to apply (e.g., "IS NULL", ">=", "=") + Text.Text -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Returns a statement that deletes matching rows and returns count + HsqlS.Statement b Int64 +deleteWhereCount colName condition encoder = + HsqlS.Statement sql encoder decoder True + where + -- Validate the column name + validCol = validateColumn @a colName + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.int8) + + -- Condition with parameter placeholder if needed + conditionWithParam = + if "NULL" `Text.isInfixOf` condition || "'" `Text.isInfixOf` condition + then condition -- For "IS NULL" or literal values like "= 'INVALID'" + else condition <> " $1" -- For parameter-based conditions like ">=" + + -- SQL statement with RETURNING count + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH deleted AS (" + , " DELETE FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " " <> conditionWithParam + , " RETURNING *" + , ")" + , "SELECT COUNT(*)::bigint FROM deleted" + ] + +-- | Creates a statement to delete all rows in a table +-- +-- === Example +-- @ +-- truncateTable :: MonadIO m => DbAction m () +-- truncateTable = +-- runDbSession (mkCallInfo "truncateTable") $ +-- HsqlSes.statement () (deleteAll @MyTable) +-- @ +deleteAll :: + forall a. + (DbInfo a) => + HsqlS.Statement () () +deleteAll = + HsqlS.Statement sql HsqlE.noParams HsqlD.noResult True + where + table = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + ["DELETE FROM " <> table] + +-- | Creates a statement to delete all rows in a table and return the count +-- +-- === Example +-- @ +-- truncateAndCount :: MonadIO m => DbAction m Int64 +-- truncateAndCount = +-- runDbSession (mkCallInfo "truncateAndCount") $ +-- HsqlSes.statement () (deleteAllCount @MyTable) +-- @ +deleteAllCount :: + forall a. + (DbInfo a) => + HsqlS.Statement () Int64 +deleteAllCount = + HsqlS.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @a) + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.int8) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH deleted AS (" + , " DELETE FROM " <> table + , " RETURNING *" + , ")" + , "SELECT COUNT(*)::bigint FROM deleted" + ] 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..d0f84f292 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Insert.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Function.Insert ( + insert, + insertCheckUnique, + insertIfUnique, + 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 a record into a table, only if it doesn't violate a unique constraint. +-- Returns Nothing if the record already exists (based on unique constraints). +insertIfUnique :: + forall a c. + (DbInfo a) => + HsqlE.Params a -> -- Encoder + HsqlD.Row (Entity c) -> -- Row decoder + HsqlS.Statement a (Maybe (Entity c)) -- Statement that returns Maybe Entity +insertIfUnique encoder entityDecoder = + case validateUniqueConstraints (Proxy @a) of + Left err -> error err + Right _ -> HsqlS.Statement sql encoder decoder True + where + decoder = HsqlD.rowMaybe entityDecoder + + table = tableName (Proxy @a) + colNames = columnNames (Proxy @a) + uniqueCols = uniqueFields (Proxy @a) + + placeholders = Text.intercalate ", " $ map (\i -> "$" <> Text.pack (show i)) [1 .. length (NE.toList colNames)] + + -- This SQL will try to insert, but on conflict will do nothing + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH ins AS (" + , " INSERT INTO " <> table + , " (" <> Text.intercalate ", " (NE.toList colNames) <> ")" + , " VALUES (" <> placeholders <> ")" + , " ON CONFLICT (" <> Text.intercalate ", " uniqueCols <> ") DO NOTHING" + , " RETURNING *" + , ")" + , "SELECT * FROM ins" + ] + +-- | 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 r. + (DbInfo a) => + ([a] -> b) -> -- Field extractor + HsqlE.Params b -> -- Encoder + ResultTypeBulk 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..7670f3a32 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Function/Query.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Cardano.Db.Statement.Function.Query where + +import Cardano.Prelude (MonadIO, Proxy (..), Word64, fromMaybe) +import Data.Fixed (Fixed (..)) +import Data.Functor.Contravariant (Contravariant (..)) +import qualified Data.List.NonEmpty as NE +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.Statement.Function.Core (ResultType (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Types (DbInfo (..), Entity, Key, validateColumn) +import Cardano.Db.Types (Ada (..), DbAction, lovelaceToAda) + +replace :: + forall a. + (DbInfo a) => + HsqlE.Params (Key a) -> -- ID encoder + HsqlE.Params a -> -- Record encoder + HsqlStmt.Statement (Key a, a) () +replace keyEncoder recordEncoder = + HsqlStmt.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 + HsqlStmt.Statement b (Maybe (Entity a)) +selectByField fieldName paramEncoder entityDecoder = + HsqlStmt.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 :: HsqlStmt.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 + HsqlStmt.Statement (Key a) r +existsById encoder resultType = + HsqlStmt.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)" + ] + +-- | Statement to check if a row exists with a specific value in a given column +-- +-- === Example +-- @ +-- existsWhereStmt :: HsqlStmt.Statement ByteString Bool +-- existsWhereStmt = existsWhere @DelistedPool "hash_raw" (HsqlE.param (HsqlE.nonNullable HsqlE.bytea)) (WithResult boolDecoder) +-- @ +existsWhere :: + forall a r. + (DbInfo a, Key a ~ Key a) => + -- | Column name to filter on + Text.Text -> + -- | Parameter encoder + HsqlE.Params (Key a) -> + -- | Whether to return result and decoder + ResultType Bool r -> + HsqlStmt.Statement (Key a) r +existsWhere colName encoder resultType = + HsqlStmt.Statement sql encoder decoder True + where + decoder = case resultType of + NoResult -> HsqlD.noResult + WithResult dec -> dec + + table = tableName (Proxy @a) + validCol = validateColumn @a colName + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT EXISTS (" + , " SELECT 1" + , " FROM " <> table + , " WHERE " <> validCol <> " = $1" + , ")" + ] + +-- | Statement to check if a row exists with a specific value in a given column +-- +-- === Example +-- @ +-- existsWhereByColumnStmt :: HsqlStmt.Statement ByteString Bool +-- existsWhereByColumnStmt = existsWhereByColumn @DelistedPool "hash_raw" (HsqlE.param (HsqlE.nonNullable HsqlE.bytea)) (WithResult boolDecoder) +-- @ +existsWhereByColumn :: + forall a b r. + (DbInfo a) => + -- | Column name to filter on + Text.Text -> + -- | Parameter encoder for the column value + HsqlE.Params b -> + -- | Whether to return result and decoder + ResultType Bool r -> + HsqlStmt.Statement b r +existsWhereByColumn colName encoder resultType = + HsqlStmt.Statement sql encoder decoder True + where + decoder = case resultType of + NoResult -> HsqlD.noResult + WithResult dec -> dec + + table = tableName (Proxy @a) + validCol = validateColumn @a colName + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT EXISTS (" + , " SELECT 1" + , " FROM " <> table + , " WHERE " <> validCol <> " = $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") $ +-- HsqlStmt.statement (key, record) $ replaceRecord +-- @VotingAnchor +-- (idEncoder getVotingAnchorId) +-- votingAnchorEncoder +-- @ +replaceRecord :: + forall a. + (DbInfo a) => + HsqlE.Params (Key a) -> -- Key encoder + HsqlE.Params a -> -- Record encoder + HsqlStmt.Statement (Key a, a) () -- Returns a statement to replace a record +replaceRecord keyEnc recordEnc = + HsqlStmt.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 => TxOutVariantType -> DbAction m Word64 +-- queryTxOutUnspentCount txOutVariantType = +-- case txOutVariantType of +-- TxOutVariantCore -> +-- 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 + HsqlStmt.Statement () Word64 +countWhere colName condition = + HsqlStmt.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 -> + HsqlStmt.Statement p Word64 +parameterisedCountWhere colName condition encoder = + HsqlStmt.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 + HsqlStmt.Statement () Word64 +countAll = + HsqlStmt.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 + ] + +--------------------------------------------------------------------------- +-- REFERENCE ID QUERIES +--------------------------------------------------------------------------- + +-- | Find the minimum ID in a table +queryMinRefIdStmt :: + forall a b. + (DbInfo a) => + -- | Field name to filter on + Text.Text -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Key decoder + HsqlD.Row (Key a) -> + HsqlStmt.Statement b (Maybe (Key a)) +queryMinRefIdStmt fieldName encoder keyDecoder = + HsqlStmt.Statement sql encoder decoder True + where + validCol = validateColumn @a fieldName + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " >= $1" + , " ORDER BY id ASC" + , " LIMIT 1" + ] + decoder = HsqlD.rowMaybe keyDecoder + +queryMinRefId :: + forall a b m. + (DbInfo a, MonadIO m) => + -- | Field name + Text.Text -> + -- | Value to compare against + b -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Key decoder + HsqlD.Row (Key a) -> + DbAction m (Maybe (Key a)) +queryMinRefId fieldName value encoder keyDecoder = + runDbSession (mkCallInfo "queryMinRefId") $ + HsqlSes.statement value (queryMinRefIdStmt @a fieldName encoder keyDecoder) + +--------------------------------------------------------------------------- +queryMinRefIdNullableStmt :: + forall a b. + (DbInfo a) => + -- | Field name to filter on + Text.Text -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Key decoder + HsqlD.Row (Key a) -> + HsqlStmt.Statement b (Maybe (Key a)) +queryMinRefIdNullableStmt fieldName encoder keyDecoder = + HsqlStmt.Statement sql encoder decoder True + where + validCol = validateColumn @a fieldName + decoder = HsqlD.rowMaybe keyDecoder + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " IS NOT NULL" + , " AND " <> validCol <> " >= $1" + , " ORDER BY id ASC" + , " LIMIT 1" + ] + +queryMinRefIdNullable :: + forall a b m. + (DbInfo a, MonadIO m) => + -- | Field name + Text.Text -> + -- | Value to compare against + b -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Key decoder + HsqlD.Row (Key a) -> + DbAction m (Maybe (Key a)) +queryMinRefIdNullable fieldName value encoder keyDecoder = + runDbSession (mkCallInfo "queryMinRefIdNullable") $ + HsqlSes.statement value (queryMinRefIdNullableStmt @a fieldName encoder keyDecoder) + +--------------------------------------------------------------------------- +queryMaxRefIdStmt :: + forall a b. + (DbInfo a) => + -- | Field name to filter on + Text.Text -> + -- | Equal or strictly less + Bool -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Key decoder + HsqlD.Row (Key a) -> + HsqlStmt.Statement b (Maybe (Key a)) +queryMaxRefIdStmt fieldName eq encoder keyDecoder = + HsqlStmt.Statement sql encoder decoder True + where + validCol = validateColumn @a fieldName + op = if eq then "<=" else "<" + decoder = HsqlD.rowMaybe keyDecoder + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM " <> tableName (Proxy @a) + , " WHERE " <> validCol <> " " <> op <> " $1" + , " ORDER BY id DESC" + , " LIMIT 1" + ] + +queryMaxRefId :: + forall a b m. + (DbInfo a, MonadIO m) => + -- | Field name + Text.Text -> + -- | Value to compare against + b -> + -- | Equal or strictly less + Bool -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Key decoder + HsqlD.Row (Key a) -> + DbAction m (Maybe (Key a)) +queryMaxRefId fieldName value eq encoder keyDecoder = + runDbSession (mkCallInfo "queryMaxRefId") $ + HsqlSes.statement value (queryMaxRefIdStmt @a fieldName eq encoder keyDecoder) + +--------------------------------------------------------------------------- +-- QUERY HELPERS +--------------------------------------------------------------------------- + +-- Decoder for Ada amounts from database int8 values +adaDecoder :: HsqlD.Row Ada +adaDecoder = do + amount <- HsqlD.column (HsqlD.nonNullable HsqlD.int8) + pure $ lovelaceToAda (MkFixed $ fromIntegral amount) + +-- Decoder for summed Ada amounts with null handling +adaSumDecoder :: HsqlD.Row Ada +adaSumDecoder = do + amount <- HsqlD.column (HsqlD.nullable HsqlD.int8) + case amount of + Just value -> pure $ lovelaceToAda (MkFixed $ fromIntegral value) + Nothing -> pure $ 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 :: HsqlD.Result Ada +unValueSumAda = + HsqlD.singleRow $ + fromMaybe (Ada 0) <$> HsqlD.column (HsqlD.nullable (Ada . fromIntegral <$> HsqlD.int8)) 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..1f6e8b939 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/GovernanceAndVoting.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Db.Statement.GovernanceAndVoting where + +import Cardano.Prelude (ByteString, Int64, MonadError (..), MonadIO, Proxy (..), Word64) +import Data.Functor.Contravariant (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 HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import Cardano.Db.Error (DbError (..)) +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 (..), validateColumn) +import Cardano.Db.Types (DbAction, DbCallInfo (..), hardcodedAlwaysAbstain, hardcodedAlwaysNoConfidence) + +-------------------------------------------------------------------------------- +-- Committee +-------------------------------------------------------------------------------- +insertCommitteeStmt :: HsqlStmt.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") $ HsqlSes.statement committee insertCommitteeStmt + pure $ entityKey entity + +queryProposalCommitteeStmt :: HsqlStmt.Statement (Maybe Id.GovActionProposalId) [Id.CommitteeId] +queryProposalCommitteeStmt = + HsqlStmt.Statement sql encoder decoder True + where + table = tableName (Proxy @SGV.Committee) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM " <> table + , " WHERE ($1::bigint IS NULL AND gov_action_proposal_id IS NULL)" + , " OR ($1::bigint IS NOT NULL AND gov_action_proposal_id = $1)" + ] + + encoder = + HsqlE.param + ( HsqlE.nullable $ + Id.getGovActionProposalId >$< HsqlE.int8 + ) + + decoder = + HsqlD.rowList + ( HsqlD.column $ + HsqlD.nonNullable $ + Id.CommitteeId <$> HsqlD.int8 + ) + +queryProposalCommittee :: MonadIO m => Maybe Id.GovActionProposalId -> DbAction m [Id.CommitteeId] +queryProposalCommittee mgapId = + runDbSession (mkCallInfo "queryProposalCommittee") $ + HsqlSes.statement mgapId queryProposalCommitteeStmt + +-------------------------------------------------------------------------------- +-- CommitteeHash +-------------------------------------------------------------------------------- + +-- | Insert +insertCommitteeHashStmt :: HsqlStmt.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") $ HsqlSes.statement committeeHash insertCommitteeHashStmt + pure $ entityKey entity + +-- | Query +queryCommitteeHashStmt :: HsqlStmt.Statement ByteString (Maybe Id.CommitteeHashId) +queryCommitteeHashStmt = + HsqlStmt.Statement sql encoder decoder True + where + table = tableName (Proxy @SGV.CommitteeHash) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM " <> table + , " WHERE raw = $1" + , " 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") $ + HsqlSes.statement hash queryCommitteeHashStmt + +-------------------------------------------------------------------------------- +-- CommitteeMember +-------------------------------------------------------------------------------- +insertCommitteeMemberStmt :: HsqlStmt.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") $ HsqlSes.statement committeeMember insertCommitteeMemberStmt + pure $ entityKey entity + +insertCommitteeDeRegistrationStmt :: HsqlStmt.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") $ + HsqlSes.statement committeeDeRegistration insertCommitteeDeRegistrationStmt + pure $ entityKey entity + +insertCommitteeRegistrationStmt :: HsqlStmt.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") $ + HsqlSes.statement committeeRegistration insertCommitteeRegistrationStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Constitution +-------------------------------------------------------------------------------- +insertConstitutionStmt :: HsqlStmt.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") $ HsqlSes.statement constitution insertConstitutionStmt + pure $ entityKey entity + +queryProposalConstitutionStmt :: HsqlStmt.Statement (Maybe Id.GovActionProposalId) [Id.ConstitutionId] +queryProposalConstitutionStmt = + HsqlStmt.Statement sql encoder decoder True + where + table = tableName (Proxy @SGV.Constitution) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM " <> table + , " WHERE ($1::bigint IS NULL AND gov_action_proposal_id IS NULL)" + , " OR ($1::bigint IS NOT NULL AND gov_action_proposal_id = $1)" + ] + + encoder = + HsqlE.param + ( HsqlE.nullable $ + Id.getGovActionProposalId >$< HsqlE.int8 + ) + + decoder = + HsqlD.rowList + ( HsqlD.column $ + HsqlD.nonNullable $ + Id.ConstitutionId <$> HsqlD.int8 + ) + +queryProposalConstitution :: MonadIO m => Maybe Id.GovActionProposalId -> DbAction m [Id.ConstitutionId] +queryProposalConstitution mgapId = + runDbSession (mkCallInfo "queryProposalConstitution") $ + HsqlSes.statement mgapId queryProposalConstitutionStmt + +-------------------------------------------------------------------------------- +-- DelegationVote +-------------------------------------------------------------------------------- +insertDelegationVoteStmt :: HsqlStmt.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") $ HsqlSes.statement delegationVote insertDelegationVoteStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Drep +-------------------------------------------------------------------------------- + +-- | INSERT +insertDrepHashStmt :: HsqlStmt.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") $ HsqlSes.statement drepHash insertDrepHashStmt + pure $ entityKey entity + +insertDrepHashAbstainStmt :: HsqlStmt.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") $ + HsqlSes.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") $ + HsqlSes.statement drepHashNoConfidence insertDrepHashAbstainStmt + pure (entityKey entity) + + drepHashNoConfidence = + SGV.DrepHash + { SGV.drepHashRaw = Nothing + , SGV.drepHashView = hardcodedAlwaysNoConfidence + , SGV.drepHashHasScript = False + } + +insertDrepRegistrationStmt :: HsqlStmt.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") $ HsqlSes.statement drepRegistration insertDrepRegistrationStmt + pure $ entityKey entity + +-- | QUERY +queryDrepHashSpecialStmt :: + forall a. + (DbInfo a) => + Text.Text -> -- targetValue + HsqlStmt.Statement () (Maybe Id.DrepHashId) +queryDrepHashSpecialStmt targetValue = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @a) + rawCol = validateColumn @a "raw" + viewCol = validateColumn @a "view" + idCol = validateColumn @a "id" + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT " + , idCol + , " FROM " + , table + , " WHERE " + , rawCol + , " IS NULL" + , " AND " + , viewCol + , " = '" + , targetValue + , "'" + ] + + decoder = + HsqlD.rowMaybe + ( HsqlD.column $ + HsqlD.nonNullable $ + Id.DrepHashId <$> HsqlD.int8 + ) + +queryDrepHashAlwaysAbstain :: MonadIO m => DbAction m (Maybe Id.DrepHashId) +queryDrepHashAlwaysAbstain = + runDbSession (mkCallInfo "queryDrepHashAlwaysAbstain") $ + HsqlSes.statement () $ + queryDrepHashSpecialStmt @SGV.DrepHash hardcodedAlwaysAbstain + +queryDrepHashAlwaysNoConfidence :: MonadIO m => DbAction m (Maybe Id.DrepHashId) +queryDrepHashAlwaysNoConfidence = + runDbSession (mkCallInfo "queryDrepHashAlwaysNoConfidence") $ + HsqlSes.statement () $ + queryDrepHashSpecialStmt @SGV.DrepHash hardcodedAlwaysNoConfidence + +-------------------------------------------------------------------------------- +-- GovActionProposal +-------------------------------------------------------------------------------- + +-- | INSERT +insertGovActionProposalStmt :: HsqlStmt.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") $ + HsqlSes.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 -> + HsqlStmt.Statement (Id.GovActionProposalId, Int64) r +updateGovActionStateStmt columnName resultType = + HsqlStmt.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 -> + HsqlStmt.Statement Int64 Int64 +setGovActionStateNullStmt columnName = + HsqlStmt.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 :: HsqlStmt.Statement (Id.GovActionProposalId, Int64) Int64 +updateGovActionEnactedStmt = updateGovActionStateStmt "enacted_epoch" (WithResult HsqlD.rowsAffected) + +updateGovActionRatifiedStmt :: HsqlStmt.Statement (Id.GovActionProposalId, Int64) () +updateGovActionRatifiedStmt = updateGovActionStateStmt "ratified_epoch" NoResult + +updateGovActionDroppedStmt :: HsqlStmt.Statement (Id.GovActionProposalId, Int64) () +updateGovActionDroppedStmt = updateGovActionStateStmt "dropped_epoch" NoResult + +updateGovActionExpiredStmt :: HsqlStmt.Statement (Id.GovActionProposalId, Int64) () +updateGovActionExpiredStmt = updateGovActionStateStmt "expired_epoch" NoResult + +setNullEnactedStmt :: HsqlStmt.Statement Int64 Int64 +setNullEnactedStmt = setGovActionStateNullStmt "enacted_epoch" + +setNullRatifiedStmt :: HsqlStmt.Statement Int64 Int64 +setNullRatifiedStmt = setGovActionStateNullStmt "ratified_epoch" + +setNullExpiredStmt :: HsqlStmt.Statement Int64 Int64 +setNullExpiredStmt = setGovActionStateNullStmt "expired_epoch" + +setNullDroppedStmt :: HsqlStmt.Statement Int64 Int64 +setNullDroppedStmt = setGovActionStateNullStmt "dropped_epoch" + +-- Executions +updateGovActionEnacted :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m Int64 +updateGovActionEnacted gaid eNo = + runDbSession (mkCallInfo "updateGovActionEnacted") $ + HsqlSes.statement (gaid, fromIntegral eNo) updateGovActionEnactedStmt + +updateGovActionRatified :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m () +updateGovActionRatified gaid eNo = + runDbSession (mkCallInfo "updateGovActionRatified") $ + HsqlSes.statement (gaid, fromIntegral eNo) updateGovActionRatifiedStmt + +updateGovActionDropped :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m () +updateGovActionDropped gaid eNo = + runDbSession (mkCallInfo "updateGovActionDropped") $ + HsqlSes.statement (gaid, fromIntegral eNo) updateGovActionDroppedStmt + +updateGovActionExpired :: MonadIO m => Id.GovActionProposalId -> Word64 -> DbAction m () +updateGovActionExpired gaid eNo = + runDbSession (mkCallInfo "updateGovActionExpired") $ + HsqlSes.statement (gaid, fromIntegral eNo) updateGovActionExpiredStmt + +setNullEnacted :: MonadIO m => Word64 -> DbAction m Int64 +setNullEnacted eNo = + runDbSession (mkCallInfo "setNullEnacted") $ + HsqlSes.statement (fromIntegral eNo) setNullEnactedStmt + +setNullRatified :: MonadIO m => Word64 -> DbAction m Int64 +setNullRatified eNo = + runDbSession (mkCallInfo "setNullRatified") $ + HsqlSes.statement (fromIntegral eNo) setNullRatifiedStmt + +setNullExpired :: MonadIO m => Word64 -> DbAction m Int64 +setNullExpired eNo = + runDbSession (mkCallInfo "setNullExpired") $ + HsqlSes.statement (fromIntegral eNo) setNullExpiredStmt + +setNullDropped :: MonadIO m => Word64 -> DbAction m Int64 +setNullDropped eNo = + runDbSession (mkCallInfo "setNullDropped") $ + HsqlSes.statement (fromIntegral eNo) setNullDroppedStmt + +queryGovActionProposalIdStmt :: HsqlStmt.Statement (Id.TxId, Word64) (Maybe Id.GovActionProposalId) +queryGovActionProposalIdStmt = + HsqlStmt.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 :: HsqlStmt.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") $ + HsqlSes.statement paramProposal insertParamProposalStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Treasury +-------------------------------------------------------------------------------- +insertTreasuryStmt :: HsqlStmt.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") $ HsqlSes.statement treasury insertTreasuryStmt + pure $ entityKey entity + +insertTreasuryWithdrawalStmt :: HsqlStmt.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") $ + HsqlSes.statement treasuryWithdrawal insertTreasuryWithdrawalStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- Voting +-------------------------------------------------------------------------------- + +-- | INSERT +insertVotingAnchorStmt :: HsqlStmt.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") $ + HsqlSes.statement votingAnchor insertVotingAnchorStmt + pure $ entityKey entity + +insertVotingProcedureStmt :: HsqlStmt.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") $ + HsqlSes.statement votingProcedure insertVotingProcedureStmt + pure $ entityKey entity + +-- | QUERY +queryVotingAnchorIdExistsStmt :: HsqlStmt.Statement Id.VotingAnchorId Bool +queryVotingAnchorIdExistsStmt = + 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") $ + HsqlSes.statement votingAnchorId queryVotingAnchorIdExistsStmt + +-- 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/JsonB.hs b/cardano-db/src/Cardano/Db/Statement/JsonB.hs new file mode 100644 index 000000000..452c439ae --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/JsonB.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Db.Statement.JsonB where + +import Cardano.Prelude (ExceptT, MonadError (..)) +import Control.Monad.IO.Class (liftIO, MonadIO) +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 HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import Cardano.Db.Error (DbError (..)) +import Cardano.Db.Statement.Function.Core (mkCallSite, runDbSession, mkCallInfo) +import Cardano.Db.Types (DbAction) + + +-------------------------------------------------------------------------------- +-- Enable JSONB for specific fields in the schema +-------------------------------------------------------------------------------- +enableJsonbInSchemaStmt :: HsqlStmt.Statement () () +enableJsonbInSchemaStmt = do + HsqlStmt.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") + ] + +enableJsonbInSchema :: MonadIO m => DbAction m () +enableJsonbInSchema = + runDbSession (mkCallInfo "enableJsonbInSchema") $ + HsqlSes.statement () enableJsonbInSchemaStmt + +-------------------------------------------------------------------------------- +-- Disable JSONB for specific fields in the schema +-------------------------------------------------------------------------------- +disableJsonbInSchemaStmt :: HsqlStmt.Statement () () +disableJsonbInSchemaStmt = + HsqlStmt.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") + ] + +disableJsonbInSchema :: MonadIO m => DbAction m () +disableJsonbInSchema = + runDbSession (mkCallInfo "disableJsonbInSchema") $ + HsqlSes.statement () disableJsonbInSchemaStmt + + +-- | Check if the JSONB column exists in the schema used for tests +queryJsonbInSchemaExists :: HsqlC.Connection -> ExceptT DbError IO Bool +queryJsonbInSchemaExists conn = do + result <- liftIO $ HsqlSes.run (HsqlSes.statement () jsonbSchemaStatement) conn + case result of + Left err -> throwError $ DbError mkCallSite "queryJsonbInSchemaExists" $ Just err + Right countRes -> pure $ countRes == 1 + where + jsonbSchemaStatement :: HsqlStmt.Statement () Int64 + jsonbSchemaStatement = + HsqlStmt.Statement + query + HsqlE.noParams -- No parameters needed + decoder + True -- Prepared statement + query = + "SELECT COUNT(*) \ + \FROM information_schema.columns \ + \WHERE table_name = 'tx_metadata' \ + \AND column_name = 'json' \ + \AND data_type = 'jsonb';" + + decoder :: HsqlD.Result Int64 + decoder = + HsqlD.singleRow $ + HsqlD.column $ + HsqlD.nonNullable HsqlD.int8 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..ea88d7848 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/MultiAsset.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Db.Statement.MultiAsset where + +import Cardano.Prelude (ByteString, MonadIO) +import Data.Functor.Contravariant (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 HsqlSes +import qualified Hasql.Statement as HsqlStmt + +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) + +-------------------------------------------------------------------------------- +-- MultiAsset +-------------------------------------------------------------------------------- + +-- | INSERT -------------------------------------------------------------------- +insertMultiAssetStmt :: HsqlStmt.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 + +-- | QUERY ------------------------------------------------------------------- +queryMultiAssetIdStmt :: HsqlStmt.Statement (ByteString, ByteString) (Maybe Id.MultiAssetId) +queryMultiAssetIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id" + , " FROM multi_asset" + , " WHERE policy = $1 AND name = $2" + ] + + encoder = + contramap fst (HsqlE.param (HsqlE.nonNullable HsqlE.bytea)) + <> contramap snd (HsqlE.param (HsqlE.nonNullable HsqlE.bytea)) + + decoder = HsqlD.rowMaybe (Id.idDecoder Id.MultiAssetId) + +queryMultiAssetId :: MonadIO m => ByteString -> ByteString -> DbAction m (Maybe Id.MultiAssetId) +queryMultiAssetId policy assetName = + runDbSession (mkCallInfo "queryMultiAssetId") $ + HsqlSes.statement (policy, assetName) queryMultiAssetIdStmt + +-------------------------------------------------------------------------------- +-- MaTxMint +-------------------------------------------------------------------------------- +insertMaTxMintStmt :: HsqlStmt.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 :: HsqlStmt.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..a2a5dd0d0 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/OffChain.hs @@ -0,0 +1,617 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.OffChain where + +import Cardano.Prelude (ByteString, MonadIO (..), Proxy (..), Text, when, Word64) +import Data.Functor.Contravariant ((>$<)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import Data.Time (UTCTime) +import qualified Hasql.Decoders as HsqlD +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Pipeline as HsqlP +import qualified Hasql.Session as HsqlS +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import qualified Cardano.Db.Schema.Core.OffChain as SO +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, insertCheckUnique) +import Cardano.Db.Statement.GovernanceAndVoting (queryVotingAnchorIdExists) +import Cardano.Db.Statement.Pool (queryPoolHashIdExistsStmt, queryPoolMetadataRefIdExistsStmt) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..)) +import Cardano.Db.Types (DbAction, VoteUrl, AnchorType, anchorTypeDecoder, voteUrlDecoder) +import Cardano.Db.Statement.Function.Query (countAll) +import Cardano.Db.Statement.Function.Delete (parameterisedDeleteWhere) +import qualified Cardano.Db.Schema.Core.GovernanceAndVoting as SV +import Cardano.Db.Schema.Types (PoolUrl, poolUrlDecoder) + +-------------------------------------------------------------------------------- +-- OffChainPoolData +-------------------------------------------------------------------------------- +insertOffChainPoolDataStmt :: HsqlStmt.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 + +-------------------------------------------------------------------------------- +queryOffChainPoolDataStmt :: HsqlStmt.Statement (ByteString, ByteString) (Maybe (Text, ByteString)) +queryOffChainPoolDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + offChainPoolDataTable = tableName (Proxy @SO.OffChainPoolData) + poolHashTable = tableName (Proxy @SP.PoolHash) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT pod.ticker_name, pod.bytes FROM " + , offChainPoolDataTable + , " pod" + , " INNER JOIN " + , poolHashTable + , " ph ON pod.pool_id = ph.id" + , " WHERE ph.hash_raw = $1" + , " AND pod.hash = $2" + , " LIMIT 1" + ] + + encoder = + mconcat + [ fst >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + , snd >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + ] + + decoder = + HsqlD.rowMaybe $ + (,) + <$> HsqlD.column (HsqlD.nonNullable HsqlD.text) + <*> HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + +queryOffChainPoolData :: MonadIO m => ByteString -> ByteString -> DbAction m (Maybe (Text, ByteString)) +queryOffChainPoolData poolHash poolMetadataHash = + runDbSession (mkCallInfo "queryOffChainPoolData") $ + HsqlSes.statement (poolHash, poolMetadataHash) queryOffChainPoolDataStmt + +-------------------------------------------------------------------------------- +queryUsedTickerStmt :: HsqlStmt.Statement (ByteString, ByteString) (Maybe Text) +queryUsedTickerStmt = + HsqlStmt.Statement sql encoder decoder True + where + offChainPoolDataTable = tableName (Proxy @SO.OffChainPoolData) + poolHashTable = tableName (Proxy @SP.PoolHash) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT pod.ticker_name FROM " + , offChainPoolDataTable + , " pod" + , " INNER JOIN " + , poolHashTable + , " ph ON ph.id = pod.pool_id" + , " WHERE ph.hash_raw = $1" + , " AND pod.hash = $2" + , " LIMIT 1" + ] + + encoder = + mconcat + [ fst >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + , snd >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + ] + + decoder = HsqlD.rowMaybe (HsqlD.column $ HsqlD.nonNullable HsqlD.text) + +queryUsedTicker :: MonadIO m => ByteString -> ByteString -> DbAction m (Maybe Text) +queryUsedTicker poolHash metaHash = + runDbSession (mkCallInfo "queryUsedTicker") $ + HsqlSes.statement (poolHash, metaHash) queryUsedTickerStmt + +-------------------------------------------------------------------------------- +-- OffChainPoolFetchError +-------------------------------------------------------------------------------- +insertOffChainPoolFetchErrorStmt :: HsqlStmt.Statement SO.OffChainPoolFetchError () +insertOffChainPoolFetchErrorStmt = + insertCheckUnique + SO.offChainPoolFetchErrorEncoder + NoResult + +insertCheckOffChainPoolFetchError :: MonadIO m => SO.OffChainPoolFetchError -> DbAction m () +insertCheckOffChainPoolFetchError offChainPoolFetchError = do + let poolHashId = SO.offChainPoolFetchErrorPoolId offChainPoolFetchError + let metadataRefId = SO.offChainPoolFetchErrorPmrId offChainPoolFetchError + + -- 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 "insertOffChainPoolFetchError") $ + HsqlS.statement offChainPoolFetchError insertOffChainPoolFetchErrorStmt + +queryOffChainPoolFetchErrorStmt :: HsqlStmt.Statement (ByteString, Maybe UTCTime) [(SO.OffChainPoolFetchError, ByteString)] +queryOffChainPoolFetchErrorStmt = + HsqlStmt.Statement sql encoder decoder True + where + offChainPoolFetchErrorTable = tableName (Proxy @SO.OffChainPoolFetchError) + poolHashTable = tableName (Proxy @SP.PoolHash) + poolMetadataRefTable = tableName (Proxy @SP.PoolMetadataRef) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT ocpfe.pool_id, ocpfe.fetch_time, ocpfe.pmr_id, " + , " ocpfe.fetch_error, ocpfe.retry_count, pmr.hash " + , "FROM " + , offChainPoolFetchErrorTable + , " ocpfe " + , "INNER JOIN " + , poolHashTable + , " ph ON ocpfe.pool_id = ph.id " + , "INNER JOIN " + , poolMetadataRefTable + , " pmr ON ocpfe.pmr_id = pmr.id " + , "WHERE ph.hash_raw = $1 " + , "AND ($2 IS NULL OR ocpfe.fetch_time >= $2) " + , "ORDER BY ocpfe.fetch_time DESC " + , "LIMIT 10" + ] + + encoder = + mconcat + [ fst >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + , snd >$< HsqlE.param (HsqlE.nullable HsqlE.timestamptz) + ] + + decoder = HsqlD.rowList $ do + poolId <- Id.idDecoder Id.PoolHashId + fetchTime <- HsqlD.column (HsqlD.nonNullable HsqlD.timestamptz) + pmrId <- Id.idDecoder Id.PoolMetadataRefId + fetchError <- HsqlD.column (HsqlD.nonNullable HsqlD.text) + retryCount <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + metadataHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + + let fetchErr = + SO.OffChainPoolFetchError + { SO.offChainPoolFetchErrorPoolId = poolId + , SO.offChainPoolFetchErrorFetchTime = fetchTime + , SO.offChainPoolFetchErrorPmrId = pmrId + , SO.offChainPoolFetchErrorFetchError = fetchError + , SO.offChainPoolFetchErrorRetryCount = retryCount + } + + pure (fetchErr, metadataHash) + +queryOffChainPoolFetchError :: MonadIO m => ByteString -> Maybe UTCTime -> DbAction m [(SO.OffChainPoolFetchError, ByteString)] +queryOffChainPoolFetchError hash mFromTime = + runDbSession (mkCallInfo "queryOffChainPoolFetchError") $ + HsqlSes.statement (hash, mFromTime) queryOffChainPoolFetchErrorStmt + +-------------------------------------------------------------------------------- + +-- Count OffChainPoolFetchError records +countOffChainPoolFetchError :: MonadIO m => DbAction m Word64 +countOffChainPoolFetchError = + runDbSession (mkCallInfo "countOffChainPoolFetchError") $ + HsqlSes.statement () (countAll @SO.OffChainPoolFetchError) + +-------------------------------------------------------------------------------- +deleteOffChainPoolFetchErrorByPmrId :: MonadIO m => Id.PoolMetadataRefId -> DbAction m () +deleteOffChainPoolFetchErrorByPmrId pmrId = + runDbSession (mkCallInfo "deleteOffChainPoolFetchErrorByPmrId") $ + HsqlSes.statement pmrId (parameterisedDeleteWhere @SO.OffChainPoolFetchError "pmr_id" ">=" (Id.idEncoder Id.getPoolMetadataRefId)) + +-------------------------------------------------------------------------------- +queryOffChainVoteWorkQueueDataStmt :: HsqlStmt.Statement Int [(UTCTime, Id.VotingAnchorId, ByteString, VoteUrl, AnchorType, Word)] +queryOffChainVoteWorkQueueDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + votingAnchorTableN = tableName (Proxy @SV.VotingAnchor) + offChainVoteFetchErrorTableN = tableName (Proxy @SO.OffChainVoteFetchError) + offChainVoteDataTableN = tableName (Proxy @SO.OffChainVoteData) + + sql = TextEnc.encodeUtf8 $ Text.concat + [ "WITH latest_errors AS (" + , " SELECT MAX(id) as max_id" + , " FROM " <> offChainVoteFetchErrorTableN + , " WHERE NOT EXISTS (" + , " SELECT 1 FROM " <> offChainVoteDataTableN <> " ocvd" + , " WHERE ocvd.voting_anchor_id = " <> offChainVoteFetchErrorTableN <> ".voting_anchor_id" + , " )" + , " GROUP BY voting_anchor_id" + , ")" + , "SELECT ocpfe.fetch_time, va.id, va.data_hash, va.url, va.type, ocpfe.retry_count" + , " FROM " <> votingAnchorTableN <> " va" + , " INNER JOIN " <> offChainVoteFetchErrorTableN <> " ocpfe ON ocpfe.voting_anchor_id = va.id" + , " WHERE ocpfe.id IN (SELECT max_id FROM latest_errors)" + , " AND va.type != 'constitution'" + , " ORDER BY ocpfe.id ASC" + , " LIMIT $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int4)) + + decoder = HsqlD.rowList $ do + fetchTime <- HsqlD.column (HsqlD.nonNullable HsqlD.timestamptz) + vaId <- HsqlD.column (HsqlD.nonNullable (Id.VotingAnchorId <$> HsqlD.int8)) + vaHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + url <- HsqlD.column (HsqlD.nonNullable voteUrlDecoder) + anchorType <- HsqlD.column (HsqlD.nonNullable anchorTypeDecoder) + retryCount <- HsqlD.column (HsqlD.nonNullable (fromIntegral <$> HsqlD.int4)) + pure (fetchTime, vaId, vaHash, url, anchorType, retryCount) + +queryOffChainVoteWorkQueueData :: MonadIO m => Int -> DbAction m [(UTCTime, Id.VotingAnchorId, ByteString, VoteUrl, AnchorType, Word)] +queryOffChainVoteWorkQueueData maxCount = + runDbSession (mkCallInfo "queryOffChainVoteWorkQueueData") $ + HsqlSes.statement maxCount queryOffChainVoteWorkQueueDataStmt + +-------------------------------------------------------------------------------- +queryNewPoolWorkQueueDataStmt :: HsqlStmt.Statement Int [(Id.PoolHashId, Id.PoolMetadataRefId, PoolUrl, ByteString)] +queryNewPoolWorkQueueDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + poolHashTableN = tableName (Proxy @SP.PoolHash) + poolMetadataRefTableN = tableName (Proxy @SP.PoolMetadataRef) + offChainPoolDataTableN = tableName (Proxy @SO.OffChainPoolData) + offChainPoolFetchErrorTableN = tableName (Proxy @SO.OffChainPoolFetchError) + + sql = TextEnc.encodeUtf8 $ Text.concat + [ "WITH latest_refs AS (" + , " SELECT MAX(id) as max_id" + , " FROM " <> poolMetadataRefTableN + , " GROUP BY pool_id" + , ")" + , "SELECT ph.id, pmr.id, pmr.url, pmr.hash" + , " FROM " <> poolHashTableN <> " ph" + , " INNER JOIN " <> poolMetadataRefTableN <> " pmr ON ph.id = pmr.pool_id" + , " WHERE pmr.id IN (SELECT max_id FROM latest_refs)" + , " AND NOT EXISTS (" + , " SELECT 1 FROM " <> offChainPoolDataTableN <> " pod" + , " WHERE pod.pmr_id = pmr.id" + , " )" + , " AND NOT EXISTS (" + , " SELECT 1 FROM " <> offChainPoolFetchErrorTableN <> " pofe" + , " WHERE pofe.pmr_id = pmr.id" + , " )" + , " LIMIT $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int4)) + + decoder = HsqlD.rowList $ do + phId <- HsqlD.column (HsqlD.nonNullable (Id.PoolHashId <$> HsqlD.int8)) + pmrId <- HsqlD.column (HsqlD.nonNullable (Id.PoolMetadataRefId <$> HsqlD.int8)) + url <- HsqlD.column (HsqlD.nonNullable poolUrlDecoder) + hash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + pure (phId, pmrId, url, hash) + +queryNewPoolWorkQueueData :: MonadIO m => Int -> DbAction m [(Id.PoolHashId, Id.PoolMetadataRefId, PoolUrl, ByteString)] +queryNewPoolWorkQueueData maxCount = + runDbSession (mkCallInfo "queryNewPoolWorkQueueData") $ + HsqlSes.statement maxCount queryNewPoolWorkQueueDataStmt + +-------------------------------------------------------------------------------- +queryOffChainPoolWorkQueueDataStmt :: HsqlStmt.Statement Int [(UTCTime, Id.PoolMetadataRefId, PoolUrl, ByteString, Id.PoolHashId, Word)] +queryOffChainPoolWorkQueueDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + poolHashTableN = tableName (Proxy @SP.PoolHash) + poolMetadataRefTableN = tableName (Proxy @SP.PoolMetadataRef) + offChainPoolFetchErrorTableN = tableName (Proxy @SO.OffChainPoolFetchError) + offChainPoolDataTableN = tableName (Proxy @SO.OffChainPoolData) + + sql = TextEnc.encodeUtf8 $ Text.concat + [ "WITH latest_errors AS (" + , " SELECT MAX(id) as max_id" + , " FROM " <> offChainPoolFetchErrorTableN <> " pofe" + , " WHERE NOT EXISTS (" + , " SELECT 1 FROM " <> offChainPoolDataTableN <> " pod" + , " WHERE pod.pmr_id = pofe.pmr_id" + , " )" + , " GROUP BY pool_id" + , ")" + , "SELECT pofe.fetch_time, pofe.pmr_id, pmr.url, pmr.hash, ph.id, pofe.retry_count" + , " FROM " <> poolHashTableN <> " ph" + , " INNER JOIN " <> poolMetadataRefTableN <> " pmr ON ph.id = pmr.pool_id" + , " INNER JOIN " <> offChainPoolFetchErrorTableN <> " pofe ON pofe.pmr_id = pmr.id" + , " WHERE pofe.id IN (SELECT max_id FROM latest_errors)" + , " ORDER BY pofe.id ASC" + , " LIMIT $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int4)) + + decoder = HsqlD.rowList $ do + fetchTime <- HsqlD.column (HsqlD.nonNullable HsqlD.timestamptz) + pmrId <- HsqlD.column (HsqlD.nonNullable (Id.PoolMetadataRefId <$> HsqlD.int8)) + url <- HsqlD.column (HsqlD.nonNullable poolUrlDecoder) + hash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + phId <- HsqlD.column (HsqlD.nonNullable (Id.PoolHashId <$> HsqlD.int8)) + retryCount <- HsqlD.column (HsqlD.nonNullable (fromIntegral <$> HsqlD.int4)) + pure (fetchTime, pmrId, url, hash, phId, retryCount) + +queryOffChainPoolWorkQueueData :: MonadIO m => Int -> DbAction m [(UTCTime, Id.PoolMetadataRefId, PoolUrl, ByteString, Id.PoolHashId, Word)] +queryOffChainPoolWorkQueueData maxCount = + runDbSession (mkCallInfo "queryOffChainPoolWorkQueueData") $ + HsqlSes.statement maxCount queryOffChainPoolWorkQueueDataStmt + +-------------------------------------------------------------------------------- +-- OffChainVoteAuthor +-------------------------------------------------------------------------------- +insertBulkOffChainVoteAuthorsStmt :: HsqlStmt.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 + ) + +-------------------------------------------------------------------------------- +insertOffChainVoteDataStmt :: HsqlStmt.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 + + +insertBulkOffChainVoteDataStmt :: HsqlStmt.Statement [SO.OffChainVoteData] [Id.OffChainVoteDataId] +insertBulkOffChainVoteDataStmt = + insertBulk + extractOffChainVoteData + SO.offChainVoteDataBulkEncoder + (WithResultBulk $ Id.idBulkDecoder Id.OffChainVoteDataId) + where + extractOffChainVoteData :: [SO.OffChainVoteData] -> ([Id.VotingAnchorId], [ByteString], [Text], [Maybe Text], [Text], [ByteString], [Maybe Text], [Maybe Bool]) + extractOffChainVoteData xs = + ( map SO.offChainVoteDataVotingAnchorId xs + , map SO.offChainVoteDataHash xs + , map SO.offChainVoteDataLanguage xs + , map SO.offChainVoteDataComment xs + , map SO.offChainVoteDataJson xs + , map SO.offChainVoteDataBytes xs + , map SO.offChainVoteDataWarning xs + , map SO.offChainVoteDataIsValid xs + ) + +insertBulkOffChainVoteData :: MonadIO m => [SO.OffChainVoteData] -> DbAction m [Id.OffChainVoteDataId] +insertBulkOffChainVoteData offChainVoteData = do + runDbSession (mkCallInfo "insertBulkOffChainVoteData") $ + HsqlS.statement offChainVoteData insertBulkOffChainVoteDataStmt + +-------------------------------------------------------------------------------- +insertOffChainVoteDrepDataStmt :: HsqlStmt.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 + +insertBulkOffChainVoteDrepDataStmt :: HsqlStmt.Statement [SO.OffChainVoteDrepData] () +insertBulkOffChainVoteDrepDataStmt = + insertBulk + extractOffChainVoteDrepData + SO.offChainVoteDrepDataBulkEncoder + NoResultBulk + where + extractOffChainVoteDrepData :: [SO.OffChainVoteDrepData] -> ([Id.OffChainVoteDataId], [Maybe Text], [Text], [Maybe Text], [Maybe Text], [Maybe Text], [Maybe Text], [Maybe Text]) + extractOffChainVoteDrepData xs = + ( map SO.offChainVoteDrepDataOffChainVoteDataId xs + , map SO.offChainVoteDrepDataPaymentAddress xs + , map SO.offChainVoteDrepDataGivenName xs + , map SO.offChainVoteDrepDataObjectives xs + , map SO.offChainVoteDrepDataMotivations xs + , map SO.offChainVoteDrepDataQualifications xs + , map SO.offChainVoteDrepDataImageUrl xs + , map SO.offChainVoteDrepDataImageHash xs + ) + +insertBulkOffChainVoteDrepData :: MonadIO m => [SO.OffChainVoteDrepData] -> DbAction m () +insertBulkOffChainVoteDrepData offChainVoteDrepData = + runDbSession (mkCallInfo "insertBulkOffChainVoteDrepData") $ + HsqlS.statement offChainVoteDrepData insertBulkOffChainVoteDrepDataStmt + + +-------------------------------------------------------------------------------- +queryNewVoteWorkQueueDataStmt :: HsqlStmt.Statement Int [(Id.VotingAnchorId, ByteString, VoteUrl, AnchorType)] +queryNewVoteWorkQueueDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + votingAnchorTableN = tableName (Proxy @SV.VotingAnchor) + offChainVoteDataTableN = tableName (Proxy @SO.OffChainVoteData) + offChainVoteFetchErrorTableN = tableName (Proxy @SO.OffChainVoteFetchError) + + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT id, data_hash, url, type" + , " FROM " <> votingAnchorTableN <> " va" + , " WHERE NOT EXISTS (" + , " SELECT 1 FROM " <> offChainVoteDataTableN <> " ocvd" + , " WHERE ocvd.voting_anchor_id = va.id" + , " )" + , " AND va.type != 'constitution'" + , " AND NOT EXISTS (" + , " SELECT 1 FROM " <> offChainVoteFetchErrorTableN <> " ocvfe" + , " WHERE ocvfe.voting_anchor_id = va.id" + , " )" + , " LIMIT $1" + ] + + encoder = HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int4)) + + decoder = HsqlD.rowList $ do + vaId <- HsqlD.column (HsqlD.nonNullable (Id.VotingAnchorId <$> HsqlD.int8)) + vaHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + url <- HsqlD.column (HsqlD.nonNullable voteUrlDecoder) + anchorType <- HsqlD.column (HsqlD.nonNullable anchorTypeDecoder) + pure (vaId, vaHash, url, anchorType) + +queryNewVoteWorkQueueData :: MonadIO m => Int -> DbAction m [(Id.VotingAnchorId, ByteString, VoteUrl, AnchorType)] +queryNewVoteWorkQueueData maxCount = + runDbSession (mkCallInfo "queryNewVoteWorkQueueData") $ + HsqlSes.statement maxCount queryNewVoteWorkQueueDataStmt + +-------------------------------------------------------------------------------- +-- OffChainVoteExternalUpdate +-------------------------------------------------------------------------------- +insertBulkOffChainVoteExternalUpdatesStmt :: HsqlStmt.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 + ) + +-------------------------------------------------------------------------------- +insertOffChainVoteFetchErrorStmt :: HsqlStmt.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 + +insertBulkOffChainVoteFetchErrorStmt :: HsqlStmt.Statement [SO.OffChainVoteFetchError] () +insertBulkOffChainVoteFetchErrorStmt = + insertBulk + extractOffChainVoteFetchError + SO.offChainVoteFetchErrorBulkEncoder + NoResultBulk + where + extractOffChainVoteFetchError :: [SO.OffChainVoteFetchError] -> ([Id.VotingAnchorId], [Text], [UTCTime], [Word]) + extractOffChainVoteFetchError xs = + ( map SO.offChainVoteFetchErrorVotingAnchorId xs + , map SO.offChainVoteFetchErrorFetchError xs + , map SO.offChainVoteFetchErrorFetchTime xs + , map SO.offChainVoteFetchErrorRetryCount xs + ) + +-------------------------------------------------------------------------------- +insertBulkOffChainVoteGovActionDataStmt :: HsqlStmt.Statement [SO.OffChainVoteGovActionData] () +insertBulkOffChainVoteGovActionDataStmt = + insertBulk + extractOffChainVoteGovActionData + SO.offChainVoteGovActionDataBulkEncoder + NoResultBulk + where + extractOffChainVoteGovActionData :: [SO.OffChainVoteGovActionData] -> ([Id.OffChainVoteDataId], [Text], [Text], [Text], [Text]) + extractOffChainVoteGovActionData xs = + ( map SO.offChainVoteGovActionDataOffChainVoteDataId xs + , map SO.offChainVoteGovActionDataTitle xs + , map SO.offChainVoteGovActionDataAbstract xs + , map SO.offChainVoteGovActionDataMotivation xs + , map SO.offChainVoteGovActionDataRationale xs + ) + +insertBulkOffChainVoteGovActionData :: MonadIO m => [SO.OffChainVoteGovActionData] -> DbAction m () +insertBulkOffChainVoteGovActionData offChainVoteGovActionData = + runDbSession (mkCallInfo "insertBulkOffChainVoteGovActionData") $ + HsqlS.statement offChainVoteGovActionData insertBulkOffChainVoteGovActionDataStmt + +-------------------------------------------------------------------------------- +-- OffChainVoteGovActionData +-------------------------------------------------------------------------------- +insertOffChainVoteGovActionDataStmt :: HsqlStmt.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 :: HsqlStmt.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 + ) + +-- 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..3cb2aaba5 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Pool.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Pool where + +import Cardano.Prelude (ByteString, MonadIO, Proxy (..), Word64, Int64) +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 HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import qualified Cardano.Db.Schema.Core.Base as SCB +import qualified Cardano.Db.Schema.Core.Pool as SCP +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, insertIfUnique) +import Cardano.Db.Statement.Function.Query (existsById, existsWhereByColumn) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..)) +import Cardano.Db.Types (CertNo (..), DbAction, DbWord64, PoolCert (..), PoolCertAction (..)) +import Cardano.Db.Statement.Function.Delete (parameterisedDeleteWhere) + +-------------------------------------------------------------------------------- +-- DelistedPool +-------------------------------------------------------------------------------- +insertDelistedPoolStmt :: HsqlStmt.Statement SCP.DelistedPool (Entity SCP.DelistedPool) +insertDelistedPoolStmt = + insert + SCP.delistedPoolEncoder + (WithResult $ HsqlD.singleRow SCP.entityDelistedPoolDecoder) + +insertDelistedPool :: MonadIO m => SCP.DelistedPool -> DbAction m Id.DelistedPoolId +insertDelistedPool delistedPool = do + entity <- + runDbSession (mkCallInfo "insertDelistedPool") $ + HsqlSes.statement delistedPool insertDelistedPoolStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +queryDelistedPoolsStmt :: HsqlStmt.Statement () [ByteString] +queryDelistedPoolsStmt = + HsqlStmt.Statement sql encoder decoder True + where + delistedPoolTable = tableName (Proxy @SCP.DelistedPool) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT hash_raw FROM " + , delistedPoolTable + ] + + encoder = mempty + decoder = HsqlD.rowList (HsqlD.column $ HsqlD.nonNullable HsqlD.bytea) + +queryDelistedPools :: MonadIO m => DbAction m [ByteString] +queryDelistedPools = + runDbSession (mkCallInfo "queryDelistedPools") $ + HsqlSes.statement () queryDelistedPoolsStmt + +-------------------------------------------------------------------------------- +existsDelistedPoolStmt :: HsqlStmt.Statement ByteString Bool +existsDelistedPoolStmt = + existsWhereByColumn + @SCP.DelistedPool -- Specify the type explicitly + "hash_raw" -- Column to match on + (HsqlE.param (HsqlE.nonNullable HsqlE.bytea)) -- ByteString encoder + (WithResult $ HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool)) + +-- Updated function that takes a ByteString +existsDelistedPool :: MonadIO m => ByteString -> DbAction m Bool +existsDelistedPool ph = + runDbSession (mkCallInfo "existsDelistedPool") $ + HsqlSes.statement ph existsDelistedPoolStmt + +-------------------------------------------------------------------------------- +deleteDelistedPoolStmt :: HsqlStmt.Statement ByteString Int64 +deleteDelistedPoolStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = TextEnc.encodeUtf8 $ Text.concat + [ "WITH deleted AS (" + , " DELETE FROM delisted_pool" + , " WHERE hash_raw = $1" + , " RETURNING *" + , ")" + , "SELECT COUNT(*)::bigint FROM deleted" + ] + + encoder = id >$< HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.int8) + +deleteDelistedPool :: MonadIO m => ByteString -> DbAction m Bool +deleteDelistedPool poolHash = + runDbSession (mkCallInfo "deleteDelistedPool") $ do + count <- HsqlSes.statement poolHash deleteDelistedPoolStmt + pure $ count > 0 + + +-------------------------------------------------------------------------------- +-- PoolHash +-------------------------------------------------------------------------------- +insertPoolHashStmt :: HsqlStmt.Statement SCP.PoolHash (Entity SCP.PoolHash) +insertPoolHashStmt = + insert + SCP.poolHashEncoder + (WithResult $ HsqlD.singleRow SCP.entityPoolHashDecoder) + +insertPoolHash :: MonadIO m => SCP.PoolHash -> DbAction m Id.PoolHashId +insertPoolHash poolHash = do + entity <- + runDbSession (mkCallInfo "insertPoolHash") $ + HsqlSes.statement poolHash insertPoolHashStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +queryPoolHashIdStmt :: HsqlStmt.Statement ByteString (Maybe Id.PoolHashId) +queryPoolHashIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + table = tableName (Proxy @SCP.PoolHash) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM " <> table + , " WHERE hash_raw = $1" + , " LIMIT 1" + ] + encoder = HsqlE.param (HsqlE.nonNullable HsqlE.bytea) + decoder = + HsqlD.rowMaybe + ( HsqlD.column $ + HsqlD.nonNullable $ + Id.PoolHashId <$> HsqlD.int8 + ) + +queryPoolHashId :: MonadIO m => ByteString -> DbAction m (Maybe Id.PoolHashId) +queryPoolHashId hash = + runDbSession (mkCallInfo "queryPoolHashId") $ + HsqlSes.statement hash queryPoolHashIdStmt + +----------------------------------------------------------------------------------- +queryPoolHashIdExistsStmt :: HsqlStmt.Statement Id.PoolHashId Bool +queryPoolHashIdExistsStmt = + existsById + (Id.idEncoder Id.getPoolHashId) + (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) + +queryPoolHashIdExists :: MonadIO m => Id.PoolHashId -> DbAction m Bool +queryPoolHashIdExists poolHashId = + runDbSession (mkCallInfo "queryPoolHashIdExists") $ + HsqlSes.statement poolHashId queryPoolHashIdExistsStmt + +-------------------------------------------------------------------------------- +-- PoolMetadataRef +-------------------------------------------------------------------------------- +insertPoolMetadataRefStmt :: HsqlStmt.Statement SCP.PoolMetadataRef (Entity SCP.PoolMetadataRef) +insertPoolMetadataRefStmt = + insert + SCP.poolMetadataRefEncoder + (WithResult $ HsqlD.singleRow SCP.entityPoolMetadataRefDecoder) + +insertPoolMetadataRef :: MonadIO m => SCP.PoolMetadataRef -> DbAction m Id.PoolMetadataRefId +insertPoolMetadataRef poolMetadataRef = do + entity <- + runDbSession (mkCallInfo "insertPoolMetadataRef") $ + HsqlSes.statement poolMetadataRef insertPoolMetadataRefStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +queryPoolMetadataRefIdExistsStmt :: HsqlStmt.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 + +-------------------------------------------------------------------------------- +existsPoolMetadataRefIdStmt :: HsqlStmt.Statement Id.PoolMetadataRefId Bool +existsPoolMetadataRefIdStmt = + existsById + (Id.idEncoder Id.getPoolMetadataRefId) + (WithResult (HsqlD.singleRow $ HsqlD.column (HsqlD.nonNullable HsqlD.bool))) + +existsPoolMetadataRefId :: MonadIO m => Id.PoolMetadataRefId -> DbAction m Bool +existsPoolMetadataRefId pmrid = + runDbSession (mkCallInfo "existsPoolMetadataRefId") $ + HsqlSes.statement pmrid existsPoolMetadataRefIdStmt + +-------------------------------------------------------------------------------- +deletePoolMetadataRefById :: MonadIO m => Id.PoolMetadataRefId -> DbAction m () +deletePoolMetadataRefById pmrId = + runDbSession (mkCallInfo "deletePoolMetadataRefById") $ + HsqlSes.statement pmrId (parameterisedDeleteWhere @SCP.PoolMetadataRef "id" ">=" $ Id.idEncoder Id.getPoolMetadataRefId) + +-------------------------------------------------------------------------------- +-- PoolRelay +-------------------------------------------------------------------------------- + +insertPoolRelayStmt :: HsqlStmt.Statement SCP.PoolRelay (Entity SCP.PoolRelay) +insertPoolRelayStmt = + insert + SCP.poolRelayEncoder + (WithResult $ HsqlD.singleRow SCP.entityPoolRelayDecoder) + +insertPoolRelay :: MonadIO m => SCP.PoolRelay -> DbAction m Id.PoolRelayId +insertPoolRelay poolRelay = do + entity <- runDbSession (mkCallInfo "insertPoolRelay") $ HsqlSes.statement poolRelay insertPoolRelayStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- PoolStat +-------------------------------------------------------------------------------- +insertBulkPoolStatStmt :: HsqlStmt.Statement [SCP.PoolStat] () +insertBulkPoolStatStmt = + insertBulk + extractPoolStat + SCP.poolStatBulkEncoder + NoResultBulk + where + extractPoolStat :: [SCP.PoolStat] -> ([Id.PoolHashId], [Word64], [DbWord64], [DbWord64], [DbWord64], [Maybe DbWord64]) + extractPoolStat xs = + ( map SCP.poolStatPoolHashId xs + , map SCP.poolStatEpochNo xs + , map SCP.poolStatNumberOfBlocks xs + , map SCP.poolStatNumberOfDelegators xs + , map SCP.poolStatStake xs + , map SCP.poolStatVotingPower xs + ) + +insertBulkPoolStat :: MonadIO m => [SCP.PoolStat] -> DbAction m () +insertBulkPoolStat poolStats = do + runDbSession (mkCallInfo "insertBulkPoolStat") $ + HsqlSes.statement poolStats insertBulkPoolStatStmt + +-------------------------------------------------------------------------------- +-- PoolUpdate +-------------------------------------------------------------------------------- + +insertPoolUpdateStmt :: HsqlStmt.Statement SCP.PoolUpdate (Entity SCP.PoolUpdate) +insertPoolUpdateStmt = + insert + SCP.poolUpdateEncoder + (WithResult $ HsqlD.singleRow SCP.entityPoolUpdateDecoder) + +insertPoolUpdate :: MonadIO m => SCP.PoolUpdate -> DbAction m Id.PoolUpdateId +insertPoolUpdate poolUpdate = do + entity <- runDbSession (mkCallInfo "insertPoolUpdate") $ HsqlSes.statement poolUpdate insertPoolUpdateStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- PoolOwner +-------------------------------------------------------------------------------- + +insertPoolOwnerStmt :: HsqlStmt.Statement SCP.PoolOwner (Entity SCP.PoolOwner) +insertPoolOwnerStmt = + insert + SCP.poolOwnerEncoder + (WithResult $ HsqlD.singleRow SCP.entityPoolOwnerDecoder) + +insertPoolOwner :: MonadIO m => SCP.PoolOwner -> DbAction m Id.PoolOwnerId +insertPoolOwner poolOwner = do + entity <- + runDbSession (mkCallInfo "insertPoolOwner") $ + HsqlSes.statement poolOwner insertPoolOwnerStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +-- PoolRetire +-------------------------------------------------------------------------------- + +insertPoolRetireStmt :: HsqlStmt.Statement SCP.PoolRetire (Entity SCP.PoolRetire) +insertPoolRetireStmt = + insert + SCP.poolRetireEncoder + (WithResult $ HsqlD.singleRow SCP.entityPoolRetireDecoder) + +insertPoolRetire :: MonadIO m => SCP.PoolRetire -> DbAction m Id.PoolRetireId +insertPoolRetire poolRetire = do + entity <- runDbSession (mkCallInfo "insertPoolRetire") $ HsqlSes.statement poolRetire insertPoolRetireStmt + pure $ entityKey entity + +-------------------------------------------------------------------------------- +queryRetiredPoolsStmt :: HsqlStmt.Statement (Maybe ByteString) [PoolCert] +queryRetiredPoolsStmt = + HsqlStmt.Statement sql encoder decoder True + where + poolRetireN = tableName (Proxy @SCP.PoolRetire) + poolHashN = tableName (Proxy @SCP.PoolHash) + txN = tableName (Proxy @SCB.Tx) + blockN = tableName (Proxy @SCB.Block) + + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT ph.hash_raw, pr.retiring_epoch, blk.block_no, tx.block_index, pr.cert_index" + , " FROM " <> poolRetireN <> " pr" + , " INNER JOIN " <> poolHashN <> " ph ON pr.hash_id = ph.id" + , " INNER JOIN " <> txN <> " tx ON pr.announced_tx_id = tx.id" + , " INNER JOIN " <> blockN <> " blk ON tx.block_id = blk.id" + , " WHERE ($1::bytea IS NULL OR ph.hash_raw = $1)" + ] + + encoder = HsqlE.param (HsqlE.nullable HsqlE.bytea) + + decoder = HsqlD.rowList $ do + hsh <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + retEpoch <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + blkNo <- HsqlD.column (HsqlD.nullable $ fromIntegral <$> HsqlD.int8) + txIndex <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + retIndex <- HsqlD.column (HsqlD.nonNullable $ fromIntegral <$> HsqlD.int8) + pure $ PoolCert + { pcHash = hsh + , pcCertAction = Retirement retEpoch + , pcCertNo = CertNo blkNo txIndex retIndex + } + +queryRetiredPools :: MonadIO m => Maybe ByteString -> DbAction m [PoolCert] +queryRetiredPools mPoolHash = + runDbSession (mkCallInfo "queryRetiredPools") $ + HsqlSes.statement mPoolHash queryRetiredPoolsStmt + +-------------------------------------------------------------------------------- +-- PoolUpdate +-------------------------------------------------------------------------------- + +-- Check if there are other PoolUpdates in the same blocks for the same pool +queryPoolUpdateByBlockStmt :: HsqlStmt.Statement (Id.BlockId, Id.PoolHashId) Bool +queryPoolUpdateByBlockStmt = + HsqlStmt.Statement sql encoder decoder True + where + blockTable = tableName (Proxy @SCB.Block) + txTable = tableName (Proxy @SCB.Tx) + poolUpdateTable = tableName (Proxy @SCP.PoolUpdate) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT EXISTS (SELECT 1 FROM " + , blockTable + , " blk" + , " INNER JOIN " + , txTable + , " tx ON blk.id = tx.block_id" + , " INNER JOIN " + , poolUpdateTable + , " poolUpdate ON tx.id = poolUpdate.registered_tx_id" + , " WHERE poolUpdate.hash_id = $1" + , " AND blk.id = $2" + , " LIMIT 1)" + ] + + encoder = + mconcat + [ snd >$< HsqlE.param (HsqlE.nonNullable (Id.getPoolHashId >$< HsqlE.int8)) + , fst >$< HsqlE.param (HsqlE.nonNullable (Id.getBlockId >$< HsqlE.int8)) + ] + decoder = HsqlD.singleRow (HsqlD.column $ HsqlD.nonNullable HsqlD.bool) + +queryPoolUpdateByBlock :: MonadIO m => Id.BlockId -> Id.PoolHashId -> DbAction m Bool +queryPoolUpdateByBlock blkId poolHashId = + runDbSession (mkCallInfo "queryPoolUpdateByBlock") $ + HsqlSes.statement (blkId, poolHashId) queryPoolUpdateByBlockStmt + +-------------------------------------------------------------------------------- +queryPoolRegisterStmt :: HsqlStmt.Statement (Maybe ByteString) [PoolCert] +queryPoolRegisterStmt = + HsqlStmt.Statement sql encoder decoder True + where + poolUpdateTable = tableName (Proxy @SCP.PoolUpdate) + poolHashTable = tableName (Proxy @SCP.PoolHash) + poolMetadataRefTable = tableName (Proxy @SCP.PoolMetadataRef) + txTable = tableName (Proxy @SCB.Tx) + blockTable = tableName (Proxy @SCB.Block) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT ph.hash_raw, pmr.hash, blk.block_no, tx.block_index, pu.cert_index" + , " FROM " + , poolUpdateTable + , " pu" + , " INNER JOIN " + , poolHashTable + , " ph ON pu.hash_id = ph.id" + , " INNER JOIN " + , poolMetadataRefTable + , " pmr ON pu.meta_id = pmr.id" + , " INNER JOIN " + , txTable + , " tx ON pu.registered_tx_id = tx.id" + , " INNER JOIN " + , blockTable + , " blk ON tx.block_id = blk.id" + , " WHERE ($1 IS NULL OR ph.hash_raw = $1)" + ] + + encoder = + id >$< HsqlE.param (HsqlE.nullable HsqlE.bytea) + + decoder = HsqlD.rowList $ do + poolHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + metaHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + blkNo <- HsqlD.column (HsqlD.nullable (fromIntegral <$> HsqlD.int8)) + txIndex <- HsqlD.column (HsqlD.nonNullable (fromIntegral <$> HsqlD.int8)) + certIndex <- HsqlD.column (HsqlD.nonNullable (fromIntegral <$> HsqlD.int8)) + pure $ + PoolCert + { pcHash = poolHash + , pcCertAction = Register metaHash + , pcCertNo = CertNo blkNo txIndex certIndex + } + +queryPoolRegister :: MonadIO m => Maybe ByteString -> DbAction m [PoolCert] +queryPoolRegister mPoolHash = + runDbSession (mkCallInfo "queryPoolRegister") $ + HsqlSes.statement mPoolHash queryPoolRegisterStmt + +-------------------------------------------------------------------------------- +-- ReservedPoolTicker +-------------------------------------------------------------------------------- + +insertReservedPoolTickerStmt :: HsqlStmt.Statement SCP.ReservedPoolTicker (Maybe (Entity SCP.ReservedPoolTicker)) +insertReservedPoolTickerStmt = + insertIfUnique + SCP.reservedPoolTickerEncoder + SCP.entityReservedPoolTickerDecoder + +insertReservedPoolTicker :: MonadIO m => SCP.ReservedPoolTicker -> DbAction m (Maybe Id.ReservedPoolTickerId) +insertReservedPoolTicker reservedPool = do + mEntity <- + runDbSession (mkCallInfo "insertReservedPoolTicker") $ + HsqlSes.statement reservedPool insertReservedPoolTickerStmt + pure $ entityKey <$> mEntity + +-------------------------------------------------------------------------------- +queryReservedTickerStmt :: HsqlStmt.Statement Text.Text (Maybe ByteString) +queryReservedTickerStmt = + HsqlStmt.Statement sql encoder decoder True + where + reservedPoolTickerTable = tableName (Proxy @SCP.ReservedPoolTicker) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT ticker.pool_hash FROM " + , reservedPoolTickerTable + , " ticker" + , " WHERE ticker.name = $1" + , " LIMIT 1" + ] + + encoder = + id >$< HsqlE.param (HsqlE.nonNullable HsqlE.text) + + decoder = HsqlD.rowMaybe (HsqlD.column $ HsqlD.nonNullable HsqlD.bytea) + +queryReservedTicker :: MonadIO m => Text.Text -> DbAction m (Maybe ByteString) +queryReservedTicker tickerName = + runDbSession (mkCallInfo "queryReservedTicker") $ + HsqlSes.statement tickerName queryReservedTickerStmt + +-------------------------------------------------------------------------------- +queryReservedTickersStmt :: HsqlStmt.Statement () [SCP.ReservedPoolTicker] +queryReservedTickersStmt = + HsqlStmt.Statement sql encoder decoder True + where + reservedPoolTickerTable = tableName (Proxy @SCP.ReservedPoolTicker) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT * FROM " + , reservedPoolTickerTable + ] + encoder = mempty + decoder = HsqlD.rowList (entityVal <$> SCP.entityReservedPoolTickerDecoder) + +queryReservedTickers :: MonadIO m => DbAction m [SCP.ReservedPoolTicker] +queryReservedTickers = + runDbSession (mkCallInfo "queryReservedTickers") $ + HsqlSes.statement () queryReservedTickersStmt + +-- 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/Rollback.hs b/cardano-db/src/Cardano/Db/Statement/Rollback.hs new file mode 100644 index 000000000..c773a07eb --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Rollback.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Rollback where + +import Cardano.Prelude (Int64, MonadIO, Proxy (..), catMaybes, forM) +import qualified Data.Text as Text +import qualified Hasql.Encoders as HsqlE +import qualified Hasql.Session as HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import qualified Cardano.Db.Schema.Core.Base as SCB +import qualified Cardano.Db.Schema.Core.EpochAndProtocol as SCE +import qualified Cardano.Db.Schema.Core.GovernanceAndVoting as SCG +import qualified Cardano.Db.Schema.Core.MultiAsset as SCM +import qualified Cardano.Db.Schema.Core.OffChain as SCO +import qualified Cardano.Db.Schema.Core.Pool as SCP +import qualified Cardano.Db.Schema.Core.StakeDeligation as SCS +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.MinIds (MinIds (..), MinIdsWrapper (..)) +import qualified Cardano.Db.Schema.Variants as SV +import qualified Cardano.Db.Schema.Variants.TxOutAddress as VA +import qualified Cardano.Db.Schema.Variants.TxOutCore as VC +import Cardano.Db.Statement.Function.Core (mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Delete (deleteWhereCount) +import Cardano.Db.Statement.Function.Query (queryMinRefId) +import Cardano.Db.Statement.Types (DbInfo (..)) +import Cardano.Db.Types (DbAction) + +-- This creates a pipeline for multiple delete operations +runDeletePipeline :: + forall m. + MonadIO m => + -- | Operation name for logging + Text.Text -> + -- | List of (table name, delete session) + [(Text.Text, HsqlSes.Session Int64)] -> + DbAction m [(Text.Text, Int64)] +runDeletePipeline opName operations = do + runDbSession (mkCallInfo opName) $ do + forM operations $ \(tName, deleteSession) -> do + count <- deleteSession + pure (tName, count) + +-- Function to create a delete session without immediately running it +prepareDelete :: + forall a b. + (DbInfo a) => + -- | Field name + Text.Text -> + -- | Value + b -> + -- | Operator + Text.Text -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Returns table name and session + (Text.Text, HsqlSes.Session Int64) +prepareDelete fieldName value operator encoder = + let tName = tableName (Proxy @a) + deleteSession = + HsqlSes.statement value $ + deleteWhereCount @a fieldName operator encoder + in (tName, deleteSession) + +deleteTablesAfterBlockId :: + forall m. + MonadIO m => + SV.TxOutVariantType -> + Id.BlockId -> + Maybe Id.TxId -> + MinIdsWrapper -> + DbAction m (Int64, [(Text.Text, Int64)]) +deleteTablesAfterBlockId txOutVariantType blkId mtxId minIdsW = do + let blockIdEncoder = Id.idEncoder Id.getBlockId + + -- Create a pipeline for initial deletions + initialLogs <- + runDeletePipeline + "initialDelete" + [ prepareDelete @SCE.AdaPots "block_id" blkId ">=" blockIdEncoder + , prepareDelete @SCB.ReverseIndex "block_id" blkId ">=" blockIdEncoder + , prepareDelete @SCE.EpochParam "block_id" blkId ">=" blockIdEncoder + ] + + -- Handle off-chain related deletions + mvaId <- + queryMinRefId @SCG.VotingAnchor + "block_id" + blkId + blockIdEncoder + (Id.idDecoder Id.VotingAnchorId) + + offChainLogs <- case mvaId of + Nothing -> pure [] + Just vaId -> do + -- For VotingAnchorId, we need the correct encoder + let vaIdEncoder = Id.idEncoder Id.getVotingAnchorId + + mocvdId <- + queryMinRefId @SCO.OffChainVoteData + "voting_anchor_id" + vaId + vaIdEncoder + (Id.idDecoder Id.OffChainVoteDataId) + + logsVoting <- case mocvdId of + Nothing -> pure [] + Just ocvdId -> do + -- For OffChainVoteDataId, we need the correct encoder + let ocvdIdEncoder = Id.idEncoder Id.getOffChainVoteDataId + offChainVoteDataId = "off_chain_vote_data_id" + + runDeletePipeline + "voteDataDelete" + [ prepareDelete @SCO.OffChainVoteGovActionData offChainVoteDataId ocvdId ">=" ocvdIdEncoder + , prepareDelete @SCO.OffChainVoteDrepData offChainVoteDataId ocvdId ">=" ocvdIdEncoder + , prepareDelete @SCO.OffChainVoteAuthor offChainVoteDataId ocvdId ">=" ocvdIdEncoder + , prepareDelete @SCO.OffChainVoteReference offChainVoteDataId ocvdId ">=" ocvdIdEncoder + , prepareDelete @SCO.OffChainVoteExternalUpdate offChainVoteDataId ocvdId ">=" ocvdIdEncoder + ] + + offChain <- + runDeletePipeline + "anchorDelete" + [ prepareDelete @SCO.OffChainVoteData "voting_anchor_id" vaId ">=" vaIdEncoder + , prepareDelete @SCO.OffChainVoteFetchError "voting_anchor_id" vaId ">=" vaIdEncoder + , prepareDelete @SCG.VotingAnchor "id" vaId ">=" vaIdEncoder + ] + pure $ logsVoting <> offChain + -- Additional deletions based on TxId and minimum IDs + afterTxIdLogs <- deleteTablesAfterTxId txOutVariantType mtxId minIdsW + -- Final block deletions + blockLogs <- + runDeletePipeline + "blockDelete" + [prepareDelete @SCB.Block "id" blkId ">=" blockIdEncoder] + -- Aggregate and return all logs + pure (sum $ map snd blockLogs, initialLogs <> blockLogs <> offChainLogs <> afterTxIdLogs) + +deleteTablesAfterTxId :: + forall m. + MonadIO m => + SV.TxOutVariantType -> + Maybe Id.TxId -> + MinIdsWrapper -> + DbAction m [(Text.Text, Int64)] +deleteTablesAfterTxId txOutVariantType mtxId minIdsW = do + let txIdEncoder = Id.idEncoder Id.getTxId + + -- Handle deletions and log accumulation from MinIdsWrapper + minIdsLogs <- case minIdsW of + CMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> do + let operations = + catMaybes + [ fmap (\txInId -> prepareOnlyDelete @SCB.TxIn "id" txInId ">=" (Id.idEncoder Id.getTxInId)) mtxInId + , prepareTypedDelete @VC.TxOutCore "id" mtxOutId SV.unwrapTxOutIdCore (Id.idEncoder Id.getTxOutCoreId) + , prepareTypedDelete @VC.MaTxOutCore "id" mmaTxOutId SV.unwrapMaTxOutIdCore (Id.idEncoder Id.getMaTxOutCoreId) + ] + if null operations + then pure [] + else runDeletePipeline "cMinIdsDelete" operations + VMinIdsWrapper (MinIds mtxInId mtxOutId mmaTxOutId) -> do + let operations = + catMaybes + [ fmap (\txInId -> prepareOnlyDelete @SCB.TxIn "id" txInId ">=" (Id.idEncoder Id.getTxInId)) mtxInId + , prepareTypedDelete @VA.TxOutAddress "id" mtxOutId SV.unwrapTxOutIdAddress (Id.idEncoder Id.getTxOutAddressId) + , prepareTypedDelete @VA.MaTxOutAddress "id" mmaTxOutId SV.unwrapMaTxOutIdAddress (Id.idEncoder Id.getMaTxOutAddressId) + ] + if null operations + then pure [] + else runDeletePipeline "vMinIdsDelete" operations + + -- 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 + -- Create a pipeline for transaction-related deletions + result <- + runDeletePipeline + "txRelatedDelete" + [ case txOutVariantType of + SV.TxOutVariantCore -> prepareDelete @VC.CollateralTxOutCore "tx_id" txId ">=" txIdEncoder + SV.TxOutVariantAddress -> prepareDelete @VA.CollateralTxOutAddress "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.CollateralTxIn "tx_in_id" txId ">=" txIdEncoder + , prepareDelete @SCB.ReferenceTxIn "tx_in_id" txId ">=" txIdEncoder + , prepareDelete @SCP.PoolRetire "announced_tx_id" txId ">=" txIdEncoder + , prepareDelete @SCS.StakeRegistration "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCS.StakeDeregistration "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCS.Delegation "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.TxMetadata "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.Withdrawal "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCE.Treasury "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCE.Reserve "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCE.PotTransfer "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCM.MaTxMint "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.Redeemer "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.Script "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.Datum "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.RedeemerData "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.ExtraKeyWitness "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCB.TxCbor "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCG.ParamProposal "registered_tx_id" txId ">=" txIdEncoder + , prepareDelete @SCG.DelegationVote "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCG.CommitteeRegistration "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCG.CommitteeDeRegistration "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCG.DrepRegistration "tx_id" txId ">=" txIdEncoder + , prepareDelete @SCG.VotingProcedure "tx_id" txId ">=" txIdEncoder + ] + + -- Handle GovActionProposal related deletions if present + mgaId <- queryMinRefId @SCG.GovActionProposal "tx_id" txId txIdEncoder (Id.idDecoder Id.GovActionProposalId) + gaLogs <- case mgaId of + Nothing -> pure [] -- No GovActionProposal ID found, skip this step + Just gaId -> do + let gaIdEncoder = Id.idEncoder Id.getGovActionProposalId + runDeletePipeline + "govActionDelete" + [ prepareDelete @SCG.TreasuryWithdrawal "gov_action_proposal_id" gaId ">=" gaIdEncoder + , prepareDelete @SCG.Committee "gov_action_proposal_id" gaId ">=" gaIdEncoder + , prepareDelete @SCG.Constitution "gov_action_proposal_id" gaId ">=" gaIdEncoder + , prepareDelete @SCG.GovActionProposal "id" gaId ">=" gaIdEncoder + ] + + -- Handle PoolMetadataRef related deletions if present + minPmr <- queryMinRefId @SCP.PoolMetadataRef "registered_tx_id" txId txIdEncoder (Id.idDecoder Id.PoolMetadataRefId) + pmrLogs <- case minPmr of + Nothing -> pure [] -- No PoolMetadataRef ID found, skip this step + Just pmrId -> do + let pmrIdEncoder = Id.idEncoder Id.getPoolMetadataRefId + runDeletePipeline + "poolMetadataRefDelete" + [ prepareDelete @SCO.OffChainPoolData "pmr_id" pmrId ">=" pmrIdEncoder + , prepareDelete @SCO.OffChainPoolFetchError "pmr_id" pmrId ">=" pmrIdEncoder + , prepareDelete @SCP.PoolMetadataRef "id" pmrId ">=" pmrIdEncoder + ] + + -- Handle PoolUpdate related deletions if present + minPoolUpdate <- queryMinRefId @SCP.PoolUpdate "registered_tx_id" txId txIdEncoder (Id.idDecoder Id.PoolUpdateId) + poolUpdateLogs <- case minPoolUpdate of + Nothing -> pure [] -- No PoolUpdate ID found, skip this step + Just puid -> do + let puidEncoder = Id.idEncoder Id.getPoolUpdateId + runDeletePipeline + "poolUpdateDelete" + [ prepareDelete @SCP.PoolOwner "pool_update_id" puid ">=" puidEncoder + , prepareDelete @SCP.PoolRelay "update_id" puid ">=" puidEncoder + , prepareDelete @SCP.PoolUpdate "id" puid ">=" puidEncoder + ] + -- Final deletions for the given TxId + txLogs <- runDeletePipeline "" [prepareOnlyDelete @SCB.Tx "id" txId ">=" txIdEncoder] + -- Combine all logs from the operations above + pure $ result <> gaLogs <> pmrLogs <> poolUpdateLogs <> txLogs + -- Return the combined logs of all operations + pure $ minIdsLogs <> txIdLogs + +-- Creates a delete statement that returns count +onlyDeleteStmt :: + forall a b. + (DbInfo a) => + -- | Field name + Text.Text -> + -- | Operator + Text.Text -> + -- | Parameter encoder + HsqlE.Params b -> + HsqlStmt.Statement b Int64 +onlyDeleteStmt = deleteWhereCount @a + +-- Prepares a delete operation for pipeline +prepareOnlyDelete :: + forall a b. + (DbInfo a) => + -- | Field name + Text.Text -> + -- | Value + b -> + -- | Operator + Text.Text -> + -- | Parameter encoder + HsqlE.Params b -> + -- | Returns table name and session + (Text.Text, HsqlSes.Session Int64) +prepareOnlyDelete fieldName value operator encoder = + let tName = tableName (Proxy @a) + deleteSession = HsqlSes.statement value $ onlyDeleteStmt @a fieldName operator encoder + in (tName, deleteSession) + +-- Helper for creating delete operations with proper unwrapping +prepareTypedDelete :: + forall a b w. + (DbInfo a) => + Text.Text -> -- Field name + Maybe w -> -- Wrapped ID (Maybe) + (w -> Maybe b) -> -- Unwrapper function + HsqlE.Params b -> -- Parameter encoder (already applied) + Maybe (Text.Text, HsqlSes.Session Int64) +prepareTypedDelete fieldName mWrappedId unwrapper encoder = + case mWrappedId of + Nothing -> Nothing + Just wrappedId -> + case unwrapper wrappedId of + Nothing -> Nothing + Just i -> Just (prepareOnlyDelete @a fieldName i ">=" encoder) 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..40dcadf98 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/StakeDeligation.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ApplicativeDo #-} + +module Cardano.Db.Statement.StakeDeligation where + +import Cardano.Prelude (ByteString, MonadIO, Proxy (..)) +import Data.Functor.Contravariant ((>$<)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEnc +import Data.Word (Word64) +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 qualified Cardano.Db.Schema.Core.Base as SCB +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, bulkEncoder) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk, insertCheckUnique) +import Cardano.Db.Statement.Function.Query (countAll, adaSumDecoder) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..), validateColumn) +import Cardano.Db.Types (DbAction, DbLovelace, RewardSource, Ada, rewardSourceDecoder, dbLovelaceDecoder, rewardSourceEncoder) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Credential (Ptr (..)) +import qualified Hasql.Pipeline as HsqlP +import Contravariant.Extras (contrazip4, contrazip2) + +-------------------------------------------------------------------------------- +-- 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 + +-------------------------------------------------------------------------------- +-- Statement for querying delegations with non-null redeemer_id +queryDelegationScriptStmt :: HsqlStmt.Statement () [SS.Delegation] +queryDelegationScriptStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SS.Delegation) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM " <> tableN + , " WHERE redeemer_id IS NOT NULL" + ] + decoder = HsqlD.rowList SS.delegationDecoder + +queryDelegationScript :: MonadIO m => DbAction m [SS.Delegation] +queryDelegationScript = + runDbSession (mkCallInfo "queryDelegationScript") $ + HsqlSes.statement () queryDelegationScriptStmt + +-------------------------------------------------------------------------------- +-- EpochStake +-------------------------------------------------------------------------------- + +-- | INSERT -------------------------------------------------------------------- +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 + +-- | QUERIES ------------------------------------------------------------------- +queryEpochStakeCountStmt :: HsqlStmt.Statement Word64 Word64 +queryEpochStakeCountStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM epoch_stake" + , " WHERE epoch_no = $1" + ] + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +queryEpochStakeCount :: MonadIO m => Word64 -> DbAction m Word64 +queryEpochStakeCount epoch = + runDbSession (mkCallInfo "queryEpochStakeCount") $ + HsqlSes.statement epoch queryEpochStakeCountStmt + +-------------------------------------------------------------------------------- +queryMinMaxEpochStakeStmt :: + forall a. + (DbInfo a) => + Text.Text -> + HsqlStmt.Statement () (Maybe Word64, Maybe Word64) +queryMinMaxEpochStakeStmt colName = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + table = tableName (Proxy @a) + validCol = validateColumn @a colName + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT " + , "(SELECT MIN(" + , validCol + , ") FROM " + , table + , "), " + , "(SELECT MAX(" + , validCol + , ") FROM " + , table + , ")" + ] + + decoder = + HsqlD.singleRow $ + ((,) . fmap fromIntegral <$> HsqlD.column (HsqlD.nullable HsqlD.int8)) + <*> (fmap fromIntegral <$> HsqlD.column (HsqlD.nullable HsqlD.int8)) + +queryMinMaxEpochStake :: MonadIO m => DbAction m (Maybe Word64, Maybe Word64) +queryMinMaxEpochStake = + runDbSession (mkCallInfo "queryMinMaxEpochStake") $ + HsqlSes.statement () $ + queryMinMaxEpochStakeStmt @SS.EpochStake "epoch_no" + +-------------------------------------------------------------------------------- +-- 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 +-------------------------------------------------------------------------------- + +-- | INSERT --------------------------------------------------------------------- +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 + +-- | QUERY --------------------------------------------------------------------- +queryNormalEpochRewardCountStmt :: HsqlStmt.Statement Word64 Word64 +queryNormalEpochRewardCountStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM reward" + , " WHERE spendable_epoch = $1" + , " AND type IN ('member', 'leader')" + ] + + encoder = HsqlE.param (HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +queryNormalEpochRewardCount :: MonadIO m => Word64 -> DbAction m Word64 +queryNormalEpochRewardCount epochNum = + runDbSession (mkCallInfo "queryNormalEpochRewardCount") $ + HsqlSes.statement epochNum queryNormalEpochRewardCountStmt + +-------------------------------------------------------------------------------- +queryRewardCount :: MonadIO m => DbAction m Word64 +queryRewardCount = + runDbSession (mkCallInfo "queryRewardCount") $ + HsqlSes.statement () (countAll @SS.Reward) + +-------------------------------------------------------------------------------- +queryRewardMapDataStmt :: HsqlStmt.Statement Word64 [(ByteString, RewardSource, DbLovelace)] +queryRewardMapDataStmt = + HsqlStmt.Statement sql encoder decoder True + where + rewardTableN = tableName (Proxy @SS.Reward) + stakeAddressTableN = tableName (Proxy @SS.StakeAddress) + + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT sa.hash_raw, r.type, r.amount" + , " FROM " <> rewardTableN <> " r" + , " INNER JOIN " <> stakeAddressTableN <> " sa ON r.addr_id = sa.id" + , " WHERE r.spendable_epoch = $1" + , " AND r.type != 'deposit-refund'" + , " AND r.type != 'treasury'" + , " AND r.type != 'reserves'" + , " ORDER BY sa.hash_raw DESC" + ] + encoder = HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int8)) + + decoder = HsqlD.rowList $ do + hashRaw <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) + rewardType <- HsqlD.column (HsqlD.nonNullable rewardSourceDecoder) + amount <- dbLovelaceDecoder + pure (hashRaw, rewardType, amount) + +queryRewardMapData :: MonadIO m => Word64 -> DbAction m [(ByteString, RewardSource, DbLovelace)] +queryRewardMapData epochNo = + runDbSession (mkCallInfo "queryRewardMapData") $ + HsqlSes.statement epochNo queryRewardMapDataStmt + + +-- Bulk delete statement +deleteRewardsBulkStmt :: HsqlStmt.Statement ([Id.StakeAddressId], [RewardSource], [Word64], [Id.PoolHashId]) () +deleteRewardsBulkStmt = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + rewardTableN = tableName (Proxy @SS.Reward) + sql = TextEnc.encodeUtf8 $ Text.concat + [ "WITH to_delete AS (" + , " SELECT r.id" + , " FROM " <> rewardTableN <> " r" + , " JOIN UNNEST($1, $2, $3, $4) AS t(addr_id, reward_type, epoch, pool_id)" + , " ON r.addr_id = t.addr_id" + , " AND r.type = t.reward_type" + , " AND r.spendable_epoch = t.epoch" + , " AND r.pool_id = t.pool_id" + , ")" + , "DELETE FROM " <> rewardTableN + , " WHERE id IN (SELECT id FROM to_delete)" + ] + + encoder = contrazip4 + (bulkEncoder $ Id.idBulkEncoder Id.getStakeAddressId) + (bulkEncoder $ HsqlE.nonNullable rewardSourceEncoder) + (bulkEncoder $ HsqlE.nonNullable (fromIntegral >$< HsqlE.int8)) + (bulkEncoder $ Id.idBulkEncoder Id.getPoolHashId) + +-- Public API function +deleteRewardsBulk :: + MonadIO m => + ([Id.StakeAddressId], [RewardSource], [Word64], [Id.PoolHashId]) -> + DbAction m () +deleteRewardsBulk params = + runDbSession (mkCallInfo "deleteRewardsBulk") $ + HsqlSes.statement params deleteRewardsBulkStmt + +-------------------------------------------------------------------------------- +deleteOrphanedRewardsBulkStmt :: HsqlStmt.Statement (Word64, [Id.StakeAddressId]) () +deleteOrphanedRewardsBulkStmt = + HsqlStmt.Statement sql encoder HsqlD.noResult True + where + rewardTableN = tableName (Proxy @SS.Reward) + sql = TextEnc.encodeUtf8 $ Text.concat + [ "DELETE FROM " <> rewardTableN + , " WHERE spendable_epoch = $1" + , " AND addr_id = ANY($2)" + ] + encoder = contrazip2 + (fromIntegral >$< HsqlE.param (HsqlE.nonNullable HsqlE.int8)) + (HsqlE.param $ HsqlE.nonNullable $ HsqlE.foldableArray (Id.idBulkEncoder Id.getStakeAddressId)) + +-- | Delete orphaned rewards in bulk +deleteOrphanedRewardsBulk :: + MonadIO m => + Word64 -> + [Id.StakeAddressId] -> + DbAction m () +deleteOrphanedRewardsBulk epochNo addrIds = + runDbSession (mkCallInfo "deleteOrphanedRewardsBulk") $ + HsqlSes.statement (epochNo, addrIds) deleteOrphanedRewardsBulkStmt + +-------------------------------------------------------------------------------- +-- 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 + +-------------------------------------------------------------------------------- +queryRewardRestCount :: MonadIO m => DbAction m Word64 +queryRewardRestCount = + runDbSession (mkCallInfo "queryRewardRestCount") $ + HsqlSes.statement () (countAll @SS.RewardRest) + +-------------------------------------------------------------------------------- +-- 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 -> DbAction m (Maybe Id.StakeAddressId) +queryStakeAddress addr = do + runDbSession callInfo $ HsqlSes.statement addr queryStakeAddressStmt + where + callInfo = mkCallInfo "queryStakeAddress" + +----------------------------------------------------------------------------------- +queryStakeRefPtrStmt :: HsqlStmt.Statement Ptr (Maybe Id.StakeAddressId) +queryStakeRefPtrStmt = + HsqlStmt.Statement sql encoder decoder True + where + blockTable = tableName (Proxy @SCB.Block) + txTable = tableName (Proxy @SCB.Tx) + srTable = tableName (Proxy @SS.StakeRegistration) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT sr.addr_id FROM " + , blockTable + , " blk" + , " INNER JOIN " + , txTable + , " tx ON blk.id = tx.block_id" + , " INNER JOIN " + , srTable + , " sr ON sr.tx_id = tx.id" + , " WHERE blk.slot_no = $1" + , " AND tx.block_index = $2" + , " AND sr.cert_index = $3" + , " ORDER BY blk.slot_no DESC" + , " LIMIT 1" + ] + + encoder = + mconcat + [ (\(Ptr (SlotNo s) _ _) -> s) >$< HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int8)) + , (\(Ptr _ (TxIx t) _) -> t) >$< HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int8)) + , (\(Ptr _ _ (CertIx c)) -> c) >$< HsqlE.param (HsqlE.nonNullable (fromIntegral >$< HsqlE.int8)) + ] + + decoder = + HsqlD.rowMaybe + ( HsqlD.column $ + HsqlD.nonNullable $ + Id.StakeAddressId <$> HsqlD.int8 + ) + +queryStakeRefPtr :: MonadIO m => Ptr -> DbAction m (Maybe Id.StakeAddressId) +queryStakeRefPtr ptr = + runDbSession (mkCallInfo "queryStakeRefPtr") $ + HsqlSes.statement ptr queryStakeRefPtrStmt + +----------------------------------------------------------------------------------- +-- Statement for querying stake addresses with non-null script_hash +queryStakeAddressScriptStmt :: HsqlStmt.Statement () [SS.StakeAddress] +queryStakeAddressScriptStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SS.StakeAddress) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM " <> tableN + , " WHERE script_hash IS NOT NULL" + ] + decoder = HsqlD.rowList SS.stakeAddressDecoder + +queryStakeAddressScript :: MonadIO m => DbAction m [SS.StakeAddress] +queryStakeAddressScript = + runDbSession (mkCallInfo "queryStakeAddressScript") $ + HsqlSes.statement () queryStakeAddressScriptStmt + +----------------------------------------------------------------------------------- +queryAddressInfoRewardsStmt :: HsqlStmt.Statement Id.StakeAddressId Ada +queryAddressInfoRewardsStmt = + HsqlStmt.Statement sql encoder decoder True + where + rewardTableN = tableName (Proxy @SS.Reward) + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT COALESCE(SUM(amount), 0)" + , " FROM " <> rewardTableN + , " WHERE addr_id = $1" + ] + encoder = Id.idEncoder Id.getStakeAddressId + decoder = HsqlD.singleRow adaSumDecoder + +queryAddressInfoWithdrawalsStmt :: HsqlStmt.Statement Id.StakeAddressId Ada +queryAddressInfoWithdrawalsStmt = + HsqlStmt.Statement sql encoder decoder True + where + withdrawalTableN = tableName (Proxy @SCB.Withdrawal) + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT COALESCE(SUM(amount), 0)" + , " FROM " <> withdrawalTableN + , " WHERE addr_id = $1" + ] + encoder = Id.idEncoder Id.getStakeAddressId + decoder = HsqlD.singleRow adaSumDecoder + +queryAddressInfoViewStmt :: HsqlStmt.Statement Id.StakeAddressId (Maybe Text.Text) +queryAddressInfoViewStmt = + HsqlStmt.Statement sql encoder decoder True + where + stakeAddrTableN = tableName (Proxy @SS.StakeAddress) + sql = TextEnc.encodeUtf8 $ Text.concat + [ "SELECT view" + , " FROM " <> stakeAddrTableN + , " WHERE id = $1" + ] + encoder = Id.idEncoder Id.getStakeAddressId + decoder = HsqlD.rowMaybe $ HsqlD.column (HsqlD.nonNullable HsqlD.text) + +-- Pipeline function +queryAddressInfoData :: MonadIO m => Id.StakeAddressId -> DbAction m (Ada, Ada, Maybe Text.Text) +queryAddressInfoData addrId = + runDbSession (mkCallInfo "queryAddressInfoData") $ + HsqlSes.pipeline $ do + rewards <- HsqlP.statement addrId queryAddressInfoRewardsStmt + withdrawals <- HsqlP.statement addrId queryAddressInfoWithdrawalsStmt + view <- HsqlP.statement addrId queryAddressInfoViewStmt + pure (rewards, withdrawals, view) +--------------------------------------------------------------------------- +-- StakeDeregistration +--------------------------------------------------------------------------- + +queryDeregistrationScriptStmt :: HsqlStmt.Statement () [SS.StakeDeregistration] +queryDeregistrationScriptStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + tableN = tableName (Proxy @SS.StakeDeregistration) + + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM " <> tableN + , " WHERE redeemer_id IS NOT NULL" + ] + + decoder = HsqlD.rowList SS.stakeDeregistrationDecoder + +queryDeregistrationScript :: MonadIO m => DbAction m [SS.StakeDeregistration] +queryDeregistrationScript = + runDbSession (mkCallInfo "queryDeregistrationScript") $ + HsqlSes.statement () queryDeregistrationScriptStmt + +-- 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..2a0c58ce9 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Types.hs @@ -0,0 +1,174 @@ +{-# 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 Cardano.Prelude (Int64) +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 + +-- Helper function for decoding standard integer IDs +stdKeyDecoder :: HsqlD.Row Int64 +stdKeyDecoder = HsqlD.column (HsqlD.nonNullable HsqlD.int8) diff --git a/cardano-db/src/Cardano/Db/Statement/Variants/TxOut.hs b/cardano-db/src/Cardano/Db/Statement/Variants/TxOut.hs new file mode 100644 index 000000000..c113fea90 --- /dev/null +++ b/cardano-db/src/Cardano/Db/Statement/Variants/TxOut.hs @@ -0,0 +1,935 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Db.Statement.Variants.TxOut where + +import Cardano.Prelude (ByteString, Int64, MonadError (..), MonadIO, Proxy (..), Text, Word64, fromMaybe) +import Control.Monad.Extra (whenJust) +import Data.Functor.Contravariant (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 HsqlSes +import qualified Hasql.Statement as HsqlStmt + +import Cardano.Db.Error (DbError (..)) +import qualified Cardano.Db.Schema.Ids as Id +import Cardano.Db.Schema.Variants (CollateralTxOutIdW (..), CollateralTxOutW (..), MaTxOutIdW (..), MaTxOutW (..), TxOutIdW (..), TxOutVariantType (..), TxOutW (..), UtxoQueryResult (..)) +import qualified Cardano.Db.Schema.Variants.TxOutAddress as SVA +import qualified Cardano.Db.Schema.Variants.TxOutCore as SVC +import Cardano.Db.Statement.Function.Core (ResultType (..), ResultTypeBulk (..), mkCallInfo, runDbSession) +import Cardano.Db.Statement.Function.Delete (deleteAllCount, parameterisedDeleteWhere) +import Cardano.Db.Statement.Function.Insert (insert, insertBulk) +import Cardano.Db.Statement.Function.Query (countAll) +import Cardano.Db.Statement.Types (DbInfo (..), Entity (..)) +import Cardano.Db.Types (Ada (..), DbAction, DbCallInfo (..), DbLovelace, DbWord64, dbLovelaceDecoder) + +-------------------------------------------------------------------------------- +-- TxOut +-------------------------------------------------------------------------------- + +-- INSERTS --------------------------------------------------------------------- + +insertTxOutCoreStmt :: HsqlStmt.Statement SVC.TxOutCore (Entity SVC.TxOutCore) +insertTxOutCoreStmt = + insert + SVC.txOutCoreEncoder + (WithResult $ HsqlD.singleRow SVC.entityTxOutCoreDecoder) + +insertTxOutAddressStmt :: HsqlStmt.Statement SVA.TxOutAddress (Entity SVA.TxOutAddress) +insertTxOutAddressStmt = + insert + SVA.txOutAddressEncoder + (WithResult $ HsqlD.singleRow SVA.entityTxOutAddressDecoder) + +insertTxOut :: MonadIO m => TxOutW -> DbAction m TxOutIdW +insertTxOut txOutW = + case txOutW of + VCTxOutW txOut -> do + txOutId <- + runDbSession (mkCallInfo "insertTxOutCore") $ + HsqlSes.statement txOut insertTxOutCoreStmt + pure $ VCTxOutIdW $ entityKey txOutId + VATxOutW txOut _ -> do + txOutId <- + runDbSession (mkCallInfo "insertTxOutAddress") $ + HsqlSes.statement txOut insertTxOutAddressStmt + pure $ VATxOutIdW $ entityKey txOutId + +-------------------------------------------------------------------------------- +insertBulkCoreTxOutStmt :: HsqlStmt.Statement [SVC.TxOutCore] [Entity SVC.TxOutCore] +insertBulkCoreTxOutStmt = + insertBulk + extractCoreTxOutValues + SVC.txOutCoreBulkEncoder + (WithResultBulk $ HsqlD.rowList SVC.entityTxOutCoreDecoder) + where + extractCoreTxOutValues :: + [SVC.TxOutCore] -> + ( [Text] + , [Bool] + , [Maybe ByteString] + , [Maybe Id.TxId] + , [Word64] + , [Maybe Id.DatumId] + , [Maybe ByteString] + , [Maybe Id.ScriptId] + , [Maybe Id.StakeAddressId] + , [Id.TxId] + , [DbLovelace] + ) + extractCoreTxOutValues xs = + ( map SVC.txOutCoreAddress xs + , map SVC.txOutCoreAddressHasScript xs + , map SVC.txOutCoreDataHash xs + , map SVC.txOutCoreConsumedByTxId xs + , map SVC.txOutCoreIndex xs + , map SVC.txOutCoreInlineDatumId xs + , map SVC.txOutCorePaymentCred xs + , map SVC.txOutCoreReferenceScriptId xs + , map SVC.txOutCoreStakeAddressId xs + , map SVC.txOutCoreTxId xs + , map SVC.txOutCoreValue xs + ) + +insertBulkAddressTxOutStmt :: HsqlStmt.Statement [SVA.TxOutAddress] [Entity SVA.TxOutAddress] +insertBulkAddressTxOutStmt = + insertBulk + extractAddressTxOutValues + SVA.txOutAddressBulkEncoder + (WithResultBulk $ HsqlD.rowList SVA.entityTxOutAddressDecoder) + where + extractAddressTxOutValues :: + [SVA.TxOutAddress] -> + ( [Id.TxId] + , [Word64] + , [Maybe Id.StakeAddressId] + , [DbLovelace] + , [Maybe ByteString] + , [Maybe Id.DatumId] + , [Maybe Id.ScriptId] + , [Maybe Id.TxId] + , [Id.AddressId] + ) + extractAddressTxOutValues xs = + ( map SVA.txOutAddressTxId xs + , map SVA.txOutAddressIndex xs + , map SVA.txOutAddressStakeAddressId xs + , map SVA.txOutAddressValue xs + , map SVA.txOutAddressDataHash xs + , map SVA.txOutAddressInlineDatumId xs + , map SVA.txOutAddressReferenceScriptId xs + , map SVA.txOutAddressConsumedByTxId xs + , map SVA.txOutAddressAddressId xs + ) + +insertBulkTxOut :: MonadIO m => Bool -> [TxOutW] -> DbAction m [TxOutIdW] +insertBulkTxOut disInOut txOutWs = + if disInOut + then pure [] + else case txOutWs of + [] -> pure [] + txOuts@(txOutW : _) -> + case txOutW of + VCTxOutW _ -> do + let coreTxOuts = map extractCoreTxOut txOuts + ids <- + runDbSession (mkCallInfo "insertBulkTxOutCore") $ + HsqlSes.statement coreTxOuts insertBulkCoreTxOutStmt + pure $ map (VCTxOutIdW . entityKey) ids + VATxOutW _ _ -> do + let variantTxOuts = map extractVariantTxOut txOuts + ids <- + runDbSession (mkCallInfo "insertBulkTxOutAddress") $ + HsqlSes.statement variantTxOuts insertBulkAddressTxOutStmt + pure $ map (VATxOutIdW . entityKey) ids + where + extractCoreTxOut :: TxOutW -> SVC.TxOutCore + extractCoreTxOut (VCTxOutW txOut) = txOut + extractCoreTxOut (VATxOutW _ _) = error "Unexpected VATxOutW in CoreTxOut list" + + extractVariantTxOut :: TxOutW -> SVA.TxOutAddress + extractVariantTxOut (VATxOutW txOut _) = txOut + extractVariantTxOut (VCTxOutW _) = error "Unexpected VCTxOutW in VariantTxOut list" + +-- | QUERIES ------------------------------------------------------------------- +queryTxOutCount :: MonadIO m => TxOutVariantType -> DbAction m Word64 +queryTxOutCount txOutVariantType = + case txOutVariantType of + TxOutVariantCore -> + runDbSession (mkCallInfo "queryTxOutCountCore") $ + HsqlSes.statement () (countAll @SVC.TxOutCore) + TxOutVariantAddress -> + runDbSession (mkCallInfo "queryTxOutCountAddress") $ + HsqlSes.statement () (countAll @SVA.TxOutAddress) + +-------------------------------------------------------------------------------- +queryTxOutValueStmt :: HsqlStmt.Statement (ByteString, Word64) (Maybe (Id.TxId, DbLovelace)) +queryTxOutValueStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_out.tx_id, tx_out.value" + , " FROM tx INNER JOIN tx_out ON tx.id = tx_out.tx_id" + , " WHERE tx_out.index = $2 AND tx.hash = $1" + ] + -- Parameter encoder for (hash, index) + encoder = + contramap fst (HsqlE.param $ HsqlE.nonNullable HsqlE.bytea) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + + -- Result decoder for (TxId, DbLovelace) + decoder = + HsqlD.rowMaybe + ( (,) + <$> Id.idDecoder Id.TxId + <*> dbLovelaceDecoder + ) + +-- | Query the value of a TxOut by its hash and index, +-- this works the same for both variations of TxOut +queryTxOutValue :: + MonadIO m => + (ByteString, Word64) -> + DbAction m (Id.TxId, DbLovelace) +queryTxOutValue hashIndex@(hash, _) = do + result <- runDbSession callInfo $ HsqlSes.statement hashIndex queryTxOutValueStmt + case result of + Just value -> pure value + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "queryTxOutValue" + errorMsg = "TxOut not found for hash: " <> Text.pack (show hash) + +-------------------------------------------------------------------------------- +queryTxOutIdStmt :: HsqlStmt.Statement (ByteString, Word64) (Maybe (Id.TxId, Int64)) +queryTxOutIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_out.tx_id, tx_out.id" + , " FROM tx INNER JOIN tx_out ON tx.id = tx_out.tx_id" + , " WHERE tx_out.index = $2 AND tx.hash = $1" + ] + + encoder = + contramap fst (HsqlE.param $ HsqlE.nonNullable HsqlE.bytea) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + + decoder = + HsqlD.rowMaybe + ( (,) + <$> Id.idDecoder Id.TxId + <*> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + ) + +queryTxOutId :: + MonadIO m => + TxOutVariantType -> + (ByteString, Word64) -> + DbAction m (Id.TxId, TxOutIdW) +queryTxOutId txOutVariantType hashIndex@(hash, _) = do + result <- runDbSession callInfo $ HsqlSes.statement hashIndex queryTxOutIdStmt + case result of + Just (txId, rawId) -> + pure $ case txOutVariantType of + TxOutVariantCore -> (txId, VCTxOutIdW (Id.TxOutCoreId rawId)) + TxOutVariantAddress -> (txId, VATxOutIdW (Id.TxOutAddressId rawId)) + Nothing -> + throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + where + callInfo = mkCallInfo "queryTxOutId" + errorMsg = "TxOut not found for hash: " <> Text.pack (show hash) + +-------------------------------------------------------------------------------- +queryTxOutIdValueStmt :: HsqlStmt.Statement (ByteString, Word64) (Maybe (Id.TxId, Int64, DbLovelace)) +queryTxOutIdValueStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_out.tx_id, tx_out.id, tx_out.value" + , " FROM tx INNER JOIN tx_out ON tx.id = tx_out.tx_id" + , " WHERE tx_out.index = $2 AND tx.hash = $1" + ] + + encoder = + contramap fst (HsqlE.param $ HsqlE.nonNullable HsqlE.bytea) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + + decoder = + HsqlD.rowMaybe + ( (,,) + <$> Id.idDecoder Id.TxId + <*> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + <*> dbLovelaceDecoder + ) + +queryTxOutIdValue :: + MonadIO m => + TxOutVariantType -> + (ByteString, Word64) -> + DbAction m (Id.TxId, TxOutIdW, DbLovelace) +queryTxOutIdValue txOutVariantType hashIndex@(hash, _) = do + let callInfo = mkCallInfo "queryTxOutIdValue" + errorMsg = "TxOut not found for hash: " <> Text.pack (show hash) + + result <- runDbSession callInfo $ HsqlSes.statement hashIndex queryTxOutIdValueStmt + case result of + Just (txId, rawId, value) -> + pure $ case txOutVariantType of + TxOutVariantCore -> (txId, VCTxOutIdW (Id.TxOutCoreId rawId), value) + TxOutVariantAddress -> (txId, VATxOutIdW (Id.TxOutAddressId rawId), value) + Nothing -> + throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + +-------------------------------------------------------------------------------- +queryTxOutCredentialsCoreStmt :: HsqlStmt.Statement (ByteString, Word64) (Maybe (Maybe ByteString)) +queryTxOutCredentialsCoreStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_out.payment_cred, tx_out.address_has_script" + , " FROM tx INNER JOIN tx_out ON tx.id = tx_out.tx_id" + , " WHERE tx_out.index = $2 AND tx.hash = $1" + ] + + encoder = + contramap fst (HsqlE.param $ HsqlE.nonNullable HsqlE.bytea) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + + decoder = + HsqlD.rowMaybe $ HsqlD.column (HsqlD.nullable HsqlD.bytea) + + +-------------------------------------------------------------------------------- +queryTxOutCredentialsVariantStmt :: HsqlStmt.Statement (ByteString, Word64) (Maybe (Maybe ByteString)) +queryTxOutCredentialsVariantStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT addr.payment_cred, addr.address_has_script" + , " FROM tx" + , " INNER JOIN tx_out ON tx.id = tx_out.tx_id" + , " INNER JOIN address addr ON tx_out.address_id = addr.id" + , " WHERE tx_out.index = $2 AND tx.hash = $1" + ] + + encoder = + contramap fst (HsqlE.param $ HsqlE.nonNullable HsqlE.bytea) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8) + + decoder = + HsqlD.rowMaybe $ HsqlD.column (HsqlD.nullable HsqlD.bytea) + +queryTxOutCredentials :: + MonadIO m => + TxOutVariantType -> + (ByteString, Word64) -> + DbAction m (Maybe ByteString) +queryTxOutCredentials txOutVariantType hashIndex@(hash, _) = do + let callInfo = mkCallInfo "queryTxOutCredentials" + errorMsg = "TxOut not found for hash: " <> Text.pack (show hash) + + result <- case txOutVariantType of + TxOutVariantCore -> + runDbSession callInfo $ HsqlSes.statement hashIndex queryTxOutCredentialsCoreStmt + TxOutVariantAddress -> + runDbSession callInfo $ HsqlSes.statement hashIndex queryTxOutCredentialsVariantStmt + + case result of + Just credentials -> pure credentials + Nothing -> throwError $ DbError (dciCallSite callInfo) errorMsg Nothing + +-------------------------------------------------------------------------------- +queryTotalSupplyStmt :: HsqlStmt.Statement () Ada +queryTotalSupplyStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(SUM(value), 0)::bigint" + , " FROM tx_out" + , " WHERE NOT EXISTS (" + , " SELECT 1 FROM tx_in" + , " WHERE tx_in.tx_out_id = tx_out.tx_id" + , " AND tx_in.tx_out_index = tx_out.index" + , " )" + ] + + decoder = + HsqlD.singleRow $ + fromMaybe (Ada 0) <$> HsqlD.column (HsqlD.nullable (Ada . fromIntegral <$> HsqlD.int8)) + +-- | 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 => TxOutVariantType -> DbAction m Ada +queryTotalSupply _ = + runDbSession (mkCallInfo "queryTotalSupply") $ + HsqlSes.statement () queryTotalSupplyStmt + +-------------------------------------------------------------------------------- +-- DELETES + +-- Statement for deleting MaTxOutCore and TxOutVariantCore records after specific IDs +deleteMaTxOutCoreAfterIdStmt :: HsqlStmt.Statement Id.MaTxOutCoreId () +deleteMaTxOutCoreAfterIdStmt = + parameterisedDeleteWhere @SVC.MaTxOutCore + "id" + ">= $1" + (Id.idEncoder Id.getMaTxOutCoreId) + +deleteTxOutCoreAfterIdStmt :: HsqlStmt.Statement Id.TxOutCoreId () +deleteTxOutCoreAfterIdStmt = + parameterisedDeleteWhere @SVC.TxOutCore + "id" + ">= $1" + (Id.idEncoder Id.getTxOutCoreId) + +-- Function that uses the core delete statements +deleteCoreTxOutTablesAfterTxId :: MonadIO m => Maybe Id.TxOutCoreId -> Maybe Id.MaTxOutCoreId -> DbAction m () +deleteCoreTxOutTablesAfterTxId mtxOutId mmaTxOutId = do + let callInfo = mkCallInfo "deleteCoreTxOutTablesAfterTxId" + + -- Delete MaTxOut entries if ID provided + whenJust mmaTxOutId $ \maTxOutId -> + runDbSession callInfo $ HsqlSes.statement maTxOutId deleteMaTxOutCoreAfterIdStmt + + -- Delete TxOut entries if ID provided + whenJust mtxOutId $ \txOutId -> + runDbSession callInfo $ HsqlSes.statement txOutId deleteTxOutCoreAfterIdStmt + +-------------------------------------------------------------------------------- +-- Statement for deleting MaTxOutAddress and TxOutAddress records after specific IDs +deleteMaTxOutAddressAfterIdStmt :: HsqlStmt.Statement Id.MaTxOutAddressId () +deleteMaTxOutAddressAfterIdStmt = + parameterisedDeleteWhere @SVA.MaTxOutAddress + "id" + ">= $1" + (Id.idEncoder Id.getMaTxOutAddressId) + +deleteTxOutAddressAfterIdStmt :: HsqlStmt.Statement Id.TxOutAddressId () +deleteTxOutAddressAfterIdStmt = + parameterisedDeleteWhere @SVA.TxOutAddress + "id" + ">= $1" + (Id.idEncoder Id.getTxOutAddressId) + +-- Function that uses the address variant delete statements +deleteVariantTxOutTablesAfterTxId :: MonadIO m => Maybe Id.TxOutAddressId -> Maybe Id.MaTxOutAddressId -> DbAction m () +deleteVariantTxOutTablesAfterTxId mtxOutId mmaTxOutId = do + let callInfo = mkCallInfo "deleteVariantTxOutTablesAfterTxId" + + -- Delete MaTxOut entries if ID provided + whenJust mmaTxOutId $ \maTxOutId -> + runDbSession callInfo $ HsqlSes.statement maTxOutId deleteMaTxOutAddressAfterIdStmt + + -- Delete TxOut entries if ID provided + whenJust mtxOutId $ \txOutId -> + runDbSession callInfo $ HsqlSes.statement txOutId deleteTxOutAddressAfterIdStmt + +-------------------------------------------------------------------------------- +-- Statements for deleting all records and returning counts +deleteTxOutCoreAllCountStmt :: HsqlStmt.Statement () Int64 +deleteTxOutCoreAllCountStmt = deleteAllCount @SVC.TxOutCore + +deleteTxOutAddressAllCountStmt :: HsqlStmt.Statement () Int64 +deleteTxOutAddressAllCountStmt = deleteAllCount @SVA.TxOutAddress + +-- Function that uses the delete all count statements +deleteTxOut :: MonadIO m => TxOutVariantType -> DbAction m Int64 +deleteTxOut = \case + TxOutVariantCore -> + runDbSession (mkCallInfo "deleteTxOutCore") $ + HsqlSes.statement () deleteTxOutCoreAllCountStmt + TxOutVariantAddress -> + runDbSession (mkCallInfo "deleteTxOutAddress") $ + HsqlSes.statement () deleteTxOutAddressAllCountStmt + +-------------------------------------------------------------------------------- +-- Address +-------------------------------------------------------------------------------- +insertAddressStmt :: HsqlStmt.Statement SVA.Address (Entity SVA.Address) +insertAddressStmt = + insert + SVA.addressEncoder + (WithResult $ HsqlD.singleRow SVA.entityAddressDecoder) + +insertAddress :: MonadIO m => SVA.Address -> DbAction m Id.AddressId +insertAddress address = do + addrId <- + runDbSession (mkCallInfo "insertAddress") $ + HsqlSes.statement address insertAddressStmt + pure $ entityKey addrId + +queryAddressIdStmt :: HsqlStmt.Statement ByteString (Maybe Id.AddressId) +queryAddressIdStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT address.id" + , " FROM address" + , " WHERE address.raw = $1" + ] + encoder = HsqlE.param $ HsqlE.nonNullable HsqlE.bytea + decoder = HsqlD.rowMaybe (Id.idDecoder Id.AddressId) + +queryAddressId :: MonadIO m => ByteString -> DbAction m (Maybe Id.AddressId) +queryAddressId addrRaw = + runDbSession (mkCallInfo "queryAddressId") $ + HsqlSes.statement addrRaw queryAddressIdStmt + +-------------------------------------------------------------------------------- +-- MaTxOut +-------------------------------------------------------------------------------- +insertBulkCoreMaTxOutStmt :: HsqlStmt.Statement [SVC.MaTxOutCore] [Entity SVC.MaTxOutCore] +insertBulkCoreMaTxOutStmt = + insertBulk + extractCoreMaTxOutValues + SVC.maTxOutCoreBulkEncoder + (WithResultBulk $ HsqlD.rowList SVC.entityMaTxOutCoreDecoder) + where + extractCoreMaTxOutValues :: + [SVC.MaTxOutCore] -> + ( [Id.MultiAssetId] + , [DbWord64] + , [Id.TxOutCoreId] + ) + extractCoreMaTxOutValues xs = + ( map SVC.maTxOutCoreIdent xs + , map SVC.maTxOutCoreQuantity xs + , map SVC.maTxOutCoreTxOutId xs + ) + +insertBulkAddressMaTxOutStmt :: HsqlStmt.Statement [SVA.MaTxOutAddress] [Entity SVA.MaTxOutAddress] +insertBulkAddressMaTxOutStmt = + insertBulk + extractAddressMaTxOutValues + SVA.maTxOutAddressBulkEncoder + (WithResultBulk $ HsqlD.rowList SVA.entityMaTxOutAddressDecoder) + where + extractAddressMaTxOutValues :: + [SVA.MaTxOutAddress] -> + ( [Id.MultiAssetId] + , [DbWord64] + , [Id.TxOutAddressId] + ) + extractAddressMaTxOutValues xs = + ( map SVA.maTxOutAddressIdent xs + , map SVA.maTxOutAddressQuantity xs + , map SVA.maTxOutAddressTxOutId xs + ) + +insertBulkMaTxOut :: MonadIO m => [MaTxOutW] -> DbAction m [MaTxOutIdW] +insertBulkMaTxOut maTxOutWs = + case maTxOutWs of + [] -> pure [] + maTxOuts@(maTxOutW : _) -> + case maTxOutW of + CMaTxOutW _ -> do + let coreMaTxOuts = map extractCoreMaTxOut maTxOuts + ids <- + runDbSession (mkCallInfo "insertBulkCoreMaTxOut") $ + HsqlSes.statement coreMaTxOuts insertBulkCoreMaTxOutStmt + pure $ map (CMaTxOutIdW . entityKey) ids + VMaTxOutW _ -> do + let addressMaTxOuts = map extractVariantMaTxOut maTxOuts + ids <- + runDbSession (mkCallInfo "insertBulkAddressMaTxOut") $ + HsqlSes.statement addressMaTxOuts insertBulkAddressMaTxOutStmt + pure $ map (VMaTxOutIdW . entityKey) ids + where + extractCoreMaTxOut :: MaTxOutW -> SVC.MaTxOutCore + extractCoreMaTxOut (CMaTxOutW maTxOut) = maTxOut + extractCoreMaTxOut (VMaTxOutW _) = error "Unexpected VMaTxOutW in CoreMaTxOut list" + + extractVariantMaTxOut :: MaTxOutW -> SVA.MaTxOutAddress + extractVariantMaTxOut (VMaTxOutW maTxOut) = maTxOut + extractVariantMaTxOut (CMaTxOutW _) = error "Unexpected CMaTxOutW in VariantMaTxOut list" + +-------------------------------------------------------------------------------- +-- CollateralTxOut +-------------------------------------------------------------------------------- +insertCollateralTxOutCoreStmt :: HsqlStmt.Statement SVC.CollateralTxOutCore (Entity SVC.CollateralTxOutCore) +insertCollateralTxOutCoreStmt = + insert + SVC.collateralTxOutCoreEncoder + (WithResult $ HsqlD.singleRow SVC.entityCollateralTxOutCoreDecoder) + +insertCollateralTxOutAddressStmt :: HsqlStmt.Statement SVA.CollateralTxOutAddress (Entity SVA.CollateralTxOutAddress) +insertCollateralTxOutAddressStmt = + insert + SVA.collateralTxOutAddressEncoder + (WithResult $ HsqlD.singleRow SVA.entityCollateralTxOutAddressDecoder) + +insertCollateralTxOut :: MonadIO m => CollateralTxOutW -> DbAction m CollateralTxOutIdW +insertCollateralTxOut collateralTxOutW = + case collateralTxOutW of + CCollateralTxOutW txOut -> do + txOutId <- + runDbSession (mkCallInfo "insertCollateralTxOutCore") $ + HsqlSes.statement txOut insertCollateralTxOutCoreStmt + pure $ CCollateralTxOutIdW $ entityKey txOutId + VCollateralTxOutW txOut -> do + txOutId <- + runDbSession (mkCallInfo "insertCollateralTxOutAddress") $ + HsqlSes.statement txOut insertCollateralTxOutAddressStmt + pure $ VCollateralTxOutIdW $ entityKey txOutId + +-------------------------------------------------------------------------------- +-- Testing or validating. Queries below are not used in production +-------------------------------------------------------------------------------- +queryTxOutUnspentCountStmt :: HsqlStmt.Statement () Word64 +queryTxOutUnspentCountStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COUNT(*)::bigint" + , " FROM tx_out" + , " WHERE NOT EXISTS (" + , " SELECT 1 FROM tx_in" + , " WHERE tx_in.tx_out_id = tx_out.tx_id" + , " AND tx_in.tx_out_index = tx_out.index" + , " )" + ] + + decoder = + HsqlD.singleRow $ + fromIntegral <$> HsqlD.column (HsqlD.nonNullable HsqlD.int8) + +queryTxOutUnspentCount :: MonadIO m => TxOutVariantType -> DbAction m Word64 +queryTxOutUnspentCount _ = + runDbSession (mkCallInfo "queryTxOutUnspentCount") $ + HsqlSes.statement () queryTxOutUnspentCountStmt + +-------------------------------------------------------------------------------- +utxoAtBlockIdWhereClause :: Text +utxoAtBlockIdWhereClause = + Text.concat + [ " WHERE txout.tx_id IN (" + , " SELECT tx.id FROM tx" + , " WHERE tx.block_id IN (" + , " SELECT block.id FROM block" + , " WHERE block.id <= $1" + , " )" + , " )" + , " AND (blk.block_no IS NULL OR blk.id > $1)" + , " AND tx2.hash IS NOT NULL" -- Filter out NULL hashes + ] + +queryUtxoAtBlockIdCoreStmt :: HsqlStmt.Statement Id.BlockId [UtxoQueryResult] +queryUtxoAtBlockIdCoreStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT txout.*, txout.address, tx2.hash" + , " FROM tx_out txout" + , " LEFT JOIN tx_in txin ON txout.tx_id = txin.tx_out_id AND txout.index = txin.tx_out_index" + , " LEFT JOIN tx tx1 ON txin.tx_in_id = tx1.id" + , " LEFT JOIN block blk ON tx1.block_id = blk.id" + , " LEFT JOIN tx tx2 ON txout.tx_id = tx2.id" + , utxoAtBlockIdWhereClause + ] + + encoder = Id.idEncoder Id.getBlockId + + decoder = HsqlD.rowList $ do + txOut <- SVC.txOutCoreDecoder + address <- HsqlD.column (HsqlD.nonNullable HsqlD.text) + txHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) -- Now non-nullable + pure $ + UtxoQueryResult + { utxoTxOutW = VCTxOutW txOut + , utxoAddress = address + , utxoTxHash = txHash + } + +queryUtxoAtBlockIdVariantStmt :: HsqlStmt.Statement Id.BlockId [UtxoQueryResult] +queryUtxoAtBlockIdVariantStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT txout.*, addr.*, tx2.hash" + , " FROM tx_out txout" + , " LEFT JOIN tx_in txin ON txout.tx_id = txin.tx_out_id AND txout.index = txin.tx_out_index" + , " LEFT JOIN tx tx1 ON txin.tx_in_id = tx1.id" + , " LEFT JOIN block blk ON tx1.block_id = blk.id" + , " LEFT JOIN tx tx2 ON txout.tx_id = tx2.id" + , " INNER JOIN address addr ON txout.address_id = addr.id" + , utxoAtBlockIdWhereClause + ] + + encoder = Id.idEncoder Id.getBlockId + + decoder = HsqlD.rowList $ do + txOut <- SVA.txOutAddressDecoder + addr <- SVA.addressDecoder + txHash <- HsqlD.column (HsqlD.nonNullable HsqlD.bytea) -- Now non-nullable + pure $ + UtxoQueryResult + { utxoTxOutW = VATxOutW txOut (Just addr) + , utxoAddress = SVA.addressAddress addr + , utxoTxHash = txHash + } + +-------------------------------------------------------------------------------- +-- Query to get block ID at a specific slot +queryBlockIdAtSlotStmt :: HsqlStmt.Statement Word64 (Maybe Id.BlockId) +queryBlockIdAtSlotStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT id FROM block" + , " WHERE slot_no = $1" + ] + + encoder = HsqlE.param $ HsqlE.nonNullable $ fromIntegral >$< HsqlE.int8 + decoder = HsqlD.rowMaybe $ Id.idDecoder Id.BlockId + +-- Shared WHERE clause for address balance queries +addressBalanceWhereClause :: Text +addressBalanceWhereClause = + Text.concat + [ " WHERE txout.tx_id IN (" + , " SELECT tx.id FROM tx" + , " WHERE tx.block_id IN (" + , " SELECT block.id FROM block" + , " WHERE block.id <= $1" + , " )" + , " )" + , " AND (blk.block_no IS NULL OR blk.id > $1)" + ] + +-- Query to get address balance for Core variant +queryAddressBalanceAtBlockIdCoreStmt :: HsqlStmt.Statement (Id.BlockId, Text) Ada +queryAddressBalanceAtBlockIdCoreStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(SUM(txout.value), 0)::bigint" + , " FROM tx_out txout" + , " LEFT JOIN tx_in txin ON txout.tx_id = txin.tx_out_id AND txout.index = txin.tx_out_index" + , " LEFT JOIN tx tx1 ON txin.tx_in_id = tx1.id" + , " LEFT JOIN block blk ON tx1.block_id = blk.id" + , " LEFT JOIN tx tx2 ON txout.tx_id = tx2.id" + , addressBalanceWhereClause + , " AND txout.address = $2" + ] + + encoder = + contramap fst (Id.idEncoder Id.getBlockId) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable HsqlE.text) + + decoder = + HsqlD.singleRow $ + fromMaybe (Ada 0) <$> HsqlD.column (HsqlD.nullable (Ada . fromIntegral <$> HsqlD.int8)) + +-- Query to get address balance for Variant variant +queryAddressBalanceAtBlockIdVariantStmt :: HsqlStmt.Statement (Id.BlockId, Text) Ada +queryAddressBalanceAtBlockIdVariantStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(SUM(txout.value), 0)::bigint" + , " FROM tx_out txout" + , " LEFT JOIN tx_in txin ON txout.tx_id = txin.tx_out_id AND txout.index = txin.tx_out_index" + , " LEFT JOIN tx tx1 ON txin.tx_in_id = tx1.id" + , " LEFT JOIN block blk ON tx1.block_id = blk.id" + , " LEFT JOIN tx tx2 ON txout.tx_id = tx2.id" + , " INNER JOIN address addr ON txout.address_id = addr.id" + , addressBalanceWhereClause + , " AND addr.address = $2" + ] + + encoder = + contramap fst (Id.idEncoder Id.getBlockId) + <> contramap snd (HsqlE.param $ HsqlE.nonNullable HsqlE.text) + + decoder = + HsqlD.singleRow $ + fromMaybe (Ada 0) <$> HsqlD.column (HsqlD.nullable (Ada . fromIntegral <$> HsqlD.int8)) + +-- Main query function +queryAddressBalanceAtSlot :: MonadIO m => TxOutVariantType -> Text -> Word64 -> DbAction m Ada +queryAddressBalanceAtSlot txOutVariantType addr slotNo = do + let callInfo = mkCallInfo "queryAddressBalanceAtSlot" + + -- First get the block ID for the slot + mBlockId <- + runDbSession callInfo $ + HsqlSes.statement slotNo queryBlockIdAtSlotStmt + + -- If no block at that slot, return 0 + case mBlockId of + Nothing -> pure $ Ada 0 + Just blockId -> + case txOutVariantType of + TxOutVariantCore -> + runDbSession (mkCallInfo "queryAddressBalanceAtBlockIdCore") $ + HsqlSes.statement (blockId, addr) queryAddressBalanceAtBlockIdCoreStmt + TxOutVariantAddress -> + runDbSession (mkCallInfo "queryAddressBalanceAtBlockIdVariant") $ + HsqlSes.statement (blockId, addr) queryAddressBalanceAtBlockIdVariantStmt + +-------------------------------------------------------------------------------- +queryAddressOutputsCoreStmt :: HsqlStmt.Statement Text DbLovelace +queryAddressOutputsCoreStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(SUM(value), 0)::bigint" + , " FROM tx_out" + , " WHERE address = $1" + ] + encoder = HsqlE.param $ HsqlE.nonNullable HsqlE.text + decoder = HsqlD.singleRow dbLovelaceDecoder + +queryAddressOutputsVariantStmt :: HsqlStmt.Statement Text DbLovelace +queryAddressOutputsVariantStmt = + HsqlStmt.Statement sql encoder decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT COALESCE(SUM(tx_out.value), 0)::bigint" + , " FROM address" + , " JOIN tx_out ON tx_out.address_id = address.id" + , " WHERE address.address = $1" + ] + encoder = HsqlE.param $ HsqlE.nonNullable HsqlE.text + decoder = HsqlD.singleRow dbLovelaceDecoder + +queryAddressOutputs :: MonadIO m => TxOutVariantType -> Text -> DbAction m DbLovelace +queryAddressOutputs txOutVariantType addr = + case txOutVariantType of + TxOutVariantCore -> + runDbSession (mkCallInfo "queryAddressOutputsCore") $ + HsqlSes.statement addr queryAddressOutputsCoreStmt + TxOutVariantAddress -> + runDbSession (mkCallInfo "queryAddressOutputsVariant") $ + HsqlSes.statement addr queryAddressOutputsVariantStmt + +-------------------------------------------------------------------------------- +queryScriptOutputsCoreStmt :: HsqlStmt.Statement () [SVC.TxOutCore] +queryScriptOutputsCoreStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT *" + , " FROM tx_out" + , " WHERE address_has_script = TRUE" + ] + decoder = HsqlD.rowList SVC.txOutCoreDecoder + +queryScriptOutputsVariantStmt :: HsqlStmt.Statement () [(SVA.TxOutAddress, SVA.Address)] +queryScriptOutputsVariantStmt = + HsqlStmt.Statement sql HsqlE.noParams decoder True + where + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "SELECT tx_out.*, address.*" + , " FROM address" + , " JOIN tx_out ON tx_out.address_id = address.id" + , " WHERE address.address_has_script = TRUE" + ] + decoder = HsqlD.rowList $ (,) <$> SVA.txOutAddressDecoder <*> SVA.addressDecoder + +queryScriptOutputs :: MonadIO m => TxOutVariantType -> DbAction m [TxOutW] +queryScriptOutputs txOutVariantType = + case txOutVariantType of + TxOutVariantCore -> do + txOuts <- + runDbSession (mkCallInfo "queryScriptOutputsCore") $ + HsqlSes.statement () queryScriptOutputsCoreStmt + pure $ map VCTxOutW txOuts + TxOutVariantAddress -> do + results <- + runDbSession (mkCallInfo "queryScriptOutputsVariant") $ + HsqlSes.statement () queryScriptOutputsVariantStmt + pure $ map (\(txOut, addr) -> VATxOutW txOut (Just addr)) results + +-------------------------------------------------------------------------------- +-- UPDATES +-------------------------------------------------------------------------------- + +-- Batch update statement +setNullTxOutConsumedBatchStmt :: + forall a. + (DbInfo a) => + HsqlStmt.Statement Id.TxId Int64 +setNullTxOutConsumedBatchStmt = + HsqlStmt.Statement sql encoder decoder True + where + tableN = tableName (Proxy @a) + sql = + TextEnc.encodeUtf8 $ + Text.concat + [ "WITH updated AS (" + , " UPDATE " <> tableN + , " SET consumed_by_tx_id = NULL" + , " WHERE consumed_by_tx_id >= $1" + , " RETURNING 1" + , ")" + , "SELECT COUNT(*)::bigint FROM updated" + ] + encoder = Id.idEncoder Id.getTxId + decoder = HsqlD.singleRow (HsqlD.column (HsqlD.nonNullable HsqlD.int8)) + +-- Main function to set NULL for tx_out consumed_by_tx_id +querySetNullTxOut :: + MonadIO m => + TxOutVariantType -> + Maybe Id.TxId -> + DbAction m (Text.Text, Int64) +querySetNullTxOut txOutVariantType mMinTxId = do + case mMinTxId of + Nothing -> pure ("No tx_out to set to null (no TxId provided)", 0) + Just txId -> do + let callInfo = mkCallInfo "querySetNullTxOut" + -- Decide which table to use based on the TxOutVariantType + updatedCount <- case txOutVariantType of + TxOutVariantCore -> + runDbSession callInfo $ + HsqlSes.statement txId (setNullTxOutConsumedBatchStmt @SVC.TxOutCore) + TxOutVariantAddress -> + runDbSession callInfo $ + HsqlSes.statement txId (setNullTxOutConsumedBatchStmt @SVA.TxOutAddress) + -- Return result + if updatedCount == 0 + then pure ("No tx_out to set to null (no matching records found)", 0) + else pure ("tx_out.consumed_by_tx_id", updatedCount) diff --git a/cardano-db/src/Cardano/Db/Types.hs b/cardano-db/src/Cardano/Db/Types.hs index 8dd52f1d5..ca9219751 100644 --- a/cardano-db/src/Cardano/Db/Types.hs +++ b/cardano-db/src/Cardano/Db/Types.hs @@ -1,87 +1,167 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Db.Types ( - Ada (..), - AnchorType (..), - AssetFingerprint (..), - DbLovelace (..), - DbInt65 (..), - DbWord64 (..), - RewardSource (..), - SyncState (..), - ScriptPurpose (..), - ScriptType (..), - PoolCertAction (..), - PruneConsumeMigration (..), - CertNo (..), - PoolCert (..), - ExtraMigration (..), - MigrationValues (..), - VoteUrl (..), - VoteMetaHash (..), - Vote (..), - VoterRole (..), - GovActionType (..), - BootstrapState (..), - processMigrationValues, - isStakeDistrComplete, - bootstrapState, - extraDescription, - deltaCoinToDbInt65, - integerToDbInt65, - lovelaceToAda, - mkAssetFingerprint, - renderAda, - scientificToAda, - readDbInt65, - showDbInt65, - readRewardSource, - readScriptPurpose, - readScriptType, - readSyncState, - renderScriptPurpose, - renderScriptType, - renderSyncState, - showRewardSource, - renderVote, - readVote, - renderVoterRole, - readVoterRole, - renderGovActionType, - readGovActionType, - renderAnchorType, - readAnchorType, - word64ToAda, - hardcodedAlwaysAbstain, - hardcodedAlwaysNoConfidence, -) where - +module Cardano.Db.Types where + +-- ( +-- DbAction (..), +-- DbCallInfo (..), +-- DbEnv (..), +-- Ada (..), +-- AnchorType (..), +-- AssetFingerprint (..), +-- DbLovelace (..), +-- DbInt65 (..), +-- DbWord64 (..), +-- RewardSource (..), +-- SyncState (..), +-- ScriptPurpose (..), +-- ScriptType (..), +-- PoolCertAction (..), +-- PruneConsumeMigration (..), +-- CertNo (..), +-- PoolCert (..), +-- ExtraMigration (..), +-- MigrationValues (..), +-- VoteUrl (..), +-- VoteMetaHash (..), +-- Vote (..), +-- VoterRole (..), +-- GovActionType (..), +-- BootstrapState (..), +-- dbInt65Decoder, +-- dbInt65Encoder, +-- fromDbInt65, +-- rewardSourceDecoder, +-- rewardSourceEncoder, +-- dbLovelaceDecoder, +-- dbLovelaceEncoder, +-- maybeDbLovelaceDecoder, +-- dbLovelaceValueEncoder, +-- maybeDbLovelaceEncoder, +-- dbWord64Decoder, +-- maybeDbWord64Decoder, +-- dbWord64Encoder, +-- maybeDbWord64Encoder, +-- processMigrationValues, +-- isStakeDistrComplete, +-- bootstrapState, +-- extraDescription, +-- deltaCoinToDbInt65, +-- integerToDbInt65, +-- lovelaceToAda, +-- mkAssetFingerprint, +-- renderAda, +-- scientificToAda, +-- 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, +-- + +import Cardano.BM.Trace (Trace) +import Cardano.Db.Error (CallSite (..), DbError (..)) import Cardano.Ledger.Coin (DeltaCoin (..)) +import Cardano.Prelude (Bifunctor (..), MonadIO (..), MonadError, MonadReader) import qualified Codec.Binary.Bech32 as Bech32 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 (..)) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT) + +---------------------------------------------------------------------------- +-- DbAction +---------------------------------------------------------------------------- +newtype DbAction m a = DbAction + {runDbAction :: ExceptT DbError (ReaderT DbEnv m) a} + deriving newtype + ( Functor + , Applicative + , Monad + , MonadError DbError + , MonadReader DbEnv + , MonadIO + ) + +---------------------------------------------------------------------------- +-- DbCallInfo +---------------------------------------------------------------------------- +data DbCallInfo = DbCallInfo + { dciName :: !Text + , dciCallSite :: !CallSite + } + +data DbEnv = DbEnv + { dbConnection :: !HsqlCon.Connection + , dbEnableLogging :: !Bool + , dbTracer :: !(Maybe (Trace IO Text)) + } +---------------------------------------------------------------------------- +-- Other types +---------------------------------------------------------------------------- +-- | Convert a `Scientific` to `Ada`. newtype Ada = Ada { unAda :: Micro } @@ -96,7 +176,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 @@ -123,22 +203,73 @@ mkAssetFingerprint policyBs assetNameBs = fromRight (error "mkAssetFingerprint: Bad human readable part") $ 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) +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 +280,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 +326,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 +354,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 +463,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 +533,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 +567,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 +631,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 +642,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 +669,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 +690,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 +699,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 +750,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 +771,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/Insert.hs b/cardano-db/test/Test/IO/Cardano/Db/Insert.hs index 233a4400c..407466b07 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Insert.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Insert.hs @@ -10,10 +10,10 @@ import Control.Monad (void) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Time.Clock -import Database.Persist.Sql (Entity, deleteWhere, selectList, (>=.)) import Test.IO.Cardano.Db.Util import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) +import Data.Maybe (fromJust) tests :: TestTree tests = @@ -31,12 +31,12 @@ insertZeroTest = deleteAllBlocks -- Delete the blocks if they exist. slid <- insertSlotLeader testSlotLeader - void $ deleteBlock TxOutCore (blockOne slid) - void $ deleteBlock TxOutCore (blockZero slid) + void $ deleteBlock TxOutVariantCore (blockOne slid) + void $ deleteBlock TxOutVariantCore (blockZero slid) -- Insert the same block twice. The first should be successful (resulting -- in a 'Right') and the second should return the same value in a 'Left'. - bid0 <- insertBlockChecked (blockZero slid) - bid1 <- insertBlockChecked (blockZero slid) + bid0 <- insertCheckUniqueBlock (blockZero slid) + bid1 <- insertCheckUniqueBlock (blockZero slid) assertBool (show bid0 ++ " /= " ++ show bid1) (bid0 == bid1) insertFirstTest :: IO () @@ -45,10 +45,10 @@ insertFirstTest = deleteAllBlocks -- Delete the block if it exists. slid <- insertSlotLeader testSlotLeader - void $ deleteBlock TxOutCore (blockOne slid) + void $ deleteBlock TxOutVariantCore (blockOne slid) -- Insert the same block twice. - bid0 <- insertBlockChecked (blockZero slid) - bid1 <- insertBlockChecked $ (\b -> b {blockPreviousId = Just bid0}) (blockOne slid) + bid0 <- insertCheckUniqueBlock (blockZero slid) + bid1 <- insertCheckUniqueBlock $ (\b -> b {blockPreviousId = Just bid0}) (blockOne slid) assertBool (show bid0 ++ " == " ++ show bid1) (bid0 /= bid1) insertTwice :: IO () @@ -56,13 +56,13 @@ insertTwice = runDbNoLoggingEnv $ do deleteAllBlocks slid <- insertSlotLeader testSlotLeader - bid <- insertBlockChecked (blockZero slid) + bid <- insertCheckUniqueBlock (blockZero slid) let adaPots = adaPotsZero bid _ <- insertAdaPots adaPots - Just pots0 <- queryAdaPots bid + pots0 <- fromJust <$> queryAdaPotsIdTest bid -- Insert with same Unique key, different first field _ <- insertAdaPots (adaPots {adaPotsSlotNo = 1 + adaPotsSlotNo adaPots}) - Just pots0' <- queryAdaPots bid + pots0' <- fromJust <$> queryAdaPotsIdTest bid assertBool (show (adaPotsSlotNo pots0) ++ " /= " ++ show (adaPotsSlotNo pots0')) (adaPotsSlotNo pots0 == adaPotsSlotNo pots0') @@ -73,32 +73,28 @@ insertForeignKeyMissing = do runDbNoLoggingEnv $ do deleteAllBlocks slid <- insertSlotLeader testSlotLeader - bid <- insertBlockChecked (blockZero slid) + bid <- insertCheckUniqueBlock (blockZero slid) txid <- insertTx (txZero bid) phid <- insertPoolHash poolHash0 pmrid <- insertPoolMetadataRef $ poolMetadataRef txid phid + let fe = offChainPoolFetchError phid pmrid time insertCheckOffChainPoolFetchError fe - count0 <- offChainPoolFetchErrorCount + count0 <- countOffChainPoolFetchError assertBool (show count0 ++ "/= 1") (count0 == 1) - -- Delete all OffChainFetchErrorTypeCount after pmrid - queryDelete OffChainPoolFetchErrorPmrId pmrid - deleteWhere [PoolMetadataRefId >=. pmrid] - count1 <- offChainPoolFetchErrorCount + -- Delete with extracted functions + deleteOffChainPoolFetchErrorByPmrId pmrid + deletePoolMetadataRefById pmrid + + count1 <- countOffChainPoolFetchError assertBool (show count1 ++ "/= 0") (count1 == 0) - -- The references check will fail below will fail, so the insertion - -- will not be attempted insertCheckOffChainPoolFetchError fe - count2 <- offChainPoolFetchErrorCount + count2 <- countOffChainPoolFetchError assertBool (show count2 ++ "/= 0") (count2 == 0) - where - offChainPoolFetchErrorCount = do - ls :: [Entity OffChainPoolFetchError] <- selectList [] [] - pure $ length ls blockZero :: SlotLeaderId -> Block blockZero slid = diff --git a/cardano-db/test/Test/IO/Cardano/Db/Migration.hs b/cardano-db/test/Test/IO/Cardano/Db/Migration.hs index 640b68a45..0e24a6854 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Migration.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Migration.hs @@ -12,7 +12,7 @@ import Cardano.Db ( MigrationValidateError (..), MigrationVersion (..), SchemaVersion (..), - TxOutTableType (..), + TxOutVariantType (..), getMigrationScripts, querySchemaVersion, readPGPassDefault, diff --git a/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs b/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs index b4133bd92..5850de7b0 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Rollback.hs @@ -2,26 +2,23 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 908 + {-# OPTIONS_GHC -Wno-x-partial #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} -#endif + module Test.IO.Cardano.Db.Rollback ( tests, ) where import Cardano.Db -import Cardano.Slotting.Slot (SlotNo (..)) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Reader (ReaderT) import Data.Word (Word64) -import Database.Persist.Sql (SqlBackend) import Test.IO.Cardano.Db.Util import Test.Tasty (TestTree, testGroup) +import Cardano.Slotting.Slot (SlotNo (..)) +import Data.Maybe (fromJust) tests :: TestTree tests = @@ -44,27 +41,27 @@ _rollbackTest = assertBool ("Block count before rollback is " ++ show beforeBlocks ++ " but should be 10.") $ beforeBlocks == 10 beforeTxCount <- queryTxCount assertBool ("Tx count before rollback is " ++ show beforeTxCount ++ " but should be 9.") $ beforeTxCount == 9 - beforeTxOutCount <- queryTxOutCount TxOutCore + beforeTxOutCount <- queryTxOutCount TxOutVariantCore assertBool ("TxOut count before rollback is " ++ show beforeTxOutCount ++ " but should be 2.") $ beforeTxOutCount == 2 beforeTxInCount <- queryTxInCount assertBool ("TxIn count before rollback is " ++ show beforeTxInCount ++ " but should be 1.") $ beforeTxInCount == 1 -- Rollback a set of blocks. latestSlotNo <- queryLatestSlotNo - Just pSlotNo <- queryWalkChain 5 latestSlotNo - void $ deleteBlocksSlotNoNoTrace TxOutCore (SlotNo pSlotNo) + pSlotNo <- fromJust <$> queryWalkChain 5 latestSlotNo + void $ deleteBlocksSlotNoNoTrace TxOutVariantCore (SlotNo pSlotNo) -- Assert the expected final state. afterBlocks <- queryBlockCount assertBool ("Block count after rollback is " ++ show afterBlocks ++ " but should be 10") $ afterBlocks == 4 afterTxCount <- queryTxCount assertBool ("Tx count after rollback is " ++ show afterTxCount ++ " but should be 10") $ afterTxCount == 1 - afterTxOutCount <- queryTxOutCount TxOutCore + afterTxOutCount <- queryTxOutCount TxOutVariantCore assertBool ("TxOut count after rollback is " ++ show afterTxOutCount ++ " but should be 1.") $ afterTxOutCount == 1 afterTxInCount <- queryTxInCount assertBool ("TxIn count after rollback is " ++ show afterTxInCount ++ " but should be 0.") $ afterTxInCount == 0 -- ----------------------------------------------------------------------------- -queryWalkChain :: (MonadBaseControl IO m, MonadIO m) => Int -> Word64 -> ReaderT SqlBackend m (Maybe Word64) +queryWalkChain :: MonadIO m => Int -> Word64 -> DbAction m (Maybe Word64) queryWalkChain count blkNo | count <= 0 = pure $ Just blkNo | otherwise = do @@ -73,23 +70,23 @@ queryWalkChain count blkNo Nothing -> pure Nothing Just pBlkNo -> queryWalkChain (count - 1) pBlkNo -createAndInsertBlocks :: (MonadBaseControl IO m, MonadIO m) => Word64 -> ReaderT SqlBackend m () +createAndInsertBlocks :: MonadIO m => Word64 -> DbAction m () createAndInsertBlocks blockCount = void $ loop (0, Nothing, Nothing) where loop :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (Word64, Maybe BlockId, Maybe TxId) -> - ReaderT SqlBackend m (Word64, Maybe BlockId, Maybe TxId) + DbAction m (Word64, Maybe BlockId, Maybe TxId) loop (indx, mPrevId, mOutId) = if indx < blockCount then loop =<< createAndInsert (indx, mPrevId, mOutId) else pure (0, Nothing, Nothing) createAndInsert :: - (MonadBaseControl IO m, MonadIO m) => + MonadIO m => (Word64, Maybe BlockId, Maybe TxId) -> - ReaderT SqlBackend m (Word64, Maybe BlockId, Maybe TxId) + DbAction m (Word64, Maybe BlockId, Maybe TxId) createAndInsert (indx, mPrevId, mTxOutId) = do slid <- insertSlotLeader testSlotLeader let newBlock = diff --git a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs index 0a7ac3dc4..2fda68490 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/TotalSupply.hs @@ -3,7 +3,6 @@ #if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} #endif @@ -11,13 +10,15 @@ module Test.IO.Cardano.Db.TotalSupply ( tests, ) where -import Cardano.Db -import qualified Cardano.Db.Schema.Core.TxOut as C import qualified Data.Text as Text import Test.IO.Cardano.Db.Util import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) +import Cardano.Db +import Cardano.Db.Schema.Variants.TxOutCore (TxOutCore(..)) + + tests :: TestTree tests = testGroup @@ -38,7 +39,7 @@ initialSupplyTest = mapM_ (insertTxOut . mkTxOutCore bid0) tx0Ids count <- queryBlockCount assertBool ("Block count should be 1, got " ++ show count) (count == 1) - supply0 <- queryTotalSupply TxOutCore + supply0 <- queryTotalSupply TxOutVariantCore assertBool "Total supply should not be > 0" (supply0 > Ada 0) -- Spend from the Utxo set. @@ -63,19 +64,19 @@ initialSupplyTest = let addr = mkAddressHash bid1 tx1Id _ <- insertTxOut $ - CTxOutW $ - C.TxOut - { C.txOutTxId = tx1Id - , C.txOutIndex = 0 - , C.txOutAddress = Text.pack addr - , C.txOutAddressHasScript = False - , C.txOutPaymentCred = Nothing - , C.txOutStakeAddressId = Nothing - , C.txOutValue = DbLovelace 500000000 - , C.txOutDataHash = Nothing - , C.txOutInlineDatumId = Nothing - , C.txOutReferenceScriptId = Nothing - , C.txOutConsumedByTxId = Nothing + VCTxOutW $ + TxOutCore + { txOutCoreTxId = tx1Id + , txOutCoreIndex = 0 + , txOutCoreAddress = Text.pack addr + , txOutCoreAddressHasScript = False + , txOutCorePaymentCred = Nothing + , txOutCoreStakeAddressId = Nothing + , txOutCoreValue = DbLovelace 500000000 + , txOutCoreDataHash = Nothing + , txOutCoreInlineDatumId = Nothing + , txOutCoreReferenceScriptId = Nothing + , txOutCoreConsumedByTxId = Nothing } - supply1 <- queryTotalSupply TxOutCore + supply1 <- queryTotalSupply TxOutVariantCore assertBool ("Total supply should be < " ++ show supply0) (supply1 < supply0) diff --git a/cardano-db/test/Test/IO/Cardano/Db/Util.hs b/cardano-db/test/Test/IO/Cardano/Db/Util.hs index 1bf6cece7..60802a8c4 100644 --- a/cardano-db/test/Test/IO/Cardano/Db/Util.hs +++ b/cardano-db/test/Test/IO/Cardano/Db/Util.hs @@ -14,36 +14,35 @@ module Test.IO.Cardano.Db.Util ( testSlotLeader, ) where -import Cardano.Db -import qualified Cardano.Db.Schema.Core.TxOut as C import Control.Monad (unless) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Reader (ReaderT) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.Text as Text import Data.Time.Calendar (Day (..)) import Data.Time.Clock (UTCTime (..)) import Data.Word (Word64) -import Database.Persist.Sql (SqlBackend) import Text.Printf (printf) +import Cardano.Db +import Cardano.Db.Schema.Variants.TxOutCore (TxOutCore(..)) + assertBool :: MonadIO m => String -> Bool -> m () assertBool msg bool = liftIO $ unless bool (error msg) -deleteAllBlocks :: MonadIO m => ReaderT SqlBackend m () +deleteAllBlocks :: MonadIO m => DbAction m () deleteAllBlocks = do mblkId <- queryMinBlock - whenJust mblkId $ uncurry (deleteBlocksForTests TxOutCore) + whenJust mblkId $ uncurry (deleteBlocksForTests TxOutVariantCore) dummyUTCTime :: UTCTime dummyUTCTime = UTCTime (ModifiedJulianDay 0) 0 mkAddressHash :: BlockId -> TxId -> String mkAddressHash blkId txId = - take 28 $ printf "tx out #%d, tx #%d" (unBlockId blkId) (unTxId txId) ++ replicate 28 ' ' + take 28 $ printf "tx out #%d, tx #%d" (getBlockId blkId) (getTxId txId) ++ replicate 28 ' ' mkBlock :: Word64 -> SlotLeaderId -> Block mkBlock blk slid = @@ -71,7 +70,7 @@ mkBlockHash blkId = mkTxHash :: BlockId -> Word64 -> ByteString mkTxHash blk tx = - BS.pack (take 32 $ printf "block #%d, tx #%d" (unBlockId blk) tx ++ replicate 32 ' ') + BS.pack (take 32 $ printf "block #%d, tx #%d" (getBlockId blk) tx ++ replicate 32 ' ') mkTxs :: BlockId -> Word -> [Tx] mkTxs blkId count = @@ -100,17 +99,17 @@ testSlotLeader = mkTxOutCore :: BlockId -> TxId -> TxOutW mkTxOutCore blkId txId = let addr = mkAddressHash blkId txId - in CTxOutW $ - C.TxOut - { C.txOutAddress = Text.pack addr - , C.txOutAddressHasScript = False - , C.txOutConsumedByTxId = Nothing - , C.txOutDataHash = Nothing - , C.txOutIndex = 0 - , C.txOutInlineDatumId = Nothing - , C.txOutPaymentCred = Nothing - , C.txOutReferenceScriptId = Nothing - , C.txOutStakeAddressId = Nothing - , C.txOutTxId = txId - , C.txOutValue = DbLovelace 1000000000 + in VCTxOutW $ + TxOutCore + { txOutCoreAddress = Text.pack addr + , txOutCoreAddressHasScript = False + , txOutCoreConsumedByTxId = Nothing + , txOutCoreDataHash = Nothing + , txOutCoreIndex = 0 + , txOutCoreInlineDatumId = Nothing + , txOutCorePaymentCred = Nothing + , txOutCoreReferenceScriptId = Nothing + , txOutCoreStakeAddressId = Nothing + , txOutCoreTxId = txId + , txOutCoreValue = DbLovelace 1000000000 } diff --git a/cardano-db/test/Test/Property/Cardano/Db/Migration.hs b/cardano-db/test/Test/Property/Cardano/Db/Migration.hs index e964584ab..096a4a03b 100644 --- a/cardano-db/test/Test/Property/Cardano/Db/Migration.hs +++ b/cardano-db/test/Test/Property/Cardano/Db/Migration.hs @@ -11,12 +11,14 @@ import qualified Hedgehog as H import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +-- Test migration version roundtrip through file format prop_roundtrip_MigrationVersion :: Property prop_roundtrip_MigrationVersion = H.property $ do mv <- H.forAll genMigrationVersion H.tripping mv renderMigrationVersionFile parseMigrationVersionFromFile +-- Test that rendered migration version has no spaces prop_roundtrip_renderMigrationVersion_no_spaces :: Property prop_roundtrip_renderMigrationVersion_no_spaces = H.property $ do diff --git a/cardano-db/test/Test/Property/Cardano/Db/Types.hs b/cardano-db/test/Test/Property/Cardano/Db/Types.hs index d0342100e..ba56d29b0 100644 --- a/cardano-db/test/Test/Property/Cardano/Db/Types.hs +++ b/cardano-db/test/Test/Property/Cardano/Db/Types.hs @@ -14,31 +14,27 @@ import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Hashes as Ledger import Cardano.Ledger.Mary.Value (AssetName (..), PolicyID (..)) import qualified Data.Aeson as Aeson -import Data.Bifunctor (first) import qualified Data.ByteString.Base16 as Base16 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Short as SBS import Data.Either (fromRight) import Data.Int (Int64) import Data.Maybe (fromMaybe) -import Data.Ratio ((%)) -import qualified Data.Text as Text import Data.WideWord.Word128 (Word128 (..)) import Data.Word (Word64) -import Database.Persist.Class (PersistField (..)) -import Database.Persist.Types (PersistValue (..)) import Hedgehog (Gen, Property, discover, (===)) import qualified Hedgehog as H import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Numeric.Natural (Natural) +-- Original JSON test prop_roundtrip_Ada_via_JSON :: Property prop_roundtrip_Ada_via_JSON = H.withTests 5000 . H.property $ do mv <- H.forAll genAda H.tripping mv Aeson.encode Aeson.eitherDecode +-- Original AssetFingerprint test prop_AssetFingerprint :: Property prop_AssetFingerprint = H.withTests 1 . H.property $ @@ -106,32 +102,105 @@ prop_AssetFingerprint = hexAssetName :: ByteString -> AssetName hexAssetName = AssetName . SBS.toShort . fromRight (error "hexAssetName") . Base16.decode -prop_roundtrip_DbInt65_PersistField :: Property -prop_roundtrip_DbInt65_PersistField = +-- Test DbInt65 roundtrip conversion +prop_roundtrip_DbInt65 :: Property +prop_roundtrip_DbInt65 = H.withTests 5000 . H.property $ do - (i65, pv) <- H.forAll genDbInt65PresistValue - fromPersistValue pv === Right i65 + -- Generate both positive and negative values + posInt64 <- H.forAll $ Gen.int64 (Range.linear 0 maxBound) + negInt64 <- H.forAll $ Gen.int64 (Range.linear minBound (-1)) -prop_roundtrip_DbLovelace_PersistField :: Property -prop_roundtrip_DbLovelace_PersistField = - H.withTests 5000 . H.property $ do - (w64, pv) <- H.forAll genDbLovelacePresistValue - fromPersistValue pv === Right w64 + let i65pos = toDbInt65 posInt64 + let i65neg = toDbInt65 negInt64 + + -- Test roundtrip conversion + runDbInt65Roundtrip i65pos === i65pos + runDbInt65Roundtrip i65neg === i65neg -prop_roundtrip_DbWord64_PersistField :: Property -prop_roundtrip_DbWord64_PersistField = +-- Test DbLovelace roundtrip conversion +prop_roundtrip_DbLovelace :: Property +prop_roundtrip_DbLovelace = H.withTests 5000 . H.property $ do - (w64, pv) <- H.forAll genDbWord64PresistValue - fromPersistValue pv === Right w64 + lovelace <- H.forAll $ DbLovelace <$> genWord64Range + + -- Test roundtrip conversion + runDbLovelaceRoundtrip lovelace === lovelace + + -- Test Maybe version + mLovelace <- H.forAll $ Gen.maybe (DbLovelace <$> genWord64Range) + runMaybeDbLovelaceRoundtrip mLovelace === mLovelace + where + genWord64Range = Gen.word64 (Range.linear 0 (fromIntegral (maxBound :: Int64))) -prop_roundtrip_Word128_PersistField :: Property -prop_roundtrip_Word128_PersistField = +-- Test DbWord64 roundtrip conversion +prop_roundtrip_DbWord64 :: Property +prop_roundtrip_DbWord64 = H.withTests 5000 . H.property $ do - w128 <- H.forAll genWord128 - H.tripping w128 toPersistValue fromPersistValue + word64 <- H.forAll $ DbWord64 <$> genWord64Range --- ----------------------------------------------------------------------------- + -- Test roundtrip conversion + runDbWord64Roundtrip word64 === word64 + + -- Test Maybe version + mWord64 <- H.forAll $ Gen.maybe (DbWord64 <$> genWord64Range) + runMaybeDbWord64Roundtrip mWord64 === mWord64 + where + genWord64Range = Gen.word64 (Range.linear 0 (fromIntegral (maxBound :: Int64))) + +-- Test Word128 roundtrip through components +prop_roundtrip_Word128 :: Property +prop_roundtrip_Word128 = + H.withTests 5000 . H.property $ do + w128 <- H.forAll genWord128Limited + runWord128Roundtrip w128 === w128 + where + genWord128Limited = do + hi <- Gen.word64 (Range.linear 0 (fromIntegral (maxBound :: Int64))) + lo <- Gen.word64 (Range.linear 0 (fromIntegral (maxBound :: Int64))) + pure $ Word128 hi lo + +-- DbInt65 specific roundtrip test function +runDbInt65Roundtrip :: DbInt65 -> DbInt65 +runDbInt65Roundtrip value = + -- Directly use the conversion functions that are at the core of your encoders/decoders + toDbInt65 (fromDbInt65 value) + +-- DbLovelace specific roundtrip test function +runDbLovelaceRoundtrip :: DbLovelace -> DbLovelace +runDbLovelaceRoundtrip (DbLovelace w) = + -- Simulate conversion to Int64 (PostgreSQL) and back + DbLovelace (fromIntegral (fromIntegral w :: Int64)) + +-- Maybe DbLovelace specific roundtrip test function +runMaybeDbLovelaceRoundtrip :: Maybe DbLovelace -> Maybe DbLovelace +runMaybeDbLovelaceRoundtrip Nothing = Nothing +runMaybeDbLovelaceRoundtrip (Just value) = Just (runDbLovelaceRoundtrip value) + +-- DbWord64 specific roundtrip test function +runDbWord64Roundtrip :: DbWord64 -> DbWord64 +runDbWord64Roundtrip (DbWord64 w) = + -- Simulate conversion to Int64 (PostgreSQL) and back + DbWord64 (fromIntegral (fromIntegral w :: Int64)) + +-- Maybe DbWord64 specific roundtrip test function +runMaybeDbWord64Roundtrip :: Maybe DbWord64 -> Maybe DbWord64 +runMaybeDbWord64Roundtrip Nothing = Nothing +runMaybeDbWord64Roundtrip (Just value) = Just (runDbWord64Roundtrip value) + +-- Word128 specific roundtrip test function +runWord128Roundtrip :: Word128 -> Word128 +runWord128Roundtrip (Word128 hi lo) = + -- Extract components and convert to Int64 (simulating DB storage) + let hiInt64 = fromIntegral hi :: Int64 + loInt64 = fromIntegral lo :: Int64 + + -- Convert back to Word64 and reconstruct (simulating DB retrieval) + hiBack = fromIntegral hiInt64 :: Word64 + loBack = fromIntegral loInt64 :: Word64 + in Word128 hiBack loBack + +-- Generators from original code genAda :: Gen Ada genAda = word64ToAda <$> genWord64Ada @@ -144,44 +213,6 @@ genAda = , Gen.word64 (Range.linear (maxLovelaceVal - 5000) maxLovelaceVal) -- Near max. ] -genDbWord64 :: Gen DbWord64 -genDbWord64 = DbWord64 <$> genWord64 - -genDbInt65PresistValue :: Gen (DbInt65, PersistValue) -genDbInt65PresistValue = do - (w64, pv) <- genWord64PresistValue - Gen.element - [ (PosInt65 w64, pv) - , if w64 == 0 - then (PosInt65 0, pv) - else (NegInt65 w64, negatePresistValue pv) - ] - where - negatePresistValue :: PersistValue -> PersistValue - negatePresistValue pv = - case pv of - PersistText txt -> PersistText ("-" <> txt) - PersistInt64 i64 -> PersistInt64 (negate i64) - PersistRational r -> PersistRational (negate r) - _other -> pv - -genDbLovelacePresistValue :: Gen (DbLovelace, PersistValue) -genDbLovelacePresistValue = first DbLovelace <$> genWord64PresistValue - -genDbWord64PresistValue :: Gen (DbWord64, PersistValue) -genDbWord64PresistValue = first DbWord64 <$> genWord64PresistValue - -genNatural :: Gen Natural -genNatural = fromIntegral <$> Gen.word (Range.linear 0 5000) - -genWord64PresistValue :: Gen (Word64, PersistValue) -genWord64PresistValue = - Gen.choice - [ (\w64 -> (w64, PersistText (Text.pack $ show w64))) <$> genWord64 - , (\i64 -> (fromIntegral i64, PersistInt64 i64)) . fromIntegral <$> Gen.int64 (Range.linear 0 (maxBound :: Int64)) - , (\w64 -> (w64, PersistRational (fromIntegral w64 % 1))) <$> genWord64 - ] - genWord128 :: Gen Word128 genWord128 = Word128 <$> genWord64 <*> genWord64 diff --git a/cardano-db/test/cardano-db-test.cabal b/cardano-db/test/cardano-db-test.cabal index cbff16efa..92ba7f89f 100644 --- a/cardano-db/test/cardano-db-test.cabal +++ b/cardano-db/test/cardano-db-test.cabal @@ -31,26 +31,17 @@ library build-depends: base >= 4.14 && < 5 , aeson - , bytestring - , cardano-db - , cardano-ledger-byron - , extra - , hedgehog - , persistent - , text - , time - , transformers - , wide-word - , base16-bytestring , bytestring - , aeson , cardano-crypto-class , cardano-db , cardano-ledger-byron , cardano-ledger-core , cardano-ledger-mary - , persistent + , cardano-slotting + , extra , hedgehog , text + , time + , transformers , wide-word diff --git a/cardano-smash-server/cardano-smash-server.cabal b/cardano-smash-server/cardano-smash-server.cabal index 338617fc1..f459ca5e6 100644 --- a/cardano-smash-server/cardano-smash-server.cabal +++ b/cardano-smash-server/cardano-smash-server.cabal @@ -65,10 +65,10 @@ library , cardano-db , cardano-prelude , containers + , hasql , http-conduit , iohk-monitoring , network-uri - , persistent-postgresql , quiet , resource-pool , servant-server diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs b/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs index 71eee155d..7dbbdd7fb 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs @@ -6,7 +6,7 @@ module Cardano.SMASH.Server.PoolDataLayer ( postgresqlPoolDataLayer, filterRegistered, createCachedPoolDataLayer, - dbToServantPoolId, + toDbPoolId, ) where import Cardano.BM.Trace (Trace) @@ -15,13 +15,13 @@ import Cardano.Prelude import Cardano.SMASH.Server.Types import qualified Data.ByteString.Base16 as Base16 import qualified Data.Map.Strict as Map -import qualified Data.Pool as DB +import Data.Pool (Pool) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Database.Persist.Postgresql import GHC.Err (error) +import qualified Hasql.Connection as HsqlCon {- HLINT ignore "Reduce duplication" -} @@ -43,12 +43,12 @@ data PoolDataLayer = PoolDataLayer } deriving (Generic) -postgresqlPoolDataLayer :: Trace IO Text -> DB.Pool SqlBackend -> PoolDataLayer +postgresqlPoolDataLayer :: Trace IO Text -> Pool HsqlCon.Connection -> PoolDataLayer postgresqlPoolDataLayer tracer conn = PoolDataLayer { dlGetPoolMetadata = \poolId poolMetadataHash -> do - let poolHash = servantToDbPoolId poolId - let metaHash = servantToDbPoolMetaHash poolMetadataHash + let poolHash = fromDbPoolId poolId + let metaHash = fromDbPoolMetaHash poolMetadataHash mMeta <- Db.runPoolDbIohkLogging conn tracer $ Db.queryOffChainPoolData poolHash metaHash case mMeta of Just (tickerName, metadata) -> pure $ Right (TickerName tickerName, PoolMetadataRaw metadata) @@ -56,25 +56,25 @@ postgresqlPoolDataLayer tracer conn = , dlAddPoolMetadata = error "dlAddPoolMetadata not defined. Will be used only for testing." , dlGetReservedTickers = do tickers <- Db.runPoolDbIohkLogging conn tracer Db.queryReservedTickers - pure $ fmap (\ticker -> (TickerName $ Db.reservedPoolTickerName ticker, dbToServantPoolId $ Db.reservedPoolTickerPoolHash ticker)) tickers + pure $ fmap (\ticker -> (TickerName $ Db.reservedPoolTickerName ticker, toDbPoolId $ Db.reservedPoolTickerPoolHash ticker)) tickers , dlAddReservedTicker = \ticker poolId -> do inserted <- Db.runPoolDbIohkLogging conn tracer $ Db.insertReservedPoolTicker $ - Db.ReservedPoolTicker (getTickerName ticker) (servantToDbPoolId poolId) + Db.ReservedPoolTicker (getTickerName ticker) (fromDbPoolId poolId) case inserted of Just _ -> pure $ Right ticker Nothing -> pure $ Left $ TickerAlreadyReserved ticker , dlCheckReservedTicker = \ticker -> do Db.runPoolDbIohkLogging conn tracer $ - fmap dbToServantPoolId <$> Db.queryReservedTicker (getTickerName ticker) + fmap toDbPoolId <$> Db.queryReservedTicker (getTickerName ticker) , dlGetDelistedPools = do - fmap dbToServantPoolId <$> Db.runPoolDbIohkLogging conn tracer Db.queryDelistedPools + fmap toDbPoolId <$> Db.runPoolDbIohkLogging conn tracer Db.queryDelistedPools , dlCheckDelistedPool = \poolHash -> do - Db.runPoolDbIohkLogging conn tracer $ Db.existsDelistedPool (servantToDbPoolId poolHash) + Db.runPoolDbIohkLogging conn tracer $ Db.existsDelistedPool (fromDbPoolId poolHash) , dlAddDelistedPool = \poolHash -> do Db.runPoolDbIohkLogging conn tracer $ do - let poolHashDb = servantToDbPoolId poolHash + let poolHashDb = fromDbPoolId poolHash isAlready <- Db.existsDelistedPool poolHashDb if isAlready then return . Left . DbInsertError $ "Delisted pool already exists!" @@ -84,21 +84,21 @@ postgresqlPoolDataLayer tracer conn = , dlRemoveDelistedPool = \poolHash -> do deleted <- Db.runPoolDbIohkLogging conn tracer $ - Db.deleteDelistedPool (servantToDbPoolId poolHash) + Db.deleteDelistedPool (fromDbPoolId poolHash) if deleted then pure $ Right poolHash else pure $ Left RecordDoesNotExist , dlAddRetiredPool = \_ _ -> throwIO $ PoolDataLayerError "dlAddRetiredPool not defined. Will be used only for testing" , dlCheckRetiredPool = \poolId -> do actions <- getCertActions tracer conn (Just poolId) - pure $ not <$> isRegistered (servantToDbPoolId poolId) actions + pure $ not <$> isRegistered (fromDbPoolId poolId) actions , dlGetRetiredPools = do ls <- filterRetired <$> getCertActions tracer conn Nothing - pure $ Right $ dbToServantPoolId <$> ls + pure $ Right $ toDbPoolId <$> ls , dlGetFetchErrors = \poolId mTimeFrom -> do fetchErrors <- Db.runPoolDbIohkLogging conn tracer $ - Db.queryOffChainPoolFetchError (servantToDbPoolId poolId) mTimeFrom + Db.queryOffChainPoolFetchError (fromDbPoolId poolId) mTimeFrom pure $ Right $ dbToServantFetchError poolId <$> fetchErrors , dlGetPool = \poolId -> do isActive <- isPoolActive tracer conn poolId @@ -112,37 +112,37 @@ dbToServantFetchError poolId (fetchError, metaHash) = PoolFetchError (utcTimeToPOSIXSeconds $ Db.offChainPoolFetchErrorFetchTime fetchError) poolId - (dbToServantMetaHash metaHash) + (toDbServantMetaHash metaHash) (Db.offChainPoolFetchErrorFetchError fetchError) (Db.offChainPoolFetchErrorRetryCount fetchError) -- For each pool return the latest certificate action. Also return the -- current epoch. -getCertActions :: Trace IO Text -> DB.Pool SqlBackend -> Maybe PoolId -> IO (Maybe Word64, Map ByteString Db.PoolCertAction) +getCertActions :: Trace IO Text -> Pool HsqlCon.Connection -> Maybe PoolId -> IO (Maybe Word64, Map ByteString Db.PoolCertAction) getCertActions tracer conn mPoolId = do (certs, epoch) <- Db.runPoolDbIohkLogging conn tracer $ do - poolRetired <- Db.queryRetiredPools (servantToDbPoolId <$> mPoolId) - poolUpdate <- Db.queryPoolRegister (servantToDbPoolId <$> mPoolId) - currentEpoch <- Db.queryCurrentEpochNo + poolRetired <- Db.queryRetiredPools (fromDbPoolId <$> mPoolId) + poolUpdate <- Db.queryPoolRegister (fromDbPoolId <$> mPoolId) + currentEpoch <- Db.queryBlocksForCurrentEpochNo pure (poolRetired ++ poolUpdate, currentEpoch) let poolActions = findLatestPoolAction certs pure (epoch, poolActions) -getActivePools :: Trace IO Text -> DB.Pool SqlBackend -> Maybe PoolId -> IO (Map ByteString ByteString) +getActivePools :: Trace IO Text -> Pool HsqlCon.Connection -> Maybe PoolId -> IO (Map ByteString ByteString) getActivePools tracer conn mPoolId = do (certs, epoch) <- Db.runPoolDbIohkLogging conn tracer $ do - poolRetired <- Db.queryRetiredPools (servantToDbPoolId <$> mPoolId) - poolUpdate <- Db.queryPoolRegister (servantToDbPoolId <$> mPoolId) - currentEpoch <- Db.queryCurrentEpochNo + poolRetired <- Db.queryRetiredPools (fromDbPoolId <$> mPoolId) + poolUpdate <- Db.queryPoolRegister (fromDbPoolId <$> mPoolId) + currentEpoch <- Db.queryBlocksForCurrentEpochNo pure (poolRetired ++ poolUpdate, currentEpoch) pure $ groupByPoolMeta epoch certs -isPoolActive :: Trace IO Text -> DB.Pool SqlBackend -> PoolId -> IO Bool +isPoolActive :: Trace IO Text -> Pool HsqlCon.Connection -> PoolId -> IO Bool isPoolActive tracer conn poolId = do isJust <$> getActiveMetaHash tracer conn poolId -- If the pool is not retired, it will return the pool Hash and the latest metadata hash. -getActiveMetaHash :: Trace IO Text -> DB.Pool SqlBackend -> PoolId -> IO (Maybe (ByteString, ByteString)) +getActiveMetaHash :: Trace IO Text -> Pool HsqlCon.Connection -> PoolId -> IO (Maybe (ByteString, ByteString)) getActiveMetaHash tracer conn poolId = do mp <- getActivePools tracer conn (Just poolId) case Map.toList mp of @@ -171,41 +171,41 @@ isRegistered pid (mEpochNo, certs) = case Map.lookup pid certs of Just (Db.Retirement retEpochNo) -> Right $ Just retEpochNo > mEpochNo Just (Db.Register _) -> Right True -servantToDbPoolId :: PoolId -> ByteString -servantToDbPoolId pid = +fromDbPoolId :: PoolId -> ByteString +fromDbPoolId pid = case Base16.decode $ Text.encodeUtf8 $ getPoolId pid of Left err -> panic $ Text.pack err Right bs -> bs -dbToServantPoolId :: ByteString -> PoolId -dbToServantPoolId bs = PoolId $ Text.decodeUtf8 $ Base16.encode bs +toDbPoolId :: ByteString -> PoolId +toDbPoolId bs = PoolId $ Text.decodeUtf8 $ Base16.encode bs -servantToDbPoolMetaHash :: PoolMetadataHash -> ByteString -servantToDbPoolMetaHash pmh = +fromDbPoolMetaHash :: PoolMetadataHash -> ByteString +fromDbPoolMetaHash pmh = case Base16.decode $ Text.encodeUtf8 $ getPoolMetadataHash pmh of Left err -> panic $ Text.pack err Right bs -> bs -dbToServantMetaHash :: ByteString -> PoolMetadataHash -dbToServantMetaHash bs = PoolMetadataHash $ Text.decodeUtf8 $ Base16.encode bs +toDbServantMetaHash :: ByteString -> PoolMetadataHash +toDbServantMetaHash bs = PoolMetadataHash $ Text.decodeUtf8 $ Base16.encode bs createCachedPoolDataLayer :: Maybe () -> IO PoolDataLayer createCachedPoolDataLayer _ = panic "createCachedPoolDataLayer not defined yet" -_getUsedTickers :: Trace IO Text -> DB.Pool SqlBackend -> IO [(TickerName, PoolMetadataHash)] +_getUsedTickers :: Trace IO Text -> Pool HsqlCon.Connection -> IO [(TickerName, PoolMetadataHash)] _getUsedTickers tracer conn = do pools <- getActivePools tracer conn Nothing tickers <- Db.runPoolDbIohkLogging conn tracer $ forM (Map.toList pools) $ \(ph, meta) -> do mticker <- Db.queryUsedTicker ph meta - pure $ map (\ticker -> (TickerName ticker, dbToServantMetaHash meta)) mticker + pure $ map (\ticker -> (TickerName ticker, toDbServantMetaHash meta)) mticker pure $ catMaybes tickers -_checkUsedTicker :: Trace IO Text -> DB.Pool SqlBackend -> TickerName -> IO (Maybe TickerName) +_checkUsedTicker :: Trace IO Text -> Pool HsqlCon.Connection -> TickerName -> IO (Maybe TickerName) _checkUsedTicker tracer conn ticker = do pools <- getActivePools tracer conn Nothing tickers <- Db.runPoolDbIohkLogging conn tracer $ forM (Map.toList pools) $ \(ph, meta) -> do mticker <- Db.queryUsedTicker ph meta - pure $ map (\tickerText -> (TickerName tickerText, dbToServantMetaHash meta)) mticker + pure $ map (\tickerText -> (TickerName tickerText, toDbServantMetaHash meta)) mticker case Map.lookup ticker (Map.fromList $ catMaybes tickers) of Nothing -> pure Nothing Just _metaHash -> pure $ Just ticker diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs index 7d5e1c99f..5a4e5c405 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs @@ -8,20 +8,13 @@ module Cardano.SMASH.Server.Run ( ) where import Cardano.BM.Trace (Trace, logInfo) -import Cardano.Db ( - PGPassSource (PGPassDefaultEnv), - readPGPass, - runOrThrowIODb, - toConnectionString, - ) -import qualified Cardano.Db as Db +import qualified Cardano.Db as DB import Cardano.Prelude import Cardano.SMASH.Server.Api import Cardano.SMASH.Server.Config import Cardano.SMASH.Server.Impl import Cardano.SMASH.Server.PoolDataLayer import Cardano.SMASH.Server.Types -import Database.Persist.Postgresql (withPostgresqlPool) import Network.Wai.Handler.Warp (defaultSettings, runSettings, setBeforeMainLoop, setPort) import Servant ( Application, @@ -31,6 +24,7 @@ import Servant ( Context (..), serveWithContext, ) +import Prelude (userError) runSmashServer :: SmashServerConfig -> IO () runSmashServer config = do @@ -41,11 +35,17 @@ runSmashServer config = do (logInfo trce $ "SMASH listening on port " <> textShow (sscSmashPort config)) defaultSettings - pgconfig <- runOrThrowIODb (readPGPass PGPassDefaultEnv) - Db.runIohkLogging trce $ withPostgresqlPool (toConnectionString pgconfig) (sscSmashPort config) $ \pool -> do - let poolDataLayer = postgresqlPoolDataLayer trce pool - app <- liftIO $ mkApp (sscTrace config) poolDataLayer (sscAdmins config) - liftIO $ runSettings settings app + pgconfig <- DB.runOrThrowIODb (DB.readPGPass DB.PGPassDefaultEnv) + connSetting <- case DB.toConnectionSetting pgconfig of + Left err -> throwIO $ userError err + Right setting -> pure setting + + -- Create the Hasql connection pool + pool <- DB.createHasqlConnectionPool [connSetting] (sscSmashPort config) + -- Setup app with the pool + app <- mkApp (sscTrace config) (postgresqlPoolDataLayer trce pool) (sscAdmins config) + -- Run the web server + runSettings settings app mkApp :: Trace IO Text -> PoolDataLayer -> ApplicationUsers -> IO Application mkApp trce dataLayer appUsers = do diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs index 23cae379b..408ecd898 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs @@ -32,7 +32,7 @@ import Cardano.Api ( serialiseToRawBytes, ) import Cardano.Api.Shelley (StakePoolKey) -import Cardano.Db (LookupFail (..), PoolMetaHash (..)) +import Cardano.Db (DbError, PoolMetaHash (..)) import Cardano.Prelude import Control.Monad.Fail (fail) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) @@ -369,7 +369,7 @@ data DBFail | DbLookupPoolMetadataHash !PoolId !PoolMetadataHash | TickerAlreadyReserved !TickerName | RecordDoesNotExist - | DBFail LookupFail + | DBFail !DbError | PoolDataLayerError !Text | ConfigError !Text deriving (Eq) 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": {