PLT-662 Added Address->Datum indexer in Marconi Indexes all datums for a given a… - input-output-hk/plutus-apps@f9d2c64c - Cardano Updates

Home / Input Output / plutus-apps / f9d2c64c

View on GitHub

File Changes

m

marconi/app/Main.hs

+1/-0

  c <- defaultConfigStdout

  withTrace c "marconi" $ \trace -> do

    let indexers = filterIndexers (Cli.utxoDbPath o)

+

                                  (Cli.addressDatumDbPath o)

                                  (Cli.datumDbPath o)

                                  (Cli.scriptTxDbPath o)

                                  (Cli.epochStakepoolSizeDbPath o)

a

marconi/changelog.d/20230130_140515_konstantinos.lambrou_PLT_662_maconi_address_datum.md

+5/-0

+

### Added

+

+

- Address-Datum indexer: indexes all datums for any given address in Cardano.

+

+

- CLI flag to allow disabling the Address-Datum indexer.

m

marconi/marconi.cabal

+11/-2

  hs-source-dirs:  src

  exposed-modules:

    Marconi.CLI

+

    Marconi.Index.AddressDatum

    Marconi.Index.Datum

    Marconi.Index.EpochStakepoolSize

    Marconi.Index.ScriptTx

    EpochStakepoolSize

    Helpers

    Integration

+

    Spec.Marconi.Index.AddressDatum

+

    Spec.Marconi.Index.AddressDatum.AddressDatumIndex

+

    Spec.Marconi.Index.AddressDatum.AddressDatumIndexEvent

+

    Spec.Marconi.Index.AddressDatum.Generators

+

    Spec.Marconi.Index.AddressDatum.Utils

    Spec.Utxo

  --------------------

  --------------------------

  build-depends:

    , cardano-api:{cardano-api, gen}

+

    , cardano-binary

+

    , cardano-crypto-class

+

    , cardano-ledger-core

    , cardano-testnet

    , iohk-monitoring

    , ouroboros-network

+

    , plutus-core

    , plutus-ledger-api

    , plutus-tx

    , plutus-tx-plugin

  build-depends:

    , aeson

    , async

-

    , base                  >=4.9 && <5

+

    , base             >=4.9 && <5

    , bytestring

    , containers

    , directory

    , filepath

    , hedgehog

    , hedgehog-extras

    , lens

-

    , optparse-applicative

    , prettyprinter

    , serialise

    , sqlite-simple

m

marconi/src/Marconi/CLI.hs

+12/-0

    , optionsParser

    , parseOptions

    , utxoDbPath

+

    , addressDatumDbPath

    , datumDbPath

    , scriptTxDbPath

    , epochStakepoolSizeDbPath

    optionsChainPoint           :: ChainPoint,

    optionsDbPath               :: FilePath,    -- ^ SQLite database directory path

    optionsDisableUtxo          :: Bool,

+

    optionsDisableAddressDatum  :: Bool,

    optionsDisableDatum         :: Bool,

    optionsDisableScript        :: Bool,

    optionsDisableStakepoolSize :: Bool,

                      <> Opt.help "disable utxo indexers."

                      <> Opt.showDefault

