Implement getRoleCurrencies query

marlowe-runtime/.golden/MarloweQuery/golden

@@ -106,6 +106,20 @@ Show: MsgRequest Nothing (ReqLeaf (ReqPayouts (PayoutFilter {isWithdrawn = Nothi
 Binary: 010000080000000000000000000000000000000000000000000000000001000000000000000100
 Show: MsgRequest Nothing (ReqLeaf (ReqPayouts (PayoutFilter {isWithdrawn = Nothing, contractIds = fromList [], roleTokens = fromList []}) (Range {rangeStart = Nothing, rangeOffset = 1, rangeLimit = 1, rangeDirection = Descending})))
 Binary: 010000080000000000000000000000000000000000000000000000000001000000000000000101
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilter (fromList [""]) (fromList []))))
+Binary: 0100000a01000000000000000100000000000000000000000000000000
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilter (fromList ["61"]) (fromList []))))
+Binary: 0100000a0100000000000000010000000000000001610000000000000000
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilter (fromList []) (fromList [ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}]))))
+Binary: 0100000a010000000000000000000000000000000100000000000000000001
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilter (fromList []) (fromList [ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}]))))
+Binary: 0100000a01000000000000000000000000000000010000000000000001610001
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilter (fromList []) (fromList []))))
+Binary: 0100000a0100000000000000000000000000000000
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies RoleCurrencyFilterAny))
+Binary: 0100000a02
+Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies RoleCurrencyFilterNone))
+Binary: 0100000a00
 Show: MsgRequest Nothing (ReqLeaf (ReqTransaction ""))
 Binary: 010000030000000000000000
 Show: MsgRequest Nothing (ReqLeaf (ReqTransaction "61"))
@@ -6036,6 +6050,14 @@ Show: MsgRespond (RuntimeStatus {nodeTip = Genesis, nodeTipUTC = 2000-01-01 00:0
 Binary: 0000000007d00000000000000001010100000000000000050010a5d4e80000000007d00000000000000001010100000000000000050010a5d4e80000000007d00000000000000001010100000000000000050010a5d4e80000000000000000000000000000000000
 Show: MsgRespond (RuntimeStatus {nodeTip = Genesis, nodeTipUTC = 2000-01-01 00:00:01 UTC, runtimeChainTip = Genesis, runtimeChainTipUTC = 2000-01-01 00:00:01 UTC, runtimeTip = Genesis, runtimeTipUTC = 2000-01-01 00:00:01 UTC, networkId = Testnet (NetworkMagic {unNetworkMagic = 0}), runtimeVersion = Version {versionBranch = [], versionTags = []}})
 Binary: 0000000007d00000000000000001010100000000000000050010a5d4e80000000007d00000000000000001010100000000000000050010a5d4e80000000007d00000000000000001010100000000000000050010a5d4e8010000000000000000000000000000000000000000
+Show: MsgRespond (fromList [RoleCurrency {rolePolicyId = "", roleContract = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}}])
+Binary: 0000000000000001000000000000000000000000000000000001
+Show: MsgRespond (fromList [RoleCurrency {rolePolicyId = "", roleContract = ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}}])
+Binary: 000000000000000100000000000000000000000000000001610001
+Show: MsgRespond (fromList [RoleCurrency {rolePolicyId = "61", roleContract = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}}])
+Binary: 000000000000000100000000000000016100000000000000000001
+Show: MsgRespond (fromList [])
+Binary: 0000000000000000
 Show: MsgRespond Nothing
 Binary: 00
 Show: MsgRespond Nothing

marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Client.hs

@@ -7,6 +7,7 @@
 
 module Language.Marlowe.Protocol.Query.Client where
 
+import Data.Set (Set)
 import Language.Marlowe.Protocol.Query.Types
 import Language.Marlowe.Runtime.ChainSync.Api (TxId, TxOutRef)
 import Language.Marlowe.Runtime.Core.Api (ContractId)
