Skip to content

Commit 806b68c

Browse files
committed
Persistent to Hasql
1 parent da76429 commit 806b68c

File tree

17 files changed

+4199
-1432
lines changed

17 files changed

+4199
-1432
lines changed

cardano-db/cardano-db.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,8 @@ library
7777
, fast-logger
7878
, filepath
7979
, file-embed
80+
, hasql
81+
, hasql-transaction
8082
, iohk-monitoring
8183
, lifted-base
8284
, memory

cardano-db/src/Cardano/Db/Operations/Insert.hs

Lines changed: 23 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -151,6 +151,10 @@ import Database.Persist.Types (
151151
entityKey,
152152
)
153153
import Database.PostgreSQL.Simple (SqlError)
154+
import Hasql.Statement (Statement)
155+
import qualified Hasql.Transaction.Sessions as Transaction
156+
import qualified Hasql.Transaction as Transactio
157+
154158

155159
-- The original naive way of inserting rows into Postgres was:
156160
--
@@ -171,8 +175,25 @@ import Database.PostgreSQL.Simple (SqlError)
171175
insertAdaPots :: (MonadBaseControl IO m, MonadIO m) => AdaPots -> ReaderT SqlBackend m AdaPotsId
172176
insertAdaPots = insertUnchecked "AdaPots"
173177

174-
insertBlock :: (MonadBaseControl IO m, MonadIO m) => Block -> ReaderT SqlBackend m BlockId
175-
insertBlock = insertUnchecked "Block"
178+
-- insertBlock :: (MonadBaseControl IO m, MonadIO m) => Block -> ReaderT SqlBackend m BlockId
179+
-- insertBlock = insertUnchecked "Block"
180+
181+
insertBlock :: Block -> Session BlockId
182+
insertBlock block = Transaction.transaction Transaction.ReadCommitted Transaction.Write insertBlockTransaction
183+
184+
insertBlockStatement :: Statement Block BlockId
185+
insertBlockStatement =
186+
Statement
187+
"INSERT INTO block (id, hash, slot_no, epoch_no) VALUES ($1, $2, $3, $4) RETURNING id"
188+
blockEncoder
189+
(BlockId <$> Decode.int64)
190+
191+
insertBlockTransaction :: Block -> Transaction BlockId
192+
insertBlockTransaction block = do
193+
result <- Transaction.statement block insertBlockStatement
194+
case result of
195+
Right blockId -> pure blockId
196+
Left err -> liftIO $ throwIO (DbInsertException "Block" (fromString $ show err))
176197

177198
insertCollateralTxIn :: (MonadBaseControl IO m, MonadIO m) => CollateralTxIn -> ReaderT SqlBackend m CollateralTxInId
178199
insertCollateralTxIn = insertUnchecked "CollateralTxIn"

cardano-db/src/Cardano/Db/Schema/BaseSchema.hs

Lines changed: 3647 additions & 1362 deletions
Large diffs are not rendered by default.

