Skip to content

Commit

Permalink
Inline ChainPointRow
Browse files Browse the repository at this point in the history 
It's only used internally in the implementation and the to/from
json/sqlite instances aren't really required.
  • Loading branch information
@eyeinsky
eyeinsky committed Jun 2, 2023
1 parent ab02d33 commit e393948
Show file tree
Hide file tree
Showing 3 changed files with 52 additions and 114 deletions.
155 changes: 47 additions & 108 deletions marconi-chain-index/src/Marconi/ChainIndex/Indexers/Utxo.hs
View file
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
Expand Down Expand Up @@ -39,7 +40,7 @@ module Marconi.ChainIndex.Indexers.Utxo where

import Control.Concurrent.Async (concurrently_)
import Control.Exception (bracket_)
import Control.Lens.Combinators (Lens', Traversal', _Just, imap, preview, view)
import Control.Lens.Combinators (Traversal', _Just, imap, preview, view)
import Control.Lens.Operators ((&), (.~), (^.))
import Control.Lens.TH (makeLenses)
import Control.Monad (guard, when)
Expand All @@ -58,9 +59,9 @@ import Data.Set qualified as Set
import Data.Text (pack)
import Data.Text qualified as Text
import Data.Word (Word64)
import Database.SQLite.Simple (NamedParam ((:=)), ResultError (UnexpectedNull))
import Database.SQLite.Simple (NamedParam ((:=)))
import Database.SQLite.Simple qualified as SQL
import Database.SQLite.Simple.FromRow (FromRow (fromRow), field, fieldWith)
import Database.SQLite.Simple.FromRow (FromRow (fromRow), field)
import Database.SQLite.Simple.ToField (ToField (toField), toField)
import Database.SQLite.Simple.ToRow (ToRow (toRow))
import GHC.Generics (Generic)
Expand All @@ -70,14 +71,12 @@ import Text.RawString.QQ (r)
import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as C
import Data.Ord (Down (Down, getDown))
import Marconi.ChainIndex.Orphans ()
import Marconi.ChainIndex.Types (TargetAddresses, TxIndexInBlock, TxOut, pattern CurrentEra)
import Marconi.ChainIndex.Utils (chainPointOrGenesis)

import Database.SQLite.Simple.FromField (returnError)
import Marconi.ChainIndex.Error (IndexerError (CantInsertEvent, CantQueryIndexer, CantRollback, CantStartIndexer, InvalidQueryInterval),
liftSQLError)
import Marconi.ChainIndex.Extract.Datum qualified as Datum
import Marconi.ChainIndex.Orphans ()
import Marconi.ChainIndex.Types (TargetAddresses, TxIndexInBlock, TxOut, pattern CurrentEra)
import Marconi.ChainIndex.Utils (chainPointOrGenesis)
import Marconi.Core.Storable (Buffered (getStoredEvents, persistToStorage), HasPoint, Queryable (queryStorage),
Resumable (resumeFromStorage), Rewindable (rewindStorage), StorableEvent, StorableMonad,
StorablePoint, StorableQuery, StorableResult, emptyState)
Expand Down Expand Up @@ -217,86 +216,55 @@ instance ToJSON Utxo where
, "txIndexInBlock" .= (u ^. txIndexInBlock)
]

data ChainPointRow
= ChainPointRow { _cpSlotNo :: C.SlotNo, _cpBlockHash :: C.Hash C.BlockHeader }
deriving (Show, Eq, Ord, Generic)

$(makeLenses ''ChainPointRow)

toChainPointRow :: C.ChainPoint -> Maybe ChainPointRow
toChainPointRow cp = ChainPointRow <$> C.chainPointToSlotNo cp <*> C.chainPointToHeaderHash cp

instance FromJSON ChainPointRow where
parseJSON (Object v)
= ChainPointRow
<$> v .: "slotNo"
<*> v .: "blockHeaderHash"
parseJSON _ = mempty

instance ToJSON ChainPointRow where
toJSON c
= object
[ "slotNo" .= view cpSlotNo c
, "blockHeaderHash" .= view cpBlockHash c
]

getChainPoint :: ChainPointRow -> C.ChainPoint
getChainPoint cp = C.ChainPoint (cp ^. cpSlotNo) (cp ^. cpBlockHash)

