/
DbSchema.hs
316 lines (261 loc) · 13.4 KB
/
DbSchema.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# options_ghc -Wno-missing-signatures #-}
{-
Here we explicitly construct the
database schema for the data which we wish to store:
- Datums
- Scripts
- Transactions
- Transaction output references indexed by address
-}
module Plutus.ChainIndex.DbSchema where
import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.Coerce (coerce)
import Data.Either (fromRight)
import Data.Kind (Constraint)
import Data.Semigroup.Generic (GenericSemigroupMonoid (..))
import Data.Word (Word64)
import Database.Beam (Beamable, Columnar, Database, DatabaseSettings, FromBackendRow, Generic, Identity, Table (..),
TableEntity, dbModification, withDbModification)
import Database.Beam.Migrate (CheckedDatabaseSettings, defaultMigratableDbSettings, renameCheckedEntity,
unCheckDatabase)
import Database.Beam.Sqlite (Sqlite)
import Ledger (BlockId (..), ChainIndexTxOut (..), Slot)
import Plutus.ChainIndex.Tx (ChainIndexTx)
import Plutus.ChainIndex.Types (BlockNumber (..), Tip (..))
import Plutus.V1.Ledger.Api (Credential, Datum, DatumHash (..), MintingPolicy, MintingPolicyHash (..), Redeemer,
RedeemerHash (..), Script, StakeValidator, StakeValidatorHash (..), TxId (..), TxOut,
TxOutRef (..), Validator, ValidatorHash (..))
import Plutus.V1.Ledger.Scripts (ScriptHash (..))
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusTx.Builtins qualified as PlutusTx
data DatumRowT f = DatumRow
{ _datumRowHash :: Columnar f ByteString
, _datumRowDatum :: Columnar f ByteString
} deriving (Generic, Beamable)
type DatumRow = DatumRowT Identity
instance Table DatumRowT where
data PrimaryKey DatumRowT f = DatumRowId (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey = DatumRowId . _datumRowHash
data ScriptRowT f = ScriptRow
{ _scriptRowHash :: Columnar f ByteString
, _scriptRowScript :: Columnar f ByteString
} deriving (Generic, Beamable)
type ScriptRow = ScriptRowT Identity
instance Table ScriptRowT where
data PrimaryKey ScriptRowT f = ScriptRowId (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey = ScriptRowId . _scriptRowHash
data RedeemerRowT f = RedeemerRow
{ _redeemerRowHash :: Columnar f ByteString
, _redeemerRowRedeemer :: Columnar f ByteString
} deriving (Generic, Beamable)
type RedeemerRow = RedeemerRowT Identity
instance Table RedeemerRowT where
data PrimaryKey RedeemerRowT f = RedeemerRowId (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey = RedeemerRowId . _redeemerRowHash
data TxRowT f = TxRow
{ _txRowTxId :: Columnar f ByteString
, _txRowTx :: Columnar f ByteString
} deriving (Generic, Beamable)
type TxRow = TxRowT Identity
instance Table TxRowT where
data PrimaryKey TxRowT f = TxRowId (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey = TxRowId . _txRowTxId
data AddressRowT f = AddressRow
{ _addressRowCred :: Columnar f ByteString
, _addressRowOutRef :: Columnar f ByteString
} deriving (Generic, Beamable)
type AddressRow = AddressRowT Identity
instance Table AddressRowT where
-- We also need an index on just the _addressRowCred column, but the primary key index provides this
-- as long as _addressRowCred is the first column in the primary key.
data PrimaryKey AddressRowT f = AddressRowId (Columnar f ByteString) (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey (AddressRow c o) = AddressRowId c o
data AssetClassRowT f = AssetClassRow
{ _assetClassRowAssetClass :: Columnar f ByteString
, _assetClassRowOutRef :: Columnar f ByteString
} deriving (Generic, Beamable)
type AssetClassRow = AssetClassRowT Identity
instance Table AssetClassRowT where
-- We also need an index on just the _assetClassRowAssetClass column, but the primary key index provides this
-- as long as _assetClassRowAssetClass is the first column in the primary key.
data PrimaryKey AssetClassRowT f = AssetClassRowId (Columnar f ByteString)
(Columnar f ByteString)
deriving (Generic, Beamable)
primaryKey (AssetClassRow c o) = AssetClassRowId c o
data TipRowT f = TipRow
{ _tipRowSlot :: Columnar f Word64
, _tipRowBlockId :: Columnar f ByteString
, _tipRowBlockNumber :: Columnar f Word64
} deriving (Generic, Beamable)
type TipRow = TipRowT Identity
instance Table TipRowT where
data PrimaryKey TipRowT f = TipRowId { unTipRowId :: Columnar f Word64 } deriving (Generic, Beamable)
primaryKey = TipRowId . _tipRowSlot
{-
The UnspentOutputRow and UnmatchedInputRow tables represent the TxUtxoBalance part of the UtxoState data on disk.
In particular the tip is the one that produced the utxo, except for the rows
that come from transactions that can no longer be rolled back:
In the UtxoState data that can no longer be rolled back are combined in a single TxUtxoBalance value.
The tip in those cases is the most recent tip that can no longer be rolled back.
(This is an automatic result of the Monoid instance on TxUtxoBalance, and is a bit weird when spelled
out as a database design, but the disk state and in memory state should be kept in sync.)
-}
data UnspentOutputRowT f = UnspentOutputRow
{ _unspentOutputRowTip :: PrimaryKey TipRowT f
, _unspentOutputRowOutRef :: Columnar f ByteString
} deriving (Generic, Beamable)
type UnspentOutputRow = UnspentOutputRowT Identity
instance Table UnspentOutputRowT where
data PrimaryKey UnspentOutputRowT f = UnspentOutputRowId (PrimaryKey TipRowT f) (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey (UnspentOutputRow t o) = UnspentOutputRowId t o
data UnmatchedInputRowT f = UnmatchedInputRow
{ _unmatchedInputRowTip :: PrimaryKey TipRowT f
, _unmatchedInputRowOutRef :: Columnar f ByteString
} deriving (Generic, Beamable)
type UnmatchedInputRow = UnmatchedInputRowT Identity
instance Table UnmatchedInputRowT where
data PrimaryKey UnmatchedInputRowT f = UnmatchedInputRowId (PrimaryKey TipRowT f) (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey (UnmatchedInputRow t o) = UnmatchedInputRowId t o
data UtxoRowT f = UtxoRow
{ _utxoRowOutRef :: Columnar f ByteString
, _utxoRowTxOut :: Columnar f ByteString
} deriving (Generic, Beamable)
type UtxoRow = UtxoRowT Identity
instance Table UtxoRowT where
data PrimaryKey UtxoRowT f = UtxoRowOutRef (Columnar f ByteString) deriving (Generic, Beamable)
primaryKey = UtxoRowOutRef . _utxoRowOutRef
data Db f = Db
{ datumRows :: f (TableEntity DatumRowT)
, scriptRows :: f (TableEntity ScriptRowT)
, redeemerRows :: f (TableEntity RedeemerRowT)
, txRows :: f (TableEntity TxRowT)
, utxoOutRefRows :: f (TableEntity UtxoRowT)
, addressRows :: f (TableEntity AddressRowT)
, assetClassRows :: f (TableEntity AssetClassRowT)
, tipRows :: f (TableEntity TipRowT)
, unspentOutputRows :: f (TableEntity UnspentOutputRowT)
, unmatchedInputRows :: f (TableEntity UnmatchedInputRowT)
} deriving (Generic, Database be)
type AllTables (c :: * -> Constraint) f =
( c (f (TableEntity DatumRowT))
, c (f (TableEntity ScriptRowT))
, c (f (TableEntity RedeemerRowT))
, c (f (TableEntity TxRowT))
, c (f (TableEntity UtxoRowT))
, c (f (TableEntity AddressRowT))
, c (f (TableEntity AssetClassRowT))
, c (f (TableEntity TipRowT))
, c (f (TableEntity UnspentOutputRowT))
, c (f (TableEntity UnmatchedInputRowT))
)
deriving via (GenericSemigroupMonoid (Db f)) instance AllTables Semigroup f => Semigroup (Db f)
deriving via (GenericSemigroupMonoid (Db f)) instance AllTables Monoid f => Monoid (Db f)
db :: DatabaseSettings Sqlite Db
db = unCheckDatabase checkedSqliteDb
checkedSqliteDb :: CheckedDatabaseSettings Sqlite Db
checkedSqliteDb = defaultMigratableDbSettings
`withDbModification` dbModification
{ datumRows = renameCheckedEntity (const "datums")
, scriptRows = renameCheckedEntity (const "scripts")
, redeemerRows = renameCheckedEntity (const "redeemers")
, txRows = renameCheckedEntity (const "txs")
, utxoOutRefRows = renameCheckedEntity (const "utxo_out_refs")
, addressRows = renameCheckedEntity (const "addresses")
, assetClassRows = renameCheckedEntity (const "asset_classes")
, tipRows = renameCheckedEntity (const "tips")
, unspentOutputRows = renameCheckedEntity (const "unspent_outputs")
, unmatchedInputRows = renameCheckedEntity (const "unmatched_inputs")
}
-- | Instances of @HasDbType@ can be converted to types that can be stored in the database.
-- `toDbValue` and `fromDbValue` must be inverses of each other.
class FromBackendRow Sqlite (DbType a) => HasDbType a where
type DbType a
toDbValue :: a -> DbType a
fromDbValue :: DbType a -> a
instance HasDbType ByteString where
type DbType ByteString = ByteString
toDbValue = id
fromDbValue = id
instance HasDbType PlutusTx.BuiltinByteString where
type DbType PlutusTx.BuiltinByteString = ByteString
toDbValue = PlutusTx.fromBuiltin
fromDbValue = PlutusTx.toBuiltin
deriving via PlutusTx.BuiltinByteString instance HasDbType DatumHash
deriving via PlutusTx.BuiltinByteString instance HasDbType ValidatorHash
deriving via PlutusTx.BuiltinByteString instance HasDbType MintingPolicyHash
deriving via PlutusTx.BuiltinByteString instance HasDbType RedeemerHash
deriving via PlutusTx.BuiltinByteString instance HasDbType StakeValidatorHash
deriving via PlutusTx.BuiltinByteString instance HasDbType TxId
deriving via ByteString instance HasDbType BlockId
deriving via PlutusTx.BuiltinByteString instance HasDbType ScriptHash
newtype Serialisable a = Serialisable { getSerialisable :: a }
instance Serialise a => HasDbType (Serialisable a) where
type DbType (Serialisable a) = ByteString
fromDbValue
= Serialisable
. fromRight (error "Deserialisation failed. Delete your chain index database and resync.")
. deserialiseOrFail
. BSL.fromStrict
toDbValue = BSL.toStrict . serialise . getSerialisable
deriving via Serialisable Datum instance HasDbType Datum
deriving via Serialisable MintingPolicy instance HasDbType MintingPolicy
deriving via Serialisable Redeemer instance HasDbType Redeemer
deriving via Serialisable StakeValidator instance HasDbType StakeValidator
deriving via Serialisable Validator instance HasDbType Validator
deriving via Serialisable ChainIndexTx instance HasDbType ChainIndexTx
deriving via Serialisable ChainIndexTxOut instance HasDbType ChainIndexTxOut
deriving via Serialisable TxOutRef instance HasDbType TxOutRef
deriving via Serialisable TxOut instance HasDbType TxOut
deriving via Serialisable Credential instance HasDbType Credential
deriving via Serialisable AssetClass instance HasDbType AssetClass
deriving via Serialisable Script instance HasDbType Script
instance HasDbType Slot where
type DbType Slot = Word64 -- In Plutus Slot is Integer, but in the Cardano API it is Word64, so this is safe
toDbValue = fromIntegral
fromDbValue = fromIntegral
instance HasDbType BlockNumber where
type DbType BlockNumber = Word64
toDbValue = coerce
fromDbValue = coerce
instance HasDbType Tip where
type DbType Tip = Maybe TipRow
toDbValue TipAtGenesis = Nothing
toDbValue (Tip sl bi bn) = Just (TipRow (toDbValue sl) (toDbValue bi) (toDbValue bn))
fromDbValue Nothing = TipAtGenesis
fromDbValue (Just (TipRow sl bi bn)) = Tip (fromDbValue sl) (fromDbValue bi) (fromDbValue bn)
instance HasDbType (DatumHash, Datum) where
type DbType (DatumHash, Datum) = DatumRow
toDbValue (hash, datum) = DatumRow (toDbValue hash) (toDbValue datum)
fromDbValue (DatumRow hash datum) = (fromDbValue hash, fromDbValue datum)
instance HasDbType (ScriptHash, Script) where
type DbType (ScriptHash, Script) = ScriptRow
toDbValue (hash, script) = ScriptRow (toDbValue hash) (toDbValue script)
fromDbValue (ScriptRow hash script) = (fromDbValue hash, fromDbValue script)
instance HasDbType (RedeemerHash, Redeemer) where
type DbType (RedeemerHash, Redeemer) = RedeemerRow
toDbValue (hash, redeemer) = RedeemerRow (toDbValue hash) (toDbValue redeemer)
fromDbValue (RedeemerRow hash redeemer) = (fromDbValue hash, fromDbValue redeemer)
instance HasDbType (TxId, ChainIndexTx) where
type DbType (TxId, ChainIndexTx) = TxRow
toDbValue (txId, tx) = TxRow (toDbValue txId) (toDbValue tx)
fromDbValue (TxRow txId tx) = (fromDbValue txId, fromDbValue tx)
instance HasDbType (Credential, TxOutRef) where
type DbType (Credential, TxOutRef) = AddressRow
toDbValue (cred, outRef) = AddressRow (toDbValue cred) (toDbValue outRef)
fromDbValue (AddressRow cred outRef) = (fromDbValue cred, fromDbValue outRef)
instance HasDbType (AssetClass, TxOutRef) where
type DbType (AssetClass, TxOutRef) = AssetClassRow
toDbValue (ac, outRef) = AssetClassRow (toDbValue ac) (toDbValue outRef)
fromDbValue (AssetClassRow ac outRef) = (fromDbValue ac, fromDbValue outRef)