adding more variants around MinId

Modified-by: Cmdv <vincent@cmdv.me>

cardano-db/cardano-db.cabal

@@ -44,13 +44,13 @@ library
                         Cardano.Db.Operations.Core.MinId
                         Cardano.Db.Operations.Core.Query
                         Cardano.Db.Operations.Core.QueryHelper
+                        Cardano.Db.Operations.Types
                         Cardano.Db.Operations.Variant.ConsumedTxOut
                         Cardano.Db.Operations.Variant.JsonbQuery
                         Cardano.Db.Operations.Variant.Multiplex
                         Cardano.Db.Operations.Variant.TxOutDelete
                         Cardano.Db.Operations.Variant.TxOutInsert
                         Cardano.Db.Operations.Variant.TxOutQuery
-                        Cardano.Db.Operations.Variant.Types
                         Cardano.Db.PGConfig
                         Cardano.Db.Run
                         Cardano.Db.Schema.Core.Schema

cardano-db/src/Cardano/Db.hs

@@ -5,7 +5,6 @@ module Cardano.Db (
   Block (..),
   Tx (..),
   TxIn (..),
-  TxOut (..),
   gitRev,
   migrateTxOut,
   queryTxConsumedColumnExists,
@@ -26,11 +25,9 @@ import Cardano.Db.Operations.Variant.ConsumedTxOut (migrateTxOut, queryTxConsume
 import Cardano.Db.Operations.Variant.JsonbQuery as X
 import Cardano.Db.Operations.Variant.Multiplex as X
 import Cardano.Db.Operations.Variant.TxOutQuery as X
-import Cardano.Db.Operations.Variant.Types 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.Core.Schema as X
-import Cardano.Db.Schema.Core.TxOut as X
 import Cardano.Db.Schema.Types as X
-import Cardano.Db.Schema.Variant.TxOut as X
 import Cardano.Db.Types as X

cardano-db/src/Cardano/Db/Migration.hs

@@ -28,8 +28,8 @@ 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.Operations.Core.Query
+import Cardano.Db.PGConfig
 import Cardano.Db.Run
 import Cardano.Db.Schema.Core.Schema
 import Cardano.Prelude (Typeable, textShow)

cardano-db/src/Cardano/Db/Operations/Core/Delete.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -23,9 +24,10 @@ module Cardano.Db.Operations.Core.Delete (
 ) where
 
 import Cardano.BM.Trace (Trace, logWarning, nullTracer)
-import Cardano.Db.Operations.Core.MinId
-import Cardano.Db.Operations.Core.Query hiding (isJust)
+import Cardano.Db.Operations.Core.MinId (MinIds (..), TypedMinIds (..), completeMinId, textToMinIds)
+import Cardano.Db.Operations.Core.Query
 import Cardano.Db.Schema.Core.Schema
+import Cardano.Db.Types (TxOutTableType (..))
 import Cardano.Prelude (Int64)
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.Monad (void)
@@ -50,54 +52,70 @@ import Database.Persist.Sql (
   (>=.),
  )
 
-deleteBlocksSlotNoNoTrace :: MonadIO m => SlotNo -> ReaderT SqlBackend m Bool
+deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool
 deleteBlocksSlotNoNoTrace = deleteBlocksSlotNo nullTracer
 
 -- | 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 -> SlotNo -> ReaderT SqlBackend m Bool
-deleteBlocksSlotNo trce (SlotNo slotNo) = do
+deleteBlocksSlotNo :: MonadIO m => Trace IO Text -> TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool
+deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) = do
   mBlockId <- queryBlockSlotNo slotNo
   case mBlockId of
     Nothing -> pure False
     Just blockId -> do
-      void $ deleteBlocksBlockId trce blockId
+      void $ deleteBlocksBlockId trce txOutTableType blockId
       pure True
 
-deleteBlocksBlockIdNotrace :: MonadIO m => BlockId -> ReaderT SqlBackend m ()
-deleteBlocksBlockIdNotrace = void . deleteBlocksBlockId nullTracer
+deleteBlocksBlockIdNotrace :: MonadIO m => TxOutTableType -> BlockId -> ReaderT SqlBackend m ()
+deleteBlocksBlockIdNotrace txOutTableType = void . deleteBlocksBlockId nullTracer txOutTableType
 
 -- | Delete starting from a 'BlockId'.
-deleteBlocksBlockId :: MonadIO m => Trace IO Text -> BlockId -> ReaderT SqlBackend m (Maybe TxId, Int64)
-deleteBlocksBlockId trce blockId = do
-  mMinIds <- fmap (textToMinId =<<) <$> queryReverseIndexBlockId blockId
-  (cminIds, completed) <- findMinIdsRec mMinIds mempty
+deleteBlocksBlockId ::
+  MonadIO m =>
+  Trace IO Text ->
+  TxOutTableType ->
+  BlockId ->
+  ReaderT SqlBackend m (Maybe TxId, Int64)
+deleteBlocksBlockId trce txOutTableType blockId = do
+  mMinIds <- fmap (textToMinIds =<<) <$> queryReverseIndexBlockId blockId
+  (cminIds, completed) <- findMinIdsRec mMinIds (emptyTypedMinIds txOutTableType)
   mTxId <- queryMinRefId TxBlockId blockId
-  minIds <- if completed then pure cminIds else completeMinId mTxId cminIds
+  minIds <- if completed then pure cminIds else completeTypedMinId mTxId cminIds
   blockCountInt <- deleteTablesAfterBlockId blockId mTxId minIds
   pure (mTxId, blockCountInt)
   where
-    findMinIdsRec :: MonadIO m => [Maybe MinIds] -> MinIds -> ReaderT SqlBackend m (MinIds, Bool)
+    findMinIdsRec :: MonadIO m => [Maybe TypedMinIds] -> TypedMinIds -> ReaderT SqlBackend m (TypedMinIds, 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."
+          liftIO $ logWarning trce "Failed to find ReverseIndex. Deletion may take longer."
           pure (minIds, False)
         Just minIdDB -> do
-          let minIds' = minIds <> minIdDB
-          if isComplete minIds'
+          let minIds' = combineTypedMinIds minIds minIdDB
+          if isCompleteTypedMinIds minIds'
             then pure (minIds', True)
             else findMinIdsRec rest minIds'
 
-    isComplete (MinIds m1 m2 m3) = isJust m1 && isJust m2 && isJust m3
+emptyTypedMinIds :: TxOutTableType -> TypedMinIds
+emptyTypedMinIds TxOutCore = CoreMinIds mempty
+emptyTypedMinIds TxOutVariant = VariantMinIds mempty
 
+combineTypedMinIds :: TypedMinIds -> TypedMinIds -> TypedMinIds
+combineTypedMinIds (CoreMinIds a) (CoreMinIds b) = CoreMinIds (a <> b)
+combineTypedMinIds (VariantMinIds a) (VariantMinIds b) = VariantMinIds (a <> b)
+combineTypedMinIds _ _ = error "Mismatched TypedMinIds types"
 
-deleteTablesAfterBlockId :: MonadIO m => BlockId -> Maybe TxId -> MinIds -> ReaderT SqlBackend m Int64
-deleteTablesAfterBlockId blkId mtxId minIds = do
+isCompleteTypedMinIds :: TypedMinIds -> Bool
+isCompleteTypedMinIds (CoreMinIds (MinIds m1 m2 m3)) = isJust m1 && isJust m2 && isJust m3
+isCompleteTypedMinIds (VariantMinIds (MinIds m1 m2 m3)) = isJust m1 && isJust m2 && isJust m3
+
+completeTypedMinId :: MonadIO m => Maybe TxId -> TypedMinIds -> ReaderT SqlBackend m TypedMinIds
+completeTypedMinId mTxId (CoreMinIds minIds) = CoreMinIds <$> completeMinId @'TxOutCore mTxId minIds
+completeTypedMinId mTxId (VariantMinIds minIds) = VariantMinIds <$> completeMinId @'TxOutVariant mTxId minIds
+
+deleteTablesAfterBlockId :: MonadIO m => BlockId -> Maybe TxId -> TypedMinIds -> ReaderT SqlBackend m Int64
+deleteTablesAfterBlockId blkId mtxId typedMinIds = do
   deleteWhere [AdaPotsBlockId >=. blkId]
   deleteWhere [ReverseIndexBlockId >=. blkId]
   deleteWhere [EpochParamBlockId >=. blkId]
@@ -114,9 +132,13 @@ deleteTablesAfterBlockId blkId mtxId minIds = do
     queryFirstAndDeleteAfter OffChainVoteDataVotingAnchorId vaId
     queryFirstAndDeleteAfter OffChainVoteFetchErrorVotingAnchorId vaId
     deleteWhere [VotingAnchorId >=. vaId]
-  deleteTablesAfterTxId mtxId (minTxInId minIds)
+  deleteTablesAfterTxId mtxId (typedMinTxInId typedMinIds)
   deleteWhereCount [BlockId >=. blkId]
 
+typedMinTxInId :: TypedMinIds -> Maybe TxInId
+typedMinTxInId (CoreMinIds minIds) = minTxInId minIds
+typedMinTxInId (VariantMinIds minIds) = minTxInId minIds
+
 deleteTablesAfterTxId :: MonadIO m => Maybe TxId -> Maybe TxInId -> ReaderT SqlBackend m ()
 deleteTablesAfterTxId mtxId mtxInId = do
   whenJust mtxInId $ \txInId -> deleteWhere [TxInId >=. txInId]
@@ -195,27 +217,15 @@ deleteDelistedPool poolHash = do
   mapM_ delete keys
   pure $ not (null keys)
 
-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
-
 -- | 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 => Block -> ReaderT SqlBackend m Bool
-deleteBlock block = do
+deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool
+deleteBlock txOutTableType block = do
   mBlockId <- listToMaybe <$> selectKeysList [BlockHash ==. blockHash block] []
   case mBlockId of
     Nothing -> pure False
     Just blockId -> do
-      void $ deleteBlocksBlockId nullTracer blockId
+      void $ deleteBlocksBlockId nullTracer txOutTableType blockId
       pure True
 
 deleteEpochRows :: MonadIO m => Word64 -> ReaderT SqlBackend m ()

cardano-db/src/Cardano/Db/Operations/Core/MinId.hs

@@ -1,27 +1,29 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Cardano.Db.Operations.Core.MinId where
 
-import Cardano.Db.Operations.Variant.Types (MaTxOutFields (..), TxOutFields (..))
+import Cardano.Db.Operations.Core.Query (queryMinRefId)
+import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..))
 import Cardano.Db.Schema.Core.Schema
+import qualified Cardano.Db.Schema.Core.TxOut as C
+import qualified Cardano.Db.Schema.Variant.TxOut as V
 import Cardano.Db.Types (TxOutTableType (..))
 import Cardano.Prelude
 import qualified Data.Text as Text
-import Database.Persist.Sql (fromSqlKey, toSqlKey)
+import Database.Persist.Sql (PersistEntity, PersistField, SqlBackend, fromSqlKey, toSqlKey)
 
 data MinIds (a :: TxOutTableType) = MinIds
-  { minTxInId :: Maybe TxInId,
-    minTxOutId :: Maybe (TxOutIdFor a),
-    minMaTxOutId :: Maybe (Key (MaTxOutTable a))
+  { minTxInId :: Maybe TxInId
+  , minTxOutId :: Maybe (TxOutIdFor a)
+  , minMaTxOutId :: Maybe (Key (MaTxOutTable a))
   }
 
 instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a)) => Monoid (MinIds a) where
