SCP-2796: Add a chain-index query for UTxOs with a specific currency

* Created the effect UtxoSetWithCurrency in chain-index which supports pagination.

* Added unit tests for testing the effect in the emulator handler and the database handler.

* Adjusted server API in plutus-chain-index to use this effect.

* Adjusted API in plutus-contract to use this effect.

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

@@ -1,14 +1,20 @@
-{-# LANGUAGE DataKinds      #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeOperators  #-}
-module Plutus.ChainIndex.Api(API, FromHashAPI, UtxoAtAddressRequest(..)) where
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TypeOperators         #-}
+module Plutus.ChainIndex.Api
+  ( API
+  , FromHashAPI
+  , UtxoAtAddressRequest(..)
+  , UtxoWithCurrencyRequest(..)
+  ) where
 
 import           Control.Monad.Freer.Extras.Pagination (Page, PageQuery)
 import           Data.Aeson                            (FromJSON, ToJSON)
 import           GHC.Generics                          (Generic)
-import           Ledger                                (Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer,
-                                                        RedeemerHash, StakeValidator, StakeValidatorHash, TxId,
-                                                        Validator, ValidatorHash)
+import           Ledger                                (AssetClass, Datum, DatumHash, MintingPolicy, MintingPolicyHash,
+                                                        Redeemer, RedeemerHash, StakeValidator, StakeValidatorHash,
+                                                        TxId, Validator, ValidatorHash)
 import           Ledger.Credential                     (Credential)
 import           Ledger.Tx                             (ChainIndexTxOut, TxOutRef)
 import           Plutus.ChainIndex.Tx                  (ChainIndexTx)
@@ -73,13 +79,38 @@ data UtxoAtAddressRequest = UtxoAtAddressRequest
     }
     deriving (Show, Eq, Generic, FromJSON, ToJSON)
 
+-- | See the comment on 'UtxoAtAddressRequest'.
+--
+-- The difference is using @currency@ field instead of @credential@.
+-- {
+--   "pageQuery": {
+--     ...
+--   },
+--   "currency": {
+--     "unAssetClass": [
+--       {
+--         "unCurrencySymbol": ""
+--       },
+--       {
+--         "unTokenName": ""
+--       }
+--     ]
+--   }
+-- }
+data UtxoWithCurrencyRequest = UtxoWithCurrencyRequest
+    { pageQuery :: Maybe (PageQuery TxOutRef)
+    , currency  :: AssetClass
+    }
+    deriving (Show, Eq, Generic, FromJSON, ToJSON)
+
 type API
     = "healthcheck" :> Get '[JSON] NoContent
     :<|> "from-hash" :> FromHashAPI
     :<|> "tx-out" :> ReqBody '[JSON] TxOutRef :> Post '[JSON] ChainIndexTxOut
     :<|> "tx" :> ReqBody '[JSON] TxId :> Post '[JSON] ChainIndexTx
     :<|> "is-utxo" :> ReqBody '[JSON] TxOutRef :> Post '[JSON] (Tip, Bool)
     :<|> "utxo-at-address" :> ReqBody '[JSON] UtxoAtAddressRequest :> Post '[JSON] (Tip, Page TxOutRef)
+    :<|> "utxo-with-currency" :> ReqBody '[JSON] UtxoWithCurrencyRequest :> Post '[JSON] (Tip, Page TxOutRef)
     :<|> "tip" :> Get '[JSON] Tip
     :<|> "collect-garbage" :> Put '[JSON] NoContent
     :<|> "diagnostics" :> Get '[JSON] Diagnostics

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

@@ -14,7 +14,8 @@ module Plutus.ChainIndex.Client(
     , getTxOut
     , getTx
     , getIsUtxo
-    , getUtxoAtAddress
+    , getUtxoSetAtAddress
+    , getUtxoSetWithCurrency
     , getTip
     , collectGarbage
     ) where
@@ -30,7 +31,8 @@ import           Ledger                                (Datum, DatumHash, Mintin
                                                         Validator, ValidatorHash)
 import           Ledger.Tx                             (ChainIndexTxOut, TxOutRef)
 import           Network.HTTP.Types.Status             (Status (..))