@@ -42,5 +43,9 @@ getPayouts
   :: (Applicative m) => PayoutFilter -> Range TxOutRef -> MarloweQueryClient m (Maybe (Page TxOutRef PayoutHeader))
 getPayouts = fmap request . ReqPayouts
 
+getRoleCurrencies
+  :: (Applicative m) => RoleCurrencyFilter -> MarloweQueryClient m (Set RoleCurrency)
+getRoleCurrencies = request . ReqRoleCurrencies
+
 getPayout :: (Applicative m) => TxOutRef -> MarloweQueryClient m (Maybe SomePayoutState)
 getPayout = request . ReqPayout

marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Server.hs

@@ -6,6 +6,7 @@ module Language.Marlowe.Protocol.Query.Server where
 
 import Cardano.Api (EraHistory (..), SlotNo (SlotNo), SystemStart (getSystemStart))
 import Control.Monad.IO.Class (MonadIO)
+import Data.Set (Set)
 import Data.Time (UTCTime)
 import Data.Version (Version)
 import Language.Marlowe.Protocol.Query.Types
@@ -43,6 +44,7 @@ marloweQueryServer
   -> (WithdrawalFilter -> Range TxId -> m (Maybe (Page TxId Withdrawal)))
   -> (PayoutFilter -> Range TxOutRef -> m (Maybe (Page TxOutRef PayoutHeader)))
   -> (TxOutRef -> m (Maybe SomePayoutState))
+  -> (RoleCurrencyFilter -> m (Set RoleCurrency))
   -> MarloweQueryServer m ()
 marloweQueryServer
   runtimeVersion
@@ -55,7 +57,8 @@ marloweQueryServer
   getWithdrawal
   getWithdrawals
   getPayouts
-  getPayout =
+  getPayout
+  getRoleCurrencies =
     respond concurrently \case
       ReqContractHeaders cFilter range -> getContractHeaders cFilter range
       ReqContractState contractId -> getContractState contractId
@@ -65,6 +68,7 @@ marloweQueryServer
       ReqWithdrawals wFilter range -> getWithdrawals wFilter range
       ReqPayouts pFilter range -> getPayouts pFilter range
       ReqPayout payoutId -> getPayout payoutId
+      ReqRoleCurrencies cFilter -> getRoleCurrencies cFilter
       ReqStatus -> do
         ((nodeTip, runtimeChainTip, systemStart, history, networkId), runtimeTip) <-
           concurrently

marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs

@@ -115,6 +115,30 @@ data RuntimeStatus = RuntimeStatus
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (Binary, Variations)
 
