Merge pull request #757 from input-output-hk/plt-8029-index-marlowe-a…

…ccounts

PLT-8029 index parties in state accounts

.github/workflows/test.yml

@@ -61,9 +61,9 @@ jobs:
       - if: ${{ steps.cache-results.outputs.cache-hit != 'true' }}
         name: Run tests
         run: |
-          result/bin/marlowe-integration-tests --strict > ~/integration-tests.log
+          set -o pipefail
+          result/bin/marlowe-integration-tests --strict | tee ~/integration-tests.log
           echo $? > ~/integration-tests.status
-          cat ~/integration-tests.log
           exit $(cat ~/integration-tests.status)
         env:
           MARLOWE_RT_TEST_DB_HOST: localhost

marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs

@@ -203,10 +203,10 @@ applyVariation filterSym = \case
 
 partyAddressesForContract :: RefSym GetHeaders -> Set PartyAddress
 partyAddressesForContract = \case
-  Contract1 -> Set.singleton Wallet2
-  Contract2 -> Set.singleton Wallet1
-  Contract3 -> Set.singleton Wallet2
-  Contract4 -> mempty -- wallet 1 is not a *visible* party address of contract 4 due to merkleization.
+  Contract1 -> Set.fromList [Wallet1, Wallet2]
+  Contract2 -> Set.fromList [Wallet1, Wallet2]
+  Contract3 -> Set.fromList [Wallet1, Wallet2]
+  Contract4 -> Set.singleton Wallet2 -- wallet 1 is not a *visible* party address of contract 4 due to merkleization.
 
 instance PaginatedQuery GetWithdrawals where
   type Filter GetWithdrawals = WithdrawalFilter

marlowe-runtime/changelog.d/20231120_130123_jhbertra_plt_8029_index_marlowe_accounts.md

@@ -0,0 +1,4 @@
+### Changed
+
+- `marlowe-indexer` now indexes contracts by parties in the accounts as well as
+  the contract.

marlowe-runtime/indexer/Language/Marlowe/Runtime/Indexer/Database/PostgreSQL/CommitBlocks.hs

@@ -22,6 +22,7 @@ import Hasql.TH (resultlessStatement)
 import qualified Hasql.Transaction as H
 import Language.Marlowe.Core.V1.Plate (Extract (..))
 import Language.Marlowe.Core.V1.Semantics (MarloweData (..), MarloweParams (..))
+import Language.Marlowe.Core.V1.Semantics.Types (ChoiceId (..), Party, State (..))
 import Language.Marlowe.Runtime.ChainSync.Api
 import Language.Marlowe.Runtime.Core.Api (
   ContractId (..),
@@ -43,6 +44,7 @@ import Language.Marlowe.Runtime.History.Api (
 import Language.Marlowe.Runtime.Indexer.Party (ContractTxOutParty (ContractTxOutParty), commitParties)
 import Language.Marlowe.Runtime.Indexer.Types
 import PlutusLedgerApi.V2 (CurrencySymbol (..), fromBuiltin)
+import qualified PlutusTx.AssocMap as AMap
 
 commitBlocks :: [MarloweBlock] -> H.Transaction ()
 commitBlocks blocks = do
@@ -283,7 +285,7 @@ transactionScriptOutputToRows contractId blockHeader@BlockHeader{..} payoutValid
     , toStrict $ runPut $ put $ toDatum marloweState
     , roleTokenMintingPolicyId
     , ContractTxOutParty TxOutRef{..} contractId roleTokenMintingPolicyId
-        <$> Set.toList (extractAll marloweContract)
+        <$> Set.toList (extractAll marloweContract <> stateParties marloweState)
     )
   , assetsToTxOutAssetRows blockHeader txId' txIx' assets
   )
@@ -293,6 +295,15 @@ transactionScriptOutputToRows contractId blockHeader@BlockHeader{..} payoutValid
     txId' = unTxId txId
     txIx' = fromIntegral txIx
 
+stateParties :: State -> Set.Set Party
+stateParties State{..} =
+  Set.fromList $
+    (fst <$> AMap.keys accounts)
+      <> (choiceParty <$> AMap.keys choices)
+
+choiceParty :: ChoiceId -> Party
+choiceParty (ChoiceId _ party) = party
+
 type CreateTxOutRow =
   ( ByteString -- txId
   , Int16 -- txIx

marlowe-runtime/indexer/Language/Marlowe/Runtime/Indexer/Party.hs

@@ -21,6 +21,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Foldable (Foldable (..))
 import Data.Int (Int16, Int64)
+import Data.List (nub)
 import Data.Maybe (fromJust)
 import Data.Semigroup (Max (..))
 import qualified Data.Set as Set
@@ -32,11 +33,12 @@ import Hasql.TH (resultlessStatement, singletonStatement, vectorStatement)
 import qualified Hasql.Transaction as T
 import qualified Hasql.Transaction.Sessions as T
 import Language.Marlowe.Core.V1.Plate (Extract (..))
-import Language.Marlowe.Core.V1.Semantics.Types (Contract, Party (..))
+import Language.Marlowe.Core.V1.Semantics.Types (ChoiceId (..), Contract, Party (..), State (..))
 import Language.Marlowe.Core.V1.Semantics.Types.Address (serialiseAddress)
 import Language.Marlowe.Runtime.ChainSync.Api (SlotNo (..), TxId (..), TxOutRef (..), fromDatum)
 import Language.Marlowe.Runtime.Core.Api (ContractId (..))
 import qualified PlutusLedgerApi.V2 as PV2
+import qualified PlutusTx.AssocMap as Map
 import UnliftIO (throwIO)
 
 indexParties :: (MonadIO m, WithLog env Message m) => Connection -> m ()
@@ -93,6 +95,7 @@ loadContracts fromSlot =
           COALESCE(createTxOut.txId, applyTx.createTxId) :: bytea,
           COALESCE(createTxOut.txIx, applyTx.createTxIx) :: smallint,
           contractTxOut.contract :: bytea,
+          contractTxOut.state :: bytea,
           blocks.slotNo :: bigint,
           contractTxOut.rolesCurrency :: bytea
         FROM marlowe.contractTxOut
@@ -110,22 +113,30 @@ loadContracts fromSlot =
           AND contractTxOutPartyRole.txId IS NULL
       |]
 