data SpentInfo
= SpentInfo
{ _siSpentPoint :: ChainPointRow
, _siSpentTxId :: C.TxId
{ _siSlotNo :: C.SlotNo
, _siBlockHeaderHash :: C.Hash C.BlockHeader
, _siSpentTxId :: C.TxId
} deriving (Show, Eq, Ord, Generic)

$(makeLenses ''SpentInfo)

data UtxoRow = UtxoRow
{ _urUtxo :: !Utxo
, _urCreationPoint :: !ChainPointRow
, _urSpentInfo :: !(Maybe SpentInfo)
{ _urUtxo :: !Utxo
, _urSlotNo :: !C.SlotNo
, _urBlockHeaderHash :: !(C.Hash C.BlockHeader)
, _urSpentInfo :: !(Maybe SpentInfo)
} deriving (Show, Eq, Ord, Generic)

$(makeLenses ''UtxoRow)

urSpentSlotNo :: Traversal' UtxoRow C.SlotNo
urSpentSlotNo = urSpentInfo . _Just . siSpentPoint . cpSlotNo

urCreationSlotNo :: Lens' UtxoRow C.SlotNo
urCreationSlotNo = urCreationPoint . cpSlotNo

urCreationBlockHash :: Lens' UtxoRow (C.Hash C.BlockHeader)
urCreationBlockHash = urCreationPoint . cpBlockHash
urSpentSlotNo = urSpentInfo . _Just . siSlotNo

urSpentBlockHash :: Traversal' UtxoRow (C.Hash C.BlockHeader)
urSpentBlockHash = urSpentInfo . _Just . siSpentPoint . cpBlockHash
urSpentBlockHash = urSpentInfo . _Just . siBlockHeaderHash

urSpentTxId :: Traversal' UtxoRow C.TxId
urSpentTxId = urSpentInfo . _Just . siSpentTxId

instance FromJSON UtxoRow where
parseJSON (Object v) = let

parseSpentInfo = do
s <- v .:? "spentSlotNo"
bh <- v .:? "spentBlockHeaderHash"
tId <- v .:? "spentTxId"
pure $ case (s, bh, tId) of
(Nothing, Nothing, Nothing) -> Nothing
(Just s', Just bh', Just txId') -> Just $ SpentInfo (ChainPointRow s' bh') txId'
_error -> fail "Inconsistent spent info"
pure $ if
| Just s' <- s, Just bh' <- bh, Just txId' <- tId -> Just $ SpentInfo s' bh' txId'
| otherwise -> Nothing

in UtxoRow
<$> v .: "utxo"
<*> (ChainPointRow <$> v .: "slotNo" <*> v .: "blockHeaderHash")
<*> v .: "slotNo"
<*> v .: "blockHeaderHash"
<*> parseSpentInfo
parseJSON _ = mempty

instance ToJSON UtxoRow where
toJSON ur = object
[ "utxo" .= view urUtxo ur
, "slotNo" .= view urCreationSlotNo ur
, "blockHeaderHash" .= view urCreationBlockHash ur
, "slotNo" .= _urSlotNo ur
, "blockHeaderHash" .= _urBlockHeaderHash ur
, "spentSlotNo" .= preview urSpentSlotNo ur
, "spentBlockHeaderHash" .= preview urSpentBlockHash ur
, "spentTxId" .= preview urSpentTxId ur
Expand Down Expand Up @@ -387,16 +355,6 @@ instance HasPoint (StorableEvent UtxoHandle) C.ChainPoint where
-- sql mappings --
------------------

instance ToRow ChainPointRow where
toRow c = toRow
[ toField $ c ^. cpSlotNo
, toField $ c ^. cpBlockHash
]


instance FromRow ChainPointRow where
fromRow = ChainPointRow <$> field <*> field

instance ToRow UtxoRow where
toRow u =
let C.TxIn txId txIx = u ^. urUtxo . txIn
Expand All @@ -409,45 +367,25 @@ instance ToRow UtxoRow where
, toField $ u ^. urUtxo . value
, toField $ u ^. urUtxo . inlineScript
, toField $ u ^. urUtxo . inlineScriptHash
, toField $ u ^. urCreationSlotNo
, toField $ u ^. urCreationBlockHash
, toField $ _urSlotNo u
, toField $ _urBlockHeaderHash u
, toField $ u ^. urUtxo . txIndexInBlock
]

-- | Used internally to parse SpentInfo
data SpentInfoRow
= SpentInfoRow !(Maybe C.SlotNo) !(Maybe (C.Hash C.BlockHeader)) !(Maybe C.TxId)

instance FromRow SpentInfoRow where

fromRow = SpentInfoRow <$> field <*> field <*> field

instance FromRow Utxo where
fromRow = Utxo
<$> field
<*> fromRow
<*> field <*> field <*> field <*> field <*> field <*> field

instance FromRow UtxoRow where
fromRow = let

spentInfo Nothing Nothing Nothing = pure Nothing
spentInfo (Just s) (Just bh) (Just tid) = pure $ Just $ SpentInfo (ChainPointRow s bh) tid
spentInfo _ _ _
= fieldWith $ \field' -> returnError
UnexpectedNull
field'
"Invalid spent values: Some fields are null, other aren't"

in do
utxo <- fromRow
created <- fromRow
(SpentInfoRow spentSlot spentBH spentTxId) <- fromRow
info <- spentInfo spentSlot spentBH spentTxId
pure $ UtxoRow utxo created info
fromRow = UtxoRow <$> fromRow <*> field <*> field <*> do
(a, b, c) <- (,,) <$> field <*> field <*> field
if | Just s <- a, Just bh <- b, Just tid <- c -> pure $ Just $ SpentInfo s bh tid
| otherwise -> pure Nothing

instance FromRow SpentInfo where
fromRow = SpentInfo <$> fromRow <*> field
fromRow = SpentInfo <$> field <*> field <*> field

instance FromRow Spent where
fromRow = Spent <$> fromRow <*> fromRow
Expand All @@ -458,8 +396,8 @@ instance ToRow Spent where
in toRow
[ toField txid
, toField txix
, toField $ s ^. sSpentInfo . siSpentPoint . cpSlotNo
, toField $ s ^. sSpentInfo . siSpentPoint . cpBlockHash
, toField $ s ^. sSpentInfo . siSlotNo
, toField $ s ^. sSpentInfo . siBlockHeaderHash
, toField $ s ^. sSpentInfo . siSpentTxId
]

Expand Down Expand Up @@ -509,11 +447,11 @@ open dbPath (Depth k) isToVacuume = do
emptyState k (UtxoHandle c k isToVacuume)

getSpentFrom :: StorableEvent UtxoHandle -> [Spent]
getSpentFrom (UtxoEvent _ txIns cp) = case toChainPointRow cp of
Nothing -> [] -- There are no Spent in the Genesis block
Just c -> do
(txin, spentTxId) <- Map.toList txIns
pure $ Spent txin (SpentInfo c spentTxId)
getSpentFrom (UtxoEvent _ txIns cp) = case cp of
C.ChainPointAtGenesis -> [] -- There are no Spent in the Genesis block
C.ChainPoint slotNo bhh -> do
(txin, spentTxId) <- Map.toList txIns
pure $ Spent txin (SpentInfo slotNo bhh spentTxId)

-- | Store UtxoEvents
-- Events are stored in memory and flushed to SQL, disk, when memory buffer has reached capacity
Expand All @@ -523,11 +461,10 @@ instance Buffered UtxoHandle where
=> f (StorableEvent UtxoHandle) -- ^ events to store
-> UtxoHandle -- ^ handler for storing events
-> StorableMonad UtxoHandle UtxoHandle
persistToStorage events h
persistToStorage events h@(UtxoHandle c _k toVacuume)
= liftSQLError CantInsertEvent $ do
let rows = concatMap eventToRows events
spents = concatMap getSpentFrom events
c = hdlConnection h
bracket_
(SQL.execute_ c "BEGIN")
(SQL.execute_ c "COMMIT")
Expand Down Expand Up @@ -556,7 +493,7 @@ instance Buffered UtxoHandle where
) VALUES
(?, ?, ?, ?, ?)|] spents))
-- We want to perform vacuum about once every 100
when (toVacuume h) $ do
when toVacuume $ do
rndCheck <- createSystemRandom >>= uniformR (1 :: Int, 100)
when (rndCheck == 42) $ do
SQL.execute_ c [r|DELETE FROM
Expand Down Expand Up @@ -663,7 +600,7 @@ rowsToEvents fetchTxIn rows
mkEvent row = UtxoEvent
(Set.singleton $ row ^. urUtxo)
Map.empty
(getChainPoint $ row ^. urCreationPoint)
(C.ChainPoint (_urSlotNo row) (_urBlockHeaderHash row))

newEventWithSpentOnly :: Map C.TxIn C.TxId -> C.ChainPoint -> StorableEvent UtxoHandle
newEventWithSpentOnly = UtxoEvent Set.empty
Expand All @@ -690,7 +627,8 @@ eventToRows (UtxoEvent utxos _ (C.ChainPoint sn bhsh)) = let
eventToRow u =
UtxoRow
{ _urUtxo = u
, _urCreationPoint = ChainPointRow sn bhsh
, _urSlotNo = sn
, _urBlockHeaderHash = bhsh
, _urSpentInfo = Nothing
}
in fmap eventToRow . Set.toList $ utxos
Expand Down Expand Up @@ -753,8 +691,9 @@ eventsAtAddress addr snoInterval events = foldMap go events
&& pointFilter event]