@@ -30,18 +32,24 @@ instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a)) => Monoid (MinIds
 instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (Key (MaTxOutTable 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)
+      { minTxInId = minJust (minTxInId mn1) (minTxInId mn2)
+      , minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2)
+      , minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2)
       }
 
-minIdsToText :: forall a. (a ~ TxOutCore , a ~ TxOutVariant) => TxOutTableType -> MinIds a -> Text
-minIdsToText TxOutCore = minIdsCoreToText
-minIdsToText TxOutVariant = minIdsVariantToText
+data TypedMinIds where
+  CoreMinIds :: MinIds 'TxOutCore -> TypedMinIds
+  VariantMinIds :: MinIds 'TxOutVariant -> TypedMinIds
 
-textToMinIds :: forall a. (a ~ TxOutCore , a ~ TxOutVariant) => TxOutTableType -> Text -> Maybe (MinIds a)
-textToMinIds TxOutCore = textToMinIdsCore
-textToMinIds TxOutVariant = textToMinIdsVariant
+minIdsToText :: TypedMinIds -> Text
+minIdsToText (CoreMinIds minIds) = minIdsCoreToText minIds
+minIdsToText (VariantMinIds minIds) = minIdsVariantToText minIds
+
+textToMinIds :: Text -> Maybe TypedMinIds
+textToMinIds txt =
+  case textToMinIdsCore txt of
+    Just minIds -> Just (CoreMinIds minIds)
+    Nothing -> VariantMinIds <$> textToMinIdsVariant txt
 
 minIdsCoreToText :: MinIds 'TxOutCore -> Text
 minIdsCoreToText minIds =
