Regroup and clean tx_out queries

IntersectMBO · Nov 4, 2024 · 8b940c5 · 8b940c5
1 parent 91aa6d9
commit 8b940c5
Show file tree

Hide file tree

Showing 2 changed files with 120 additions and 132 deletions.
diff --git a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs
@@ -198,6 +198,126 @@ queryTxOutCredentialsVariant (hash, index) = do
     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
 --------------------------------------------------------------------------------
@@ -387,17 +507,6 @@ queryScriptOutputsVariant = do
     combineToWrapper txOut address =
       VTxOutW (entityVal txOut) (Just (entityVal address))
 
---------------------------------------------------------------------------------
--- 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
-
 --------------------------------------------------------------------------------
 -- queryAddressOutputs
 --------------------------------------------------------------------------------
@@ -420,94 +529,6 @@ queryAddressOutputs txOutTableType addr = do
       Just (Just x) -> x
       _otherwise -> DbLovelace 0
 
---------------------------------------------------------------------------------
--- 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)
-
---------------------------------------------------------------------------------
--- 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)
-
 --------------------------------------------------------------------------------
 -- Helper Functions
 --------------------------------------------------------------------------------
@@ -549,20 +570,3 @@ queryTxOutUnspentCount txOutTableType =
         txOutUnspentP @a txOut
         pure countRows
       pure $ maybe 0 unValue (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
-        )
diff --git a/cardano-db/src/Cardano/Db/Operations/Types.hs b/cardano-db/src/Cardano/Db/Operations/Types.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
@@ -30,16 +29,6 @@ data TxOutW
   = CTxOutW !C.TxOut
   | VTxOutW !V.TxOut !(Maybe V.Address)
 
--- Pattern synonyms for easier construction
-pattern CoreTxOut :: C.TxOut -> TxOutW
-pattern CoreTxOut txOut = CTxOutW txOut
-
-pattern VariantTxOutWithAddr :: V.TxOut -> V.Address -> TxOutW
-pattern VariantTxOutWithAddr txOut address = VTxOutW txOut (Just address)
-
-pattern VariantTxOutNoAddr :: V.TxOut -> Maybe V.Address -> TxOutW
-pattern VariantTxOutNoAddr txOut maybeAddress = VTxOutW txOut maybeAddress
-
 -- | A wrapper for TxOutId
 data TxOutIdW
   = CTxOutIdW !C.TxOutId
@@ -193,11 +182,6 @@ 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"
 
-extractVariantAddress :: TxOutW -> Maybe V.Address
-extractVariantAddress (VTxOutW _ address) = address
--- this will never error as we can only have either CoreTxOut or VariantTxOut
-extractVariantAddress (CTxOutW _) = error "Unexpected CTxOut in VariantTxOut list"
-
 convertTxOutIdCore :: [TxOutIdW] -> [C.TxOutId]
 convertTxOutIdCore = mapMaybe unwrapCore
   where