+data RoleCurrency = RoleCurrency
+  { rolePolicyId :: PolicyId
+  , roleContract :: ContractId
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (Binary, Variations)
+
+data RoleCurrencyFilter
+  = RoleCurrencyFilterNone
+  | RoleCurrencyFilter (Set PolicyId) (Set ContractId)
+  | RoleCurrencyFilterAny
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (Binary, Variations, ToJSON)
+
+instance Semigroup RoleCurrencyFilter where
+  RoleCurrencyFilterNone <> a = a
+  a <> RoleCurrencyFilterNone = a
+  RoleCurrencyFilterAny <> _ = RoleCurrencyFilterAny
+  _ <> RoleCurrencyFilterAny = RoleCurrencyFilterAny
+  RoleCurrencyFilter p c <> RoleCurrencyFilter p' c' = RoleCurrencyFilter (p <> p') (c <> c')
+
+instance Monoid RoleCurrencyFilter where
+  mempty = RoleCurrencyFilterNone
+
 data MarloweSyncRequest a where
   ReqStatus :: MarloweSyncRequest RuntimeStatus
   ReqContractHeaders :: ContractFilter -> Range ContractId -> MarloweSyncRequest (Maybe (Page ContractId ContractHeader))
@@ -125,6 +149,7 @@ data MarloweSyncRequest a where
   ReqWithdrawals :: WithdrawalFilter -> Range TxId -> MarloweSyncRequest (Maybe (Page TxId Withdrawal))
   ReqPayouts :: PayoutFilter -> Range TxOutRef -> MarloweSyncRequest (Maybe (Page TxOutRef PayoutHeader))
   ReqPayout :: TxOutRef -> MarloweSyncRequest (Maybe SomePayoutState)
+  ReqRoleCurrencies :: RoleCurrencyFilter -> MarloweSyncRequest (Set RoleCurrency)
 
 deriving instance Show (MarloweSyncRequest a)
 deriving instance Eq (MarloweSyncRequest a)
@@ -140,6 +165,7 @@ instance Request MarloweSyncRequest where
     TagWithdrawals :: Tag MarloweSyncRequest (Maybe (Page TxId Withdrawal))
     TagPayouts :: Tag MarloweSyncRequest (Maybe (Page TxOutRef PayoutHeader))
     TagPayout :: Tag MarloweSyncRequest (Maybe SomePayoutState)
+    TagRoleCurrencies :: Tag MarloweSyncRequest (Set RoleCurrency)
   tagFromReq = \case
     ReqStatus -> TagStatus
     ReqContractHeaders _ _ -> TagContractHeaders
@@ -150,6 +176,7 @@ instance Request MarloweSyncRequest where
     ReqWithdrawals _ _ -> TagWithdrawals
     ReqPayouts _ _ -> TagPayouts
     ReqPayout _ -> TagPayout
+    ReqRoleCurrencies _ -> TagRoleCurrencies
   tagEq = \case
     TagStatus -> \case
       TagStatus -> Just Refl
@@ -178,6 +205,9 @@ instance Request MarloweSyncRequest where
     TagPayout -> \case
       TagPayout -> Just Refl
       _ -> Nothing
+    TagRoleCurrencies -> \case
+      TagRoleCurrencies -> Just Refl
+      _ -> Nothing
 
 deriving instance Show (Tag MarloweSyncRequest a)
 deriving instance Eq (Tag MarloweSyncRequest a)
@@ -195,6 +225,7 @@ instance BinaryRequest MarloweSyncRequest where
       0x07 -> pure $ SomeRequest ReqStatus
       0x08 -> SomeRequest <$> (ReqPayouts <$> get <*> get)
       0x09 -> SomeRequest <$> (ReqPayout <$> get)
+      0x0a -> SomeRequest <$> (ReqRoleCurrencies <$> get)
       _ -> fail "Invalid MarloweSyncRequest tag"
 
   putReq req = case req of
@@ -226,6 +257,9 @@ instance BinaryRequest MarloweSyncRequest where
     ReqPayout payoutId -> do
       putWord8 0x09
       put payoutId
+    ReqRoleCurrencies cFilter -> do
+      putWord8 0x0a
+      put cFilter
 
   getResult = \case
     TagContractHeaders -> get
@@ -237,6 +271,7 @@ instance BinaryRequest MarloweSyncRequest where
     TagPayouts -> get
     TagPayout -> get
     TagStatus -> get
+    TagRoleCurrencies -> get
 
   putResult = \case
     TagContractHeaders -> put
@@ -248,6 +283,7 @@ instance BinaryRequest MarloweSyncRequest where
     TagPayouts -> put
     TagPayout -> put
     TagStatus -> put
+    TagRoleCurrencies -> put
 
 instance RequestVariations MarloweSyncRequest where
   tagVariations =
@@ -261,6 +297,7 @@ instance RequestVariations MarloweSyncRequest where
       , SomeTag TagPayouts
       , SomeTag TagPayout
       , SomeTag TagStatus
+      , SomeTag TagRoleCurrencies
       ]
   requestVariations = \case
     TagContractHeaders -> ReqContractHeaders <$> variations `varyAp` variations
@@ -272,6 +309,7 @@ instance RequestVariations MarloweSyncRequest where
     TagPayouts -> ReqPayouts <$> variations `varyAp` variations
     TagPayout -> ReqPayout <$> variations
     TagStatus -> pure ReqStatus
+    TagRoleCurrencies -> ReqRoleCurrencies <$> variations
   resultVariations = \case
     TagContractHeaders -> variations
     TagContractState -> variations