-import           Plutus.ChainIndex.Api                 (API, UtxoAtAddressRequest (UtxoAtAddressRequest))
+import           Plutus.ChainIndex.Api                 (API, UtxoAtAddressRequest (UtxoAtAddressRequest),
+                                                        UtxoWithCurrencyRequest (UtxoWithCurrencyRequest))
 import           Plutus.ChainIndex.Effects             (ChainIndexQueryEffect (..))
 import           Plutus.ChainIndex.Tx                  (ChainIndexTx)
 import           Plutus.ChainIndex.Types               (Tip)
@@ -51,17 +53,19 @@ getRedeemer :: RedeemerHash -> ClientM Redeemer
 getTxOut :: TxOutRef -> ClientM ChainIndexTxOut
 getTx :: TxId -> ClientM ChainIndexTx
 getIsUtxo :: TxOutRef -> ClientM (Tip, Bool)
-getUtxoAtAddress :: UtxoAtAddressRequest -> ClientM (Tip, Page TxOutRef)
+getUtxoSetAtAddress :: UtxoAtAddressRequest -> ClientM (Tip, Page TxOutRef)
+getUtxoSetWithCurrency :: UtxoWithCurrencyRequest -> ClientM (Tip, Page TxOutRef)
 getTip :: ClientM Tip
 
-(healthCheck, (getDatum, getValidator, getMintingPolicy, getStakeValidator, getRedeemer), getTxOut, getTx, getIsUtxo, getUtxoAtAddress, getTip, collectGarbage) =
-    (healthCheck_, (getDatum_, getValidator_, getMintingPolicy_, getStakeValidator_, getRedeemer_), getTxOut_, getTx_, getIsUtxo_, getUtxoAtAddress_, getTip_, collectGarbage_) where
+(healthCheck, (getDatum, getValidator, getMintingPolicy, getStakeValidator, getRedeemer), getTxOut, getTx, getIsUtxo, getUtxoSetAtAddress, getUtxoSetWithCurrency, getTip, collectGarbage) =
+    (healthCheck_, (getDatum_, getValidator_, getMintingPolicy_, getStakeValidator_, getRedeemer_), getTxOut_, getTx_, getIsUtxo_, getUtxoSetAtAddress_, getUtxoSetWithCurrency_, getTip_, collectGarbage_) where
         healthCheck_
             :<|> (getDatum_ :<|> getValidator_ :<|> getMintingPolicy_ :<|> getStakeValidator_ :<|> getRedeemer_)
             :<|> getTxOut_
             :<|> getTx_
             :<|> getIsUtxo_
-            :<|> getUtxoAtAddress_
+            :<|> getUtxoSetAtAddress_
+            :<|> getUtxoSetWithCurrency_
             :<|> getTip_
             :<|> collectGarbage_
             :<|> _ = client (Proxy @API)
@@ -100,5 +104,6 @@ handleChainIndexClient event = do
         TxOutFromRef r           -> runClientMaybe (getTxOut r)
         TxFromTxId t             -> runClientMaybe (getTx t)
         UtxoSetMembership r      -> runClient (getIsUtxo r)
-        UtxoSetAtAddress pq a    -> runClient (getUtxoAtAddress $ UtxoAtAddressRequest (Just pq) a)
+        UtxoSetAtAddress pq a    -> runClient (getUtxoSetAtAddress $ UtxoAtAddressRequest (Just pq) a)
+        UtxoSetWithCurrency pq a -> runClient (getUtxoSetWithCurrency $ UtxoWithCurrencyRequest (Just pq) a)
         GetTip                   -> runClient getTip

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