generateSpentInfo :: StorableEvent UtxoHandle -> C.TxId -> Maybe SpentInfo
generateSpentInfo event txid = flip SpentInfo txid
<$> toChainPointRow (ueChainPoint event)
generateSpentInfo event txid = case ueChainPoint event of
C.ChainPoint slotNo bhh -> Just $ SpentInfo slotNo bhh txid
C.ChainPointAtGenesis -> Nothing

getBufferSpent :: StorableEvent UtxoHandle -> Set C.TxIn
getBufferSpent event = if afterUpperBound event
Expand Down Expand Up @@ -856,13 +795,13 @@ instance Queryable UtxoHandle where
(_:_) -> liftSQLError CantQueryIndexer $ do
persisted <- SQL.query c queryLastSlot (SQL.Only (1 :: Word64))
pure . LastSyncPointResult $ case persisted of
p:_ -> getChainPoint p
p:_ -> p
_other -> C.ChainPointAtGenesis
-- 0 element in memory
[] -> liftSQLError CantQueryIndexer $ do
persisted <- SQL.query c queryLastSlot (SQL.Only (2 :: Word64))
pure . LastSyncPointResult $ case persisted of
_:p:_xs -> getChainPoint p
_:p:_xs -> p
_other -> C.ChainPointAtGenesis

