From f530b83b25345d09c1acd708f9f3a2e16137d7bb Mon Sep 17 00:00:00 2001 From: Sjoerd Visscher Date: Mon, 11 Oct 2021 11:12:28 +0200 Subject: [PATCH] SCP-2827: Conversion to/from database types (#4077) * Refactor 'DbStore' Effect - Move the DbStore Effect into `freer-extras` under 'Beam' - Call it 'BeamEffect' instead, because it's married to Beam. - Refactor the chain index to use it - Refactor the pab to use it * Shuffling * comments * beam in purescript * explicit batching of inserts * Add HasDbType class * Add HasDbType instances for key-value tables * Simplify getResumePoints * Fix issues from merge conflicts * PR feedback Co-authored-by: silky --- .../src/Plutus/ChainIndex/Compatibility.hs | 15 +- .../src/Plutus/ChainIndex/DbSchema.hs | 122 +++++++++-- .../src/Plutus/ChainIndex/Handlers.hs | 199 ++++++++---------- 3 files changed, 213 insertions(+), 123 deletions(-) diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Compatibility.hs b/plutus-chain-index/src/Plutus/ChainIndex/Compatibility.hs index 4add41d6316..376543635c6 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Compatibility.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Compatibility.hs @@ -1,7 +1,9 @@ module Plutus.ChainIndex.Compatibility where -import Cardano.Api (Block (..), BlockHeader (..), BlockInMode (..), BlockNo (..), CardanoMode, - ChainPoint (..), ChainTip (..), Hash, SlotNo (..), serialiseToRawBytes) +import Cardano.Api (AsType (..), Block (..), BlockHeader (..), BlockInMode (..), BlockNo (..), + CardanoMode, ChainPoint (..), ChainTip (..), Hash, SlotNo (..), + deserialiseFromRawBytes, proxyToAsType, serialiseToRawBytes) +import Data.Proxy (Proxy (..)) import Ledger (BlockId (..), Slot (..)) import Plutus.ChainIndex.Tx (ChainIndexTx (..)) import Plutus.ChainIndex.Types (BlockNumber (..), Point (..), Tip (..)) @@ -22,6 +24,11 @@ fromCardanoPoint (ChainPoint slot hash) = , pointBlockId = fromCardanoBlockId hash } +toCardanoPoint :: Point -> Maybe ChainPoint +toCardanoPoint PointAtGenesis = Just ChainPointAtGenesis +toCardanoPoint (Point slot blockId) = + ChainPoint (fromIntegral slot) <$> toCardanoBlockId blockId + tipFromCardanoBlock :: BlockInMode CardanoMode -> Tip @@ -35,6 +42,10 @@ fromCardanoBlockId :: Hash BlockHeader -> BlockId fromCardanoBlockId hash = BlockId $ serialiseToRawBytes hash +toCardanoBlockId :: BlockId -> Maybe (Hash BlockHeader) +toCardanoBlockId (BlockId bs) = + deserialiseFromRawBytes (AsHash (proxyToAsType (Proxy :: Proxy BlockHeader))) bs + fromCardanoBlockHeader :: BlockHeader -> Tip fromCardanoBlockHeader (BlockHeader slotNo hash blockNo) = Tip { tipSlot = fromCardanoSlot slotNo diff --git a/plutus-chain-index/src/Plutus/ChainIndex/DbSchema.hs b/plutus-chain-index/src/Plutus/ChainIndex/DbSchema.hs index 14a112a85b4..7c8886ff6fb 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/DbSchema.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/DbSchema.hs @@ -1,18 +1,15 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# options_ghc -Wno-missing-signatures #-} @@ -30,15 +27,27 @@ database schema for the data which we wish to store: module Plutus.ChainIndex.DbSchema where -import Data.ByteString (ByteString) -import Data.Kind (Constraint) -import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) -import Data.Word (Word64) -import Database.Beam (Beamable, Columnar, Database, DatabaseSettings, Generic, Identity, Table (..), - TableEntity, dbModification, withDbModification) -import Database.Beam.Migrate (CheckedDatabaseSettings, defaultMigratableDbSettings, renameCheckedEntity, - unCheckDatabase) -import Database.Beam.Sqlite (Sqlite) +import Codec.Serialise (Serialise, deserialiseOrFail, serialise) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy 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 (..), Datum, DatumHash (..), MintingPolicy, MintingPolicyHash (..), + Redeemer, RedeemerHash (..), Script, ScriptHash (..), Slot, StakeValidator, + StakeValidatorHash (..), TxId (..), TxOutRef (..), Validator, + ValidatorHash (..)) +import Plutus.ChainIndex.Tx (ChainIndexTx) +import Plutus.ChainIndex.Types (BlockNumber (..), Tip (..)) +import Plutus.V1.Ledger.Api (Credential) +import PlutusTx.Builtins.Internal (BuiltinByteString (..)) data DatumRowT f = DatumRow { _datumRowHash :: Columnar f ByteString @@ -87,7 +96,7 @@ instance Table AddressRowT where primaryKey (AddressRow c o) = AddressRowId c o data TipRowT f = TipRow - { _tipRowSlot :: Columnar f Word64 -- In Plutus Slot is Integer, but in the Cardano API it is Word64, so this is safe + { _tipRowSlot :: Columnar f Word64 , _tipRowBlockId :: Columnar f ByteString , _tipRowBlockNumber :: Columnar f Word64 } deriving (Generic, Beamable) @@ -166,3 +175,86 @@ checkedSqliteDb = defaultMigratableDbSettings , 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 + +deriving via ByteString instance HasDbType DatumHash +deriving via ByteString instance HasDbType ValidatorHash +deriving via ByteString instance HasDbType MintingPolicyHash +deriving via ByteString instance HasDbType RedeemerHash +deriving via ByteString instance HasDbType StakeValidatorHash +deriving via ByteString instance HasDbType TxId +deriving via ByteString instance HasDbType BlockId +deriving via ByteString 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 TxOutRef instance HasDbType TxOutRef +deriving via Serialisable Credential instance HasDbType Credential +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) = ScriptRow + toDbValue (hash, script) = ScriptRow (toDbValue hash) (toDbValue script) + fromDbValue (ScriptRow hash script) = (fromDbValue hash, fromDbValue script) + +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) diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs b/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs index c0b1dc6a2d0..dcd71b7e3ec 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-| Handlers for the 'ChainIndexQueryEffect' and the 'ChainIndexControlEffect' -} module Plutus.ChainIndex.Handlers ( handleQuery @@ -18,7 +19,6 @@ module Plutus.ChainIndex.Handlers ) where import qualified Cardano.Api as C -import Codec.Serialise (Serialise, deserialiseOrFail, serialise) import Control.Applicative (Const (..)) import Control.Lens (Lens', _Just, ix, view, (^?)) import Control.Monad.Freer (Eff, Member, type (~>)) @@ -30,8 +30,6 @@ import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logErr import Control.Monad.Freer.Extras.Pagination (Page (Page), PageQuery (..)) import Control.Monad.Freer.State (State, get, gets, put) import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BSL -import Data.Either (fromRight) import qualified Data.FingerTree as FT import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) @@ -39,42 +37,34 @@ import Data.Monoid (Ap (..)) import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.Word (Word64) -import Database.Beam (Identity, SqlOrd ((>.)), SqlSelect, TableEntity, aggregate_, - all_, countAll_, delete, filter_, guard_, limit_, nub_, - orderBy_, select, val_) -import Database.Beam.Query (asc_, desc_, exists_, update, (&&.), (<-.), (<.), (==.)) +import Database.Beam (Columnar, Identity, SqlSelect, TableEntity, aggregate_, all_, + countAll_, delete, filter_, guard_, limit_, nub_, select, val_) +import Database.Beam.Backend.SQL (BeamSqlBackendCanSerialize) +import Database.Beam.Query (HasSqlEqualityCheck, asc_, desc_, exists_, orderBy_, update, + (&&.), (<-.), (<.), (==.), (>.)) import Database.Beam.Schema.Tables (zipTables) import Database.Beam.Sqlite (Sqlite) -import Ledger (Address (..), ChainIndexTxOut (..), Datum, DatumHash (..), - MintingPolicyHash (..), RedeemerHash (..), - StakeValidatorHash (..), TxId (..), TxOut (..), TxOutRef (..), - ValidatorHash (..)) +import Ledger (Address (..), ChainIndexTxOut (..), Datum, DatumHash, TxId (..), + TxOut (..), TxOutRef (..)) import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..)) import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog (..)) +import Plutus.ChainIndex.Compatibility (toCardanoPoint) import Plutus.ChainIndex.DbSchema import Plutus.ChainIndex.Effects (ChainIndexControlEffect (..), ChainIndexQueryEffect (..)) import Plutus.ChainIndex.Tx import qualified Plutus.ChainIndex.TxUtxoBalance as TxUtxoBalance -import Plutus.ChainIndex.Types (BlockId (BlockId), BlockNumber (BlockNumber), Diagnostics (..), - Point (..), Tip (..), TxUtxoBalance (..), tipAsPoint) +import Plutus.ChainIndex.Types (Diagnostics (..), Point (..), Tip (..), TxUtxoBalance (..), + tipAsPoint) import Plutus.ChainIndex.UtxoState (InsertUtxoSuccess (..), RollbackResult (..), UtxoIndex) import qualified Plutus.ChainIndex.UtxoState as UtxoState import Plutus.V1.Ledger.Api (Credential (PubKeyCredential, ScriptCredential)) -import PlutusTx.Builtins.Internal (BuiltinByteString (..)) -import qualified PlutusTx.Prelude as PlutusTx type ChainIndexState = UtxoIndex TxUtxoBalance getResumePoints :: Member BeamEffect effs => Eff effs [C.ChainPoint] -getResumePoints = do - rows <- selectList . select - . fmap (\row -> (_tipRowSlot row, _tipRowBlockId row)) - . orderBy_ (desc_ . _tipRowSlot) - $ all_ (tipRows db) - pure $ mapMaybe toChainPoint rows - where - toChainPoint :: (Word64, ByteString) -> Maybe C.ChainPoint - toChainPoint (slot, bi) = C.ChainPoint (C.SlotNo slot) <$> C.deserialiseFromRawBytes (C.AsHash (C.proxyToAsType (Proxy :: Proxy C.BlockHeader))) bi +getResumePoints + = fmap (mapMaybe (toCardanoPoint . tipAsPoint . fromDbValue . Just)) + . selectList . select . orderBy_ (desc_ . _tipRowSlot) . all_ $ tipRows db restoreStateFromDb :: ( Member (State ChainIndexState) effs @@ -94,13 +84,13 @@ restoreStateFromDb point = do where outputToTxUtxoBalance :: UnspentOutputRow -> (Word64, TxUtxoBalance) outputToTxUtxoBalance (UnspentOutputRow (TipRowId slot) outRef) - = (slot, TxUtxoBalance (Set.singleton (fromByteString outRef)) mempty) + = (slot, TxUtxoBalance (Set.singleton (fromDbValue outRef)) mempty) inputToTxUtxoBalance :: UnmatchedInputRow -> (Word64, TxUtxoBalance) inputToTxUtxoBalance (UnmatchedInputRow (TipRowId slot) outRef) - = (slot, TxUtxoBalance mempty (Set.singleton (fromByteString outRef))) + = (slot, TxUtxoBalance mempty (Set.singleton (fromDbValue outRef))) toUtxoState :: Map.Map Word64 TxUtxoBalance -> TipRow -> UtxoState.UtxoState TxUtxoBalance - toUtxoState balances (TipRow slot bi bn) - = UtxoState.UtxoState (Map.findWithDefault mempty slot balances) (Tip (fromIntegral slot) (BlockId bi) (BlockNumber bn)) + toUtxoState balances tip + = UtxoState.UtxoState (Map.findWithDefault mempty (_tipRowSlot tip) balances) (fromDbValue (Just tip)) handleQuery :: ( Member (State ChainIndexState) effs @@ -110,13 +100,13 @@ handleQuery :: ) => ChainIndexQueryEffect ~> Eff effs handleQuery = \case - DatumFromHash dh -> getDatumFromHash dh - ValidatorFromHash (ValidatorHash hash) -> queryOneScript hash - MintingPolicyFromHash (MintingPolicyHash hash) -> queryOneScript hash - RedeemerFromHash (RedeemerHash hash) -> queryOneScript hash - StakeValidatorFromHash (StakeValidatorHash hash) -> queryOneScript hash - TxFromTxId txId -> getTxFromTxId txId - TxOutFromRef tor -> getTxOutFromRef tor + DatumFromHash dh -> getDatumFromHash dh + ValidatorFromHash hash -> getScriptFromHash hash + MintingPolicyFromHash hash -> getScriptFromHash hash + RedeemerFromHash hash -> getScriptFromHash hash + StakeValidatorFromHash hash -> getScriptFromHash hash + TxFromTxId txId -> getTxFromTxId txId + TxOutFromRef tor -> getTxOutFromRef tor UtxoSetMembership r -> do utxoState <- gets @ChainIndexState UtxoState.utxoState case UtxoState.tip utxoState of @@ -126,19 +116,49 @@ handleQuery = \case GetTip -> getTip getTip :: Member BeamEffect effs => Eff effs Tip -getTip = do - row <- selectOne . select $ limit_ 1 (orderBy_ (desc_ . _tipRowSlot) (all_ (tipRows db))) - pure $ case row of - Nothing -> TipAtGenesis - Just (TipRow slot bi bn) -> Tip (fromIntegral slot) (BlockId bi) (BlockNumber bn) +getTip = fmap fromDbValue . selectOne . select $ limit_ 1 (orderBy_ (desc_ . _tipRowSlot) (all_ (tipRows db))) getDatumFromHash :: Member BeamEffect effs => DatumHash -> Eff effs (Maybe Datum) -getDatumFromHash (DatumHash (BuiltinByteString dh)) = - queryOne . select $ _datumRowDatum <$> filter_ (\row -> _datumRowHash row ==. val_ dh) (all_ (datumRows db)) +getDatumFromHash = queryOne . queryKeyValue datumRows _datumRowHash _datumRowDatum getTxFromTxId :: Member BeamEffect effs => TxId -> Eff effs (Maybe ChainIndexTx) -getTxFromTxId (TxId (BuiltinByteString txId)) = - queryOne . select $ _txRowTx <$> filter_ (\row -> _txRowTxId row ==. val_ txId) (all_ (txRows db)) +getTxFromTxId = queryOne . queryKeyValue txRows _txRowTxId _txRowTx + +getScriptFromHash :: + ( Member BeamEffect effs + , HasDbType i + , DbType i ~ ByteString + , HasDbType o + , DbType o ~ ByteString + ) => i + -> Eff effs (Maybe o) +getScriptFromHash = queryOne . queryKeyValue scriptRows _scriptRowHash _scriptRowScript + +queryKeyValue :: + ( HasDbType key + , HasSqlEqualityCheck Sqlite (DbType key) + , BeamSqlBackendCanSerialize Sqlite (DbType key) + ) => (forall f. Db f -> f (TableEntity table)) + -> (forall f. table f -> Columnar f (DbType key)) + -> (forall f. table f -> Columnar f value) + -> key + -> SqlSelect Sqlite value +queryKeyValue table getKey getValue (toDbValue -> key) = + select $ getValue <$> filter_ (\row -> getKey row ==. val_ key) (all_ (table db)) + +queryOne :: + ( Member BeamEffect effs + , HasDbType o + ) => SqlSelect Sqlite (DbType o) + -> Eff effs (Maybe o) +queryOne = fmap (fmap fromDbValue) . selectOne + +queryList :: + ( Member BeamEffect effs + , HasDbType o + ) => SqlSelect Sqlite (DbType o) + -> Eff effs [o] +queryList = fmap (fmap fromDbValue) . selectList -- | Get the 'ChainIndexTxOut' for a 'TxOutRef'. getTxOutFromRef :: @@ -159,14 +179,14 @@ getTxOutFromRef ref@TxOutRef{txOutRefId, txOutRefIdx} = do case addressCredential $ txOutAddress txout of PubKeyCredential _ -> pure $ Just $ PublicKeyChainIndexTxOut (txOutAddress txout) (txOutValue txout) - ScriptCredential (ValidatorHash vh) -> do + ScriptCredential vh -> do case txOutDatumHash txout of Nothing -> do -- If the txout comes from a script address, the Datum should not be Nothing logWarn $ NoDatumScriptAddr txout pure Nothing Just dh -> do - v <- maybe (Left (ValidatorHash vh)) Right <$> queryOneScript vh + v <- maybe (Left vh) Right <$> getScriptFromHash vh d <- maybe (Left dh) Right <$> getDatumFromHash dh pure $ Just $ ScriptChainIndexTxOut (txOutAddress txout) v d (txOutValue txout) @@ -179,7 +199,7 @@ getUtxoSetAtAddress => PageQuery TxOutRef -> Credential -> Eff effs (Tip, Page TxOutRef) -getUtxoSetAtAddress pageQuery cred = do +getUtxoSetAtAddress pageQuery (toDbValue -> cred) = do utxoState <- gets @ChainIndexState UtxoState.utxoState case UtxoState.tip utxoState of @@ -189,42 +209,18 @@ getUtxoSetAtAddress pageQuery cred = do tp -> do let query = fmap _addressRowOutRef - $ filter_ (\row -> _addressRowCred row ==. val_ (toByteString cred)) + $ filter_ (\row -> _addressRowCred row ==. val_ cred) $ do utxo <- all_ (unspentOutputRows db) a <- all_ (addressRows db) guard_ (_addressRowOutRef a ==. _unspentOutputRowOutRef utxo) pure a - outRefs <- selectPage (fmap toByteString pageQuery) query - let page = fmap fromByteString outRefs + outRefs <- selectPage (fmap toDbValue pageQuery) query + let page = fmap fromDbValue outRefs pure (tp, page) -queryOneScript :: - ( Member BeamEffect effs - , Serialise a - ) => BuiltinByteString - -> Eff effs (Maybe a) -queryOneScript (BuiltinByteString hash) = - queryOne . select $ _scriptRowScript <$> filter_ (\row -> _scriptRowHash row ==. val_ hash) (all_ (scriptRows db)) - -queryOne :: - ( Member BeamEffect effs - , Serialise a - ) => SqlSelect Sqlite ByteString - -> Eff effs (Maybe a) -queryOne = fmap (fmap fromByteString) . selectOne - -fromByteString :: Serialise a => ByteString -> a -fromByteString - = fromRight (error "Deserialisation failed. Delete you chain index database and resync.") - . deserialiseOrFail - . BSL.fromStrict - -toByteString :: Serialise a => a -> ByteString -toByteString = BSL.toStrict . serialise - handleControl :: forall effs. ( Member (State ChainIndexState) effs @@ -295,18 +291,18 @@ insertUtxoDb :: => UtxoState.UtxoState TxUtxoBalance -> Eff effs () insertUtxoDb (UtxoState.UtxoState _ TipAtGenesis) = throwError $ InsertionFailed UtxoState.InsertUtxoNoTip -insertUtxoDb (UtxoState.UtxoState (TxUtxoBalance outputs inputs) (Tip sl (BlockId bi) (BlockNumber bn))) +insertUtxoDb (UtxoState.UtxoState (TxUtxoBalance outputs inputs) tip) = insert $ mempty - { tipRows = InsertRows [TipRow (fromIntegral sl) bi bn] - , unspentOutputRows = InsertRows $ UnspentOutputRow tipRowId . toByteString <$> Set.toList outputs - , unmatchedInputRows = InsertRows $ UnmatchedInputRow tipRowId . toByteString <$> Set.toList inputs + { tipRows = InsertRows $ catMaybes [toDbValue tip] + , unspentOutputRows = InsertRows $ UnspentOutputRow tipRowId . toDbValue <$> Set.toList outputs + , unmatchedInputRows = InsertRows $ UnmatchedInputRow tipRowId . toDbValue <$> Set.toList inputs } where - tipRowId = TipRowId (fromIntegral sl) + tipRowId = TipRowId (toDbValue (tipSlot tip)) reduceOldUtxoDb :: Member BeamEffect effs => Tip -> Eff effs () reduceOldUtxoDb TipAtGenesis = pure () -reduceOldUtxoDb (Tip slotNo _ _) = do +reduceOldUtxoDb (Tip (toDbValue -> slot) _ _) = do -- Delete all the tips before 'slot' deleteRows $ delete (tipRows db) (\row -> _tipRowSlot row <. val_ slot) -- Assign all the older utxo changes to 'slot' @@ -328,16 +324,13 @@ reduceOldUtxoDb (Tip slotNo _ _) = do (unTipRowId (_unmatchedInputRowTip input) ==. val_ slot) &&. (_unspentOutputRowOutRef output ==. _unmatchedInputRowOutRef input)) (all_ (unmatchedInputRows db)))) - where - slot :: Word64 - slot = fromIntegral slotNo rollbackUtxoDb :: Member BeamEffect effs => Point -> Eff effs () rollbackUtxoDb PointAtGenesis = deleteRows $ delete (tipRows db) (const (val_ True)) -rollbackUtxoDb (Point slot _) = do - deleteRows $ delete (tipRows db) (\row -> _tipRowSlot row >. val_ (fromIntegral slot)) - deleteRows $ delete (unspentOutputRows db) (\row -> unTipRowId (_unspentOutputRowTip row) >. val_ (fromIntegral slot)) - deleteRows $ delete (unmatchedInputRows db) (\row -> unTipRowId (_unmatchedInputRowTip row) >. val_ (fromIntegral slot)) +rollbackUtxoDb (Point (toDbValue -> slot) _) = do + deleteRows $ delete (tipRows db) (\row -> _tipRowSlot row >. val_ slot) + deleteRows $ delete (unspentOutputRows db) (\row -> unTipRowId (_unspentOutputRowTip row) >. val_ slot) + deleteRows $ delete (unmatchedInputRows db) (\row -> unTipRowId (_unmatchedInputRowTip row) >. val_ slot) data InsertRows te where InsertRows :: BeamableSqlite t => [t Identity] -> InsertRows (TableEntity t) @@ -352,29 +345,23 @@ insert = getAp . getConst . zipTables Proxy (\tbl (InsertRows rows) -> Const $ A fromTx :: ChainIndexTx -> Db InsertRows fromTx tx = mempty - { datumRows = fromMap citxData DatumRow - , scriptRows = mconcat - [ fromMap citxScripts ScriptRow - , fromMap citxRedeemers ScriptRow - ] - , txRows = InsertRows [TxRow (PlutusTx.fromBuiltin $ getTxId $ _citxTxId tx) (toByteString tx)] - , addressRows = fromPairs (fmap credential . txOutsWithRef) AddressRow + { datumRows = fromMap citxData + , scriptRows = fromMap citxScripts <> fromMap citxRedeemers + , txRows = InsertRows [toDbValue (_citxTxId tx, tx)] + , addressRows = fromPairs (fmap credential . txOutsWithRef) } where credential (TxOut{txOutAddress=Address{addressCredential}}, ref) = (addressCredential, ref) fromMap - :: (BeamableSqlite t, Serialise k, Serialise v) - => Lens' ChainIndexTx (Map.Map k v) - -> (ByteString -> ByteString -> t Identity) - -> InsertRows (TableEntity t) + :: (BeamableSqlite t, HasDbType (k, v), DbType (k, v) ~ t Identity) + => Lens' ChainIndexTx (Map.Map k v) + -> InsertRows (TableEntity t) fromMap l = fromPairs (Map.toList . view l) fromPairs - :: (BeamableSqlite t, Serialise k, Serialise v) - => (ChainIndexTx - -> [(k, v)]) - -> (ByteString -> ByteString -> t Identity) - -> InsertRows (TableEntity t) - fromPairs l mkRow = InsertRows . fmap (\(k, v) -> mkRow (toByteString k) (toByteString v)) . l $ tx + :: (BeamableSqlite t, HasDbType (k, v), DbType (k, v) ~ t Identity) + => (ChainIndexTx -> [(k, v)]) + -> InsertRows (TableEntity t) + fromPairs l = InsertRows . fmap toDbValue . l $ tx diagnostics :: @@ -383,7 +370,7 @@ diagnostics :: ) => Eff effs Diagnostics diagnostics = do numTransactions <- selectOne . select $ aggregate_ (const countAll_) (all_ (txRows db)) - txIds <- selectList . select $ _txRowTxId <$> limit_ 10 (all_ (txRows db)) + txIds <- queryList . select $ _txRowTxId <$> limit_ 10 (all_ (txRows db)) numScripts <- selectOne . select $ aggregate_ (const countAll_) (all_ (scriptRows db)) numAddresses <- selectOne . select $ aggregate_ (const countAll_) $ nub_ $ _addressRowCred <$> all_ (addressRows db) TxUtxoBalance outputs inputs <- UtxoState._usTxUtxoData . UtxoState.utxoState <$> get @ChainIndexState @@ -394,5 +381,5 @@ diagnostics = do , numAddresses = fromMaybe (-1) numAddresses , numUnspentOutputs = length outputs , numUnmatchedInputs = length inputs - , someTransactions = fmap (TxId . BuiltinByteString) txIds + , someTransactions = txIds }