@@ -282,6 +320,7 @@ instance RequestVariations MarloweSyncRequest where
     TagPayouts -> variations
     TagPayout -> variations
     TagStatus -> variations
+    TagRoleCurrencies -> variations
 
 instance ToJSON (MarloweSyncRequest a) where
   toJSON = \case
@@ -330,6 +369,10 @@ instance ToJSON (MarloweSyncRequest a) where
         [ "get-payouts" .= payoutId
         ]
     ReqStatus -> String "get-status"
+    ReqRoleCurrencies cFilter ->
+      object
+        [ "get-role-currencies" .= cFilter
+        ]
 
 data Range a = Range
   { rangeStart :: Maybe a
@@ -583,6 +626,7 @@ instance OTelRequest MarloweSyncRequest where
     TagPayouts -> "payouts"
     TagPayout -> "payout"
     TagStatus -> "status"
+    TagRoleCurrencies -> "role_currencies"
 
 instance ShowRequest MarloweSyncRequest where
   showsPrecResult p = \case
@@ -595,6 +639,7 @@ instance ShowRequest MarloweSyncRequest where
     TagPayouts -> showsPrec p
     TagPayout -> showsPrec p
     TagStatus -> showsPrec p
+    TagRoleCurrencies -> showsPrec p
 
 instance RequestEq MarloweSyncRequest where
   resultEq TagContractHeaders = (==)
@@ -606,3 +651,4 @@ instance RequestEq MarloweSyncRequest where
   resultEq TagPayouts = (==)
   resultEq TagPayout = (==)
   resultEq TagStatus = (==)
+  resultEq TagRoleCurrencies = (==)

marlowe-runtime/sync/Language/Marlowe/Runtime/Sync.hs

@@ -140,6 +140,9 @@ renderDatabaseSelectorOTel dbName dbUser host port = \case
   GetPayout ->
     renderQuerySelectorOTel "get_payout" $
       Just . toAttribute . renderTxOutRef
+  GetRoleCurrencies ->
+    renderQuerySelectorOTel "get_role_currencies" $
+      Just . fromString . show
   where
     renderQuerySelectorOTel :: Text -> (p -> Maybe Attribute) -> OTelRendered (QueryField p r)
     renderQuerySelectorOTel queryName renderArguments =

marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database.hs

@@ -10,6 +10,7 @@ module Language.Marlowe.Runtime.Sync.Database where
 
 import Control.Monad.Event.Class (MonadInjectEvent, withEvent)
 import Data.Aeson (ToJSON)
+import Data.Set (Set)
 import Data.Word (Word8)
 import GHC.Generics (Generic)
 import Language.Marlowe.Protocol.Query.Types (
@@ -18,6 +19,8 @@ import Language.Marlowe.Protocol.Query.Types (
   PayoutFilter,
   PayoutHeader,
   Range,
+  RoleCurrency,
+  RoleCurrencyFilter,
   SomeContractState,
   SomePayoutState,
   SomeTransaction,
@@ -49,6 +52,7 @@ data DatabaseSelector f where
   GetWithdrawals :: DatabaseSelector (QueryField GetWithdrawalsArguments (Maybe (Page TxId Withdrawal)))
   GetPayouts :: DatabaseSelector (QueryField GetPayoutsArguments (Maybe (Page TxOutRef PayoutHeader)))
   GetPayout :: DatabaseSelector (QueryField TxOutRef (Maybe SomePayoutState))
+  GetRoleCurrencies :: DatabaseSelector (QueryField RoleCurrencyFilter (Set RoleCurrency))
 
 data GetPayoutsArguments = GetPayoutsArguments
   { filter :: PayoutFilter
@@ -187,6 +191,11 @@ logDatabaseQueries DatabaseQueries{..} =
         result <- getPayout payoutId
         addField ev $ Result result
         pure result
+    , getRoleCurrencies = \cFilter -> withEvent GetRoleCurrencies \ev -> do
+        addField ev $ Arguments cFilter
+        result <- getRoleCurrencies cFilter
+        addField ev $ Result result
+        pure result
     }
 
 hoistDatabaseQueries :: (forall x. m x -> n x) -> DatabaseQueries m -> DatabaseQueries n
@@ -208,6 +217,7 @@ hoistDatabaseQueries f DatabaseQueries{..} =
     , getWithdrawals = fmap f . getWithdrawals
     , getPayouts = fmap f . getPayouts
     , getPayout = f . getPayout
+    , getRoleCurrencies = f . getRoleCurrencies
     }
 
 data DatabaseQueries m = DatabaseQueries
@@ -227,6 +237,7 @@ data DatabaseQueries m = DatabaseQueries
   , getWithdrawals :: WithdrawalFilter -> Range TxId -> m (Maybe (Page TxId Withdrawal))
   , getPayouts :: PayoutFilter -> Range TxOutRef -> m (Maybe (Page TxOutRef PayoutHeader))
   , getPayout :: TxOutRef -> m (Maybe SomePayoutState)
+  , getRoleCurrencies :: RoleCurrencyFilter -> m (Set RoleCurrency)
   }
 
 data Next a

marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs

@@ -39,3 +39,4 @@ databaseQueries =
     (fmap (T.transaction T.Serializable T.Read) . getWithdrawals)
     (fmap (T.transaction T.Serializable T.Read) . getPayouts)
     (T.transaction T.Serializable T.Read . getPayout)
+    (T.transaction T.Serializable T.Read . undefined)

marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/QueryServer.hs

@@ -30,5 +30,6 @@ queryServer QueryServerDependencies{..} =
         getWithdrawals
         getPayouts
         getPayout
+        getRoleCurrencies
   where
     DatabaseQueries{..} = databaseQueries

marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs

@@ -32,6 +32,7 @@ instance ArbitraryRequest MarloweSyncRequest where
       , SomeTag TagWithdrawals
       , SomeTag TagPayout
       , SomeTag TagPayouts
+      , SomeTag TagRoleCurrencies
       , SomeTag TagStatus
       ]
   arbitraryReq = \case