instance Rewindable UtxoHandle where
Expand Down
4 changes: 2 additions & 2 deletions marconi-chain-index/test/Spec/Marconi/ChainIndex/Indexers/Utxo/UtxoIndex.hs
View file
Expand Up @@ -5,7 +5,7 @@

module Spec.Marconi.ChainIndex.Indexers.Utxo.UtxoIndex (tests) where

import Control.Lens (filtered, folded, toListOf, view, (^.), (^..))
import Control.Lens (filtered, folded, to, toListOf, view, (^.), (^..))
import Control.Monad (forM, forM_, void)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson qualified as Aeson
Expand Down Expand Up @@ -492,7 +492,7 @@ propUtxoQueryByAddressAndSlotInterval = property $ do
$ openIntervalQuery

let rows :: [Utxo.UtxoRow] = concatMap filterResult openIntervalResult
cps :: [C.SlotNo] = Set.toList . Set.fromList $ rows ^.. folded . Utxo.urCreationPoint . Utxo.cpSlotNo
cps :: [C.SlotNo] = Set.toList . Set.fromList $ rows ^.. folded . to Utxo._urSlotNo
(retrievedLowSlotNo, retrievedHighSlotNo) = (head cps, last cps)
-- Show we did not retrieve any slotNo before the queryInterval [low, ]
Hedgehog.assert (retrievedLowSlotNo >= lowerBoundSlotNo)
Expand Down
7 changes: 3 additions & 4 deletions marconi-sidechain/src/Marconi/Sidechain/Api/Query/Indexers/Utxo.hs
View file
Expand Up @@ -24,8 +24,7 @@ import Data.Text (Text, unpack)
import GHC.Word (Word64)
import Marconi.ChainIndex.Error (IndexerError)
import Marconi.ChainIndex.Indexers.AddressDatum (StorableQuery)
import Marconi.ChainIndex.Indexers.Utxo (address, datum, datumHash, txIn, urCreationBlockHash, urCreationSlotNo,
urSpentSlotNo, urSpentTxId, urUtxo)
import Marconi.ChainIndex.Indexers.Utxo (address, datum, datumHash, txIn, urSpentSlotNo, urSpentTxId, urUtxo)
import Marconi.ChainIndex.Indexers.Utxo qualified as Utxo
import Marconi.ChainIndex.Types (TargetAddresses)
import Marconi.Core.Storable qualified as Storable
Expand Down Expand Up @@ -137,8 +136,8 @@ withQueryAction env query =
Right (Utxo.UtxoResult rows) ->
Right $ GetUtxosFromAddressResult $ rows <&> \row ->
AddressUtxoResult
(row ^. urCreationBlockHash)
(row ^. urCreationSlotNo)
(Utxo._urBlockHeaderHash row)
(Utxo._urSlotNo row)
(row ^. urUtxo . txIn)
(row ^. urUtxo . address)
(row ^. urUtxo . datumHash)
Expand Down

0 comments on commit e393948

Please sign in to comment.