-decodeContractTxOut :: (ByteString, Int16, ByteString, Int16, ByteString, Int64, ByteString) -> ContractTxOut
-decodeContractTxOut (txId, txIx, createTxId, createTxIx, contract, slotNo, rolesCurrency) =
+decodeContractTxOut
+  :: (ByteString, Int16, ByteString, Int16, ByteString, ByteString, Int64, ByteString) -> ContractTxOut
+decodeContractTxOut (txId, txIx, createTxId, createTxIx, contract, state, slotNo, rolesCurrency) =
   ContractTxOut
     { contractOut = TxOutRef (TxId txId) (fromIntegral txIx)
     , contractId = ContractId $ TxOutRef (TxId createTxId) (fromIntegral createTxIx)
     , contract = fromJust $ fromDatum $ runGet get $ LBS.fromStrict contract
+    , state = fromJust $ fromDatum $ runGet get $ LBS.fromStrict state
     , slotNo = fromIntegral slotNo
     , rolesCurrency
     }
 
 toEntries :: ContractTxOut -> (Max SlotNo, [ContractTxOutParty])
 toEntries ContractTxOut{..} =
   ( Max slotNo
-  , [ContractTxOutParty{..} | party <- Set.toList $ extractAll contract]
+  , nub $
+      [ContractTxOutParty{..} | party <- Set.toList $ extractAll contract]
+        <> [ContractTxOutParty{..} | party <- fmap fst . Map.keys $ accounts state]
+        <> [ContractTxOutParty{..} | party <- fmap choiceParty . Map.keys $ choices state]
   )
 
+choiceParty :: ChoiceId -> Party
+choiceParty (ChoiceId _ party) = party
+
 commitParties :: [ContractTxOutParty] -> T.Transaction ()
 commitParties parties =
   T.statement params statement
@@ -215,6 +226,7 @@ data ContractTxOut = ContractTxOut
   { contractOut :: TxOutRef
   , contractId :: ContractId
   , contract :: Contract
+  , state :: State
   , rolesCurrency :: ByteString
   , slotNo :: SlotNo
   }
@@ -225,3 +237,4 @@ data ContractTxOutParty = ContractTxOutParty
   , rolesCurrency :: ByteString
   , party :: Party
   }
+  deriving (Eq)

marlowe-runtime/marlowe-indexer/deploy/resetParties.sql

@@ -0,0 +1,9 @@
+-- Deploy marlowe:resetParties to pg
+-- requires: parties
+
+BEGIN;
+
+TRUNCATE TABLE marlowe.contractTxOutPartyAddress;
+TRUNCATE TABLE marlowe.contractTxOutPartyRole;
+
+COMMIT;

marlowe-runtime/marlowe-indexer/revert/resetParties.sql

@@ -0,0 +1,7 @@
+-- Revert marlowe:resetParties from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;

marlowe-runtime/marlowe-indexer/sqitch.plan

@@ -11,3 +11,4 @@ indexRoleCurrency [schema] 2023-02-28T21:16:41Z Jamie Bertram <jamie.bertram@ioh
 tags [schema] 2023-03-02T18:33:26Z Jamie Bertram <[email protected]> # Adds contract tags table.
 tag-text [tags] 2023-07-11T12:37:05Z Jamie Bertram <[email protected]> # Changes tags from varchar(64) to text.
 parties [schema] 2023-08-29T15:49:56Z Jamie Bertram <[email protected]> # Adds party indexes.
+resetParties [parties] 2023-11-20T17:09:21Z Jamie Bertram <[email protected]> # Reset parties index

marlowe-runtime/marlowe-indexer/verify/resetParties.sql

@@ -0,0 +1,7 @@
+-- Verify marlowe:resetParties on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;

marlowe-runtime/marlowe-runtime.cabal

@@ -314,6 +314,7 @@ library indexer
     , mtl >=2.2 && <3
     , nonempty-containers ^>=0.3.4
     , plutus-ledger-api ^>=1.5
+    , plutus-tx ^>=1.5
     , stm ^>=2.5
     , text ^>=1.2
     , time >=1.9 && <2