@@ -89,3 +97,70 @@ 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
+--------------------------------------------------------------------------------
+class CompleteMinId a where
+  completeMinIdImpl :: MonadIO m => Maybe TxId -> MinIds a -> ReaderT SqlBackend m (MinIds a)
+
+instance CompleteMinId 'TxOutCore where
+  completeMinIdImpl = completeMinIdCore
+
+instance CompleteMinId 'TxOutVariant where
+  completeMinIdImpl = completeMinIdVariant
+
+-- example use case would be: `result <- completeMinId @'TxOutCore mTxId minIds`
+completeMinId ::
+  forall a m.
+  (CompleteMinId a, MonadIO m) =>
+  Maybe TxId ->
+  MinIds a ->
+  ReaderT SqlBackend m (MinIds a)
+completeMinId = completeMinIdImpl
+
+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 'TxOutVariant -> ReaderT SqlBackend m (MinIds 'TxOutVariant)
+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

cardano-db/src/Cardano/Db/Operations/Core/Query.hs

@@ -103,6 +103,7 @@ module Cardano.Db.Operations.Core.Query (
 ) where
 
 import Cardano.Db.Error
+import Cardano.Db.Operations.Core.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda)
 import Cardano.Db.Schema.Core.Schema
 import Cardano.Db.Types
 import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..))