+

    <*> Opt.switch (Opt.long "disable-address-datum"

+

                      <> Opt.help "disable address->datum indexers."

+

                      <> Opt.showDefault

+

    <*> Opt.switch (Opt.long "disable-datum"

                      <> Opt.help "disable datum indexers."

                      <> Opt.showDefault

utxoDbName :: FilePath

utxoDbName = "utxo.db"

+

addressDatumDbName :: FilePath

+

addressDatumDbName = "addressdatum.db"

+

datumDbName :: FilePath

datumDbName = "datum.db"

utxoDbPath :: Options -> Maybe FilePath

utxoDbPath o = if optionsDisableUtxo o then Nothing; else Just (optionsDbPath o </> utxoDbName)

+

addressDatumDbPath :: Options -> Maybe FilePath

+

addressDatumDbPath o = if optionsDisableAddressDatum o then Nothing; else Just (optionsDbPath o </> addressDatumDbName)

+

datumDbPath :: Options -> Maybe FilePath

datumDbPath o = if optionsDisableDatum o then Nothing; else Just (optionsDbPath o </> datumDbName)

a

marconi/src/Marconi/Index/AddressDatum.hs

+517/-0

+

{-# LANGUAGE DerivingStrategies #-}

+

{-# LANGUAGE FlexibleInstances  #-}

+

{-# LANGUAGE GADTs              #-}

+

{-# LANGUAGE NamedFieldPuns     #-}

+

{-# LANGUAGE OverloadedStrings  #-}

+

{-# LANGUAGE QuasiQuotes        #-}

+

{-# LANGUAGE TemplateHaskell    #-}

+

{-# LANGUAGE TupleSections      #-}

+

+

-- | Module for indexing the datums for all addresses in the Cardano blockchain.

+

+

-- This module will create the SQL tables:

+

+

-- + table: address_datums

+

--

+

-- @

+

--    |---------+------------+---------+------------|

+

--    | address | datum_hash | slot_no | block_hash |

+

--    |---------+------------+---------+------------|

+

-- @

+

--

+

-- + table: datumhash_datum

+

--

+

-- @

+

--    |------------+-------|

+

--    | datum_hash | datum |

+

--    |------------+-------|

+

-- @

+

+

-- To create these tables, we extract all transactions outputs from each transactions fetched with

+

-- the chain-sync protocol of the local node.

+

+

-- Here is a synopsis of the indexing algorithm.

+

+

-- Each transaction output contains an address along with an optional datum hash or an optional inline

+

-- datum (actual datum).

+

-- In the inline datum scenario, we simply create an entry in the `address_datums` table with the hash

+

-- of the datum, and add an entry in the `datumhash_datum` table.

+

-- In the datum hash scenario, we create an entry in the `address_datums` table, but not in the

+

-- `datumhash_datum` table, as we don't know the actual value of the datum and we can't infer it from

+

-- the hash.

+

-- In that last scenario, we can resolve in the datum hash in one of three ways (which we then simply

+

-- add an entry in the `datumhash_datum` table):

+

--

+

--     * a different transaction output has an inline datum with that same hash

+

--

+

--     * a datum with that same hash has been found in the in transaction body

+

--

+

--     * a datum with that same hash was included in the witnesses for a Plutus spending script

+

--     which was included in the transaction body

+

--

+

module Marconi.Index.AddressDatum

+

  ( -- * AddressDatumIndex

+

    AddressDatumIndex

+

  , AddressDatumHandle

+

  , StorableEvent(..)

+

  , StorableQuery(..)

+

  , StorableResult(..)

+

  , toAddressDatumIndexEvent

+

  , AddressDatumQuery

+

  , AddressDatumResult

+

  , AddressDatumDepth (..)

+

  , open

+

  ) where

+

+

import Cardano.Api qualified as C

+

import Cardano.Api.Shelley qualified as C

+

import Cardano.Ledger.Alonzo.TxWitness qualified as Ledger

+

import Control.Applicative ((<|>))

+

import Control.Monad (forM, forM_)

+

import Data.Foldable (Foldable (foldl'), fold, toList)

+

import Data.List.NonEmpty (NonEmpty)

+

import Data.List.NonEmpty qualified as NonEmpty

+

import Data.Map.Strict (Map)

+

import Data.Map.Strict qualified as Map

+

import Data.Maybe (catMaybes, listToMaybe, mapMaybe)

+

import Data.Set (Set)

+

import Data.Set qualified as Set

+

import Database.SQLite.Simple qualified as SQL

+

import Database.SQLite.Simple.ToField qualified as SQL

+

import GHC.Generics (Generic)

+

import Marconi.Orphans ()

+

import RewindableIndex.Storable (Buffered (persistToStorage), HasPoint (getPoint),

+

                                 QueryInterval (QEverything, QInterval), Queryable (queryStorage), Resumable,

+

                                 Rewindable (rewindStorage), StorableEvent, StorableMonad, StorablePoint, StorableQuery,

+

                                 StorableResult, emptyState, filterWithQueryInterval)

+

import RewindableIndex.Storable qualified as Storable

+

import Text.RawString.QQ (r)

+

+

-- | Define the `handler` data type, meant as a wrapper for the connection type (in this case the

+

-- SQLite connection). In this indexer, we also add the number of events that we want to return from

+

-- the on-disk buffer.

+

data AddressDatumHandle = AddressDatumHandle

+

    { addressDatumHandleConnection :: SQL.Connection

+

    , _addressDatumHandleDiskStore :: Int

+

+

+

type instance StorableMonad AddressDatumHandle = IO

+

+

-- | 'StorableEvent AddressDatumHandle is the type of events. Events are the data atoms that the

+

-- indexer consumes.

+

-- They depend on the `handle` because they need to eventually be persisted in the database, so the

+

-- database has to be able to accomodate them.

+

+

-- We store the datum hashes of each address that we processed.

+

-- Then we keep a separate 'Map' which stores the actual datum given a datum hash.

+

-- Note that we don't always have the actual datum for a given hash.

+

data instance StorableEvent AddressDatumHandle =

+

    AddressDatumIndexEvent

+

        (Map C.AddressAny (Set (C.Hash C.ScriptData)))

+

        (Map (C.Hash C.ScriptData) C.ScriptData)

+

        !C.ChainPoint

+

    deriving (Eq, Show)

+

+

instance Semigroup (StorableEvent AddressDatumHandle) where

+

    AddressDatumIndexEvent ad1 d1 c1 <> AddressDatumIndexEvent ad2 d2 c2 =

+

        AddressDatumIndexEvent

+

            (Map.unionWith (<>) ad1 ad2)

+

            (Map.union d1 d2)

+

            (max c1 c2)

+

+

instance Monoid (StorableEvent AddressDatumHandle) where

+

    mempty = AddressDatumIndexEvent Map.empty Map.empty C.ChainPointAtGenesis

+

    mappend = (<>)

+

+

type instance StorablePoint AddressDatumHandle = C.ChainPoint

+

+

instance HasPoint (StorableEvent AddressDatumHandle) C.ChainPoint where

+

  getPoint (AddressDatumIndexEvent _ _ s) = s

+

+

data instance StorableQuery AddressDatumHandle =

+

    AllAddressesQuery

+

    | AddressDatumQuery C.AddressAny

+

+

data instance StorableResult AddressDatumHandle =

+

    AllAddressesResult (Set C.AddressAny)

+

  | AddressDatumResult (Set C.ScriptData)

+

    deriving (Eq, Show)

+

+

type AddressDatumQuery = StorableQuery AddressDatumHandle

+

type AddressDatumResult = StorableResult AddressDatumHandle

+

+

type AddressDatumIndex = Storable.State AddressDatumHandle

+

+

newtype AddressDatumDepth = AddressDatumDepth Int

+

+

-- * SQLite

+

+

data AddressDatumHashRow = AddressDatumHashRow

+

  { addressDatumRowAddress   :: !C.AddressAny

+

  , addressDatumRowDatumHash :: !(C.Hash C.ScriptData)

+

  , addressDatumRowSlot      :: !C.SlotNo

+

  , addressDatumRowBlockHash :: !(C.Hash C.BlockHeader)

+

  } deriving (Show, Generic)

+

+

instance SQL.ToRow AddressDatumHashRow where

+

  toRow (AddressDatumHashRow addr d slotNo blockHash) =

+

      [ SQL.toField addr

+

      , SQL.toField d

+

      , SQL.toField slotNo

+

      , SQL.toField blockHash

+

+

+

deriving anyclass instance SQL.FromRow AddressDatumHashRow

+

+

data DatumRow = DatumRow

+

    { datumRowDatumHash :: C.Hash C.ScriptData

+

    , datumRowDatum     :: C.ScriptData

+

    } deriving (Show, Generic)

+

+

instance SQL.ToRow DatumRow where

+

  toRow (DatumRow dh d) = [SQL.toField dh, SQL.toField d]

+

+

deriving anyclass instance SQL.FromRow DatumRow

+

+

toAddressDatumIndexEvent

+

    :: Maybe (C.Address C.ShelleyAddr -> Bool)

+

    -> [C.Tx era]

+

    -> C.ChainPoint

+

    -> StorableEvent AddressDatumHandle

+

toAddressDatumIndexEvent addressFilter txs chainPoint = do

+

    let datumsPerAddr = getDatumsPerAddressFromTxs

+

        filterFun =

+

            case addressFilter of

+

              Nothing -> id

+

              Just f -> Map.filterWithKey $ \k _ ->

+

                  case k of

+

                      -- Target addresses filter are only shelley addresses. Therefore, is we

+

                      -- encounter Byron addresses with datum, we don't filter them. However, that

+

                      -- is highly improbable as Byron addresses are almost never used anymore.

+

                      C.AddressByron _      -> True

+

                      C.AddressShelley addr -> f addr

+

        filteredDatumsPerAddr = filterFun datumsPerAddr

+

        datumMap = Map.fromList

+

                 $ mapMaybe (\(dh, d) -> fmap (dh,) d)

+

                 $ concatMap (\datums -> Map.toList datums)

+

                 $ Map.elems filteredDatumsPerAddr

+

     in AddressDatumIndexEvent

+

            (fmap Map.keysSet filteredDatumsPerAddr)

m

marconi/src/Marconi/Index/ScriptTx.hs

+3/-18

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE OverloadedStrings          #-}

{-# LANGUAGE ScopedTypeVariables        #-}

-

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Marconi.Index.ScriptTx where

import Data.ByteString qualified as BS

import Data.Foldable (foldl', toList)

-

import Data.Functor ((<&>))

-

import Data.Maybe (catMaybes, fromMaybe)

-

import Data.Proxy (Proxy (Proxy))

+

import Data.Maybe (catMaybes)

import Database.SQLite.Simple qualified as SQL

import Database.SQLite.Simple.FromField qualified as SQL

import Database.SQLite.Simple.ToField qualified as SQL

import GHC.Generics (Generic)

-

import Cardano.Api (BlockHeader, ChainPoint (ChainPoint, ChainPointAtGenesis), Hash, SlotNo (SlotNo))

+

import Cardano.Api (BlockHeader, ChainPoint (ChainPoint, ChainPointAtGenesis), Hash, SlotNo)

import Cardano.Api qualified as C

import Cardano.Api.Shelley qualified as Shelley

-- TODO Remove the following dependencies (and also cardano-ledger-*

import Cardano.Ledger.Keys qualified as LedgerShelley

import Cardano.Ledger.Shelley.Scripts qualified as LedgerShelley

import Cardano.Ledger.ShelleyMA.Timelocks qualified as Timelock

+

import Marconi.Orphans ()

import Marconi.Types ()

import RewindableIndex.Storable (Buffered (getStoredEvents, persistToStorage), HasPoint (getPoint),

                                 QueryInterval (QEverything, QInterval), Queryable (queryStorage),

      \b -> maybe cantDeserialise (return . ScriptTxAddress) $ Shelley.deserialiseFromRawBytes Shelley.AsScriptHash b

    where

      cantDeserialise = SQL.returnError SQL.ConversionFailed f "Cannot deserialise address."

-

instance SQL.ToField SlotNo where

-

  toField (SlotNo n) =  SQL.toField (fromIntegral n :: Int)

-

instance SQL.FromField SlotNo where

-

  fromField f = SlotNo <$> SQL.fromField f

instance SQL.ToRow ScriptTxRow where

  toRow o = [ SQL.toField $ scriptAddress o

deriving instance SQL.FromRow ScriptTxRow

-

instance SQL.ToField (Hash BlockHeader) where

-

  toField f = SQL.toField $ C.serialiseToRawBytes f

-

-

instance SQL.FromField (Hash BlockHeader) where

-

   fromField f =

-

      SQL.fromField f <&>

-

        fromMaybe (error "Cannot deserialise block hash") .

-

          C.deserialiseFromRawBytes (C.proxyToAsType Proxy)

-

-- * Indexer

type Query  = StorableQuery  ScriptTxHandle

m

marconi/src/Marconi/Index/Utxo.hs

+10/-109

{-# LANGUAGE TemplateHaskell      #-}

{-# LANGUAGE UndecidableInstances #-}

-

{-# OPTIONS_GHC -Wno-orphans #-}

-

{-# OPTIONS_GHC -Wno-name-shadowing #-}

-

{-

-- | Back-end support for Utxo Indexer

import Control.Lens.Operators ((^.))

import Control.Lens.TH (makeLenses)

import Control.Monad (unless, when)

-

import Data.Aeson (eitherDecode, encode)

-

import Data.ByteString.Lazy (toStrict)

import Data.Foldable (foldl', toList)

import Data.Functor ((<&>))

import Data.List (elemIndex)

import Data.List.NonEmpty (NonEmpty)

-

import Data.Maybe (fromMaybe)

-

import Data.Proxy (Proxy (Proxy))

import Data.Set (Set)

import Data.Set qualified as Set

-

import Database.SQLite.Simple (Only (Only), SQLData (SQLBlob, SQLInteger))

+

import Database.SQLite.Simple (Only (Only))

import Database.SQLite.Simple qualified as SQL

-

import Database.SQLite.Simple.FromField (FromField (fromField), ResultError (ConversionFailed), returnError)

import Database.SQLite.Simple.FromRow (FromRow (fromRow), field)

import Database.SQLite.Simple.ToField (ToField (toField))

import Database.SQLite.Simple.ToRow (ToRow (toRow))

import Cardano.Api ()

import Cardano.Api qualified as C

import "cardano-api" Cardano.Api.Shelley qualified as Shelley

+

import Marconi.Orphans ()

import Marconi.Types (CurrentEra, TargetAddresses, TxOut, pattern CurrentEra)

import RewindableIndex.Storable (Buffered (getStoredEvents, persistToStorage), HasPoint (getPoint),

                                 QueryInterval (QEverything, QInterval), Queryable (queryStorage),

$(makeLenses ''Spent)

instance Ord Spent where

-

  compare l r =

-

      case  (l ^. sTxInTxId) `compare` (r ^. sTxInTxId) of

-

        EQ  -> (l ^. sTxInTxIx) `compare` (r ^. sTxInTxIx)

+

  compare spent spent' =

+

      case  (spent ^. sTxInTxId) `compare` (spent' ^. sTxInTxId) of

+

        EQ  -> (spent ^. sTxInTxIx) `compare` (spent' ^. sTxInTxIx)

        neq -> neq

instance HasPoint (StorableEvent UtxoHandle) C.ChainPoint where

---------------------------------------------------------------------------------

--------------- sql mappings unspent_transactions and Spent tables -------------

---------------------------------------------------------------------------------

-

instance ToField (C.Hash C.BlockHeader) where

-

  toField f = toField $ C.serialiseToRawBytes f

-

-

instance FromField (C.Hash C.BlockHeader) where

-

   fromField f =

-

      fromField f <&>

-

        fromMaybe (error "Cannot deserialise block hash") .

-

          C.deserialiseFromRawBytes (C.proxyToAsType Proxy)

-

-

instance FromRow C.TxIn where

-

  fromRow = C.TxIn <$> field <*> field

-

-

instance ToRow C.TxIn where

-

  toRow (C.TxIn txid txix) = toRow (txid, txix)

-

instance ToRow UtxoRow where

  toRow u =

    [ toField (u ^. urUtxo . address)

                <*> field <*> field <*> field <*> field)

      <*> field <*> field <*> field

-

instance FromField C.AddressAny where

-

  fromField f = fromField f >>= \b -> maybe

-

    cantDeserialise

-

    pure $ C.deserialiseFromRawBytes C.AsAddressAny

-

-

    where

-

      cantDeserialise = returnError SQL.ConversionFailed f "Cannot deserialise address."

-

-

instance ToField C.AddressAny where

-

  toField = SQLBlob . C.serialiseToRawBytes

-

-

instance FromField C.TxId where

-

  fromField f = fromField f >>= maybe

-

    (returnError ConversionFailed f "Cannot deserialise TxId.")

-

    pure . C.deserialiseFromRawBytes (C.proxyToAsType Proxy)

-

-

instance ToField C.TxId where

-

  toField = SQLBlob . C.serialiseToRawBytes

-

-

instance FromField C.TxIx where

-

  fromField = fmap C.TxIx . fromField

-

-

instance ToField C.TxIx where

-

  toField (C.TxIx i) = SQLInteger $ fromIntegral i

-

-

instance FromField (C.Hash C.ScriptData) where

-

  fromField f = fromField f >>= either

-

    (const $ returnError ConversionFailed f "Cannot deserialise ScriptDataHash.")

-

    pure . C.deserialiseFromRawBytesHex (C.proxyToAsType Proxy)

-

-

instance ToField (C.Hash C.ScriptData) where

-

  toField = SQLBlob . C.serialiseToRawBytesHex

-

-

instance FromField C.ScriptData where

-

  fromField f = fromField f >>= either

-

    (const $ returnError ConversionFailed f "Cannot deserialise scriptdata.")

-

    pure . C.deserialiseFromCBOR (C.proxyToAsType Proxy)

-

-

instance ToField C.ScriptData where

-

  toField = SQLBlob . C.serialiseToCBOR

-

-

instance ToField C.Value where

-

  toField = SQLBlob . toStrict . encode

-

-

instance FromField C.Value where

-

  fromField f = fromField f >>= either

-

    (const $ returnError ConversionFailed f "Cannot deserialise value.")

-

    pure . eitherDecode

-

-

instance ToField C.ScriptInAnyLang where

-

  toField = SQLBlob . toStrict . encode

-

-

instance FromField C.ScriptInAnyLang where

-

  fromField f = fromField f >>= either

-

    (const $ returnError ConversionFailed f "Cannot deserialise value.")

-

    pure . eitherDecode

-

-

instance ToField C.ScriptHash where

-

  toField = SQLBlob . C.serialiseToRawBytesHex

-

-

instance FromField C.ScriptHash where

-

  fromField f = fromField f >>= either

-

    (const $ returnError ConversionFailed f "Cannot deserialise scriptDataHash.")

-

    pure . C.deserialiseFromRawBytesHex (C.proxyToAsType Proxy)

-

-

instance FromField C.SlotNo where

-

  fromField f = C.SlotNo <$> fromField f

-

-

instance ToField C.SlotNo where

-

  toField (C.SlotNo s) = SQLInteger $ fromIntegral s

-

-

instance FromField C.BlockNo where

-

  fromField f = C.BlockNo <$> fromField f

-

-

instance ToField C.BlockNo where

-

  toField (C.BlockNo s) = SQLInteger $ fromIntegral s

-

instance FromRow Spent where

  fromRow = Spent <$> field <*> field <*> field <*> field

    findIndex' x xs = elemIndex (ueChainPoint x) (ueChainPoint <$> xs)

    eventFromRow :: UtxoRow -> IO (StorableEvent UtxoHandle)

-

    eventFromRow r = do

-

      ins <- f (C.ChainPoint (r ^. urSlotNo)(r ^. urBlockHash) )

+

    eventFromRow utxoRow = do

+

      ins <- f (C.ChainPoint (utxoRow ^. urSlotNo) (utxoRow ^. urBlockHash) )

      pure $ UtxoEvent

-

        { ueUtxos  = Set.singleton (r ^. urUtxo)

+

        { ueUtxos  = Set.singleton (utxoRow ^. urUtxo)

        , ueInputs = ins

-

        , ueBlockNo = r ^. urBlockNo

-

        , ueChainPoint = C.ChainPoint (r ^. urSlotNo) (r ^. urBlockHash)

+

        , ueBlockNo = utxoRow ^. urBlockNo

+

        , ueChainPoint = C.ChainPoint (utxoRow ^. urSlotNo) (utxoRow ^. urBlockHash)

-- | convert utoEvents to urs

m

marconi/src/Marconi/Indexers.hs

+69/-8

{-# LANGUAGE GADTs                 #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE NamedFieldPuns        #-}

-

{-# LANGUAGE PackageImports        #-}

{-# LANGUAGE ScopedTypeVariables   #-}

{-# LANGUAGE TupleSections         #-}

import Cardano.Api (Block (Block), BlockHeader (BlockHeader), BlockInMode (BlockInMode), CardanoMode,

                    ChainPoint (ChainPoint, ChainPointAtGenesis), Hash, ScriptData, SlotNo, Tx (Tx), chainPointToSlotNo)

import Cardano.Api qualified as C

-

import "cardano-api" Cardano.Api.Shelley qualified as Shelley

+

import Cardano.Api.Shelley qualified as Shelley

import Cardano.Ledger.Alonzo.TxWitness qualified as Alonzo

import Cardano.Streaming (ChainSyncEvent (RollBackward, RollForward))

import Cardano.Streaming qualified as CS

+

import Marconi.Index.AddressDatum (AddressDatumDepth (AddressDatumDepth), AddressDatumHandle, AddressDatumIndex)

+

import Marconi.Index.AddressDatum qualified as AddressDatum

import Marconi.Index.Datum (DatumIndex)

import Marconi.Index.Datum qualified as Datum

import Marconi.Index.EpochStakepoolSize qualified as EpochStakepoolSize

  void . forkIO $ loop

  readMVar ix >>= Storable.resumeFromStorage . view Storable.handle

+

addressDatumWorker

+

  :: (Storable.StorableEvent AddressDatumHandle -> IO [()])

+

  -> Maybe TargetAddresses

+

  -> Worker

+

addressDatumWorker onInsert targetAddresses coordinator path = do

+

  workerChannel <- atomically . dupTChan $ _channel coordinator

+

  (loop, ix) <-

+

      addressDatumWorker_

+

        onInsert

+

        targetAddresses

+

        (AddressDatumDepth 2160)

+

        coordinator

+

        workerChannel

+

        path

+

  void . forkIO $ loop

+

  readMVar ix >>= Storable.resumeFromStorage . view Storable.handle

+

+

addressDatumWorker_

+

    :: (Storable.StorableEvent AddressDatumHandle -> IO [()])

+

    -> Maybe TargetAddresses  -- ^ Target addresses to filter for

+

    -> AddressDatumDepth

+

    -> Coordinator

+

    -> TChan (ChainSyncEvent (BlockInMode CardanoMode))

+

    -> FilePath

+

    -> IO (IO (), MVar AddressDatumIndex)

+

addressDatumWorker_ onInsert targetAddresses depth Coordinator{_barrier} ch path = do

+

    index <- AddressDatum.open path depth

+

    mIndex <- newMVar index

+

    pure (innerLoop mIndex, mIndex)

+

  where

+

    innerLoop :: MVar AddressDatumIndex -> IO ()

+

    innerLoop index = do

+

      signalQSemN _barrier 1

+

      event <- atomically $ readTChan ch

+

      case event of

+

        RollForward (BlockInMode (Block (BlockHeader slotNo bh _) txs) _) _ -> do

+

            -- TODO Redo. Inefficient filtering

+

            let addressFilter = case targetAddresses of

+

                    Just targetAddrs -> Just $ \addr ->  addr `elem` targetAddrs

+

                    _                -> Nothing -- no filtering is applied

+

                addressDatumIndexEvent =

+

                    AddressDatum.toAddressDatumIndexEvent addressFilter txs (C.ChainPoint slotNo bh)

+

            modifyMVar_ index (Storable.insert addressDatumIndexEvent)

+

            void $ onInsert addressDatumIndexEvent

+

            innerLoop index

+

        RollBackward cp _ct -> do

+

          modifyMVar_ index $ \ix -> fromMaybe ix <$> Storable.rewind cp ix

+

          innerLoop index

scriptTxWorker_

  :: (Storable.StorableEvent ScriptTx.ScriptTxHandle -> IO [()])

  -> ScriptTx.Depth

-

  -> Coordinator -> TChan (ChainSyncEvent (BlockInMode CardanoMode)) -> FilePath -> IO (IO (), MVar ScriptTx.ScriptTxIndexer)

+

  -> Coordinator

+

  -> TChan (ChainSyncEvent (BlockInMode CardanoMode))

+

  -> FilePath

+

  -> IO (IO (), MVar ScriptTx.ScriptTxIndexer)

scriptTxWorker_ onInsert depth Coordinator{_barrier} ch path = do

  indexer <- ScriptTx.open path depth

  mIndexer <- newMVar indexer

  -> Maybe FilePath

  -> Maybe FilePath

  -> Maybe FilePath

+

  -> Maybe FilePath

  -> Maybe TargetAddresses

  -> Maybe FilePath

  -> [(Worker, FilePath)]

-

filterIndexers utxoPath datumPath scriptTxPath epochStakepoolSizePath maybeTargetAddresses maybeConfigPath =

+

filterIndexers

+

    utxoPath

+

    addressDatumPath

+

    datumPath

+

    scriptTxPath

+

    epochStakepoolSizePath

+

    maybeTargetAddresses

+

    maybeConfigPath =

  mapMaybe liftMaybe pairs

  where

    liftMaybe (worker, maybePath) = case maybePath of

      _               -> []

    pairs =

-

      [(utxoWorker (\_ -> pure ()) maybeTargetAddresses, utxoPath)

-

      , (datumWorker, datumPath)

-

      , (scriptTxWorker (\_ -> pure []), scriptTxPath)

-

      ] <> epochStakepoolSizeIndexer

+

        [ (utxoWorker (\_ -> pure ()) maybeTargetAddresses, utxoPath)

+

        , (addressDatumWorker (\_ -> pure []) maybeTargetAddresses, addressDatumPath)

+

        , (datumWorker, datumPath)

+

        , (scriptTxWorker (\_ -> pure []), scriptTxPath)

+

        ] <> epochStakepoolSizeIndexer

startIndexers

  :: [(Worker, FilePath)]

m

marconi/src/Marconi/Orphans.hs

+127/-2

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE OverloadedStrings #-}

+

{-# OPTIONS_GHC -Wno-orphans #-}

module Marconi.Orphans where

import Cardano.Api (BlockHeader, BlockNo (BlockNo), ChainPoint (ChainPoint, ChainPointAtGenesis),

-

                    ChainTip (ChainTip, ChainTipAtGenesis), Hash, SlotNo (SlotNo), serialiseToRawBytesHexText)

+

                    ChainTip (ChainTip, ChainTipAtGenesis), Hash, SlotNo (SlotNo))

+

import Cardano.Api qualified as C

+

import Cardano.Binary (fromCBOR, toCBOR)

+

import Codec.Serialise (Serialise (decode, encode), deserialiseOrFail, serialise)

+

import Data.Aeson qualified as Aeson

+

import Data.ByteString.Lazy (toStrict)

+

import Data.Functor ((<&>))

+

import Data.Maybe (fromMaybe)

+

import Data.Proxy (Proxy (Proxy))

+

import Database.SQLite.Simple qualified as SQL

+

import Database.SQLite.Simple.FromField qualified as SQL

+

import Database.SQLite.Simple.ToField qualified as SQL

import Prettyprinter (Pretty (pretty), (<+>))

instance Pretty ChainTip where

  pretty ChainPointAtGenesis = "ChainPointAtGenesis"

  pretty (ChainPoint sn ha)  = "ChainPoint(" <> pretty sn <> "," <+> pretty ha <> ")"

+

instance Ord ChainPoint where

+

   C.ChainPointAtGenesis <= _                  = True

+

   _ <= C.ChainPointAtGenesis                  = False

+

   (C.ChainPoint sn _) <= (C.ChainPoint sn' _) = sn <= sn'

+

+

-- * C.Hash C.BlockHeader

+

instance Pretty (Hash BlockHeader) where

-

  pretty hash = "BlockHash" <+> pretty (serialiseToRawBytesHexText hash)

+

  pretty hash = "BlockHash" <+> pretty (C.serialiseToRawBytesHexText hash)

+

+

instance SQL.ToField (C.Hash C.BlockHeader) where

+

  toField f = SQL.toField $ C.serialiseToRawBytes f

+

+

instance SQL.FromField (C.Hash C.BlockHeader) where

+

   fromField f =

+

      SQL.fromField f <&>

+

        fromMaybe (error "Cannot deserialise C.Hash C.BlockHeader") .

+

          C.deserialiseFromRawBytes (C.proxyToAsType Proxy)

+

+

-- * C.SlotNo

instance Pretty SlotNo where

  pretty (SlotNo n) = "Slot" <+> pretty n

+

instance SQL.ToField C.SlotNo where

+

  toField (C.SlotNo n) =  SQL.toField (fromIntegral n :: Int)

+

+

instance SQL.FromField C.SlotNo where

+

  fromField f = C.SlotNo <$> SQL.fromField f

+

instance Pretty BlockNo where

  pretty (BlockNo bn) = "BlockNo" <+> pretty bn

+

+

instance SQL.FromField C.BlockNo where

+

  fromField f = C.BlockNo <$> SQL.fromField f

+

+

instance SQL.ToField C.BlockNo where

+

  toField (C.BlockNo s) = SQL.SQLInteger $ fromIntegral s

+

+

-- * C.AddressAny

+

+

instance SQL.FromField C.AddressAny where

+

  fromField f = SQL.fromField f >>= \b -> maybe

+

    cantDeserialise

+

    pure $ C.deserialiseFromRawBytes C.AsAddressAny

+

+

    where

+

      cantDeserialise = SQL.returnError SQL.ConversionFailed f "Cannot deserialise address."

+

+

+

instance SQL.ToField C.AddressAny where

+

  toField = SQL.SQLBlob . C.serialiseToRawBytes

+

+

-- * C.Hash C.ScriptData

+

+

instance SQL.FromField (C.Hash C.ScriptData) where

+

  fromField f = SQL.fromField f >>=

+

    maybe (SQL.returnError SQL.ConversionFailed f "Cannot deserialise C.Hash C.ScriptData.") pure

+

    . C.deserialiseFromRawBytes (C.AsHash C.AsScriptData)

+

+

instance SQL.ToField (C.Hash C.ScriptData) where

+

  toField = SQL.SQLBlob . C.serialiseToRawBytes

+

+

-- * C.ScriptData

+

+

instance Serialise C.ScriptData where

+

  encode = toCBOR

+

  decode = fromCBOR

+

+

instance SQL.FromField C.ScriptData where

+

  fromField f = SQL.fromField f >>=

+

    either (const $ SQL.returnError SQL.ConversionFailed f "Cannot deserialise C.ScriptData.") pure

+

    . deserialiseOrFail

+

+

instance SQL.ToField C.ScriptData where

+

  toField = SQL.SQLBlob . toStrict . serialise

+

+

instance SQL.FromRow C.TxIn where

+

  fromRow = C.TxIn <$> SQL.field <*> SQL.field

+

+

instance SQL.ToRow C.TxIn where

+

  toRow (C.TxIn txid txix) = SQL.toRow (txid, txix)

+

+

instance SQL.FromField C.TxId where

+

  fromField f = SQL.fromField f >>= maybe

+

    (SQL.returnError SQL.ConversionFailed f "Cannot deserialise TxId.")

+

    pure . C.deserialiseFromRawBytes (C.proxyToAsType Proxy)

+

+

instance SQL.ToField C.TxId where

+

  toField = SQL.SQLBlob . C.serialiseToRawBytes

+

+

instance SQL.FromField C.TxIx where

+

  fromField = fmap C.TxIx . SQL.fromField

+

+

instance SQL.ToField C.TxIx where

+

  toField (C.TxIx i) = SQL.SQLInteger $ fromIntegral i

+

+

instance SQL.ToField C.Value where

+

  toField = SQL.SQLBlob . toStrict . Aeson.encode

+

+

instance SQL.FromField C.Value where

+

  fromField f = SQL.fromField f >>= either

+

    (const $ SQL.returnError SQL.ConversionFailed f "Cannot deserialise value.")

+

    pure . Aeson.eitherDecode

+

+

instance SQL.ToField C.ScriptInAnyLang where

+

  toField = SQL.SQLBlob . toStrict . Aeson.encode

+

+

instance SQL.FromField C.ScriptInAnyLang where

+

  fromField f = SQL.fromField f >>= either

+

    (const $ SQL.returnError SQL.ConversionFailed f "Cannot deserialise value.")

+

    pure . Aeson.eitherDecode

+

+

instance SQL.ToField C.ScriptHash where

+

  toField = SQL.SQLBlob . C.serialiseToRawBytesHex

+

+

instance SQL.FromField C.ScriptHash where

+

  fromField f = SQL.fromField f >>= either

+

    (const $ SQL.returnError SQL.ConversionFailed f "Cannot deserialise scriptDataHash.")

+

    pure . C.deserialiseFromRawBytesHex (C.proxyToAsType Proxy)

+

m

marconi/src/Marconi/Types.hs

+0/-7

       ) where

import Cardano.Api qualified as C

-

import Data.List.NonEmpty (NonEmpty)

-

-- | Typre represents non empty list of Bech32 Shelley compatable addresses

type TargetAddresses = NonEmpty (C.Address C.ShelleyAddr)

txOutRef :: C.TxId -> C.TxIx -> C.TxIn

txOutRef = C.TxIn

-

-

instance Ord C.ChainPoint where

-

   C.ChainPointAtGenesis <= _                  = True

-

   _ <= C.ChainPointAtGenesis                  = False

-

   (C.ChainPoint sn _) <= (C.ChainPoint sn' _) = sn <= sn'

m

marconi/test/Spec.hs

+2/-0

import Gen.Cardano.Api.Typed qualified as CGen

import Marconi.Index.ScriptTx qualified as ScriptTx

+

import Spec.Marconi.Index.AddressDatum qualified as AddressDatum

-- See TODO below, import EpochStakepoolSize qualified

import Integration qualified

tests = testGroup "Marconi"

  [ testPropertyNamed "prop_script_hashes_in_tx_match" "getTxBodyScriptsRoundtrip" getTxBodyScriptsRoundtrip

  , Spec.Utxo.tests

+

  , AddressDatum.tests

  , Integration.tests

  -- , EpochStakepoolSize.tests

  -- TODO Enable above when the following PR in cardano-node is merged: https://github.com/input-output-hk/cardano-node/pull/4680/

a

marconi/test/Spec/Marconi/Index/AddressDatum.hs

+14/-0

+

module Spec.Marconi.Index.AddressDatum (tests) where

+

+

import Test.Tasty (TestTree, localOption, testGroup)

+

import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))

+

+

import Spec.Marconi.Index.AddressDatum.AddressDatumIndex qualified as AddressDatumIndex

+

import Spec.Marconi.Index.AddressDatum.AddressDatumIndexEvent qualified as AddressDatumIndexEvent

+

+

tests :: TestTree

+

tests = localOption (HedgehogTestLimit $ Just 200) $

+

    testGroup "Spec.Marconi.Index.AddressDatum"

+

    [ AddressDatumIndexEvent.tests

+

    , AddressDatumIndex.tests

+

a

marconi/test/Spec/Marconi/Index/AddressDatum/AddressDatumIndex.hs

+357/-0

+

{-# LANGUAGE DataKinds         #-}

+

{-# LANGUAGE GADTs             #-}

+

{-# LANGUAGE OverloadedStrings #-}

+

+

module Spec.Marconi.Index.AddressDatum.AddressDatumIndex

+

    ( tests

+

    ) where

+

+

import Cardano.Api qualified as C

+

import Control.Lens ((^.))

+

import Control.Monad (foldM, forM, forM_)

+

import Control.Monad.IO.Class (liftIO)

+

import Data.Foldable (fold)

+

import Data.List qualified as List

+

import Data.Map (Map)

+

import Data.Map qualified as Map

+

import Data.Maybe (fromMaybe, mapMaybe)

+

import Data.Set (Set)

+

import Data.Set qualified as Set

+

import Data.Word (Word64)

+

import Hedgehog (Gen, Property, forAll, property, (===))

+

import Hedgehog qualified

+

import Hedgehog.Gen qualified as Gen

+

import Hedgehog.Range qualified as Range

+

import Marconi.Index.AddressDatum (AddressDatumDepth (AddressDatumDepth), AddressDatumHandle,

+

                                   StorableEvent (AddressDatumIndexEvent),

+

                                   StorableQuery (AddressDatumQuery, AddressDatumQuery, AllAddressesQuery),

+

                                   StorableResult (AddressDatumResult, AllAddressesResult))

+

import Marconi.Index.AddressDatum qualified as AddressDatum

+

import RewindableIndex.Storable qualified as Storable

+

import Spec.Marconi.Index.AddressDatum.Generators (genAddressInEra, genHashBlockHeader, genSimpleScriptData)

+

import Spec.Marconi.Index.AddressDatum.Utils (addressInEraToAddressAny)

+

import Test.Tasty (TestTree, localOption, testGroup)

+

import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit), testPropertyNamed)

+

+

tests :: TestTree

+

tests = localOption (HedgehogTestLimit $ Just 200) $

+

    testGroup "Spec.Marconi.Index.AddressDatum.AddressDatumIndex"

+

    [ testPropertyNamed

+

          "All addresses from generated events are queryable from the index"

+

          "propAllAddressesAreQueryable"

+

          propAllAddressesAreQueryable

+

    , testPropertyNamed

+

          "All addresses from generated events are queryable from the index when specifying a query range within the range of indexed points"

+

          "propAllAddressesAreQueryableInGeneratedRange "

+

          propAllAddressesAreQueryableInGeneratedRange

+

    , testPropertyNamed

+

          "No addresses from generated events are queryable from the index when specifying a query range outside of the range of indexed points"

+

          "propNoAddressQueryableOutsideOfQueryRange "

+

          propNoAddressQueryableOutsideOfQueryRange

+

    , testPropertyNamed

+

          "All datums of each address in generated events are queryable from the index"

+

          "propAddressDatumAreQueryable"

+

          propAddressDatumAreQueryable

+

    , testPropertyNamed

+

          "All datums of each address in generated events are queryable from the index when specifying a queyr range which the range of indexed points"

+

          "propAddressDatumAreQueryableInGeneratedRange"

+

          propAddressDatumAreQueryableInGeneratedRange

+

    , testPropertyNamed

+

          "Rewinding an index to a point which is later than the last indexed point should not alter then index"

+

          "propRewindingWithNewSlotShouldKeepIndexState "

+

          propRewindingWithNewSlotShouldKeepIndexState

+

    , testPropertyNamed

+

          "Rewinding an index to a point which is before than the last indexed point should bring the index to a previous state"

+

          "propRewindingWithOldSlotShouldBringIndexInPreviousState "

+

          propRewindingWithOldSlotShouldBringIndexInPreviousState

+

    , testPropertyNamed

+

          "The points that indexer can be resumed from should return at least the genesis point"

+

          "propResumingShouldReturnAtLeastTheGenesisPoint"

+

          propResumingShouldReturnAtLeastTheGenesisPoint

+

    , testPropertyNamed

+

          "The points that indexer can be resumed from should return at least non-genesis point when some data was indexed on disk"

+

          "propResumingShouldReturnAtLeastOneNonGenesisPointIfStoredOnDisk"

+

          propResumingShouldReturnAtLeastOneNonGenesisPointIfStoredOnDisk

+

+

+

-- | The property verifies that the addresses in those generated events are all queryable from the

+

-- index.

+

propAllAddressesAreQueryable :: Property

+

propAllAddressesAreQueryable = property $ do

+

    cps <- forAll $ genChainPoints 1 5

+

    events <- forAll $ forM cps genAddressDatumStorableEvent

+

    depth <- forAll $ Gen.int (Range.linear 1 $ length cps)

+

    initialIndex <- liftIO $ AddressDatum.open ":memory:" (AddressDatumDepth depth)

+

    finalIndex <- liftIO $ Storable.insertMany events initialIndex

+

    let addrs = Set.fromList

+

              $ concatMap (\(AddressDatumIndexEvent addressDatumMap _ _) ->

+

                  Map.keys addressDatumMap) events

+

    (AllAddressesResult actualAddrs) <- liftIO $ do

+

        Storable.query Storable.QEverything finalIndex AllAddressesQuery

+

    actualAddrs === addrs

+

+

-- | The property verifies that the addresses in those generated events are all queryable from the

+

-- index given a 'C.ChainPoint' interval.

+

--

+

-- TODO: Generate events. Then, partition the events in 'm' partitions. Check for each partition that the

+

-- events can be found in the query result for that interval.

+

propAllAddressesAreQueryableInGeneratedRange :: Property

+

propAllAddressesAreQueryableInGeneratedRange = property $ do

+

    cps <- forAll $ genChainPoints 1 5

+

    events <- forAll $ forM cps genAddressDatumStorableEvent

+

    depth <- forAll $ Gen.int (Range.linear 1 $ length cps)

+

    initialIndex <- liftIO $ AddressDatum.open ":memory:" (AddressDatumDepth depth)

+

    finalIndex <- liftIO $ Storable.insertMany events initialIndex

+

        >>= Storable.insert (AddressDatum.toAddressDatumIndexEvent Nothing [] (head cps))

+

+

    let addrs = Set.fromList

+

              $ concatMap (\(AddressDatumIndexEvent addressDatumMap _ _) ->

+

                  Map.keys addressDatumMap) events

+

+

    (AllAddressesResult actualAddrs) <- liftIO $ do

+

        Storable.query

+

            (Storable.QInterval C.ChainPointAtGenesis (last cps))

+

            finalIndex

+

            AllAddressesQuery

+

    actualAddrs === addrs

+

+

    (AllAddressesResult actualAddrs') <- liftIO $ do

+

        Storable.query

+

            (Storable.QInterval (head cps) C.ChainPointAtGenesis)

+

            finalIndex

+

            AllAddressesQuery

+

    Hedgehog.assert $ Set.null actualAddrs'

+

+

    (AllAddressesResult actualAddrs'') <- liftIO $ do

+

        Storable.query

+

            (Storable.QInterval C.ChainPointAtGenesis C.ChainPointAtGenesis)

+

            finalIndex

+

            AllAddressesQuery

+

    Hedgehog.assert $ Set.null actualAddrs''

+

+

    (AllAddressesResult actualAddrs''') <- liftIO $ do

+

        Storable.query

+

            (Storable.QInterval (head cps) (last cps))

+

            finalIndex

+

            AllAddressesQuery

+

    actualAddrs''' === addrs

+

+

-- | The property verifies that if we query the index with a 'C.ChainPoint' interval outside of the

+

-- range of indexed slots, no addresses are returned.

+

propNoAddressQueryableOutsideOfQueryRange :: Property

+

propNoAddressQueryableOutsideOfQueryRange = property $ do

+

    cps <- forAll $ genChainPoints 2 10

+

    events <- forAll $ forM (init $ init cps) genAddressDatumStorableEvent

+

    depth <- forAll $ Gen.int (Range.linear 1 $ length cps)

+

    initialIndex <- liftIO $ AddressDatum.open ":memory:" (AddressDatumDepth depth)

+

    finalIndex <- liftIO $ Storable.insertMany events initialIndex

+

+

    (AllAddressesResult actualAddrs) <- liftIO $ do

+

        Storable.query

+

            (Storable.QInterval (last $ init cps) (last cps))

+

            finalIndex

+

            AllAddressesQuery

+

    Hedgehog.assert $ Set.null actualAddrs

+

+

-- | The property verifies that the datums of each address in those generated events are all

+

-- queryable from the index.

+

propAddressDatumAreQueryable :: Property

+

propAddressDatumAreQueryable = property $ do

+

    cps <- forAll $ genChainPoints 1 5

+

    events <- forAll $ forM cps genAddressDatumStorableEvent

+

    depth <- forAll $ Gen.int (Range.linear 1 $ length cps)

+

    initialIndex <- liftIO $ AddressDatum.open ":memory:" (AddressDatumDepth depth)

+

    finalIndex <- liftIO $ Storable.insertMany events initialIndex

+

    let addressDatumsMap = indexEventsToAddressDatumsMap events

+

    forM_ (Map.toList addressDatumsMap) $ \(addr, expectedDatums) -> do

+

        (AddressDatumResult actualDatums) <- liftIO $ do

+

            Storable.query Storable.QEverything finalIndex $ AddressDatumQuery addr

+

        actualDatums === expectedDatums

+

 where

+

    indexEventsToAddressDatumsMap

+

         :: [Storable.StorableEvent AddressDatumHandle]

+

         -> Map C.AddressAny (Set C.ScriptData)

+

    indexEventsToAddressDatumsMap events =

+

        indexEventToAddressDatumsMap $ fold events

+

+

    indexEventToAddressDatumsMap

+

         :: Storable.StorableEvent AddressDatumHandle

+

         -> Map C.AddressAny (Set C.ScriptData)

+

    indexEventToAddressDatumsMap (AddressDatumIndexEvent addressDatumMap datumMap _chainPoint) =

+

        Map.fromListWith (<>)

+

            $ foldMap (\(addr, datumHashes) -> [(addr, resolveMapKeys datumHashes datumMap)])

+

            $ Map.toList addressDatumMap

+

+

    resolveMapKeys

+

        :: (Ord k, Ord v)

+

        => Set k

+

        -> Map k v

+

        -> Set v

+

    resolveMapKeys keys m =

+

        -- TODO Not efficient to convert back n forth between Set

+

        Set.fromList $ mapMaybe (\k -> Map.lookup k m) $ Set.toList keys

+

+

-- | The property verifies that the datums of each address in those generated events are all

+

-- queryable from the index given a 'C.ChainPoint' interval.

+

propAddressDatumAreQueryableInGeneratedRange  :: Property

+

propAddressDatumAreQueryableInGeneratedRange = property $ do

+

    cps <- forAll $ genChainPoints 1 5

+

    events <- forAll $ forM cps genAddressDatumStorableEvent

a

marconi/test/Spec/Marconi/Index/AddressDatum/AddressDatumIndexEvent.hs

+430/-0

+

{-# LANGUAGE DataKinds         #-}

+

{-# LANGUAGE GADTs             #-}

+

{-# LANGUAGE LambdaCase        #-}

+

{-# LANGUAGE NamedFieldPuns    #-}

+

{-# LANGUAGE OverloadedStrings #-}

+

{-# LANGUAGE TupleSections     #-}

+

{-# LANGUAGE TypeApplications  #-}

+

+

module Spec.Marconi.Index.AddressDatum.AddressDatumIndexEvent

+

    ( tests

+

    ) where

+

+

import Cardano.Api qualified as C

+

import Cardano.Api.Shelley qualified as C

+

import Cardano.Binary qualified as CBOR

+

import Cardano.Crypto.Hash.Class qualified as CRYPTO

+

import Cardano.Ledger.SafeHash (unsafeMakeSafeHash)

+

import Control.Monad (forM)

+

import Data.Coerce (coerce)

+

import Data.List qualified as List

+

import Data.Map qualified as Map

+

import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)

+

import Data.Set qualified as Set

+

import GHC.Int (Int64)

+

import GHC.Natural (Natural)

+

import GHC.Real (Ratio, (%))

+

import Gen.Cardano.Api.Typed qualified as CGen

+

import PlutusCore (defaultCostModelParams)

+

import RewindableIndex.Storable qualified as Storable

+

import Test.Tasty (TestTree, localOption, testGroup)

+

import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit), testPropertyNamed)

+

+

import Hedgehog (Gen, Property, forAll, property, (===))

+

import Hedgehog qualified

+

import Hedgehog.Gen qualified as Gen

+

import Hedgehog.Range qualified as Range

+

+

import Marconi.Index.AddressDatum (AddressDatumHandle, StorableEvent (AddressDatumIndexEvent))

+

import Marconi.Index.AddressDatum qualified as AddressDatum

+

import Spec.Marconi.Index.AddressDatum.Generators (genAddressInEra, genChainPoint, genSimpleScriptData)

+

import Spec.Marconi.Index.AddressDatum.Utils (addressInEraToAddressAny)

+

+

tests :: TestTree

+

tests = localOption (HedgehogTestLimit $ Just 200) $

+

    testGroup "Spec.Marconi.Index.AddressDatum.AddressDatumIndexEvent.toAddressDatumIndexEvent"

+

    [ testPropertyNamed

+

          "should track the addresses with datum in a transaction output (datum hash, datum in tx body and inline datum)"

+

          "propShouldIndexAddressWithTxOutDatum"

+

          propShouldIndexAddressWithTxOutDatum

+

    -- TODO Very slow test case. There seems to be a performance issue with creating transactions

+

    -- with cardano-api when Plutus scripts are included in the witness set.

+

    , testPropertyNamed

+

          "should track the addresses with datums that are part of a Plutus datum witness set"

+

          "propShouldAlwaysIndexPlutusDatumWitness"

+

          propShouldAlwaysIndexPlutusDatumWitness

+

    , testPropertyNamed

+

          "should not track addresses that are not linked to any datum"

+

          "propShouldNotIndexAddressWithoutDatum"

+

          propShouldNotIndexAddressWithoutDatum

+

    , testPropertyNamed

+

          "should track addresses based on provided address filter"

+

          "propShouldIndexAddressBasedOnFilter"

+

          propShouldIndexAddressBasedOnFilter

+

+

+

propShouldIndexAddressWithTxOutDatum :: Property

+

propShouldIndexAddressWithTxOutDatum = property $ do

+

    cp <- forAll genChainPoint

+

    let datGen =

+

            Gen.choice

+

                [ fmap (\d -> TxOutDatumHashLocation (C.hashScriptData d) d) genSimpleScriptData

+

                , fmap (\d -> TxOutDatumInTxLocation (C.hashScriptData d) d) genSimpleScriptData

+

                , fmap (\d -> TxOutDatumInlineLocation (C.hashScriptData d) d) genSimpleScriptData

+

+

    addressesDatum <- forAll $ genAddressesWithDatum datGen

+

    Hedgehog.cover 30 "At least one address with datum hash in tx out"

+

        $ isJust

+

        $ List.find (\(_, dat) -> case dat of { TxOutDatumHashLocation {} -> True; _ -> False })

+

        addressesDatum

+

    Hedgehog.cover 30 "At least one address with datum hash in tx out and datum in tx body"

+

        $ isJust

+

        $ List.find (\(_, dat) -> case dat of { TxOutDatumInTxLocation {} -> True; _ -> False })

+

        addressesDatum

+

    Hedgehog.cover 30 "At least one address with inline datum in tx out"

+

        $ isJust

+

        $ List.find (\(_, dat) -> case dat of { TxOutDatumInlineLocation {} -> True; _ -> False })

+

        addressesDatum

+

    Hedgehog.cover 10 "At least one address with multiple datums"

+

        $ isJust

+

        $ List.find (\xs -> length xs > 1)

+

        $ List.groupBy (\x y -> fst x == fst y)

+

        $ List.sortOn (addressInEraToAddressAny . fst)

+

        addressesDatum

+

+

    txs <- forAll $ Gen.list (Range.constant 1 5)

+

                  $ C.makeSignedTransaction [] <$> genTxBodyWithAddresses addressesDatum

+

+

    let actualAddressDatumIndexEvent = AddressDatum.toAddressDatumIndexEvent Nothing txs cp

+

    let expectedAddressDatumIndexEvent =

+

            addressesDatumToAddressDatumIndexEvent Nothing cp addressesDatum

+

    expectedAddressDatumIndexEvent === actualAddressDatumIndexEvent

+

+

propShouldNotIndexAddressWithoutDatum :: Property

+

propShouldNotIndexAddressWithoutDatum = property $ do

+

    cp <- forAll genChainPoint

+

    let datGen = pure NoDatumLocation

+

    addresses <- forAll $ genAddressesWithDatum datGen

+

    txs <- forAll $ Gen.list (Range.constant 1 5)

+

                  $ C.makeSignedTransaction [] <$> genTxBodyWithAddresses addresses

+

    let (AddressDatumIndexEvent addressDats datums _) = AddressDatum.toAddressDatumIndexEvent Nothing txs cp

+

+

    Hedgehog.assert $ List.null addressDats

+

    Hedgehog.assert $ List.null datums

+

+

-- Having a Plutus Script datum witness implies that there is an UTxO with the hash of that datum.

+

propShouldAlwaysIndexPlutusDatumWitness :: Property

+

propShouldAlwaysIndexPlutusDatumWitness = property $ do

+

    cp <- forAll genChainPoint

+

+

    let txOutDatGen =

+

            Gen.choice [ fmap (\d -> TxOutDatumHashLocation (C.hashScriptData d) d) genSimpleScriptData

+

                       , fmap (\d -> TxOutDatumInTxLocation (C.hashScriptData d) d) genSimpleScriptData

+

                       , fmap (\d -> TxOutDatumInlineLocation (C.hashScriptData d) d) genSimpleScriptData

+

+

    addressesDatum1 <- forAll $ genAddressesWithDatum txOutDatGen

+

    txs1 <- forAll $ Gen.list (Range.constant 1 5)

+

                   $ C.makeSignedTransaction [] <$> genTxBodyWithAddresses addressesDatum1

+

+

    let plutusWitDatGen =

+

            fmap (\d -> PlutusScriptDatumLocation (C.hashScriptData d) d) genSimpleScriptData

+

    addressesDatum2 <- forAll $ genAddressesWithDatum plutusWitDatGen

+

    txs2 <- forAll $ Gen.list (Range.constant 1 5)

+

                   $ C.makeSignedTransaction [] <$> genTxBodyWithAddresses addressesDatum2

+

    let txs = txs2 <> txs1

+

        addressesDatum = addressesDatum1 <> addressesDatum2

+

+

    let actualAddressDatumIndexEvent = AddressDatum.toAddressDatumIndexEvent Nothing txs cp

+

    let expectedAddressDatumIndexEvent =

+

            addressesDatumToAddressDatumIndexEvent Nothing cp addressesDatum

+

    expectedAddressDatumIndexEvent === actualAddressDatumIndexEvent

+

+

propShouldIndexAddressBasedOnFilter :: Property

+

propShouldIndexAddressBasedOnFilter = property $ do

+

    cp <- forAll genChainPoint

+

    let datGen = fmap (\d -> TxOutDatumInlineLocation (C.hashScriptData d) d) genSimpleScriptData

+

    addressesWithDatum <- forAll $ genAddressesWithDatum datGen

+

    let filteredAddresses =

+

            List.nub

+

          $ fmap (fst . snd)

+

          $ filter (\(i, (addr, _)) -> even i || not (isShelleyAddressInEra addr))

+

          $ zip [(0::Integer)..] addressesWithDatum

+

    let filterF addr =

+

            C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraBabbage) addr `elem` filteredAddresses

+

    txs <- forAll $ Gen.list (Range.constant 1 5)

+

                  $ C.makeSignedTransaction [] <$> genTxBodyWithAddresses addressesWithDatum

+

+

    let actualAddressDatumIndexEvent = AddressDatum.toAddressDatumIndexEvent (Just filterF) txs cp

+

    let expectedAddressDatumIndexEvent =

+

            addressesDatumToAddressDatumIndexEvent (Just filterF) cp addressesWithDatum

+

    expectedAddressDatumIndexEvent === actualAddressDatumIndexEvent

+

+

addressesDatumToAddressDatumIndexEvent

+

    :: Maybe (C.Address C.ShelleyAddr -> Bool)

+

    -> C.ChainPoint

+

    -> [(C.AddressInEra C.BabbageEra, DatumLocation)]

+

    -> Storable.StorableEvent AddressDatumHandle

+

addressesDatumToAddressDatumIndexEvent filterF cp addressDatums =

+

    let addressesWithDatumFilter (C.AddressInEra C.ByronAddressInAnyEra _, _) =

+

            True

+

        addressesWithDatumFilter (C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraBabbage) addr, _) =

+

            case filterF of

+

              Nothing -> True

+

              Just f  -> f addr

+

        filteredAddressDatums = filter addressesWithDatumFilter addressDatums

+

+

        addressDatumsMap =

+

            Map.fromListWith (<>)

+

                $ mapMaybe (\(addr, datLoc) ->

+

                    fmap (\(dh, _) -> (addressInEraToAddressAny addr, Set.singleton dh))

+

                        $ getDatumFromTxOutLocation datLoc) filteredAddressDatums

+

+

        datums = Map.fromList

+

               $ mapMaybe (\(h, d) -> fmap (h,) d)

+

               $ mapMaybe (\(_ , datLoc) -> getDatumFromAnyLocation datLoc) filteredAddressDatums

+

     in AddressDatumIndexEvent addressDatumsMap datums cp

+

 where

+

    getDatumFromAnyLocation :: DatumLocation -> Maybe (C.Hash C.ScriptData, Maybe C.ScriptData)

+

    getDatumFromAnyLocation NoDatumLocation                  = Nothing

+

    getDatumFromAnyLocation (TxOutDatumHashLocation hd _)    = Just (hd, Nothing)

+

    getDatumFromAnyLocation (TxOutDatumInTxLocation hd d)    = Just (hd, Just d)

+

    getDatumFromAnyLocation (TxOutDatumInlineLocation hd d)  = Just (hd, Just d)

+

    getDatumFromAnyLocation (PlutusScriptDatumLocation hd d) = Just (hd, Just d)

+

+

    getDatumFromTxOutLocation :: DatumLocation -> Maybe (C.Hash C.ScriptData, Maybe C.ScriptData)

+

    getDatumFromTxOutLocation NoDatumLocation                 = Nothing

+

    getDatumFromTxOutLocation (TxOutDatumHashLocation hd _)   = Just (hd, Nothing)

+

    getDatumFromTxOutLocation (TxOutDatumInTxLocation hd d)   = Just (hd, Just d)

+

    getDatumFromTxOutLocation (TxOutDatumInlineLocation hd d) = Just (hd, Just d)

+

    getDatumFromTxOutLocation (PlutusScriptDatumLocation _ _) = Nothing

a

marconi/test/Spec/Marconi/Index/AddressDatum/Generators.hs

+61/-0

+

module Spec.Marconi.Index.AddressDatum.Generators

+

    ( genAddressInEra

+

    , genSimpleScriptData

+

    , genChainPoint

+

    , genHashBlockHeader

+

+

where

+

+

import Cardano.Api qualified as C

+

import Cardano.Api.Shelley qualified as C

+

import Data.ByteString (ByteString)

+

import Data.ByteString qualified as BS

+

import Data.ByteString.Short qualified as BSS

+

import Data.Word (Word64)

+

+

import Gen.Cardano.Api.Typed qualified as CGen

+

import Hedgehog (Gen)

+

import Hedgehog.Gen qualified as Gen

+

import Hedgehog.Range qualified as Range

+

+

-- Copied from cardano-api. Delete when this function is reexported

+

genAddressInEra :: C.CardanoEra era -> Gen (C.AddressInEra era)

+

genAddressInEra era =

+

  case C.cardanoEraStyle era of

+

    C.LegacyByronEra ->

+

      C.byronAddressInEra <$> CGen.genAddressByron

+

+

    C.ShelleyBasedEra _ ->

+

      Gen.choice

+

        [ C.byronAddressInEra   <$> CGen.genAddressByron

+

        -- , C.shelleyAddressInEra <$> CGen.genAddressShelley

+

+

+

-- Copied from cardano-api, but removed the recursive construction because it is time consuming ,

+

-- about a factor of 20 when compared to this simple generator.

+

genSimpleScriptData :: Gen C.ScriptData

+

genSimpleScriptData =

+

    Gen.choice

+

        [ C.ScriptDataNumber <$> genInteger

+

        , C.ScriptDataBytes  <$> genByteString

+

        , C.ScriptDataConstructor <$> genInteger <*> pure []

+

        , pure $ C.ScriptDataList []

+

        , pure $ C.ScriptDataMap []

+

+

  where

+

    genInteger :: Gen Integer

+

    genInteger = Gen.integral

+

                  (Range.linear

+

+

                    (fromIntegral (maxBound :: Word64) :: Integer))

+

+

    genByteString :: Gen ByteString

+

    genByteString = BS.pack <$> Gen.list (Range.linear 0 64)

+

                                         (Gen.word8 Range.constantBounded)

+

+

genChainPoint :: Gen C.ChainPoint

+

genChainPoint = do

+

    C.ChainPoint <$> CGen.genSlotNo <*> genHashBlockHeader

+

+

genHashBlockHeader :: Gen (C.Hash C.BlockHeader)

+

genHashBlockHeader = C.HeaderHash . BSS.toShort <$> Gen.bytes (Range.singleton 32)

a

marconi/test/Spec/Marconi/Index/AddressDatum/Utils.hs

+9/-0

+

module Spec.Marconi.Index.AddressDatum.Utils

+

    ( addressInEraToAddressAny

+

+

where

+

+

import Cardano.Api qualified as C

+

+

addressInEraToAddressAny :: C.AddressInEra era -> C.AddressAny

+

addressInEraToAddressAny (C.AddressInEra _ addr) = C.toAddressAny addr

m

rewindable-index/src/RewindableIndex/Storable.hs

+3/-1

-}

data family StorableEvent h

+

-- | The resume and query functionality requires a way to specify points on the chain from which we

+

-- want to resume, or points up to which we want to query.

type family StorablePoint h

data family StorableQuery h

        if there is a demand from the users of the API.

-}

class Buffered h where

-

  -- This function persists the memory/buffer events to disk.

+

  -- | This function persists the memory/buffer events to disk when the memory buffer is filled.

  persistToStorage :: Foldable f => f (StorableEvent h) -> h -> StorableMonad h h

  {- This function retrieves the events from the disk/events area.

Yesterday's Report

Friday, March 24, 2023

548 commits in 56 repos

New Repo Discovered

Thu, 23 Mar 23 21:21:33 +0000 · honeycomb-lx2-ubuntu-jammy

Plaintext · No license

New Releases

Fri, 24 Mar 23 08:55:29 +0000 · Unstable Development Builds mithril Wed, 22 Mar 23 20:56:32 +0000 · v1.35.6-3 docker-cardano-node Wed, 22 Mar 23 20:04:47 +0000 · release-57 awesome-starter-kits Tue, 21 Mar 23 22:40:29 +0000 · release-53 awesome-starter-kits Tue, 21 Mar 23 10:19:31 +0000 · v1.17.0 koios-java-client Mon, 20 Mar 23 16:35:50 +0000 · Cardano Clusterlib 0.4.1 cardano-clusterlib-py

3,441 commits this week Mar 18, 2023 - Mar 25, 2023

Showing 25 of 3441 recent commits.