Adding datumsAt contract request query. (#791)

* Added `Plutus.Contract.Request.datumsAt` which returns all datums
  associated with a target address

* Added datum in address row of plutus-chain-index DbSchema to avoid
  recording transaction in db and facilitate retrival and added
  datumsAtAddress query

* Added DatumAtAddress query to pab-blockfrost

Co-authored-by: etiennjf <jean-frederic.etienne@iohk.io>

pab-blockfrost/pab-blockfrost.cabal

@@ -48,13 +48,25 @@ library
     Plutus.Blockfrost.Utils
 
   hs-source-dirs:  src
+
+  --------------------
+  -- Local components
+  --------------------
   build-depends:
     , freer-extras
     , plutus-chain-index-core
     , plutus-ledger
+
+  --------------------------
+  -- Other IOG dependencies
+  --------------------------
+  build-depends:
     , plutus-ledger-api
     , plutus-tx
 
+  ------------------------
+  -- Non-IOG dependencies
+  ------------------------
   build-depends:
     , aeson
     , aeson-qq
@@ -65,6 +77,7 @@ library
     , bytestring
     , cardano-api
     , containers
+    , extra
     , freer-simple
     , hex-text
     , mtl

pab-blockfrost/src/Plutus/Blockfrost/Client.hs

@@ -66,3 +66,4 @@ handleBlockfrostClient event = do
             TxoSetAtAddress pq a          -> (runClientWithDef defaultGetList . getTxoAtAddressBlockfrost pq . credentialToAddress (envNetworkId bfEnv)) a >>= processGetTxos pq
             GetTip                        -> runClient getTipBlockfrost >>= processTip
             UnspentTxOutSetAtAddress pq a -> (runClientWithDef defaultGetList . getUnspentAtAddressBlockfrost pq . credentialToAddress (envNetworkId bfEnv)) a  >>= processUnspentTxOutSetAtAddress pq a
+            DatumsAtAddress pq a          -> (runClientWithDef defaultGetList . getDatumsAtAddressBlockfrost pq . credentialToAddress (envNetworkId bfEnv)) a  >>= processDatumsAtAddress pq a

pab-blockfrost/src/Plutus/Blockfrost/Queries.hs

@@ -13,6 +13,7 @@ module Plutus.Blockfrost.Queries (
     , getIsUtxoBlockfrost
     , getUtxoAtAddressBlockfrost
     , getUnspentAtAddressBlockfrost
+    , getDatumsAtAddressBlockfrost
     , getTxoAtAddressBlockfrost
     , getUtxoSetWithCurrency
     , getTxFromTxIdBlockfrost
@@ -80,6 +81,13 @@ getUtxoAtAddressBlockfrost _ addr = do
 getUnspentAtAddressBlockfrost :: MonadBlockfrost m => PageQuery a -> Address -> m [AddressUtxo]
 getUnspentAtAddressBlockfrost _ addr = allPages (wrapperPaged getAddressUtxos' addr)
 
+getDatumsAtAddressBlockfrost :: MonadBlockfrost m => PageQuery a -> Address -> m [Value]
+getDatumsAtAddressBlockfrost p a = do
+  -- get all txouts at address
+  txos <- getTxoAtAddressBlockfrost p a
+  let dhs = catMaybes $ _utxoInputDataHash <$> txos
+  liftIO $ mapConcurrently getDatumBlockfrost dhs
+
 getTxoAtAddressBlockfrost :: MonadBlockfrost m => PageQuery a -> Address -> m [UtxoInput]
 getTxoAtAddressBlockfrost _ a = do
     addTxs <- allPages (wrapperPagedTx getAddressTransactions' a)

pab-blockfrost/src/Plutus/Blockfrost/Responses.hs

@@ -13,10 +13,12 @@ module Plutus.Blockfrost.Responses (
     , processGetUtxos
     , processGetTxos
     , processUnspentTxOutSetAtAddress
+    , processDatumsAtAddress
     , processGetTxFromTxId
     , processGetTxsFromTxIds
     ) where
 
+import Control.Monad.Extra (mapMaybeM)
 import Control.Monad.Freer.Extras.Pagination (Page (..), PageQuery (..))
 import Data.Aeson qualified as JSON
 import Data.Aeson.QQ
@@ -46,6 +48,7 @@ import Plutus.V1.Ledger.Value qualified as Ledger
 import PlutusTx qualified
 
 import Control.Monad ((<=<))
+
 import Plutus.Blockfrost.Types
 import Plutus.Blockfrost.Utils
 import Plutus.ChainIndex.Types qualified as CI
@@ -214,6 +217,18 @@ processUnspentTxOutSetAtAddress _ cred xs =
     utxoDatumHash :: AddressUtxo -> Ledger.DatumHash
     utxoDatumHash = textToDatumHash . fromJust . _addressUtxoDataHash
 
+
+processDatumsAtAddress ::
+  PlutusTx.FromData a
+  => PageQuery TxOutRef
+  -> Credential
+  -> [JSON.Value]
+  -> IO (QueryResponse [a])
+processDatumsAtAddress _ _ xs = do
+  items <- mapMaybeM (\d -> processGetDatum (Just d)) xs
+  return $ QueryResponse {queryResult = items, nextQuery = Nothing}
+
+
 processGetTxFromTxId :: Maybe TxResponse -> IO (Maybe ChainIndexTx)
 processGetTxFromTxId Nothing = pure Nothing
 processGetTxFromTxId (Just TxResponse{..}) = do

plutus-chain-index-core/src/Plutus/ChainIndex/Api.hs

@@ -177,6 +177,7 @@ type API
     :<|> "is-utxo" :> Description "Check if the reference is an UTxO." :> ReqBody '[JSON] TxOutRef :> Post '[JSON] IsUtxoResponse
     :<|> "utxo-at-address" :> Description "Get all UTxOs at an address." :> ReqBody '[JSON] UtxoAtAddressRequest :> Post '[JSON] UtxosResponse
     :<|> "unspent-txouts-at-address" :> Description "Get all unspent transaction output at an address." :> ReqBody '[JSON] QueryAtAddressRequest :> Post '[JSON] (QueryResponse [(TxOutRef, ChainIndexTxOut)])
+    :<|> "datums-at-address" :> Description "Get all Datums at an address." :> ReqBody '[JSON] QueryAtAddressRequest :> Post '[JSON] (QueryResponse [Datum])
     :<|> "utxo-with-currency" :> Description "Get all UTxOs with a currency." :> ReqBody '[JSON] UtxoWithCurrencyRequest :> Post '[JSON] UtxosResponse
     :<|> "txs" :> Description "Get transactions from a list of their ids." :> ReqBody '[JSON] [TxId] :> Post '[JSON] [ChainIndexTx]
     :<|> "txo-at-address" :> Description "Get TxOs at an address." :> ReqBody '[JSON] TxoAtAddressRequest :> Post '[JSON] TxosResponse

plutus-chain-index-core/src/Plutus/ChainIndex/Client.hs

@@ -64,13 +64,14 @@ getUnspentTxOut :: TxOutRef -> ClientM ChainIndexTxOut
 getIsUtxo :: TxOutRef -> ClientM IsUtxoResponse
 getUtxoSetAtAddress :: UtxoAtAddressRequest -> ClientM UtxosResponse
 getUnspentTxOutsAtAddress :: QueryAtAddressRequest -> ClientM (QueryResponse [(TxOutRef, ChainIndexTxOut)])
+getDatumsAtAddress :: QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
 getUtxoSetWithCurrency :: UtxoWithCurrencyRequest -> ClientM UtxosResponse
 getTxs :: [TxId] -> ClientM [ChainIndexTx]
 getTxoSetAtAddress :: TxoAtAddressRequest -> ClientM TxosResponse
 getTip :: ClientM Tip
 
-(healthCheck, (getDatum, getValidator, getMintingPolicy, getStakeValidator, getRedeemer), getTxOut, getUnspentTxOut, getTx, getIsUtxo, getUtxoSetAtAddress, getUnspentTxOutsAtAddress, getUtxoSetWithCurrency, getTxs, getTxoSetAtAddress, getTip, collectGarbage) =
-    (healthCheck_, (getDatum_, getValidator_, getMintingPolicy_, getStakeValidator_, getRedeemer_), getTxOut_, getUnspentTxOut_, getTx_, getIsUtxo_, getUtxoSetAtAddress_, getUnspentTxOutsAtAddress_, getUtxoSetWithCurrency_, getTxs_, getTxoSetAtAddress_, getTip_, collectGarbage_) where
+(healthCheck, (getDatum, getValidator, getMintingPolicy, getStakeValidator, getRedeemer), getTxOut, getUnspentTxOut, getTx, getIsUtxo, getUtxoSetAtAddress, getUnspentTxOutsAtAddress, getDatumsAtAddress, getUtxoSetWithCurrency, getTxs, getTxoSetAtAddress, getTip, collectGarbage) =
+    (healthCheck_, (getDatum_, getValidator_, getMintingPolicy_, getStakeValidator_, getRedeemer_), getTxOut_, getUnspentTxOut_, getTx_, getIsUtxo_, getUtxoSetAtAddress_, getUnspentTxOutsAtAddress_, getDatumsAtAddress_, getUtxoSetWithCurrency_, getTxs_, getTxoSetAtAddress_, getTip_, collectGarbage_) where
         healthCheck_
             :<|> (getDatum_ :<|> getValidator_ :<|> getMintingPolicy_ :<|> getStakeValidator_ :<|> getRedeemer_)
             :<|> getTxOut_
@@ -79,6 +80,7 @@ getTip :: ClientM Tip
             :<|> getIsUtxo_
             :<|> getUtxoSetAtAddress_
             :<|> getUnspentTxOutsAtAddress_
+            :<|> getDatumsAtAddress_
             :<|> getUtxoSetWithCurrency_
             :<|> getTxs_
             :<|> getTxoSetAtAddress_
@@ -123,6 +125,7 @@ handleChainIndexClient event = do
         UtxoSetMembership r           -> runClient (getIsUtxo r)
         UtxoSetAtAddress pq a         -> runClient (getUtxoSetAtAddress $ UtxoAtAddressRequest (Just pq) a)
         UnspentTxOutSetAtAddress pq a -> runClient (getUnspentTxOutsAtAddress $ QueryAtAddressRequest (Just pq) a)
+        DatumsAtAddress pq a          -> runClient (getDatumsAtAddress $ QueryAtAddressRequest (Just pq) a)
         UtxoSetWithCurrency pq a      -> runClient (getUtxoSetWithCurrency $ UtxoWithCurrencyRequest (Just pq) a)
         TxsFromTxIds t                -> runClient (getTxs t)
         TxoSetAtAddress pq a          -> runClient (getTxoSetAtAddress $ TxoAtAddressRequest (Just pq) a)

plutus-chain-index-core/src/Plutus/ChainIndex/DbSchema.hs

@@ -25,6 +25,7 @@ module Plutus.ChainIndex.DbSchema where
 
 import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
 import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
 import Data.Coerce (coerce)
 import Data.Either (fromRight)
@@ -40,12 +41,14 @@ import Ledger (BlockId (..), ChainIndexTxOut (..), Slot, Versioned)
 import Plutus.ChainIndex.Tx (ChainIndexTx)
 import Plutus.ChainIndex.Tx qualified as CI
 import Plutus.ChainIndex.Types (BlockNumber (..), Tip (..))
+
 import Plutus.V1.Ledger.Api (Credential, Datum, DatumHash (..), MintingPolicy, MintingPolicyHash (..), Redeemer,
                              RedeemerHash (..), Script, StakeValidator, StakeValidatorHash (..), TxId (..),
                              TxOutRef (..), Validator, ValidatorHash (..))
 import Plutus.V1.Ledger.Scripts (ScriptHash (..))
 import Plutus.V1.Ledger.Value (AssetClass)
 import PlutusTx.Builtins qualified as PlutusTx
+import PlutusTx.Builtins.Internal (BuiltinByteString (..), emptyByteString)
 
 data DatumRowT f = DatumRow
     { _datumRowHash  :: Columnar f ByteString
@@ -92,17 +95,20 @@ instance Table TxRowT where
     primaryKey = TxRowId . _txRowTxId
 
 data AddressRowT f = AddressRow
-    { _addressRowCred   :: Columnar f ByteString
-    , _addressRowOutRef :: Columnar f ByteString
+    { _addressRowCred      :: Columnar f ByteString
+    , _addressRowOutRef    :: Columnar f ByteString
+    -- Keep datumHash in address row which is useful to retrieve all datum associated to a partial
+    -- address
+    , _addressRowDatumHash :: Columnar f ByteString
     } deriving (Generic, Beamable)
 
 type AddressRow = AddressRowT Identity
 
 instance Table AddressRowT where
     -- We also need an index on just the _addressRowCred column, but the primary key index provides this
     -- as long as _addressRowCred is the first column in the primary key.
-    data PrimaryKey AddressRowT f = AddressRowId (Columnar f ByteString) (Columnar f ByteString) deriving (Generic, Beamable)
-    primaryKey (AddressRow c o) = AddressRowId c o
+    data PrimaryKey AddressRowT f = AddressRowId (Columnar f ByteString) (Columnar f ByteString) (Columnar f ByteString) deriving (Generic, Beamable)
+    primaryKey (AddressRow c o d) = AddressRowId c o d
 
 data AssetClassRowT f = AssetClassRow
     { _assetClassRowAssetClass :: Columnar f ByteString
@@ -306,10 +312,17 @@ instance HasDbType (TxId, ChainIndexTx) where
     toDbValue (txId, tx) = TxRow (toDbValue txId) (toDbValue tx)
     fromDbValue (TxRow txId tx) = (fromDbValue txId, fromDbValue tx)
 
-instance HasDbType (Credential, TxOutRef) where
-    type DbType (Credential, TxOutRef) = AddressRow
-    toDbValue (cred, outRef) = AddressRow (toDbValue cred) (toDbValue outRef)
-    fromDbValue (AddressRow cred outRef) = (fromDbValue cred, fromDbValue outRef)
+instance HasDbType (Credential, TxOutRef, Maybe DatumHash) where
+  type DbType (Credential, TxOutRef, Maybe DatumHash) = AddressRow
+  toDbValue (cred, outRef, Nothing) = AddressRow (toDbValue cred) (toDbValue outRef) (toDbValue $ DatumHash emptyByteString)
+  toDbValue (cred, outRef, Just dh) = AddressRow (toDbValue cred) (toDbValue outRef) (toDbValue dh)
+  fromDbValue (AddressRow cred outRef dh) =
+    let dh'@(DatumHash (BuiltinByteString bs)) = fromDbValue dh in
+      if BS.null bs then
+        (fromDbValue cred, fromDbValue outRef, Nothing)
+      else
+        (fromDbValue cred, fromDbValue outRef, Just dh')
+
 
 instance HasDbType (AssetClass, TxOutRef) where
     type DbType (AssetClass, TxOutRef) = AssetClassRow

plutus-chain-index-core/src/Plutus/ChainIndex/Effects.hs

@@ -17,6 +17,7 @@ module Plutus.ChainIndex.Effects(
     , utxoSetMembership
     , utxoSetAtAddress
     , unspentTxOutSetAtAddress
+    , datumsAtAddress
     , utxoSetWithCurrency
     , txoSetAtAddress
     , txsFromTxIds
@@ -77,6 +78,9 @@ data ChainIndexQueryEffect r where
     -- This is to avoid multiple queries from chain-index when using utxosAt
     UnspentTxOutSetAtAddress :: PageQuery TxOutRef -> Credential -> ChainIndexQueryEffect (QueryResponse [(TxOutRef, ChainIndexTxOut)])
 
+    -- | get the datums located at addresses with the given credential.
+    DatumsAtAddress :: PageQuery TxOutRef -> Credential -> ChainIndexQueryEffect (QueryResponse [Datum])
+
     -- | Unspent outputs containing a specific currency ('AssetClass').
     --
     -- Note that requesting unspent outputs containing Ada should not return

plutus-chain-index-core/src/Plutus/ChainIndex/Emulator/Handlers.hs

@@ -23,7 +23,7 @@ module Plutus.ChainIndex.Emulator.Handlers(
     , utxoIndex
     ) where
 
-import Control.Lens (at, ix, makeLenses, over, preview, set, to, view, (&))
+import Control.Lens (at, ix, makeLenses, over, preview, set, to, view, (&), (^?))
 import Control.Monad (foldM)
 import Control.Monad.Freer (Eff, Member, type (~>))
 import Control.Monad.Freer.Error (Error, throwError)
@@ -38,7 +38,8 @@ import GHC.Generics (Generic)
 import Ledger.Address (Address (addressCredential))
 import Ledger.Scripts (ScriptHash (ScriptHash))
 import Ledger.Tx (TxId, TxOutRef (..), Versioned)
-import Ledger.Tx qualified as L (ChainIndexTxOut (PublicKeyChainIndexTxOut, ScriptChainIndexTxOut), DatumFromQuery (..))
+import Ledger.Tx qualified as L (ChainIndexTxOut (PublicKeyChainIndexTxOut, ScriptChainIndexTxOut), DatumFromQuery (..),
+                                 datumInDatumFromQuery)
 import Plutus.ChainIndex.Api (IsUtxoResponse (IsUtxoResponse), QueryResponse (QueryResponse),
                               TxosResponse (TxosResponse), UtxosResponse (UtxosResponse))
 import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
@@ -100,6 +101,7 @@ getTxFromTxId i = do
         Nothing -> logWarn (TxNotFound i) >> pure Nothing
         _       -> pure result
 
+
 -- | Get the 'ChainIndexTxOut' for a 'TxOutRef'.
 getTxOutFromRef ::
   forall effs.
@@ -221,7 +223,27 @@ handleQuery = \case
             mtxouts <- mapM getUtxoutFromRef (pageItems page)
             let txouts = [ (t, o) | (t, mo) <- List.zip (pageItems page) mtxouts, o <- maybeToList mo]
             pure $ QueryResponse txouts (nextPageQuery page)
-
+    DatumsAtAddress pageQuery cred -> do
+      state <- get
+      let outRefs = view (diskState . addressMap . at cred) state
+          txoRefs = fromMaybe mempty outRefs
+          utxo = view (utxoIndex . to utxoState) state
+          page = pageOf pageQuery txoRefs
+          resolveDatum (Just h, Nothing) = gets (view $ diskState . dataMap . at h)
+          resolveDatum (_, Just d)       = pure $ Just d
+          resolveDatum (_, _)            = pure Nothing
+          txOutToDatum (L.PublicKeyChainIndexTxOut _ _ (Just (dh, mdatum)) _) =
+              (Just dh, mdatum ^? L.datumInDatumFromQuery)
+          txOutToDatum (L.ScriptChainIndexTxOut _ _ (dh, mdatum) _ _) =
+              (Just dh, mdatum ^? L.datumInDatumFromQuery)
+          txOutToDatum _ = (Nothing, Nothing)
+      txouts <- catMaybes <$> mapM getTxOutFromRef (pageItems page)
+      datums <- catMaybes <$> mapM (resolveDatum . txOutToDatum) txouts
+      case tip utxo of
+        TipAtGenesis -> do
+          logWarn TipIsGenesis
+          pure $ QueryResponse [] Nothing
+        _ -> pure $ QueryResponse datums (nextPageQuery page)
     UtxoSetWithCurrency pageQuery assetClass -> do
         state <- get
         let outRefs = view (diskState . assetClassMap . at assetClass) state