Skip to content

Commit fd13fa4

Browse files
CmdvCmdv
committed
adding more variants around MinId
Modified-by: Cmdv <[email protected]>
1 parent ee83a31 commit fd13fa4

File tree

15 files changed

+393
-313
lines changed

15 files changed

+393
-313
lines changed

‎cardano-db/cardano-db.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,13 +44,13 @@ library
4444
Cardano.Db.Operations.Core.MinId
4545
Cardano.Db.Operations.Core.Query
4646
Cardano.Db.Operations.Core.QueryHelper
47+
Cardano.Db.Operations.Types
4748
Cardano.Db.Operations.Variant.ConsumedTxOut
4849
Cardano.Db.Operations.Variant.JsonbQuery
4950
Cardano.Db.Operations.Variant.Multiplex
5051
Cardano.Db.Operations.Variant.TxOutDelete
5152
Cardano.Db.Operations.Variant.TxOutInsert
5253
Cardano.Db.Operations.Variant.TxOutQuery
53-
Cardano.Db.Operations.Variant.Types
5454
Cardano.Db.PGConfig
5555
Cardano.Db.Run
5656
Cardano.Db.Schema.Core.Schema

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

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,6 @@ module Cardano.Db (
55
Block (..),
66
Tx (..),
77
TxIn (..),
8-
TxOut (..),
98
gitRev,
109
migrateTxOut,
1110
queryTxConsumedColumnExists,
@@ -26,11 +25,9 @@ import Cardano.Db.Operations.Variant.ConsumedTxOut (migrateTxOut, queryTxConsume
2625
import Cardano.Db.Operations.Variant.JsonbQuery as X
2726
import Cardano.Db.Operations.Variant.Multiplex as X
2827
import Cardano.Db.Operations.Variant.TxOutQuery as X
29-
import Cardano.Db.Operations.Variant.Types as X
28+
import Cardano.Db.Operations.Types as X
3029
import Cardano.Db.PGConfig as X
3130
import Cardano.Db.Run as X
3231
import Cardano.Db.Schema.Core.Schema as X
33-
import Cardano.Db.Schema.Core.TxOut as X
3432
import Cardano.Db.Schema.Types as X
35-
import Cardano.Db.Schema.Variant.TxOut as X
3633
import Cardano.Db.Types as X

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,8 @@ import Cardano.BM.Trace (Trace)
2828
import Cardano.Crypto.Hash (Blake2b_256, ByteString, Hash, hashToStringAsHex, hashWith)
2929
import Cardano.Db.Migration.Haskell
3030
import Cardano.Db.Migration.Version
31-
import Cardano.Db.PGConfig
3231
import Cardano.Db.Operations.Core.Query
32+
import Cardano.Db.PGConfig
3333
import Cardano.Db.Run
3434
import Cardano.Db.Schema.Core.Schema
3535
import Cardano.Prelude (Typeable, textShow)

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

Lines changed: 49 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE GADTs #-}
34
{-# LANGUAGE OverloadedStrings #-}
@@ -23,9 +24,10 @@ module Cardano.Db.Operations.Core.Delete (
2324
) where
2425

2526
import Cardano.BM.Trace (Trace, logWarning, nullTracer)
26-
import Cardano.Db.Operations.Core.MinId
27-
import Cardano.Db.Operations.Core.Query hiding (isJust)
27+
import Cardano.Db.Operations.Core.MinId (MinIds (..), TypedMinIds (..), completeMinId, textToMinIds)
28+
import Cardano.Db.Operations.Core.Query
2829
import Cardano.Db.Schema.Core.Schema
30+
import Cardano.Db.Types (TxOutTableType (..))
2931
import Cardano.Prelude (Int64)
3032
import Cardano.Slotting.Slot (SlotNo (..))
3133
import Control.Monad (void)
@@ -50,54 +52,70 @@ import Database.Persist.Sql (
5052
(>=.),
5153
)
5254

53-
deleteBlocksSlotNoNoTrace :: MonadIO m => SlotNo -> ReaderT SqlBackend m Bool
55+
deleteBlocksSlotNoNoTrace :: MonadIO m => TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool
5456
deleteBlocksSlotNoNoTrace = deleteBlocksSlotNo nullTracer
5557

5658
-- | Delete a block if it exists. Returns 'True' if it did exist and has been
5759
-- deleted and 'False' if it did not exist.
58-
deleteBlocksSlotNo :: MonadIO m => Trace IO Text -> SlotNo -> ReaderT SqlBackend m Bool
59-
deleteBlocksSlotNo trce (SlotNo slotNo) = do
60+
deleteBlocksSlotNo :: MonadIO m => Trace IO Text -> TxOutTableType -> SlotNo -> ReaderT SqlBackend m Bool
61+
deleteBlocksSlotNo trce txOutTableType (SlotNo slotNo) = do
6062
mBlockId <- queryBlockSlotNo slotNo
6163
case mBlockId of
6264
Nothing -> pure False
6365
Just blockId -> do
64-
void $ deleteBlocksBlockId trce blockId
66+
void $ deleteBlocksBlockId trce txOutTableType blockId
6567
pure True
6668

67-
deleteBlocksBlockIdNotrace :: MonadIO m => BlockId -> ReaderT SqlBackend m ()
68-
deleteBlocksBlockIdNotrace = void . deleteBlocksBlockId nullTracer
69+
deleteBlocksBlockIdNotrace :: MonadIO m => TxOutTableType -> BlockId -> ReaderT SqlBackend m ()
70+
deleteBlocksBlockIdNotrace txOutTableType = void . deleteBlocksBlockId nullTracer txOutTableType
6971

7072
-- | Delete starting from a 'BlockId'.
71-
deleteBlocksBlockId :: MonadIO m => Trace IO Text -> BlockId -> ReaderT SqlBackend m (Maybe TxId, Int64)
72-
deleteBlocksBlockId trce blockId = do
73-
mMinIds <- fmap (textToMinId =<<) <$> queryReverseIndexBlockId blockId
74-
(cminIds, completed) <- findMinIdsRec mMinIds mempty
73+
deleteBlocksBlockId ::
74+
MonadIO m =>
75+
Trace IO Text ->
76+
TxOutTableType ->
77+
BlockId ->
78+
ReaderT SqlBackend m (Maybe TxId, Int64)
79+
deleteBlocksBlockId trce txOutTableType blockId = do
80+
mMinIds <- fmap (textToMinIds =<<) <$> queryReverseIndexBlockId blockId
81+
(cminIds, completed) <- findMinIdsRec mMinIds (emptyTypedMinIds txOutTableType)
7582
mTxId <- queryMinRefId TxBlockId blockId
76-
minIds <- if completed then pure cminIds else completeMinId mTxId cminIds
83+
minIds <- if completed then pure cminIds else completeTypedMinId mTxId cminIds
7784
blockCountInt <- deleteTablesAfterBlockId blockId mTxId minIds
7885
pure (mTxId, blockCountInt)
7986
where
80-
findMinIdsRec :: MonadIO m => [Maybe MinIds] -> MinIds -> ReaderT SqlBackend m (MinIds, Bool)
87+
findMinIdsRec :: MonadIO m => [Maybe TypedMinIds] -> TypedMinIds -> ReaderT SqlBackend m (TypedMinIds, Bool)
8188
findMinIdsRec [] minIds = pure (minIds, True)
8289
findMinIdsRec (mMinIds : rest) minIds =
8390
case mMinIds of
8491
Nothing -> do
85-
liftIO $
86-
logWarning
87-
trce
88-
"Failed to find ReverseIndex. Deletion may take longer."
92+
liftIO $ logWarning trce "Failed to find ReverseIndex. Deletion may take longer."
8993
pure (minIds, False)
9094
Just minIdDB -> do
91-
let minIds' = minIds <> minIdDB
92-
if isComplete minIds'
95+
let minIds' = combineTypedMinIds minIds minIdDB
96+
if isCompleteTypedMinIds minIds'
9397
then pure (minIds', True)
9498
else findMinIdsRec rest minIds'
9599

96-
isComplete (MinIds m1 m2 m3) = isJust m1 && isJust m2 && isJust m3
100+
emptyTypedMinIds :: TxOutTableType -> TypedMinIds
101+
emptyTypedMinIds TxOutCore = CoreMinIds mempty
102+
emptyTypedMinIds TxOutVariant = VariantMinIds mempty
97103

104+
combineTypedMinIds :: TypedMinIds -> TypedMinIds -> TypedMinIds
105+
combineTypedMinIds (CoreMinIds a) (CoreMinIds b) = CoreMinIds (a <> b)
106+
combineTypedMinIds (VariantMinIds a) (VariantMinIds b) = VariantMinIds (a <> b)
107+
combineTypedMinIds _ _ = error "Mismatched TypedMinIds types"
98108

99-
deleteTablesAfterBlockId :: MonadIO m => BlockId -> Maybe TxId -> MinIds -> ReaderT SqlBackend m Int64
100-
deleteTablesAfterBlockId blkId mtxId minIds = do
109+
isCompleteTypedMinIds :: TypedMinIds -> Bool
110+
isCompleteTypedMinIds (CoreMinIds (MinIds m1 m2 m3)) = isJust m1 && isJust m2 && isJust m3
111+
isCompleteTypedMinIds (VariantMinIds (MinIds m1 m2 m3)) = isJust m1 && isJust m2 && isJust m3
112+
113+
completeTypedMinId :: MonadIO m => Maybe TxId -> TypedMinIds -> ReaderT SqlBackend m TypedMinIds
114+
completeTypedMinId mTxId (CoreMinIds minIds) = CoreMinIds <$> completeMinId @'TxOutCore mTxId minIds
115+
completeTypedMinId mTxId (VariantMinIds minIds) = VariantMinIds <$> completeMinId @'TxOutVariant mTxId minIds
116+
117+
deleteTablesAfterBlockId :: MonadIO m => BlockId -> Maybe TxId -> TypedMinIds -> ReaderT SqlBackend m Int64
118+
deleteTablesAfterBlockId blkId mtxId typedMinIds = do
101119
deleteWhere [AdaPotsBlockId >=. blkId]
102120
deleteWhere [ReverseIndexBlockId >=. blkId]
103121
deleteWhere [EpochParamBlockId >=. blkId]
@@ -114,9 +132,13 @@ deleteTablesAfterBlockId blkId mtxId minIds = do
114132
queryFirstAndDeleteAfter OffChainVoteDataVotingAnchorId vaId
115133
queryFirstAndDeleteAfter OffChainVoteFetchErrorVotingAnchorId vaId
116134
deleteWhere [VotingAnchorId >=. vaId]
117-
deleteTablesAfterTxId mtxId (minTxInId minIds)
135+
deleteTablesAfterTxId mtxId (typedMinTxInId typedMinIds)
118136
deleteWhereCount [BlockId >=. blkId]
119137

138+
typedMinTxInId :: TypedMinIds -> Maybe TxInId
139+
typedMinTxInId (CoreMinIds minIds) = minTxInId minIds
140+
typedMinTxInId (VariantMinIds minIds) = minTxInId minIds
141+
120142
deleteTablesAfterTxId :: MonadIO m => Maybe TxId -> Maybe TxInId -> ReaderT SqlBackend m ()
121143
deleteTablesAfterTxId mtxId mtxInId = do
122144
whenJust mtxInId $ \txInId -> deleteWhere [TxInId >=. txInId]
@@ -195,27 +217,15 @@ deleteDelistedPool poolHash = do
195217
mapM_ delete keys
196218
pure $ not (null keys)
197219

198-
whenNothingQueryMinRefId ::
199-
forall m record field.
200-
(MonadIO m, PersistEntity record, PersistField field) =>
201-
Maybe (Key record) ->
202-
EntityField record field ->
203-
field ->
204-
ReaderT SqlBackend m (Maybe (Key record))
205-
whenNothingQueryMinRefId mKey efield field = do
206-
case mKey of
207-
Just k -> pure $ Just k
208-
Nothing -> queryMinRefId efield field
209-
210220
-- | Delete a block if it exists. Returns 'True' if it did exist and has been
211221
-- deleted and 'False' if it did not exist.
212-
deleteBlock :: MonadIO m => Block -> ReaderT SqlBackend m Bool
213-
deleteBlock block = do
222+
deleteBlock :: MonadIO m => TxOutTableType -> Block -> ReaderT SqlBackend m Bool
223+
deleteBlock txOutTableType block = do
214224
mBlockId <- listToMaybe <$> selectKeysList [BlockHash ==. blockHash block] []
215225
case mBlockId of
216226
Nothing -> pure False
217227
Just blockId -> do
218-
void $ deleteBlocksBlockId nullTracer blockId
228+
void $ deleteBlocksBlockId nullTracer txOutTableType blockId
219229
pure True
220230

221231
deleteEpochRows :: MonadIO m => Word64 -> ReaderT SqlBackend m ()

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

Lines changed: 91 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,29 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE ExistentialQuantification #-}
23
{-# LANGUAGE FlexibleContexts #-}
34
{-# LANGUAGE GADTs #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE ScopedTypeVariables #-}
67
{-# LANGUAGE TypeFamilies #-}
78
{-# LANGUAGE UndecidableInstances #-}
8-
{-# LANGUAGE DataKinds #-}
99
{-# LANGUAGE NoImplicitPrelude #-}
10-
{-# LANGUAGE TypeOperators #-}
1110

1211
module Cardano.Db.Operations.Core.MinId where
1312

14-
import Cardano.Db.Operations.Variant.Types (MaTxOutFields (..), TxOutFields (..))
13+
import Cardano.Db.Operations.Core.Query (queryMinRefId)
14+
import Cardano.Db.Operations.Types (MaTxOutFields (..), TxOutFields (..))
1515
import Cardano.Db.Schema.Core.Schema
16+
import qualified Cardano.Db.Schema.Core.TxOut as C
17+
import qualified Cardano.Db.Schema.Variant.TxOut as V
1618
import Cardano.Db.Types (TxOutTableType (..))
1719
import Cardano.Prelude
1820
import qualified Data.Text as Text
19-
import Database.Persist.Sql (fromSqlKey, toSqlKey)
21+
import Database.Persist.Sql (PersistEntity, PersistField, SqlBackend, fromSqlKey, toSqlKey)
2022

2123
data MinIds (a :: TxOutTableType) = MinIds
22-
{ minTxInId :: Maybe TxInId,
23-
minTxOutId :: Maybe (TxOutIdFor a),
24-
minMaTxOutId :: Maybe (Key (MaTxOutTable a))
24+
{ minTxInId :: Maybe TxInId
25+
, minTxOutId :: Maybe (TxOutIdFor a)
26+
, minMaTxOutId :: Maybe (Key (MaTxOutTable a))
2527
}
2628

2729
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
3032
instance (TxOutFields a, MaTxOutFields a, Ord (TxOutIdFor a), Ord (Key (MaTxOutTable a))) => Semigroup (MinIds a) where
3133
mn1 <> mn2 =
3234
MinIds
33-
{ minTxInId = minJust (minTxInId mn1) (minTxInId mn2),
34-
minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2),
35-
minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2)
35+
{ minTxInId = minJust (minTxInId mn1) (minTxInId mn2)
36+
, minTxOutId = minJust (minTxOutId mn1) (minTxOutId mn2)
37+
, minMaTxOutId = minJust (minMaTxOutId mn1) (minMaTxOutId mn2)
3638
}
3739

38-
minIdsToText :: forall a. (a ~ TxOutCore , a ~ TxOutVariant) => TxOutTableType -> MinIds a -> Text
39-
minIdsToText TxOutCore = minIdsCoreToText
40-
minIdsToText TxOutVariant = minIdsVariantToText
40+
data TypedMinIds where
41+
CoreMinIds :: MinIds 'TxOutCore -> TypedMinIds
42+
VariantMinIds :: MinIds 'TxOutVariant -> TypedMinIds
4143

42-
textToMinIds :: forall a. (a ~ TxOutCore , a ~ TxOutVariant) => TxOutTableType -> Text -> Maybe (MinIds a)
43-
textToMinIds TxOutCore = textToMinIdsCore
44-
textToMinIds TxOutVariant = textToMinIdsVariant
44+
minIdsToText :: TypedMinIds -> Text
45+
minIdsToText (CoreMinIds minIds) = minIdsCoreToText minIds
46+
minIdsToText (VariantMinIds minIds) = minIdsVariantToText minIds
47+
48+
textToMinIds :: Text -> Maybe TypedMinIds
49+
textToMinIds txt =
50+
case textToMinIdsCore txt of
51+
Just minIds -> Just (CoreMinIds minIds)
52+
Nothing -> VariantMinIds <$> textToMinIdsVariant txt
4553

4654
minIdsCoreToText :: MinIds 'TxOutCore -> Text
4755
minIdsCoreToText minIds =
@@ -89,3 +97,70 @@ minJust :: (Ord a) => Maybe a -> Maybe a -> Maybe a
8997
minJust Nothing y = y
9098
minJust x Nothing = x
9199
minJust (Just x) (Just y) = Just (min x y)
100+
101+
--------------------------------------------------------------------------------
102+
-- CompleteMinId
103+
--------------------------------------------------------------------------------
104+
class CompleteMinId a where
105+
completeMinIdImpl :: MonadIO m => Maybe TxId -> MinIds a -> ReaderT SqlBackend m (MinIds a)
106+
107+
instance CompleteMinId 'TxOutCore where
108+
completeMinIdImpl = completeMinIdCore
109+
110+
instance CompleteMinId 'TxOutVariant where
111+
completeMinIdImpl = completeMinIdVariant
112+
113+
-- example use case would be: `result <- completeMinId @'TxOutCore mTxId minIds`
114+
completeMinId ::
115+
forall a m.
116+
(CompleteMinId a, MonadIO m) =>
117+
Maybe TxId ->
118+
MinIds a ->
119+
ReaderT SqlBackend m (MinIds a)
120+
completeMinId = completeMinIdImpl
121+
122+
completeMinIdCore :: MonadIO m => Maybe TxId -> MinIds 'TxOutCore -> ReaderT SqlBackend m (MinIds 'TxOutCore)
123+
completeMinIdCore mTxId minIds = do
124+
case mTxId of
125+
Nothing -> pure mempty
126+
Just txId -> do
127+
mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId
128+
mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) C.TxOutTxId txId
129+
mMaTxOutId <- case mTxOutId of
130+
Nothing -> pure Nothing
131+
Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) C.MaTxOutTxOutId txOutId
132+
pure $
133+
MinIds
134+
{ minTxInId = mTxInId
135+
, minTxOutId = mTxOutId
136+
, minMaTxOutId = mMaTxOutId
137+
}
138+
139+
completeMinIdVariant :: MonadIO m => Maybe TxId -> MinIds 'TxOutVariant -> ReaderT SqlBackend m (MinIds 'TxOutVariant)
140+
completeMinIdVariant mTxId minIds = do
141+
case mTxId of
142+
Nothing -> pure mempty
143+
Just txId -> do
144+
mTxInId <- whenNothingQueryMinRefId (minTxInId minIds) TxInTxInId txId
145+
mTxOutId <- whenNothingQueryMinRefId (minTxOutId minIds) V.TxOutTxId txId
146+
mMaTxOutId <- case mTxOutId of
147+
Nothing -> pure Nothing
148+
Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) V.MaTxOutTxOutId txOutId
149+
pure $
150+
MinIds
151+
{ minTxInId = mTxInId
152+
, minTxOutId = mTxOutId
153+
, minMaTxOutId = mMaTxOutId
154+
}
155+
156+
whenNothingQueryMinRefId ::
157+
forall m record field.
158+
(MonadIO m, PersistEntity record, PersistField field) =>
159+
Maybe (Key record) ->
160+
EntityField record field ->
161+
field ->
162+
ReaderT SqlBackend m (Maybe (Key record))
163+
whenNothingQueryMinRefId mKey efield field = do
164+
case mKey of
165+
Just k -> pure $ Just k
166+
Nothing -> queryMinRefId efield field

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -103,6 +103,7 @@ module Cardano.Db.Operations.Core.Query (
103103
) where
104104

105105
import Cardano.Db.Error
106+
import Cardano.Db.Operations.Core.QueryHelper (defaultUTCTime, isJust, maybeToEither, unValue2, unValue3, unValue5, unValueSumAda)
106107
import Cardano.Db.Schema.Core.Schema
107108
import Cardano.Db.Types
108109
import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..))
@@ -161,7 +162,6 @@ import Database.Esqueleto.Experimental (
161162
)
162163
import Database.Persist.Class.PersistQuery (selectList)
163164
import Database.Persist.Types (SelectOpt (Asc))
164-
import Cardano.Db.Operations.Core.QueryHelper (maybeToEither, unValue3, isJust, unValue2, unValue5, unValueSumAda, defaultUTCTime)
165165

166166
{- HLINT ignore "Redundant ^." -}
167167
{- HLINT ignore "Fuse on/on" -}

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

Lines changed: 17 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,28 @@
66
module Cardano.Db.Operations.Core.QueryHelper where
77

88
import Cardano.Db.Schema.Core.Schema
9+
import Cardano.Db.Types
10+
import Data.Fixed (Micro)
11+
import Data.Time.Clock (UTCTime)
912
import Data.Word (Word64)
1013
import Database.Esqueleto.Experimental (
1114
Entity (..),
15+
PersistField,
16+
SqlExpr,
1217
Value (unValue),
13-
unSqlBackendKey, PersistField, SqlExpr, ValueList, isNothing, not_, subList_select, from, in_, (^.), where_, table, (<=.), val,
18+
ValueList,
19+
from,
20+
in_,
21+
isNothing,
22+
not_,
23+
subList_select,
24+
table,
25+
unSqlBackendKey,
26+
val,
27+
where_,
28+
(<=.),
29+
(^.),
1430
)
15-
import Data.Fixed (Micro)
16-
import Cardano.Db.Types
17-
import Data.Time.Clock (UTCTime)
1831

1932
-- Filter out 'Nothing' from a 'Maybe a'.
2033
isJust :: PersistField a => SqlExpr (Value (Maybe a)) -> SqlExpr (Value Bool)

0 commit comments

Comments
 (0)