@@ -1,17 +1,13 @@
 {-# LANGUAGE ConstraintKinds      #-}
 {-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DefaultSignatures    #-}
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DerivingVia          #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE LambdaCase           #-}
-{-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns         #-}
 {-# options_ghc -Wno-missing-signatures #-}
 {-
 
@@ -40,10 +36,10 @@ import           Database.Beam              (Beamable, Columnar, Database, Datab
 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           Ledger                     (AssetClass, 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)
@@ -95,6 +91,21 @@ instance Table AddressRowT where
     data PrimaryKey AddressRowT f = AddressRowId (Columnar f ByteString) (Columnar f ByteString) deriving (Generic, Beamable)
     primaryKey (AddressRow c o) = AddressRowId c o
 
+data AssetClassRowT f = AssetClassRow
+    { _assetClassRowAssetClass :: Columnar f ByteString
+    , _assetClassRowOutRef     :: Columnar f ByteString
+    } deriving (Generic, Beamable)
+
+type AssetClassRow = AssetClassRowT Identity
+
+instance Table AssetClassRowT where
+    -- We also need an index on just the _assetClassRowAssetClass column, but the primary key index provides this
+    -- as long as _assetClassRowAssetClass is the first column in the primary key.
+    data PrimaryKey AssetClassRowT f = AssetClassRowId (Columnar f ByteString)
+                                                       (Columnar f ByteString)
+      deriving (Generic, Beamable)
+    primaryKey (AssetClassRow c o) = AssetClassRowId c o
+
 data TipRowT f = TipRow
     { _tipRowSlot        :: Columnar f Word64
     , _tipRowBlockId     :: Columnar f ByteString
@@ -144,6 +155,7 @@ data Db f = Db
     , scriptRows         :: f (TableEntity ScriptRowT)
     , txRows             :: f (TableEntity TxRowT)
     , addressRows        :: f (TableEntity AddressRowT)
+    , assetClassRows     :: f (TableEntity AssetClassRowT)
     , tipRows            :: f (TableEntity TipRowT)
     , unspentOutputRows  :: f (TableEntity UnspentOutputRowT)
     , unmatchedInputRows :: f (TableEntity UnmatchedInputRowT)
@@ -154,6 +166,7 @@ type AllTables (c :: * -> Constraint) f =
     , c (f (TableEntity ScriptRowT))
     , c (f (TableEntity TxRowT))
     , c (f (TableEntity AddressRowT))
+    , c (f (TableEntity AssetClassRowT))
     , c (f (TableEntity TipRowT))
     , c (f (TableEntity UnspentOutputRowT))
     , c (f (TableEntity UnmatchedInputRowT))
@@ -171,6 +184,7 @@ checkedSqliteDb = defaultMigratableDbSettings
     , scriptRows  = renameCheckedEntity (const "scripts")
     , txRows      = renameCheckedEntity (const "txs")
     , addressRows = renameCheckedEntity (const "addresses")
+    , assetClassRows = renameCheckedEntity (const "asset_classes")
     , tipRows     = renameCheckedEntity (const "tips")
     , unspentOutputRows  = renameCheckedEntity (const "unspent_outputs")
     , unmatchedInputRows = renameCheckedEntity (const "unmatched_inputs")
@@ -215,6 +229,7 @@ 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 AssetClass instance HasDbType AssetClass
 deriving via Serialisable Script instance HasDbType Script
 
 instance HasDbType Slot where
@@ -258,3 +273,8 @@ 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 (AssetClass, TxOutRef) where
+    type DbType (AssetClass, TxOutRef) = AssetClassRow
+    toDbValue (ac, outRef) = AssetClassRow (toDbValue ac) (toDbValue outRef)
+    fromDbValue (AssetClassRow ac outRef) = (fromDbValue ac, fromDbValue outRef)

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

@@ -15,6 +15,7 @@ module Plutus.ChainIndex.Effects(
     , txFromTxId
     , utxoSetMembership
     , utxoSetAtAddress
+    , utxoSetWithCurrency
     , getTip
     -- * Control effect
     , ChainIndexControlEffect(..)
@@ -26,9 +27,9 @@ module Plutus.ChainIndex.Effects(
 
 import           Control.Monad.Freer.Extras.Pagination (Page, PageQuery)
 import           Control.Monad.Freer.TH                (makeEffect)
-import           Ledger                                (Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer,
-                                                        RedeemerHash, StakeValidator, StakeValidatorHash, TxId,
-                                                        Validator, ValidatorHash)
+import           Ledger                                (AssetClass, Datum, DatumHash, MintingPolicy, MintingPolicyHash,
+                                                        Redeemer, RedeemerHash, StakeValidator, StakeValidatorHash,
+                                                        TxId, Validator, ValidatorHash)
 import           Ledger.Credential                     (Credential)
 import           Ledger.Tx                             (ChainIndexTxOut, TxOutRef)
 import           Plutus.ChainIndex.Tx                  (ChainIndexTx)
@@ -63,6 +64,8 @@ data ChainIndexQueryEffect r where
     -- | Unspent outputs located at addresses with the given credential.
     UtxoSetAtAddress :: PageQuery TxOutRef -> Credential -> ChainIndexQueryEffect (Tip, Page TxOutRef)
 
+    UtxoSetWithCurrency :: PageQuery TxOutRef -> AssetClass -> ChainIndexQueryEffect (Tip, Page TxOutRef)
+
     -- | Get the tip of the chain index
     GetTip :: ChainIndexQueryEffect Tip
 

plutus-chain-index/src/Plutus/ChainIndex/Emulator/DiskState.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DerivingVia     #-}
 {-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections   #-}
 {-# LANGUAGE TypeFamilies    #-}
 {-| The disk state is the part of the chain index that is kept on disk. This
 module defines an in-memory implementation of the disk state which can be
@@ -14,9 +15,12 @@ module Plutus.ChainIndex.Emulator.DiskState(
     , redeemerMap
     , txMap
     , addressMap
+    , assetClassMap
     , fromTx
     , CredentialMap
     , unCredentialMap
+    , AssetClassMap
+    , unAssetClassMap
     , diagnostics
 ) where
 
@@ -35,6 +39,8 @@ import           Ledger.TxId             (TxId)
 import           Plutus.ChainIndex.Tx    (ChainIndexTx (..), citxData, citxRedeemers, citxScripts, citxTxId,
                                           txOutsWithRef)
 import           Plutus.ChainIndex.Types (Diagnostics (..))
+import qualified Plutus.V1.Ledger.Ada    as Ada
+import           Plutus.V1.Ledger.Value  (AssetClass (AssetClass), flattenValue)
 
 -- | Set of transaction output references for each address.
 newtype CredentialMap = CredentialMap { _unCredentialMap :: Map Credential (Set TxOutRef) }
@@ -64,17 +70,60 @@ instance Monoid CredentialMap where
 txCredentialMap :: ChainIndexTx -> CredentialMap
 txCredentialMap  =
     let credential TxOut{txOutAddress=Address{addressCredential}} = addressCredential
-    in CredentialMap . Map.fromListWith (<>) . fmap (bimap credential Set.singleton) . txOutsWithRef
+    in CredentialMap
+       . Map.fromListWith (<>)
+       . fmap (bimap credential Set.singleton)
+       . txOutsWithRef
+
+-- | Set of transaction output references for each asset class.
+newtype AssetClassMap = AssetClassMap { _unAssetClassMap :: Map AssetClass (Set TxOutRef) }
+    deriving stock (Eq, Show, Generic)
+
+makeLenses ''AssetClassMap
+
+type instance IxValue AssetClassMap = Set TxOutRef
+type instance Index AssetClassMap = AssetClass
+
+instance Ixed AssetClassMap where
+    ix ac f (AssetClassMap mp) = AssetClassMap <$> ix ac f mp
+
+instance At AssetClassMap where
+    at idx = lens g s where
+        g (AssetClassMap mp) = mp ^. at idx
+        s (AssetClassMap mp) refs = AssetClassMap $ mp & at idx .~ refs
+
+instance Semigroup AssetClassMap where
+    (AssetClassMap l) <> (AssetClassMap r) = AssetClassMap $ Map.unionWith (<>) l r
+
+instance Monoid AssetClassMap where
+    mappend = (<>)
+    mempty  = AssetClassMap mempty
+
+-- | Convert the outputs of the transaction into a 'AssetClassMap'.
+txAssetClassMap :: ChainIndexTx -> AssetClassMap
+txAssetClassMap =
+    AssetClassMap
+      . Map.fromListWith (<>)
+      . concatMap (\(txOut, txOutRef) ->
+          fmap (, Set.singleton txOutRef) $ assetClassesOfTxOut txOut)
+      . txOutsWithRef
+  where
+    assetClassesOfTxOut :: TxOut -> [AssetClass]
+    assetClassesOfTxOut TxOut { txOutValue } =
+      fmap (\(c, t, _) -> AssetClass (c, t))
+           $ filter (\(c, t, _) -> not $ c == Ada.adaSymbol && t == Ada.adaToken)
+           $ flattenValue txOutValue
 
 -- | Data that we keep on disk. (This type is used for testing only - we need
 --   other structures for the disk-backed storage)
 data DiskState =
     DiskState
-        { _DataMap     :: Map DatumHash Datum
-        , _ScriptMap   :: Map ScriptHash Script
-        , _RedeemerMap :: Map RedeemerHash Redeemer
-        , _TxMap       :: Map TxId ChainIndexTx
-        , _AddressMap  :: CredentialMap
+        { _DataMap       :: Map DatumHash Datum
+        , _ScriptMap     :: Map ScriptHash Script
+        , _RedeemerMap   :: Map RedeemerHash Redeemer
+        , _TxMap         :: Map TxId ChainIndexTx
+        , _AddressMap    :: CredentialMap
+        , _AssetClassMap :: AssetClassMap
         }
         deriving stock (Eq, Show, Generic)
         deriving (Semigroup, Monoid) via (GenericSemigroupMonoid DiskState)
@@ -90,14 +139,16 @@ fromTx tx =
         , _TxMap = Map.singleton (view citxTxId tx) tx
         , _RedeemerMap = view citxRedeemers tx
         , _AddressMap = txCredentialMap tx
+        , _AssetClassMap = txAssetClassMap tx
         }
 
 diagnostics :: DiskState -> Diagnostics
-diagnostics DiskState{_DataMap, _ScriptMap, _TxMap, _RedeemerMap, _AddressMap} =
+diagnostics DiskState{_DataMap, _ScriptMap, _TxMap, _RedeemerMap, _AddressMap, _AssetClassMap} =
     Diagnostics
         { numTransactions = toInteger $ Map.size _TxMap
         , numScripts = toInteger $ Map.size _ScriptMap
         , numAddresses = toInteger $ Map.size $ _unCredentialMap _AddressMap
+        , numAssetClasses = toInteger $ Map.size $ _unAssetClassMap _AssetClassMap
         , someTransactions = take 10 $ fmap fst $ Map.toList _TxMap
         -- These 2 are filled in Handlers.hs
         , numUnmatchedInputs = 0

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

@@ -41,7 +41,8 @@ import           Ledger.Scripts                        (ScriptHash (ScriptHash))
 import           Plutus.ChainIndex.ChainIndexError     (ChainIndexError (..))
 import           Plutus.ChainIndex.ChainIndexLog       (ChainIndexLog (..))
 import           Plutus.ChainIndex.Effects             (ChainIndexControlEffect (..), ChainIndexQueryEffect (..))
-import           Plutus.ChainIndex.Emulator.DiskState  (DiskState, addressMap, dataMap, redeemerMap, scriptMap, txMap)
+import           Plutus.ChainIndex.Emulator.DiskState  (DiskState, addressMap, assetClassMap, dataMap, redeemerMap,
+                                                        scriptMap, txMap)
 import qualified Plutus.ChainIndex.Emulator.DiskState  as DiskState
 import           Plutus.ChainIndex.Tx                  (ChainIndexTx, _ValidTx, citxOutputs)
 import qualified Plutus.ChainIndex.TxUtxoBalance       as TxUtxoBalance
@@ -131,9 +132,20 @@ handleQuery = \case
         state <- get
         let outRefs = view (diskState . addressMap . at cred) state
             utxo = view (utxoIndex . to utxoState) state
-            page = pageOf pageQuery
-                 $ Set.filter (flip TxUtxoBalance.isUnspentOutput utxo)
-                              (fromMaybe mempty outRefs)
+            utxoRefs = Set.filter (flip TxUtxoBalance.isUnspentOutput utxo)
+                                  (fromMaybe mempty outRefs)
+            page = pageOf pageQuery utxoRefs
+        case tip utxo of
+            TipAtGenesis -> do
+                logWarn TipIsGenesis
+                pure (TipAtGenesis, pageOf pageQuery Set.empty)
+            tp           -> pure (tp, page)
+    UtxoSetWithCurrency pageQuery assetClass -> do
+        state <- get
+        let outRefs = view (diskState . assetClassMap . at assetClass) state
+            utxo = view (utxoIndex . to utxoState) state
+            utxoRefs = Set.filter (flip TxUtxoBalance.isUnspentOutput utxo) (fromMaybe mempty outRefs)
+            page = pageOf pageQuery utxoRefs
         case tip utxo of
             TipAtGenesis -> do
                 logWarn TipIsGenesis