cardano-db/src/Cardano/Db/Schema/Orphans.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -30,8 +30,8 @@ import Cardano.Db.Types (
3030
readVoterRole,
3131
renderAnchorType,
3232
renderGovActionType,
33-
renderScriptPurpose,
34-
renderScriptType,
33+
scriptPurposeFromText,
34+
scriptPurposeToText,
3535
renderSyncState,
3636
renderVote,
3737
renderVoterRole,
@@ -109,13 +109,13 @@ instance PersistField SyncState where
109109
Left $ mconcat ["Failed to parse Haskell type SyncState: ", Text.pack (show x)]
110110

111111
instance PersistField ScriptPurpose where
112-
toPersistValue = PersistText . renderScriptPurpose
112+
toPersistValue = PersistText . scriptPurposeFromText
113113
fromPersistValue (PersistLiteral bs) = Right $ readScriptPurpose (BS.unpack bs)
114114
fromPersistValue x =
115115
Left $ mconcat ["Failed to parse Haskell type ScriptPurpose: ", Text.pack (show x)]
116116

117117
instance PersistField ScriptType where
118-
toPersistValue = PersistText . renderScriptType
118+
toPersistValue = PersistText . scriptPurposeToText
119119
fromPersistValue (PersistLiteral bs) = Right $ readScriptType (BS.unpack bs)
120120
fromPersistValue x =
121121
Left $ mconcat ["Failed to parse Haskell type ScriptType: ", Text.pack (show x)]
Lines changed: 180 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,180 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE DeriveDataTypeable #-}
4+
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE DerivingStrategies #-}
6+
{-# LANGUAGE FlexibleContexts #-}
7+
{-# LANGUAGE FlexibleInstances #-}
8+
{-# LANGUAGE GADTs #-}
9+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+
{-# LANGUAGE MultiParamTypeClasses #-}
11+
{-# LANGUAGE OverloadedStrings #-}
12+
{-# LANGUAGE QuasiQuotes #-}
13+
{-# LANGUAGE StandaloneDeriving #-}
14+
{-# LANGUAGE TemplateHaskell #-}
15+
{-# LANGUAGE TypeFamilies #-}
16+
{-# LANGUAGE TypeOperators #-}
17+
{-# LANGUAGE UndecidableInstances #-}
18+
19+
module Cardano.Db.Schema.Core.TxOut where
20+
21+
import Cardano.Db.Schema.BaseSchema (DatumId, MultiAssetId, ScriptId, StakeAddressId, TxId)
22+
import Cardano.Db.Types (DbLovelace, DbWord64)
23+
import Data.ByteString.Char8 (ByteString)
24+
import Data.Text (Text)
25+
import Data.Word (Word64)
26+
import Database.Persist.Documentation (deriveShowFields, document, (#), (--^))
27+
import Database.Persist.EntityDef.Internal (EntityDef (..))
28+
import Database.Persist.TH
29+
import GHC.Generics (Generic)
30+
31+
-----------------------------------------------------------------------------------------------
32+
-- TxOut
33+
-----------------------------------------------------------------------------------------------
34+
data TxOut = TxOut
35+
{ txOutId :: !TxOutId
36+
, txOutAddress :: !Text
37+
, txOutAddressHasScript :: !Bool
38+
, txOutDataHash :: !(Maybe ByteString)
39+
, txOutConsumedByTxId :: !(Maybe TxId)
40+
, txOutIndex :: !Word64
41+
, txOutInlineDatumId :: !(Maybe DatumId)
42+
, txOutPaymentCred :: !(Maybe ByteString)
43+
, txOutReferenceScriptId :: !(Maybe ScriptId)
44+
, txOutStakeAddressId :: !(Maybe StakeAddressId)
45+
, txOutTxId :: !TxId
46+
, txOutValue :: !DbLovelace
47+
}
48+
deriving (Eq, Show, Generic)
49+
50+
newtype TxOutId = TxOutId { unTxOutId :: Word64 }
51+
deriving newtype (Eq, Ord, Show)
52+
53+
-----------------------------------------------------------------------------------------------
54+
-- CollateralTxOut
55+
-----------------------------------------------------------------------------------------------
56+
data CollateralTxOut = CollateralTxOut
57+
{ colateralTxOutId :: !TxOutId
58+
, collateralTxOutTxId :: !TxId
59+
, collateralTxOutIndex :: !Word64
60+
, collateralTxOutAddress :: !Text
61+
, collateralTxOutAddressHasScript :: !Bool
62+
, collateralTxOutPaymentCred :: !(Maybe ByteString)
63+
, collateralTxOutStakeAddressId :: !(Maybe StakeAddressId)
64+
, collateralTxOutValue :: !DbLovelace
65+
, collateralTxOutDataHash :: !(Maybe ByteString)
66+
, collateralTxOutMultiAssetsDescr :: !Text
67+
, collateralTxOutInlineDatumId :: !(Maybe DatumId)
68+
, collateralTxOutReferenceScriptId :: !(Maybe ScriptId)
69+
}
70+
deriving (Eq, Show, Generic)
71+
72+
newtype CollateralTxOutId = CollateralTxOutId { unCollateralTxOutId :: Word64 }
73+
deriving newtype (Eq, Ord, Show)
74+
75+
-----------------------------------------------------------------------------------------------
76+
-- MultiAssetTxOut
77+
-----------------------------------------------------------------------------------------------
78+
data MaTxOut = MaTxOut
79+
{ maTxOutId :: !MaTxOutId
80+
, maTxOutIdent :: !MultiAssetId
81+
, maTxOutQuantity :: !DbWord64
82+
, maTxOutTxOutId :: !TxOutId
83+
}
84+
deriving (Eq, Show, Generic)
85+
86+
newtype MaTxOutId = MaTxOutId { unMaTxOutId :: Word64 }
87+
88+
89+
90+
91+
92+
-- share
93+
-- [ mkPersist sqlSettings
94+
-- , mkMigrate "migrateCoreTxOutCardanoDb"
95+
-- , mkEntityDefList "entityDefsTxOutCore"
96+
-- , deriveShowFields
97+
-- ]
98+
-- [persistLowerCase|
99+
-- ----------------------------------------------
100+
-- -- Core TxOut
101+
-- ----------------------------------------------
102+
-- TxOut
103+
-- address Text
104+
-- addressHasScript Bool
105+
-- dataHash ByteString Maybe sqltype=hash32type
106+
-- consumedByTxId TxId Maybe noreference
107+
-- index Word64 sqltype=txindex
108+
-- inlineDatumId DatumId Maybe noreference
109+
-- paymentCred ByteString Maybe sqltype=hash28type
110+
-- referenceScriptId ScriptId Maybe noreference
111+
-- stakeAddressId StakeAddressId Maybe noreference
112+
-- txId TxId noreference
113+
-- value DbLovelace sqltype=lovelace
114+
-- UniqueTxout txId index -- The (tx_id, index) pair must be unique.
115+
116+
-- ----------------------------------------------
117+
-- -- Core CollateralTxOut
118+
-- ----------------------------------------------
119+
-- CollateralTxOut
120+
-- txId TxId noreference -- This type is the primary key for the 'tx' table.
121+
-- index Word64 sqltype=txindex
122+
-- address Text
123+
-- addressHasScript Bool
124+
-- paymentCred ByteString Maybe sqltype=hash28type
125+
-- stakeAddressId StakeAddressId Maybe noreference
126+
-- value DbLovelace sqltype=lovelace
127+
-- dataHash ByteString Maybe sqltype=hash32type
128+
-- multiAssetsDescr Text
129+
-- inlineDatumId DatumId Maybe noreference
130+
-- referenceScriptId ScriptId Maybe noreference
131+
-- deriving Show
132+
133+
-- ----------------------------------------------
134+
-- -- MultiAsset
135+
-- ----------------------------------------------
136+
-- MaTxOut
137+
-- ident MultiAssetId noreference
138+
-- quantity DbWord64 sqltype=word64type
139+
-- txOutId TxOutId noreference
140+
-- deriving Show
141+
142+
-- |]
143+
144+
-- schemaDocsTxOutCore :: [EntityDef]
145+
-- schemaDocsTxOutCore =
146+
-- document entityDefsTxOutCore $ do
147+
-- TxOut --^ do
148+
-- "A table for transaction outputs."
149+
-- TxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era."
150+
-- TxOutAddressHasScript # "Flag which shows if this address is locked by a script."
151+
-- TxOutConsumedByTxId # "The Tx table index of the transaction that consumes this transaction output. Not populated by default, can be activated via tx-out configs."
152+
-- TxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)."
153+
-- TxOutIndex # "The index of this transaction output with the transaction."
154+
-- TxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13."
155+
-- TxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash."
156+
-- TxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13."
157+
-- TxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)."
158+
-- TxOutValue # "The output value (in Lovelace) of the transaction output."
159+
160+
-- TxOutTxId # "The Tx table index of the transaction that contains this transaction output."
161+
162+
-- CollateralTxOut --^ do
163+
-- "A table for transaction collateral outputs. New in v13."
164+
-- CollateralTxOutTxId # "The Tx table index of the transaction that contains this transaction output."
165+
-- CollateralTxOutIndex # "The index of this transaction output with the transaction."
166+
-- CollateralTxOutAddress # "The human readable encoding of the output address. Will be Base58 for Byron era addresses and Bech32 for Shelley era."
167+
-- CollateralTxOutAddressHasScript # "Flag which shows if this address is locked by a script."
168+
-- CollateralTxOutPaymentCred # "The payment credential part of the Shelley address. (NULL for Byron addresses). For a script-locked address, this is the script hash."
169+
-- CollateralTxOutStakeAddressId # "The StakeAddress table index for the stake address part of the Shelley address. (NULL for Byron addresses)."
170+
-- CollateralTxOutValue # "The output value (in Lovelace) of the transaction output."
171+
-- CollateralTxOutDataHash # "The hash of the transaction output datum. (NULL for Txs without scripts)."
172+
-- 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."
173+
-- CollateralTxOutInlineDatumId # "The inline datum of the output, if it has one. New in v13."
174+
-- CollateralTxOutReferenceScriptId # "The reference script of the output, if it has one. New in v13."
175+
176+
-- MaTxOut --^ do
177+
-- "A table containing Multi-Asset transaction outputs."
178+
-- MaTxOutIdent # "The MultiAsset table index specifying the asset."
179+
-- MaTxOutQuantity # "The Multi Asset transaction output amount (denominated in the Multi Asset)."
180+
-- MaTxOutTxOutId # "The TxOut table index for the transaction that this Multi Asset transaction output."

0 commit comments

Comments
 (0)