@@ -161,7 +162,6 @@ import Database.Esqueleto.Experimental (
  )
 import Database.Persist.Class.PersistQuery (selectList)
 import Database.Persist.Types (SelectOpt (Asc))
-import Cardano.Db.Operations.Core.QueryHelper (maybeToEither, unValue3, isJust, unValue2, unValue5, unValueSumAda, defaultUTCTime)
 
 {- HLINT ignore "Redundant ^." -}
 {- HLINT ignore "Fuse on/on" -}

cardano-db/src/Cardano/Db/Operations/Core/QueryHelper.hs

@@ -6,15 +6,28 @@
 module Cardano.Db.Operations.Core.QueryHelper where
 
 import Cardano.Db.Schema.Core.Schema
+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),
-  unSqlBackendKey, PersistField, SqlExpr, ValueList, isNothing, not_, subList_select, from, in_, (^.), where_, table, (<=.), val,
+  ValueList,
+  from,
+  in_,
+  isNothing,
+  not_,
+  subList_select,
+  table,
+  unSqlBackendKey,
+  val,
+  where_,
+  (<=.),
+  (^.),
  )
-import Data.Fixed (Micro)
-import Cardano.Db.Types
-import Data.Time.Clock (UTCTime)
 
 -- Filter out 'Nothing' from a 'Maybe a'.
 isJust :: PersistField a => SqlExpr (Value (Maybe a)) -> SqlExpr (Value Bool)