@@ -44,6 +45,7 @@ instance ArbitraryRequest MarloweSyncRequest where
     TagStatus -> pure ReqStatus
     TagPayouts -> ReqPayouts <$> arbitrary <*> arbitrary
     TagPayout -> ReqPayout <$> arbitrary
+    TagRoleCurrencies -> ReqRoleCurrencies <$> arbitrary
 
   shrinkReq = \case
     ReqContractHeaders cFilter range ->
@@ -67,6 +69,7 @@ instance ArbitraryRequest MarloweSyncRequest where
         , ReqPayouts pFilter <$> shrink range
         ]
     ReqPayout payoutId -> ReqPayout <$> shrink payoutId
+    ReqRoleCurrencies cFilter -> ReqRoleCurrencies <$> shrink cFilter
 
   arbitraryResult = \case
     TagContractHeaders -> arbitrary
@@ -78,6 +81,7 @@ instance ArbitraryRequest MarloweSyncRequest where
     TagStatus -> arbitrary
     TagPayouts -> arbitrary
     TagPayout -> arbitrary
+    TagRoleCurrencies -> arbitrary
 
   shrinkResult = \case
     TagContractHeaders -> shrink
@@ -89,6 +93,20 @@ instance ArbitraryRequest MarloweSyncRequest where
     TagStatus -> shrink
     TagPayouts -> shrink
     TagPayout -> shrink
+    TagRoleCurrencies -> shrink
+
+instance Arbitrary RoleCurrency where
+  arbitrary = RoleCurrency <$> arbitrary <*> arbitrary
+  shrink = genericShrink
+
+instance Arbitrary RoleCurrencyFilter where
+  arbitrary =
+    frequency
+      [ (1, pure RoleCurrencyFilterNone)
+      , (1, pure RoleCurrencyFilterAny)
+      , (10, RoleCurrencyFilter <$> arbitrary <*> arbitrary)
+      ]
+  shrink = genericShrink
 
 instance Arbitrary SomeContractState where
   arbitrary = SomeContractState MarloweV1 <$> arbitrary