From e2e506ed452fe1686bec21df5a8b16c8ff400bb0 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 6 Feb 2024 10:56:26 -0500 Subject: [PATCH 01/18] Add burn command to tx API --- .../Marlowe/Runtime/Transaction/Api.hs | 271 +++++++++++++++++- 1 file changed, 270 insertions(+), 1 deletion(-) diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index 65b226bfcf..93bfe61c54 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -14,6 +14,9 @@ module Language.Marlowe.Runtime.Transaction.Api ( Account (..), ApplyInputsConstraintsBuildupError (..), ApplyInputsError (..), + BurnError (..), + BurnTx (..), + BurnTxInEra (..), CoinSelectionError (..), ConstraintError (..), ContractCreated (..), @@ -30,6 +33,16 @@ module Language.Marlowe.Runtime.Transaction.Api ( Mint (..), MintRole (..), NFTMetadataFile (..), + RoleToken (..), + RoleTokenFilter ( + RoleTokensOr, + RoleTokensAnd, + RoleTokenFilterAny, + RoleTokenFilterNone, + RoleTokenFilterByContracts, + RoleTokenFilterByPolicyIds, + RoleTokenFilterByTokens + ), RoleTokenMetadata (..), RoleTokensConfig (RoleTokensNone, RoleTokensUsePolicy, RoleTokensMint), SubmitError (..), @@ -41,6 +54,8 @@ module Language.Marlowe.Runtime.Transaction.Api ( WithdrawTxInEra (..), decodeRoleTokenMetadata, encodeRoleTokenMetadata, + evalRoleTokenFilter, + filterRoleTokens, getTokenQuantities, hasRecipient, mkMint, @@ -104,7 +119,7 @@ import Language.Marlowe.Runtime.Cardano.Api (cardanoEraToAsType) import Language.Marlowe.Runtime.Cardano.Feature (hush) import Language.Marlowe.Runtime.ChainSync.Api ( Address, - AssetId, + AssetId (..), Assets, BlockHeader, DatumHash, @@ -757,12 +772,222 @@ instance (IsShelleyBasedEra era) => ToJSON (InputsAppliedInEra era 'V1) where , "tx-body" .= serialiseToTextEnvelope Nothing txBody ] +data BurnTx where + BurnTx + :: BabbageEraOnwards era -> BurnTxInEra era -> BurnTx + +instance Variations BurnTx where + variations = BurnTx BabbageEraOnwardsBabbage <$> variations + +instance Show BurnTx where + showsPrec p (BurnTx BabbageEraOnwardsBabbage created) = + showParen (p > 10) $ + showString "BurnTx" + . showSpace + . showString "BabbageEraOnwardsBabbage" + . showsPrec 11 created + showsPrec p (BurnTx BabbageEraOnwardsConway created) = + showParen (p > 10) $ + showString "BurnTx" + . showSpace + . showString "BabbageEraOnwardsConway" + . showsPrec 11 created + +instance Eq BurnTx where + BurnTx BabbageEraOnwardsBabbage a == BurnTx BabbageEraOnwardsBabbage b = + a == b + BurnTx BabbageEraOnwardsBabbage _ == _ = False + BurnTx BabbageEraOnwardsConway a == BurnTx BabbageEraOnwardsConway b = + a == b + BurnTx BabbageEraOnwardsConway _ == _ = False + +instance Binary BurnTx where + put (BurnTx BabbageEraOnwardsBabbage created) = do + putWord8 0 + put created + put (BurnTx BabbageEraOnwardsConway created) = do + putWord8 1 + put created + get = do + eraTag <- getWord8 + case eraTag of + 0 -> BurnTx BabbageEraOnwardsBabbage <$> get + 1 -> BurnTx BabbageEraOnwardsConway <$> get + _ -> fail $ "Invalid era tag value: " <> show eraTag + +data BurnTxInEra era = BurnTxInEra + { burnedTokens :: Chain.Assets + , txBody :: TxBody era + } + +deriving instance Show (BurnTxInEra BabbageEra) +deriving instance Eq (BurnTxInEra BabbageEra) +deriving instance Show (BurnTxInEra ConwayEra) +deriving instance Eq (BurnTxInEra ConwayEra) + +instance (IsShelleyBasedEra era) => Variations (BurnTxInEra era) where + variations = BurnTxInEra <$> variations `varyAp` variations + +instance (IsShelleyBasedEra era) => Binary (BurnTxInEra era) where + put BurnTxInEra{..} = do + put burnedTokens + putTxBody txBody + get = do + burnedTokens <- get + txBody <- getTxBody + pure BurnTxInEra{..} + data Account = RoleAccount TokenName | AddressAccount Address deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary, ToJSON, Variations) +data BurnError + = BurnRolesActive (Set AssetId) + | BurnNoTokens + | BurnBalancingError String + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Binary, ToJSON, Variations) + +data RoleTokenFilter + = MkRoleTokensOr RoleTokenFilter RoleTokenFilter + | MkRoleTokensAnd RoleTokenFilter RoleTokenFilter + | RoleTokenFilterAny + | RoleTokenFilterNone + | MkRoleTokenFilterByContracts (Set ContractId) + | MkRoleTokenFilterByPolicyIds (Set PolicyId) + | MkRoleTokenFilterByTokens (Set AssetId) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Variations) + +instance Binary RoleTokenFilter where + put (RoleTokensOr a b) = do + putWord8 0 + put a + put b + put (RoleTokensAnd a b) = do + putWord8 1 + put a + put b + put RoleTokenFilterAny = putWord8 2 + put RoleTokenFilterNone = putWord8 3 + put (RoleTokenFilterByContracts contracts) = do + putWord8 4 + put contracts + put (RoleTokenFilterByPolicyIds policies) = do + putWord8 5 + put policies + put (RoleTokenFilterByTokens tokens) = do + putWord8 6 + put tokens + + get = label "RoleTokenFilter" do + tag <- getWord8 + join $ label "tag" case tag of + 0 -> pure $ label "RoleTokensOr" $ RoleTokensOr <$> label "lhs" get <*> label "rhs" get + 1 -> pure $ label "RoleTokensAnd" $ RoleTokensAnd <$> label "lhs" get <*> label "rhs" get + 2 -> pure $ pure RoleTokenFilterAny + 3 -> pure $ pure RoleTokenFilterNone + 4 -> pure $ label "RoleTokenFilterByContracts" $ RoleTokenFilterByContracts <$> get + 5 -> pure $ label "RoleTokenFilterByPolicyIds" $ RoleTokenFilterByPolicyIds <$> get + 6 -> pure $ label "RoleTokenFilterByTokens" $ RoleTokenFilterByTokens <$> get + _ -> fail $ "invalid value: " <> show tag + +{-# COMPLETE + RoleTokensOr + , RoleTokensAnd + , RoleTokenFilterAny + , RoleTokenFilterNone + , RoleTokenFilterByContracts + , RoleTokenFilterByPolicyIds + , RoleTokenFilterByTokens + #-} + +pattern RoleTokensOr :: RoleTokenFilter -> RoleTokenFilter -> RoleTokenFilter +pattern RoleTokensOr a b <- MkRoleTokensOr a b + where + RoleTokensOr RoleTokenFilterAny _ = RoleTokenFilterAny + RoleTokensOr _ RoleTokenFilterAny = RoleTokenFilterAny + RoleTokensOr RoleTokenFilterNone b = b + RoleTokensOr a RoleTokenFilterNone = a + RoleTokensOr (RoleTokenFilterByContracts a) (RoleTokenFilterByContracts b) = + RoleTokenFilterByContracts (Set.union a b) + RoleTokensOr (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByPolicyIds b) = + RoleTokenFilterByPolicyIds (Set.union a b) + RoleTokensOr (RoleTokenFilterByTokens a) (RoleTokenFilterByTokens b) = + RoleTokenFilterByTokens (Set.union a b) + RoleTokensOr (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByTokens b) = + RoleTokensOr (RoleTokenFilterByTokens b) (RoleTokenFilterByPolicyIds a) + RoleTokensOr (RoleTokenFilterByTokens a) (RoleTokenFilterByPolicyIds b) = + let tokens = Set.filter (not . flip Set.member b . policyId) a + in if tokens == a + then RoleTokensOr (RoleTokenFilterByTokens tokens) (RoleTokenFilterByPolicyIds b) + else MkRoleTokensOr (RoleTokenFilterByTokens tokens) (RoleTokenFilterByPolicyIds b) + RoleTokensOr a (RoleTokensOr b c) = RoleTokensOr (RoleTokensOr a b) c + RoleTokensOr a b = MkRoleTokensOr a b + +pattern RoleTokensAnd :: RoleTokenFilter -> RoleTokenFilter -> RoleTokenFilter +pattern RoleTokensAnd a b <- MkRoleTokensAnd a b + where + RoleTokensAnd RoleTokenFilterAny b = b + RoleTokensAnd a RoleTokenFilterAny = a + RoleTokensAnd RoleTokenFilterNone _ = RoleTokenFilterNone + RoleTokensAnd _ RoleTokenFilterNone = RoleTokenFilterNone + RoleTokensAnd (RoleTokenFilterByContracts a) (RoleTokenFilterByContracts b) = + RoleTokenFilterByContracts (Set.intersection a b) + RoleTokensAnd (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByPolicyIds b) = + RoleTokenFilterByPolicyIds (Set.intersection a b) + RoleTokensAnd (RoleTokenFilterByTokens a) (RoleTokenFilterByTokens b) = + RoleTokenFilterByTokens (Set.intersection a b) + RoleTokensAnd (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByTokens b) = + RoleTokensAnd (RoleTokenFilterByTokens b) (RoleTokenFilterByPolicyIds a) + RoleTokensAnd (RoleTokenFilterByTokens a) (RoleTokenFilterByPolicyIds b) = + RoleTokenFilterByTokens $ Set.filter (flip Set.member b . policyId) a + RoleTokensAnd a (RoleTokensAnd b c) = RoleTokensAnd (RoleTokensAnd a b) c + RoleTokensAnd a b = MkRoleTokensAnd a b + +pattern RoleTokenFilterByContracts :: Set ContractId -> RoleTokenFilter +pattern RoleTokenFilterByContracts contracts <- MkRoleTokenFilterByContracts contracts + where + RoleTokenFilterByContracts contracts + | Set.null contracts = RoleTokenFilterNone + | otherwise = MkRoleTokenFilterByContracts contracts + +pattern RoleTokenFilterByPolicyIds :: Set PolicyId -> RoleTokenFilter +pattern RoleTokenFilterByPolicyIds policies <- MkRoleTokenFilterByPolicyIds policies + where + RoleTokenFilterByPolicyIds policies + | Set.null policies = RoleTokenFilterNone + | otherwise = MkRoleTokenFilterByPolicyIds policies + +pattern RoleTokenFilterByTokens :: Set AssetId -> RoleTokenFilter +pattern RoleTokenFilterByTokens tokens <- MkRoleTokenFilterByTokens tokens + where + RoleTokenFilterByTokens tokens + | Set.null tokens = RoleTokenFilterNone + | otherwise = MkRoleTokenFilterByTokens tokens + +data RoleToken = RoleToken + { roleTokenAssetId :: AssetId + , roleTokenContract :: ContractId + } + +evalRoleTokenFilter :: RoleTokenFilter -> RoleToken -> Bool +evalRoleTokenFilter f RoleToken{..} = go f + where + go = \case + RoleTokensOr f1 f2 -> go f1 || go f2 + RoleTokensAnd f1 f2 -> go f1 && go f2 + RoleTokenFilterAny -> True + RoleTokenFilterNone -> False + RoleTokenFilterByContracts contracts -> Set.member roleTokenContract contracts + RoleTokenFilterByPolicyIds policies -> Set.member (policyId roleTokenAssetId) policies + RoleTokenFilterByTokens tokens -> Set.member roleTokenAssetId tokens + +filterRoleTokens :: RoleTokenFilter -> Set RoleToken -> Set RoleToken +filterRoleTokens = Set.filter . evalRoleTokenFilter + -- | The low-level runtime API for building and submitting transactions. data MarloweTxCommand status err result where -- | Construct a transaction that starts a new Marlowe contract. The @@ -827,6 +1052,14 @@ data MarloweTxCommand status err result where WithdrawError ( WithdrawTx v -- The unsigned tx body, to be signed by a wallet. ) + -- | Construct a transaction that burns all role tokens in a wallet which match + -- the given filter. + Burn + :: WalletAddresses + -- ^ The wallet addresses to use when constructing the transaction + -> RoleTokenFilter + -- ^ Which role tokens to burn + -> MarloweTxCommand Void BurnError BurnTx -- | Submits a signed transaction to the attached Cardano node. Submit :: BabbageEraOnwards era @@ -846,6 +1079,7 @@ instance OTelCommand MarloweTxCommand where TagCreate _ -> "create" TagApplyInputs _ -> "apply_inputs" TagWithdraw _ -> "withdraw" + TagBurn -> "burn" TagSubmit -> "submit" instance Command MarloweTxCommand where @@ -853,6 +1087,7 @@ instance Command MarloweTxCommand where TagCreate :: MarloweVersion v -> Tag MarloweTxCommand Void CreateError (ContractCreated v) TagApplyInputs :: MarloweVersion v -> Tag MarloweTxCommand Void ApplyInputsError (InputsApplied v) TagWithdraw :: MarloweVersion v -> Tag MarloweTxCommand Void WithdrawError (WithdrawTx v) + TagBurn :: Tag MarloweTxCommand Void BurnError BurnTx TagSubmit :: Tag MarloweTxCommand SubmitStatus SubmitError BlockHeader data JobId MarloweTxCommand stats err result where @@ -862,6 +1097,7 @@ instance Command MarloweTxCommand where Create _ version _ _ _ _ _ _ _ -> TagCreate version ApplyInputs version _ _ _ _ _ _ -> TagApplyInputs version Withdraw version _ _ -> TagWithdraw version + Burn _ _ -> TagBurn Submit _ _ -> TagSubmit tagFromJobId = \case @@ -874,6 +1110,8 @@ instance Command MarloweTxCommand where (TagApplyInputs _, _) -> Nothing (TagWithdraw MarloweV1, TagWithdraw MarloweV1) -> pure (Refl, Refl, Refl) (TagWithdraw _, _) -> Nothing + (TagBurn, TagBurn) -> pure (Refl, Refl, Refl) + (TagBurn, _) -> Nothing (TagSubmit, TagSubmit) -> pure (Refl, Refl, Refl) (TagSubmit, _) -> Nothing @@ -882,6 +1120,7 @@ instance Command MarloweTxCommand where TagApplyInputs version -> putWord8 0x02 *> put (SomeMarloweVersion version) TagWithdraw version -> putWord8 0x03 *> put (SomeMarloweVersion version) TagSubmit -> putWord8 0x04 + TagBurn -> putWord8 0x05 getTag = do tag <- getWord8 @@ -896,6 +1135,7 @@ instance Command MarloweTxCommand where SomeMarloweVersion version <- get pure $ SomeTag $ TagWithdraw version 0x04 -> pure $ SomeTag TagSubmit + 0x05 -> pure $ SomeTag TagBurn _ -> fail $ "Invalid command tag: " <> show tag putJobId = \case @@ -905,6 +1145,7 @@ instance Command MarloweTxCommand where TagCreate _ -> fail "create has no job ID" TagApplyInputs _ -> fail "apply inputs has no job ID" TagWithdraw _ -> fail "withdraw has no job ID" + TagBurn -> fail "burn has no job ID" TagSubmit -> JobIdSubmit <$> get putCommand = \case @@ -927,6 +1168,9 @@ instance Command MarloweTxCommand where Withdraw _ walletAddresses payoutIds -> do put walletAddresses put payoutIds + Burn walletAddresses tokenFilter -> do + put walletAddresses + put tokenFilter Submit era tx -> case era of BabbageEraOnwardsBabbage -> do putWord8 0 @@ -957,6 +1201,7 @@ instance Command MarloweTxCommand where TagWithdraw version -> do walletAddresses <- get Withdraw version walletAddresses <$> get + TagBurn -> Burn <$> get <*> get TagSubmit -> do eraTag <- getWord8 case eraTag of @@ -976,36 +1221,42 @@ instance Command MarloweTxCommand where TagCreate _ -> absurd TagApplyInputs _ -> absurd TagWithdraw _ -> absurd + TagBurn -> absurd TagSubmit -> put getStatus = \case TagCreate _ -> fail "create has no status" TagApplyInputs _ -> fail "apply inputs has no status" TagWithdraw _ -> fail "withdraw has no status" + TagBurn -> fail "burn has no status" TagSubmit -> get putErr = \case TagCreate MarloweV1 -> put TagApplyInputs MarloweV1 -> put TagWithdraw MarloweV1 -> put + TagBurn -> put TagSubmit -> put getErr = \case TagCreate MarloweV1 -> get TagApplyInputs MarloweV1 -> get TagWithdraw MarloweV1 -> get + TagBurn -> get TagSubmit -> get putResult = \case TagCreate MarloweV1 -> put TagApplyInputs MarloweV1 -> put TagWithdraw MarloweV1 -> put + TagBurn -> put TagSubmit -> put getResult = \case TagCreate MarloweV1 -> get TagApplyInputs MarloweV1 -> get TagWithdraw MarloweV1 -> get + TagBurn -> get TagSubmit -> get putTxBody :: (IsShelleyBasedEra era) => TxBody era -> Put @@ -1184,6 +1435,10 @@ instance CommandEq MarloweTxCommand where Withdraw MarloweV1 wallet' payoutIds' -> wallet == wallet' && payoutIds == payoutIds' + Burn wallet tokenFilter -> \case + Burn wallet' tokenFilter' -> + wallet == wallet' + && tokenFilter == tokenFilter' Submit BabbageEraOnwardsBabbage tx -> \case Submit BabbageEraOnwardsBabbage tx' -> tx == tx' _ -> False @@ -1199,18 +1454,21 @@ instance CommandEq MarloweTxCommand where TagCreate MarloweV1 -> (==) TagApplyInputs MarloweV1 -> (==) TagWithdraw MarloweV1 -> (==) + TagBurn -> (==) TagSubmit -> (==) errEq = \case TagCreate MarloweV1 -> (==) TagApplyInputs MarloweV1 -> (==) TagWithdraw MarloweV1 -> (==) + TagBurn -> (==) TagSubmit -> (==) resultEq = \case TagCreate MarloweV1 -> (==) TagApplyInputs MarloweV1 -> (==) TagWithdraw MarloweV1 -> (==) + TagBurn -> (==) TagSubmit -> (==) instance ShowCommand MarloweTxCommand where @@ -1236,6 +1494,7 @@ instance ShowCommand MarloweTxCommand where . showSpace . showString "MarloweV1" ) + TagBurn -> showString "TagBurn" TagSubmit -> showString "TagSubmit" showsPrecCommand p = @@ -1287,6 +1546,13 @@ instance ShowCommand MarloweTxCommand where . showSpace . showsPrec 11 payoutIds ) + Burn wallet tokenFilter -> + ( showString "Burn" + . showSpace + . showsPrec 11 wallet + . showSpace + . showsPrec 11 tokenFilter + ) Submit BabbageEraOnwardsBabbage tx -> ( showString "Submit" . showSpace @@ -1315,18 +1581,21 @@ instance ShowCommand MarloweTxCommand where TagCreate MarloweV1 -> showsPrec p TagApplyInputs MarloweV1 -> showsPrec p TagWithdraw MarloweV1 -> showsPrec p + TagBurn -> showsPrec p TagSubmit -> showsPrec p showsPrecErr p = \case TagCreate MarloweV1 -> showsPrec p TagApplyInputs MarloweV1 -> showsPrec p TagWithdraw MarloweV1 -> showsPrec p + TagBurn -> showsPrec p TagSubmit -> showsPrec p showsPrecResult p = \case TagCreate MarloweV1 -> showsPrec p TagApplyInputs MarloweV1 -> showsPrec p TagWithdraw MarloweV1 -> showsPrec p + TagBurn -> showsPrec p TagSubmit -> showsPrec p instance Variations V1.TransactionError From f3f33548785a1c380aa47193862c1f0bcf91464b Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Tue, 6 Feb 2024 11:58:20 -0500 Subject: [PATCH 02/18] Add generators for burn types --- .../Marlowe/Runtime/Transaction/Gen.hs | 61 +++++++++++++++++++ .../Marlowe/Runtime/Transaction/Api.hs | 22 +++++-- 2 files changed, 79 insertions(+), 4 deletions(-) diff --git a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs index 8e656f8d27..dda87df8c5 100644 --- a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs +++ b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs @@ -342,6 +342,22 @@ instance (ArbitraryMarloweVersion v, IsShelleyBasedEra era) => Arbitrary (Withdr <*> hedgehog (genTxBody shelleyBasedEra) shrink WithdrawTxInEra{..} = [WithdrawTxInEra{..}{WithdrawTxInEra.inputs = inputs'} | inputs' <- shrink inputs] +instance Arbitrary BurnTx where + arbitrary = + oneof + [ BurnTx BabbageEraOnwardsBabbage <$> arbitrary + , BurnTx BabbageEraOnwardsConway <$> arbitrary + ] + shrink (BurnTx BabbageEraOnwardsBabbage created) = + BurnTx BabbageEraOnwardsBabbage <$> shrink created + shrink (BurnTx BabbageEraOnwardsConway created) = + BurnTx BabbageEraOnwardsConway <$> shrink created + +instance (IsShelleyBasedEra era) => Arbitrary (BurnTxInEra era) where + arbitrary = BurnTxInEra <$> arbitrary <*> hedgehog (genTxBody shelleyBasedEra) + shrink BurnTxInEra{..} = + [BurnTxInEra{..}{burnedTokens = burnedTokens'} | burnedTokens' <- shrink burnedTokens] + instance Arbitrary Account where arbitrary = oneof @@ -350,12 +366,40 @@ instance Arbitrary Account where ] shrink = genericShrink +instance Arbitrary RoleTokenFilter where + arbitrary = sized \case + 0 -> frequency leaves + size -> frequency $ leaves <> nodes size + where + leaves = + [ (1, pure RoleTokenFilterAny) + , (1, pure RoleTokenFilterNone) + , (5, MkRoleTokenFilterByContracts <$> arbitrary) + , (5, MkRoleTokenFilterByPolicyIds <$> arbitrary) + , (5, MkRoleTokenFilterByTokens <$> arbitrary) + ] + nodes size = + [ (5, resize (size `div` 2) $ MkRoleTokensOr <$> arbitrary <*> arbitrary) + , (5, resize (size `div` 2) $ MkRoleTokensAnd <$> arbitrary <*> arbitrary) + ] + shrink = genericShrink + +instance Arbitrary BurnError where + arbitrary = + frequency + [ (5, BurnRolesActive <$> arbitrary) + , (1, pure BurnNoTokens) + , (3, BurnBalancingError <$> arbitrary) + ] + shrink = genericShrink + instance ArbitraryCommand MarloweTxCommand where arbitraryTag = elements [ SomeTag $ TagCreate Core.MarloweV1 , SomeTag $ TagApplyInputs Core.MarloweV1 , SomeTag $ TagWithdraw Core.MarloweV1 + , SomeTag TagBurn , SomeTag TagSubmit ] arbitraryCmd = \case @@ -382,6 +426,7 @@ instance ArbitraryCommand MarloweTxCommand where Withdraw Core.MarloweV1 <$> arbitrary <*> arbitrary + TagBurn -> Burn <$> arbitrary <*> arbitrary TagSubmit -> oneof [ Submit BabbageEraOnwardsBabbage <$> hedgehog (genTx ShelleyBasedEraBabbage) @@ -391,21 +436,25 @@ instance ArbitraryCommand MarloweTxCommand where TagCreate Core.MarloweV1 -> Nothing TagApplyInputs Core.MarloweV1 -> Nothing TagWithdraw Core.MarloweV1 -> Nothing + TagBurn -> Nothing TagSubmit -> Just $ JobIdSubmit <$> arbitrary arbitraryStatus = \case TagCreate Core.MarloweV1 -> Nothing TagApplyInputs Core.MarloweV1 -> Nothing TagWithdraw Core.MarloweV1 -> Nothing + TagBurn -> Nothing TagSubmit -> Just arbitrary arbitraryErr = \case TagCreate Core.MarloweV1 -> Just arbitrary TagApplyInputs Core.MarloweV1 -> Just arbitrary TagWithdraw Core.MarloweV1 -> Just arbitrary + TagBurn -> Just arbitrary TagSubmit -> Just arbitrary arbitraryResult = \case TagCreate Core.MarloweV1 -> arbitrary TagApplyInputs Core.MarloweV1 -> arbitrary TagWithdraw Core.MarloweV1 -> arbitrary + TagBurn -> arbitrary TagSubmit -> arbitrary shrinkCommand = \case Create staking Core.MarloweV1 wallet thread roleConfig meta minAda state contract -> @@ -489,6 +538,9 @@ instance ArbitraryCommand MarloweTxCommand where Withdraw Core.MarloweV1 wallet payouts -> (Withdraw Core.MarloweV1 <$> shrink wallet <*> pure payouts) <> (Withdraw Core.MarloweV1 wallet <$> shrink payouts) + Burn wallet tokenFilter -> + (Burn <$> shrink wallet <*> pure tokenFilter) + <> (Burn wallet <$> shrink tokenFilter) Submit _ _ -> [] shrinkJobId = \case JobIdSubmit txId -> JobIdSubmit <$> shrink txId @@ -496,16 +548,19 @@ instance ArbitraryCommand MarloweTxCommand where TagCreate Core.MarloweV1 -> shrink TagApplyInputs Core.MarloweV1 -> shrink TagWithdraw Core.MarloweV1 -> shrink + TagBurn -> shrink TagSubmit -> shrink shrinkResult = \case TagCreate Core.MarloweV1 -> shrink TagApplyInputs Core.MarloweV1 -> shrink TagWithdraw Core.MarloweV1 -> shrink + TagBurn -> shrink TagSubmit -> shrink shrinkStatus = \case TagCreate Core.MarloweV1 -> \case {} TagApplyInputs Core.MarloweV1 -> \case {} TagWithdraw Core.MarloweV1 -> \case {} + TagBurn -> \case {} TagSubmit -> shrink instance CommandVariations MarloweTxCommand where @@ -538,6 +593,8 @@ instance CommandVariations MarloweTxCommand where `varyAp` variations TagWithdraw Core.MarloweV1 -> Withdraw Core.MarloweV1 <$> variations `varyAp` variations + TagBurn -> + Burn <$> variations `varyAp` variations TagSubmit -> sconcat $ NE.fromList @@ -548,19 +605,23 @@ instance CommandVariations MarloweTxCommand where TagCreate Core.MarloweV1 -> [] TagApplyInputs Core.MarloweV1 -> [] TagWithdraw Core.MarloweV1 -> [] + TagBurn -> [] TagSubmit -> NE.toList $ JobIdSubmit <$> variations statusVariations = \case TagCreate Core.MarloweV1 -> [] TagApplyInputs Core.MarloweV1 -> [] TagWithdraw Core.MarloweV1 -> [] + TagBurn -> [] TagSubmit -> NE.toList variations errVariations = \case TagCreate Core.MarloweV1 -> NE.toList variations TagApplyInputs Core.MarloweV1 -> NE.toList variations TagWithdraw Core.MarloweV1 -> NE.toList variations + TagBurn -> NE.toList variations TagSubmit -> NE.toList variations resultVariations = \case TagCreate Core.MarloweV1 -> variations TagApplyInputs Core.MarloweV1 -> variations TagWithdraw Core.MarloweV1 -> variations + TagBurn -> variations TagSubmit -> variations diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index 93bfe61c54..ed0b59b0fa 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -35,10 +35,9 @@ module Language.Marlowe.Runtime.Transaction.Api ( NFTMetadataFile (..), RoleToken (..), RoleTokenFilter ( + .., RoleTokensOr, RoleTokensAnd, - RoleTokenFilterAny, - RoleTokenFilterNone, RoleTokenFilterByContracts, RoleTokenFilterByPolicyIds, RoleTokenFilterByTokens @@ -59,6 +58,7 @@ module Language.Marlowe.Runtime.Transaction.Api ( getTokenQuantities, hasRecipient, mkMint, + optimizeRoleTokenFilter, ) where import Cardano.Api ( @@ -861,6 +861,16 @@ data RoleTokenFilter deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Variations) +optimizeRoleTokenFilter :: RoleTokenFilter -> RoleTokenFilter +optimizeRoleTokenFilter = \case + RoleTokensOr a b -> RoleTokensOr (optimizeRoleTokenFilter a) (optimizeRoleTokenFilter b) + RoleTokensAnd a b -> RoleTokensAnd (optimizeRoleTokenFilter a) (optimizeRoleTokenFilter b) + RoleTokenFilterAny -> RoleTokenFilterAny + RoleTokenFilterNone -> RoleTokenFilterNone + RoleTokenFilterByContracts a -> RoleTokenFilterByContracts a + RoleTokenFilterByPolicyIds a -> RoleTokenFilterByPolicyIds a + RoleTokenFilterByTokens a -> RoleTokenFilterByTokens a + instance Binary RoleTokenFilter where put (RoleTokensOr a b) = do putWord8 0 @@ -925,7 +935,9 @@ pattern RoleTokensOr a b <- MkRoleTokensOr a b then RoleTokensOr (RoleTokenFilterByTokens tokens) (RoleTokenFilterByPolicyIds b) else MkRoleTokensOr (RoleTokenFilterByTokens tokens) (RoleTokenFilterByPolicyIds b) RoleTokensOr a (RoleTokensOr b c) = RoleTokensOr (RoleTokensOr a b) c - RoleTokensOr a b = MkRoleTokensOr a b + RoleTokensOr a b + | a == b = a + | otherwise = MkRoleTokensOr a b pattern RoleTokensAnd :: RoleTokenFilter -> RoleTokenFilter -> RoleTokenFilter pattern RoleTokensAnd a b <- MkRoleTokensAnd a b @@ -945,7 +957,9 @@ pattern RoleTokensAnd a b <- MkRoleTokensAnd a b RoleTokensAnd (RoleTokenFilterByTokens a) (RoleTokenFilterByPolicyIds b) = RoleTokenFilterByTokens $ Set.filter (flip Set.member b . policyId) a RoleTokensAnd a (RoleTokensAnd b c) = RoleTokensAnd (RoleTokensAnd a b) c - RoleTokensAnd a b = MkRoleTokensAnd a b + RoleTokensAnd a b + | a == b = a + | otherwise = MkRoleTokensAnd a b pattern RoleTokenFilterByContracts :: Set ContractId -> RoleTokenFilter pattern RoleTokenFilterByContracts contracts <- MkRoleTokenFilterByContracts contracts From 960153e6af87b1a674e6db43e8352ffe40218997 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 7 Feb 2024 11:41:29 -0500 Subject: [PATCH 03/18] Add tests for burn types --- .../Marlowe/Runtime/Transaction/Gen.hs | 13 +- marlowe-runtime/marlowe-runtime.cabal | 3 + .../Transaction/RoleTokenFilterSpec.hs | 103 ++++++ .../Marlowe/Runtime/Transaction/Api.hs | 295 +++++++++--------- .../Marlowe/Runtime/Transaction/Burn.hs | 21 ++ .../Marlowe/Runtime/Transaction/Server.hs | 46 ++- 6 files changed, 320 insertions(+), 161 deletions(-) create mode 100644 marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/RoleTokenFilterSpec.hs create mode 100644 marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs diff --git a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs index dda87df8c5..95bda65ea2 100644 --- a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs +++ b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs @@ -366,7 +366,7 @@ instance Arbitrary Account where ] shrink = genericShrink -instance Arbitrary RoleTokenFilter where +instance (Arbitrary c, Ord c, Arbitrary p, Ord p, Arbitrary t, Ord t) => Arbitrary (RoleTokenFilter' c p t) where arbitrary = sized \case 0 -> frequency leaves size -> frequency $ leaves <> nodes size @@ -374,13 +374,14 @@ instance Arbitrary RoleTokenFilter where leaves = [ (1, pure RoleTokenFilterAny) , (1, pure RoleTokenFilterNone) - , (5, MkRoleTokenFilterByContracts <$> arbitrary) - , (5, MkRoleTokenFilterByPolicyIds <$> arbitrary) - , (5, MkRoleTokenFilterByTokens <$> arbitrary) + , (5, RoleTokenFilterByContracts <$> arbitrary) + , (5, RoleTokenFilterByPolicyIds <$> arbitrary) + , (5, RoleTokenFilterByTokens <$> arbitrary) ] nodes size = - [ (5, resize (size `div` 2) $ MkRoleTokensOr <$> arbitrary <*> arbitrary) - , (5, resize (size `div` 2) $ MkRoleTokensAnd <$> arbitrary <*> arbitrary) + [ (5, resize (size `div` 2) $ RoleTokensOr <$> arbitrary <*> arbitrary) + , (5, resize (size `div` 2) $ RoleTokensAnd <$> arbitrary <*> arbitrary) + , (5, resize (size - 1) $ RoleTokensNot <$> arbitrary) ] shrink = genericShrink diff --git a/marlowe-runtime/marlowe-runtime.cabal b/marlowe-runtime/marlowe-runtime.cabal index 50b3513e46..19e9310145 100644 --- a/marlowe-runtime/marlowe-runtime.cabal +++ b/marlowe-runtime/marlowe-runtime.cabal @@ -485,6 +485,7 @@ library tx-api , containers ^>=0.6.5 , http-media ^>=0.8 , keys + , lens >=5.2 && <6 , marlowe-cardano ==0.2.1.0 , marlowe-chain-sync ==0.0.6 , marlowe-protocols ==0.3.0.0 @@ -504,6 +505,7 @@ library tx exposed-modules: Language.Marlowe.Runtime.Transaction Language.Marlowe.Runtime.Transaction.BuildConstraints + Language.Marlowe.Runtime.Transaction.Burn Language.Marlowe.Runtime.Transaction.Chain Language.Marlowe.Runtime.Transaction.Constraints Language.Marlowe.Runtime.Transaction.Query @@ -815,6 +817,7 @@ test-suite marlowe-runtime-test Language.Marlowe.Runtime.Transaction.BuildConstraintsSpec Language.Marlowe.Runtime.Transaction.CommandSpec Language.Marlowe.Runtime.Transaction.ConstraintsSpec + Language.Marlowe.Runtime.Transaction.RoleTokenFilterSpec Language.Marlowe.Runtime.Transaction.SafetySpec Paths_marlowe_runtime diff --git a/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/RoleTokenFilterSpec.hs b/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/RoleTokenFilterSpec.hs new file mode 100644 index 0000000000..69b09c18cc --- /dev/null +++ b/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/RoleTokenFilterSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Language.Marlowe.Runtime.Transaction.RoleTokenFilterSpec where + +import qualified Data.Set as Set +import Data.Word (Word8) +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Transaction.Api ( + IsToken (..), + RoleTokenFilter' (..), + evalRoleTokenFilter, + optimizeRoleTokenFilter, + ) +import Language.Marlowe.Runtime.Transaction.Gen () +import Test.Hspec +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.QuickCheck + +spec :: Spec +spec = modifyMaxSuccess (* 100) do + prop "and-annulment" \a -> a `RoleTokensAnd` RoleTokenFilterNone .=== RoleTokenFilterNone + prop "or-annulment" \a -> a `RoleTokensOr` RoleTokenFilterAny .=== RoleTokenFilterAny + prop "and-identity" \a -> a `RoleTokensAnd` RoleTokenFilterAny .=== a + prop "or-identity" \a -> a `RoleTokensOr` RoleTokenFilterNone .=== a + prop "and-idempotent" \a -> a `RoleTokensAnd` a .=== a + prop "or-idempotent" \a -> a `RoleTokensOr` a .=== a + prop "and-complement" \a -> a `RoleTokensAnd` RoleTokensNot a .=== RoleTokenFilterNone + prop "or-complement" \a -> a `RoleTokensOr` RoleTokensNot a .=== RoleTokenFilterAny + prop "double-negation" \a -> RoleTokensNot (RoleTokensNot a) .=== a + prop "and-commutative" \a b -> a `RoleTokensAnd` b .=== b `RoleTokensAnd` a + prop "or-commutative" \a b -> a `RoleTokensOr` b .=== b `RoleTokensOr` a + prop "distributive" \a b c -> a `RoleTokensAnd` (b `RoleTokensOr` c) .=== (a `RoleTokensAnd` b) `RoleTokensOr` (a `RoleTokensAnd` c) + prop "inverse-distributive" \a b c -> (a `RoleTokensOr` b) `RoleTokensAnd` (a `RoleTokensOr` c) .=== a `RoleTokensOr` (b `RoleTokensAnd` c) + prop "and-absorption-1" \a b -> a `RoleTokensAnd` (a `RoleTokensOr` b) .=== a + prop "and-absorption-2" \a b -> a `RoleTokensAnd` (RoleTokensNot a `RoleTokensOr` b) .=== a `RoleTokensAnd` b + prop "or-absorption-1" \a b -> a `RoleTokensOr` (a `RoleTokensAnd` b) .=== a + prop "or-absorption-2" \a b -> a `RoleTokensOr` (RoleTokensNot a `RoleTokensAnd` b) .=== a `RoleTokensOr` b + prop "and-de-morgan" \a b -> RoleTokensNot (a `RoleTokensAnd` b) .=== RoleTokensNot a `RoleTokensOr` RoleTokensNot b + prop "or-de-morgan" \a b -> RoleTokensNot (a `RoleTokensOr` b) .=== RoleTokensNot a `RoleTokensAnd` RoleTokensNot b + prop "consensus" \a b c -> + let ab = a `RoleTokensAnd` b + a'c = RoleTokensNot a `RoleTokensAnd` c + bc = b `RoleTokensAnd` c + lhs = ab `RoleTokensOr` a'c `RoleTokensOr` bc + rhs = ab `RoleTokensOr` a'c + in lhs .=== rhs + prop "null-contracts" $ RoleTokenFilterByContracts mempty .=== RoleTokenFilterNone + prop "null-policyIds" $ RoleTokenFilterByPolicyIds mempty .=== RoleTokenFilterNone + prop "null-tokens" $ RoleTokenFilterByTokens mempty .=== RoleTokenFilterNone + prop "and-contracts" \c1 c2 -> + RoleTokensAnd (RoleTokenFilterByContracts c1) (RoleTokenFilterByContracts c2) + .=== RoleTokenFilterByContracts (Set.intersection c1 c2) + prop "and-policyIds" \p1 p2 -> + RoleTokensAnd (RoleTokenFilterByPolicyIds p1) (RoleTokenFilterByPolicyIds p2) + .=== RoleTokenFilterByPolicyIds (Set.intersection p1 p2) + prop "and-tokens" \t1 t2 -> + RoleTokensAnd (RoleTokenFilterByTokens t1) (RoleTokenFilterByTokens t2) + .=== RoleTokenFilterByTokens (Set.intersection t1 t2) + prop "and-policyIds-tokens" \p t -> + RoleTokensAnd (RoleTokenFilterByPolicyIds p) (RoleTokenFilterByTokens t) + .=== RoleTokenFilterByTokens (Set.filter (flip Set.member p . tokenPolicyId) t) + prop "or-contracts" \c1 c2 -> + RoleTokensOr (RoleTokenFilterByContracts c1) (RoleTokenFilterByContracts c2) + .=== RoleTokenFilterByContracts (Set.union c1 c2) + prop "or-policyIds" \p1 p2 -> + RoleTokensOr (RoleTokenFilterByPolicyIds p1) (RoleTokenFilterByPolicyIds p2) + .=== RoleTokenFilterByPolicyIds (Set.union p1 p2) + prop "or-tokens" \t1 t2 -> + RoleTokensOr (RoleTokenFilterByTokens t1) (RoleTokenFilterByTokens t2) + .=== RoleTokenFilterByTokens (Set.union t1 t2) + prop "or-policyIds-tokens" \p t -> + RoleTokensOr (RoleTokenFilterByPolicyIds p) (RoleTokenFilterByTokens t) + .=== RoleTokensOr + (RoleTokenFilterByPolicyIds p) + (RoleTokenFilterByTokens $ Set.filter (not . flip Set.member p . tokenPolicyId) t) + prop "optimize" \f -> + let f' = optimizeRoleTokenFilter f in counterexample ("Optimized: " <> show f') $ f' .=== f + +(.===) :: RoleTokenFilter -> RoleTokenFilter -> ContractId -> Token -> Property +(.===) a b c t = evalRoleTokenFilter a c t === evalRoleTokenFilter b c t + +infix 4 .=== + +type RoleTokenFilter = RoleTokenFilter' ContractId PolicyId Token + +newtype ContractId = ContractId Word8 + deriving newtype (Show, Eq, Ord, Arbitrary) + +newtype PolicyId = PolicyId Word8 + deriving newtype (Show, Eq, Ord, Arbitrary) + +newtype TokenName = TokenName Word8 + deriving newtype (Show, Eq, Ord, Arbitrary) + +data Token = Token PolicyId TokenName + deriving (Show, Eq, Ord, Generic) + +instance Arbitrary Token where + arbitrary = Token <$> arbitrary <*> arbitrary + shrink = genericShrink + +instance IsToken Token PolicyId where + tokenPolicyId (Token p _) = p diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index ed0b59b0fa..d708bc07a7 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternSynonyms #-} @@ -26,6 +27,7 @@ module Language.Marlowe.Runtime.Transaction.Api ( Destination (..), InputsApplied (..), InputsAppliedInEra (..), + IsToken (..), JobId (..), LoadHelpersContextError (..), LoadMarloweContextError (..), @@ -33,15 +35,8 @@ module Language.Marlowe.Runtime.Transaction.Api ( Mint (..), MintRole (..), NFTMetadataFile (..), - RoleToken (..), - RoleTokenFilter ( - .., - RoleTokensOr, - RoleTokensAnd, - RoleTokenFilterByContracts, - RoleTokenFilterByPolicyIds, - RoleTokenFilterByTokens - ), + RoleTokenFilter' (..), + RoleTokenFilter, RoleTokenMetadata (..), RoleTokensConfig (RoleTokensNone, RoleTokensUsePolicy, RoleTokensMint), SubmitError (..), @@ -54,11 +49,11 @@ module Language.Marlowe.Runtime.Transaction.Api ( decodeRoleTokenMetadata, encodeRoleTokenMetadata, evalRoleTokenFilter, - filterRoleTokens, getTokenQuantities, hasRecipient, mkMint, optimizeRoleTokenFilter, + rewriteRoleTokenFilter, ) where import Cardano.Api ( @@ -144,6 +139,7 @@ import Language.Marlowe.Runtime.Core.ScriptRegistry (HelperScript) import Language.Marlowe.Runtime.History.Api (ExtractCreationError, ExtractMarloweTransactionError) import Network.HTTP.Media (MediaType) +import Control.Lens (Plated (..), rewrite) import Control.Monad (join) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as Aeson @@ -844,163 +840,166 @@ data Account deriving anyclass (Binary, ToJSON, Variations) data BurnError - = BurnRolesActive (Set AssetId) + = BurnEraUnsupported AnyCardanoEra + | BurnRolesActive (Set AssetId) | BurnNoTokens | BurnBalancingError String deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary, ToJSON, Variations) -data RoleTokenFilter - = MkRoleTokensOr RoleTokenFilter RoleTokenFilter - | MkRoleTokensAnd RoleTokenFilter RoleTokenFilter +data RoleTokenFilter' c p t + = RoleTokensOr (RoleTokenFilter' c p t) (RoleTokenFilter' c p t) + | RoleTokensAnd (RoleTokenFilter' c p t) (RoleTokenFilter' c p t) + | RoleTokensNot (RoleTokenFilter' c p t) | RoleTokenFilterAny | RoleTokenFilterNone - | MkRoleTokenFilterByContracts (Set ContractId) - | MkRoleTokenFilterByPolicyIds (Set PolicyId) - | MkRoleTokenFilterByTokens (Set AssetId) + | RoleTokenFilterByContracts (Set c) + | RoleTokenFilterByPolicyIds (Set p) + | RoleTokenFilterByTokens (Set t) deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (Variations) - -optimizeRoleTokenFilter :: RoleTokenFilter -> RoleTokenFilter -optimizeRoleTokenFilter = \case - RoleTokensOr a b -> RoleTokensOr (optimizeRoleTokenFilter a) (optimizeRoleTokenFilter b) - RoleTokensAnd a b -> RoleTokensAnd (optimizeRoleTokenFilter a) (optimizeRoleTokenFilter b) - RoleTokenFilterAny -> RoleTokenFilterAny - RoleTokenFilterNone -> RoleTokenFilterNone - RoleTokenFilterByContracts a -> RoleTokenFilterByContracts a - RoleTokenFilterByPolicyIds a -> RoleTokenFilterByPolicyIds a - RoleTokenFilterByTokens a -> RoleTokenFilterByTokens a - -instance Binary RoleTokenFilter where - put (RoleTokensOr a b) = do - putWord8 0 - put a - put b - put (RoleTokensAnd a b) = do - putWord8 1 - put a - put b - put RoleTokenFilterAny = putWord8 2 - put RoleTokenFilterNone = putWord8 3 - put (RoleTokenFilterByContracts contracts) = do - putWord8 4 - put contracts - put (RoleTokenFilterByPolicyIds policies) = do - putWord8 5 - put policies - put (RoleTokenFilterByTokens tokens) = do - putWord8 6 - put tokens - - get = label "RoleTokenFilter" do - tag <- getWord8 - join $ label "tag" case tag of - 0 -> pure $ label "RoleTokensOr" $ RoleTokensOr <$> label "lhs" get <*> label "rhs" get - 1 -> pure $ label "RoleTokensAnd" $ RoleTokensAnd <$> label "lhs" get <*> label "rhs" get - 2 -> pure $ pure RoleTokenFilterAny - 3 -> pure $ pure RoleTokenFilterNone - 4 -> pure $ label "RoleTokenFilterByContracts" $ RoleTokenFilterByContracts <$> get - 5 -> pure $ label "RoleTokenFilterByPolicyIds" $ RoleTokenFilterByPolicyIds <$> get - 6 -> pure $ label "RoleTokenFilterByTokens" $ RoleTokenFilterByTokens <$> get - _ -> fail $ "invalid value: " <> show tag - -{-# COMPLETE - RoleTokensOr - , RoleTokensAnd - , RoleTokenFilterAny - , RoleTokenFilterNone - , RoleTokenFilterByContracts - , RoleTokenFilterByPolicyIds - , RoleTokenFilterByTokens - #-} - -pattern RoleTokensOr :: RoleTokenFilter -> RoleTokenFilter -> RoleTokenFilter -pattern RoleTokensOr a b <- MkRoleTokensOr a b - where - RoleTokensOr RoleTokenFilterAny _ = RoleTokenFilterAny - RoleTokensOr _ RoleTokenFilterAny = RoleTokenFilterAny - RoleTokensOr RoleTokenFilterNone b = b - RoleTokensOr a RoleTokenFilterNone = a - RoleTokensOr (RoleTokenFilterByContracts a) (RoleTokenFilterByContracts b) = - RoleTokenFilterByContracts (Set.union a b) - RoleTokensOr (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByPolicyIds b) = - RoleTokenFilterByPolicyIds (Set.union a b) - RoleTokensOr (RoleTokenFilterByTokens a) (RoleTokenFilterByTokens b) = - RoleTokenFilterByTokens (Set.union a b) - RoleTokensOr (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByTokens b) = - RoleTokensOr (RoleTokenFilterByTokens b) (RoleTokenFilterByPolicyIds a) - RoleTokensOr (RoleTokenFilterByTokens a) (RoleTokenFilterByPolicyIds b) = - let tokens = Set.filter (not . flip Set.member b . policyId) a - in if tokens == a - then RoleTokensOr (RoleTokenFilterByTokens tokens) (RoleTokenFilterByPolicyIds b) - else MkRoleTokensOr (RoleTokenFilterByTokens tokens) (RoleTokenFilterByPolicyIds b) - RoleTokensOr a (RoleTokensOr b c) = RoleTokensOr (RoleTokensOr a b) c - RoleTokensOr a b - | a == b = a - | otherwise = MkRoleTokensOr a b - -pattern RoleTokensAnd :: RoleTokenFilter -> RoleTokenFilter -> RoleTokenFilter -pattern RoleTokensAnd a b <- MkRoleTokensAnd a b - where - RoleTokensAnd RoleTokenFilterAny b = b - RoleTokensAnd a RoleTokenFilterAny = a - RoleTokensAnd RoleTokenFilterNone _ = RoleTokenFilterNone - RoleTokensAnd _ RoleTokenFilterNone = RoleTokenFilterNone - RoleTokensAnd (RoleTokenFilterByContracts a) (RoleTokenFilterByContracts b) = - RoleTokenFilterByContracts (Set.intersection a b) - RoleTokensAnd (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByPolicyIds b) = - RoleTokenFilterByPolicyIds (Set.intersection a b) - RoleTokensAnd (RoleTokenFilterByTokens a) (RoleTokenFilterByTokens b) = - RoleTokenFilterByTokens (Set.intersection a b) - RoleTokensAnd (RoleTokenFilterByPolicyIds a) (RoleTokenFilterByTokens b) = - RoleTokensAnd (RoleTokenFilterByTokens b) (RoleTokenFilterByPolicyIds a) - RoleTokensAnd (RoleTokenFilterByTokens a) (RoleTokenFilterByPolicyIds b) = - RoleTokenFilterByTokens $ Set.filter (flip Set.member b . policyId) a - RoleTokensAnd a (RoleTokensAnd b c) = RoleTokensAnd (RoleTokensAnd a b) c - RoleTokensAnd a b - | a == b = a - | otherwise = MkRoleTokensAnd a b - -pattern RoleTokenFilterByContracts :: Set ContractId -> RoleTokenFilter -pattern RoleTokenFilterByContracts contracts <- MkRoleTokenFilterByContracts contracts - where - RoleTokenFilterByContracts contracts - | Set.null contracts = RoleTokenFilterNone - | otherwise = MkRoleTokenFilterByContracts contracts + deriving anyclass (Variations, Binary) -pattern RoleTokenFilterByPolicyIds :: Set PolicyId -> RoleTokenFilter -pattern RoleTokenFilterByPolicyIds policies <- MkRoleTokenFilterByPolicyIds policies - where - RoleTokenFilterByPolicyIds policies - | Set.null policies = RoleTokenFilterNone - | otherwise = MkRoleTokenFilterByPolicyIds policies +instance Plated (RoleTokenFilter' c p t) where + plate f = \case + RoleTokensOr f1 f2 -> RoleTokensOr <$> f f1 <*> f f2 + RoleTokensAnd f1 f2 -> RoleTokensAnd <$> f f1 <*> f f2 + RoleTokensNot f' -> RoleTokensNot <$> f f' + rf -> pure rf -pattern RoleTokenFilterByTokens :: Set AssetId -> RoleTokenFilter -pattern RoleTokenFilterByTokens tokens <- MkRoleTokenFilterByTokens tokens - where - RoleTokenFilterByTokens tokens - | Set.null tokens = RoleTokenFilterNone - | otherwise = MkRoleTokenFilterByTokens tokens +type RoleTokenFilter = RoleTokenFilter' ContractId PolicyId AssetId -data RoleToken = RoleToken - { roleTokenAssetId :: AssetId - , roleTokenContract :: ContractId - } +class IsToken t p | t -> p where + tokenPolicyId :: t -> p -evalRoleTokenFilter :: RoleTokenFilter -> RoleToken -> Bool -evalRoleTokenFilter f RoleToken{..} = go f +instance IsToken AssetId PolicyId where + tokenPolicyId = policyId + +evalRoleTokenFilter :: (Ord c, Ord p, Ord t, IsToken t p) => RoleTokenFilter' c p t -> c -> t -> Bool +evalRoleTokenFilter f roleTokenContract roleToken = go f where go = \case RoleTokensOr f1 f2 -> go f1 || go f2 RoleTokensAnd f1 f2 -> go f1 && go f2 + RoleTokensNot f' -> not $ go f' RoleTokenFilterAny -> True RoleTokenFilterNone -> False RoleTokenFilterByContracts contracts -> Set.member roleTokenContract contracts - RoleTokenFilterByPolicyIds policies -> Set.member (policyId roleTokenAssetId) policies - RoleTokenFilterByTokens tokens -> Set.member roleTokenAssetId tokens - -filterRoleTokens :: RoleTokenFilter -> Set RoleToken -> Set RoleToken -filterRoleTokens = Set.filter . evalRoleTokenFilter + RoleTokenFilterByPolicyIds policies -> Set.member (tokenPolicyId roleToken) policies + RoleTokenFilterByTokens tokens -> Set.member roleToken tokens + +optimizeRoleTokenFilter :: (Ord c, Ord p, Ord t, IsToken t p) => RoleTokenFilter' c p t -> RoleTokenFilter' c p t +optimizeRoleTokenFilter = rewrite rewriteRoleTokenFilter + +rewriteRoleTokenFilter :: (Ord c, Ord p, Ord t, IsToken t p) => RoleTokenFilter' c p t -> Maybe (RoleTokenFilter' c p t) +rewriteRoleTokenFilter = \case + RoleTokenFilterAny -> Nothing + RoleTokenFilterNone -> Nothing + -- rule double-negation + RoleTokensNot (RoleTokensNot a) -> Just a + -- rule not-any + RoleTokensNot RoleTokenFilterAny -> Just RoleTokenFilterNone + -- rule not-none + RoleTokensNot RoleTokenFilterNone -> Just RoleTokenFilterAny + RoleTokenFilterByContracts contracts + -- rule null-contracts + | Set.null contracts -> Just RoleTokenFilterNone + | otherwise -> Nothing + RoleTokenFilterByPolicyIds policies + -- rule null-policy-ids + | Set.null policies -> Just RoleTokenFilterNone + | otherwise -> Nothing + RoleTokenFilterByTokens tokens + -- rule null-tokens + | Set.null tokens -> Just RoleTokenFilterNone + | otherwise -> Nothing + RoleTokensAnd a b -> rewriteRoleTokensAnd a b <|> rewriteRoleTokensAnd b a + RoleTokensOr a b -> rewriteRoleTokensOr a b <|> rewriteRoleTokensOr b a + _ -> Nothing + +rewriteRoleTokensAnd + :: (Ord c, Ord p, Ord t, IsToken t p) + => RoleTokenFilter' c p t + -> RoleTokenFilter' c p t + -> Maybe (RoleTokenFilter' c p t) +rewriteRoleTokensAnd = curry \case + -- rule and-annulment + (_, RoleTokenFilterNone) -> Just RoleTokenFilterNone + -- rule and-identity + (a, RoleTokenFilterAny) -> Just a + -- rule de-morgan + (RoleTokensNot a, RoleTokensNot b) -> Just $ RoleTokensNot $ a `RoleTokensOr` b + -- and-distribute + (RoleTokensOr a b, RoleTokensOr c d) + | a == c -> Just $ a `RoleTokensAnd` (b `RoleTokensOr` d) + | a == d -> Just $ a `RoleTokensAnd` (b `RoleTokensOr` c) + | b == c -> Just $ b `RoleTokensAnd` (a `RoleTokensOr` d) + | b == d -> Just $ b `RoleTokensAnd` (a `RoleTokensOr` c) + -- rule and-contracts + (RoleTokenFilterByContracts a, RoleTokenFilterByContracts b) -> + Just $ RoleTokenFilterByContracts $ Set.intersection a b + -- rule and-policies + (RoleTokenFilterByPolicyIds a, RoleTokenFilterByPolicyIds b) -> + Just $ RoleTokenFilterByPolicyIds $ Set.intersection a b + -- rule and-tokens + (RoleTokenFilterByTokens a, RoleTokenFilterByTokens b) -> + Just $ RoleTokenFilterByTokens $ Set.intersection a b + -- rule and-policies-tokens + (RoleTokenFilterByPolicyIds p, RoleTokenFilterByTokens t) -> + Just $ RoleTokenFilterByTokens $ Set.filter (flip Set.member p . tokenPolicyId) t + -- rule and-complement + (a, RoleTokensNot a') | a == a' -> Just RoleTokenFilterNone + -- rule and-absorption + (a, RoleTokensOr b c) + | a == b || a == c -> Just a + | b == RoleTokensNot a -> Just $ a `RoleTokensAnd` c + | c == RoleTokensNot a -> Just $ a `RoleTokensAnd` b + -- rule and-idempotent + (a, a') | a == a' -> Just a + _ -> Nothing + +rewriteRoleTokensOr + :: (Ord c, Ord p, Ord t, IsToken t p) + => RoleTokenFilter' c p t + -> RoleTokenFilter' c p t + -> Maybe (RoleTokenFilter' c p t) +rewriteRoleTokensOr = curry \case + -- rule or-annulment + (_, RoleTokenFilterAny) -> Just RoleTokenFilterAny + -- rule or-identity + (a, RoleTokenFilterNone) -> Just a + -- rule de-morgan + (RoleTokensNot a, RoleTokensNot b) -> Just $ RoleTokensNot $ a `RoleTokensAnd` b + -- or-distribute + (RoleTokensOr a b, RoleTokensOr c d) + | a == c -> Just $ a `RoleTokensOr` (b `RoleTokensOr` d) + | a == d -> Just $ a `RoleTokensOr` (b `RoleTokensOr` c) + | b == c -> Just $ b `RoleTokensOr` (a `RoleTokensOr` d) + | b == d -> Just $ b `RoleTokensOr` (a `RoleTokensOr` c) + -- rule or-contracts + (RoleTokenFilterByContracts a, RoleTokenFilterByContracts b) -> + Just $ RoleTokenFilterByContracts $ Set.union a b + -- rule or-policies + (RoleTokenFilterByPolicyIds a, RoleTokenFilterByPolicyIds b) -> + Just $ RoleTokenFilterByPolicyIds $ Set.union a b + -- rule or-tokens + (RoleTokenFilterByTokens a, RoleTokenFilterByTokens b) -> + Just $ RoleTokenFilterByTokens $ Set.union a b + -- rule or-policies-tokens + (RoleTokenFilterByPolicyIds p, RoleTokenFilterByTokens t) -> + let t' = Set.filter (not . flip Set.member p . tokenPolicyId) t + in if t == t' + then Nothing + else Just $ RoleTokensOr (RoleTokenFilterByPolicyIds p) (RoleTokenFilterByTokens t') + -- rule or-complement + (a, RoleTokensNot a') | a == a' -> Just RoleTokenFilterAny + -- rule or-absorption + (a, RoleTokensAnd b c) + | a == b || a == c -> Just a + | b == RoleTokensNot a -> Just $ a `RoleTokensOr` c + | c == RoleTokensNot a -> Just $ a `RoleTokensOr` b + -- rule or-idempotent + (a, a') | a == a' -> Just a + _ -> Nothing -- | The low-level runtime API for building and submitting transactions. data MarloweTxCommand status err result where diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs new file mode 100644 index 0000000000..681bfe7ee1 --- /dev/null +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} + +module Language.Marlowe.Runtime.Transaction.Burn where + +import Cardano.Api (BabbageEraOnwards) +import Cardano.Api.Shelley (LedgerProtocolParameters) +import Control.Error (ExceptT) +import Language.Marlowe.Runtime.Transaction.Api (BurnError, BurnTxInEra, RoleTokenFilter) +import Language.Marlowe.Runtime.Transaction.Constraints (WalletContext (..)) +import UnliftIO (MonadUnliftIO) + +burnRoleTokens + :: (MonadUnliftIO m) + => BabbageEraOnwards era + -> LedgerProtocolParameters era + -> WalletContext + -> RoleTokenFilter + -> ExceptT BurnError m (BurnTxInEra era) +burnRoleTokens era protocol WalletContext{..} tokenFilter = undefined diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs index c9345b09f4..0e2884912e 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs @@ -51,7 +51,7 @@ import Control.Concurrent.STM (STM, modifyTVar, newEmptyTMVar, newTVar, putTMVar import Control.Error (MaybeT (..)) import Control.Error.Util (hush, note, noteT) import Control.Exception (Exception (..), SomeException) -import Control.Monad (guard, unless, (<=<)) +import Control.Monad (guard, unless, when, (<=<)) import Control.Monad.Event.Class import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) @@ -108,6 +108,8 @@ import Language.Marlowe.Runtime.Core.ScriptRegistry (HelperScript (..), MarloweS import Language.Marlowe.Runtime.Transaction.Api ( Account, ApplyInputsError (..), + BurnError (..), + BurnTx (BurnTx), ContractCreated (..), ContractCreatedInEra (..), CreateError (..), @@ -118,6 +120,8 @@ import Language.Marlowe.Runtime.Transaction.Api ( MarloweTxCommand (..), Mint (unMint), MintRole (roleTokenRecipients), + RoleTokenFilter, + RoleTokenFilter' (..), RoleTokensConfig (..), SubmitError (..), SubmitStatus (..), @@ -133,7 +137,12 @@ import Language.Marlowe.Runtime.Transaction.BuildConstraints ( buildWithdrawConstraints, initialMarloweState, ) -import Language.Marlowe.Runtime.Transaction.Constraints (MarloweContext (..), SolveConstraints, TxConstraints) +import Language.Marlowe.Runtime.Transaction.Burn (burnRoleTokens) +import Language.Marlowe.Runtime.Transaction.Constraints ( + MarloweContext (..), + SolveConstraints, + TxConstraints, + ) import qualified Language.Marlowe.Runtime.Transaction.Constraints as Constraints import Language.Marlowe.Runtime.Transaction.Query ( LoadMarloweContext, @@ -294,6 +303,14 @@ transactionServer = component "tx-job-server" \TransactionServerDependencies{..} version addresses payouts + Burn addresses tokenFilter -> + withEvent ExecWithdraw \_ -> + execBurn + era + ledgerProtocolParameters + loadWalletContext + addresses + tokenFilter Submit BabbageEraOnwardsBabbage tx -> execSubmit (mkSubmitJob AlonzoEraOnwardsBabbage) trackSubmitJob tx Submit BabbageEraOnwardsConway tx -> @@ -335,7 +352,7 @@ execCreate -> NominalDiffTime -> m (ServerStCmd MarloweTxCommand Void CreateError (ContractCreated v) m ()) execCreate mkRoleTokenMintingPolicy era contractQueryConnector getCurrentScripts solveConstraints protocolParameters loadWalletContext loadHelpersContext networkId mStakeCredential version addresses threadRole roleTokens metadata optMinAda accounts contract analysisTimeout = execExceptT do - eon <- referenceInputsSupportedInEra (CreateEraUnsupported $ AnyCardanoEra era) era + eon <- toBabbageEraOnwards (CreateEraUnsupported $ AnyCardanoEra era) era let adjustMinUtxo = mkAdjustMinimumUtxo eon protocolParameters version let threadRole' = fromMaybe "" threadRole walletContext <- lift $ loadWalletContext addresses @@ -468,9 +485,9 @@ execCreate mkRoleTokenMintingPolicy era contractQueryConnector getCurrentScripts , safetyErrors } -referenceInputsSupportedInEra +toBabbageEraOnwards :: (Monad m) => e -> CardanoEra era -> ExceptT e m (BabbageEraOnwards era) -referenceInputsSupportedInEra e = inEonForEra (throwE e) pure +toBabbageEraOnwards e = inEonForEra (throwE e) pure singletonContinuations :: Contract.ContractWithAdjacency -> Continuations 'V1 singletonContinuations Contract.ContractWithAdjacency{..} = Map.singleton contractHash contract @@ -538,7 +555,7 @@ execApplyInputs invalidBefore' invalidHereafter' inputs = execExceptT do - eon <- referenceInputsSupportedInEra (ApplyInputsEraUnsupported $ AnyCardanoEra era) era + eon <- toBabbageEraOnwards (ApplyInputsEraUnsupported $ AnyCardanoEra era) era marloweContext@MarloweContext{..} <- withExceptT ApplyInputsLoadMarloweContextFailed $ ExceptT $ @@ -607,7 +624,7 @@ execWithdraw -> m (ServerStCmd MarloweTxCommand Void WithdrawError (WithdrawTx v) m ()) execWithdraw era protocolParameters solveConstraints loadWalletContext loadPayoutContext loadHelpersContext version addresses payouts = execExceptT $ case version of MarloweV1 -> do - eon <- referenceInputsSupportedInEra (WithdrawEraUnsupported $ AnyCardanoEra era) era + eon <- toBabbageEraOnwards (WithdrawEraUnsupported $ AnyCardanoEra era) era payoutContext <- lift $ loadPayoutContext version payouts (inputs, constraints) <- buildWithdrawConstraints payoutContext version payouts walletContext <- lift $ loadWalletContext addresses @@ -680,3 +697,18 @@ execExceptT => ExceptT e m a -> m (ServerStCmd cmd status e a n ()) execExceptT = fmap (either (flip SendMsgFail ()) (flip SendMsgSucceed ())) . runExceptT + +execBurn + :: (MonadUnliftIO m, IsCardanoEra era) + => CardanoEra era + -> LedgerProtocolParameters era + -> LoadWalletContext m + -> WalletAddresses + -> RoleTokenFilter + -> m (ServerStCmd MarloweTxCommand Void BurnError BurnTx m ()) +execBurn era protocol loadWalletContext addresses tokenFilter = execExceptT do + eon <- toBabbageEraOnwards (BurnEraUnsupported $ AnyCardanoEra era) era + when (tokenFilter == RoleTokenFilterNone) $ throwE BurnNoTokens + walletContext <- lift $ loadWalletContext addresses + burnTx <- burnRoleTokens eon protocol walletContext tokenFilter + pure $ BurnTx eon burnTx From 94cb0a419bc464776d01f90b96643a12962a982b Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 7 Feb 2024 12:32:08 -0500 Subject: [PATCH 04/18] Add script table --- marlowe-chain-sync/deploy/scripts.sql | 23 +++++++++++++++++++++++ marlowe-chain-sync/revert/scripts.sql | 9 +++++++++ marlowe-chain-sync/sqitch.plan | 1 + marlowe-chain-sync/verify/scripts.sql | 7 +++++++ 4 files changed, 40 insertions(+) create mode 100644 marlowe-chain-sync/deploy/scripts.sql create mode 100644 marlowe-chain-sync/revert/scripts.sql create mode 100644 marlowe-chain-sync/verify/scripts.sql diff --git a/marlowe-chain-sync/deploy/scripts.sql b/marlowe-chain-sync/deploy/scripts.sql new file mode 100644 index 0000000000..f11a30364d --- /dev/null +++ b/marlowe-chain-sync/deploy/scripts.sql @@ -0,0 +1,23 @@ +-- Deploy chain:scripts to pg +-- requires: appschema + +BEGIN; + +-- NOTE this migration requires a reset of the entire database, as the chain +-- needs to be re-synchronized. +TRUNCATE chain.block CASCADE; +TRUNCATE chain.tx CASCADE; +TRUNCATE chain.txIn CASCADE; +TRUNCATE chain.txOut CASCADE; +TRUNCATE chain.assetOut; +TRUNCATE chain.assetMint; + +CREATE TYPE chain.SCRIPTLANG as ENUM ('SimpleScript', 'PlutusV1', 'PlutusV2', 'PlutusV3'); + +CREATE TABLE chain.script + ( id BYTEA PRIMARY KEY + , bytes BYTEA NOT NULL + , language chain.SCRIPTLANG NOT NULL + ); + +COMMIT; diff --git a/marlowe-chain-sync/revert/scripts.sql b/marlowe-chain-sync/revert/scripts.sql new file mode 100644 index 0000000000..33c98a3e80 --- /dev/null +++ b/marlowe-chain-sync/revert/scripts.sql @@ -0,0 +1,9 @@ +-- Revert chain:scripts from pg + +BEGIN; + +DROP TABLE chain.script; + +DROP TYPE chain.SCRIPTLANG; + +COMMIT; diff --git a/marlowe-chain-sync/sqitch.plan b/marlowe-chain-sync/sqitch.plan index 41bca0af02..30943eb6be 100644 --- a/marlowe-chain-sync/sqitch.plan +++ b/marlowe-chain-sync/sqitch.plan @@ -16,3 +16,4 @@ fix-upper-validity [split-address] 2023-02-23T21:59:30Z Brian W Bush # Adds new partitions to tables. drop-assets [asset] 2023-10-31T19:50:15Z Jamie Bertram # Drop asset table indexAddresses [split-address] 2023-11-07T20:26:39Z Jamie Bertram # Add indexes for address headers +scripts [appschema] 2024-02-07T17:20:49Z Jamie Bertram # Add script table diff --git a/marlowe-chain-sync/verify/scripts.sql b/marlowe-chain-sync/verify/scripts.sql new file mode 100644 index 0000000000..fe435f868e --- /dev/null +++ b/marlowe-chain-sync/verify/scripts.sql @@ -0,0 +1,7 @@ +-- Verify chain:scripts on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; From 122eb9c7560dd004d0a2b083c5bdda14b8eba3e0 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 7 Feb 2024 14:18:51 -0500 Subject: [PATCH 05/18] Insert into scripts table --- .../Language/Marlowe/Runtime/ChainIndexer.hs | 10 ++++ .../ChainIndexer/Database/PostgreSQL.hs | 51 ++++++++++++++----- marlowe-chain-sync/deploy/scripts.sql | 2 +- marlowe-chain-sync/marlowe-chain-copy/Main.hs | 26 ++++++++-- marlowe-chain-sync/marlowe-chain-sync.cabal | 1 + .../ChainSync/Database/PostgreSQL/Allegra.hs | 17 +++++++ .../ChainSync/Database/PostgreSQL/Alonzo.hs | 18 +++++++ .../ChainSync/Database/PostgreSQL/Babbage.hs | 39 ++++++++++++-- .../ChainSync/Database/PostgreSQL/Byron.hs | 1 + .../ChainSync/Database/PostgreSQL/Cardano.hs | 7 +-- .../ChainSync/Database/PostgreSQL/Conway.hs | 45 ++++++++++++++++ .../ChainSync/Database/PostgreSQL/Mary.hs | 17 +++++++ .../ChainSync/Database/PostgreSQL/Shelley.hs | 14 +++++ .../ChainSync/Database/PostgreSQL/Types.hs | 24 ++++++++- 14 files changed, 245 insertions(+), 27 deletions(-) diff --git a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer.hs b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer.hs index 1b22c2d286..6575ad086b 100644 --- a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer.hs +++ b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer.hs @@ -152,6 +152,16 @@ renderDatabaseSelectorOTel dbName dbUser host port = \case CopyTxIns -> renderCopy "txIn" CopyAssetOuts -> renderCopy "assetOut" CopyAssetMints -> renderCopy "assetMint" + CopyScripts -> + OTelRendered + { eventName = "INSERT INTO chain.script" + , eventKind = Internal + , renderField = \rows -> + standardAttributes + <> [ ("db.statement", "INSERT INTO chain.script VALUES (?,?,?) ON CONFLICT (id) DO NOTHING") + , ("db.rowsAffected", toAttribute rows) + ] + } where standardAttributes = catMaybes diff --git a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs index c3769ea2e2..1c590d2b50 100644 --- a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs +++ b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs @@ -57,7 +57,9 @@ import Data.ByteString.Short (fromShort, toShort) import Data.Csv (ToRecord) import Data.Csv.Incremental (Builder, encode, encodeRecord) import Data.Foldable (traverse_) +import Data.Function (on) import Data.Int (Int64) +import Data.List (nubBy) import Data.Profunctor (rmap) import qualified Data.Set as Set import Data.String (IsString (..)) @@ -65,9 +67,11 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Vector (Vector) import qualified Data.Vector as V +import Database.PostgreSQL.Simple (executeMany) import qualified Database.PostgreSQL.Simple as PS import Database.PostgreSQL.Simple.Copy (copy, putCopyData, putCopyEnd, putCopyError) import qualified Database.PostgreSQL.Simple.Internal as PS +import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Transaction (withTransactionSerializable) import qualified Database.PostgreSQL.Simple.Types as PS import Hasql.Connection (withLibPQConnection) @@ -117,6 +121,7 @@ data QuerySelector f where CopyTxIns :: QuerySelector Int64 CopyAssetOuts :: QuerySelector Int64 CopyAssetMints :: QuerySelector Int64 + CopyScripts :: QuerySelector Int64 data QueryField = SqlStatement ByteString @@ -331,7 +336,7 @@ commitBlocks commitBlocks runInIO = CommitBlocks \blocks -> do liftIO $ runInIO $ logInfo $ "Saving " <> T.pack (show $ length blocks) <> " blocks" let blockGroups = blockToRows <$> blocks - let (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows) = flattenBlockGroups blockGroups + let (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows, scripts) = flattenBlockGroups blockGroups sessionConnection <- ask liftIO $ withLibPQConnection sessionConnection \libPqConnection -> do connectionHandle <- newMVar libPqConnection @@ -345,26 +350,34 @@ commitBlocks runInIO = CommitBlocks \blocks -> do runInIO $ copyTxIns connection txInRows runInIO $ copyAssetOuts connection assetOutRows runInIO $ copyAssetMints connection assetMintRows + runInIO $ copyScripts connection $ nubBy (on (==) scriptHash) scripts -flattenBlockGroups :: [BlockRowGroup] -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow]) -flattenBlockGroups = foldr foldBlockGroup ([], [], [], [], [], []) +flattenBlockGroups + :: [BlockRowGroup] -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow]) +flattenBlockGroups = foldr foldBlockGroup ([], [], [], [], [], [], []) where foldBlockGroup :: BlockRowGroup - -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow]) - -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow]) - foldBlockGroup (blockRow, txGroups) (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows) = - (blockRow : blockRows, txRows', txOutRows', txInRows', assetOutRows', assetMintRows') + -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow]) + -> ([BlockRow], [TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow]) + foldBlockGroup (blockRow, txGroups) (blockRows, txRows, txOutRows, txInRows, assetOutRows, assetMintRows, scriptRows) = + (blockRow : blockRows, txRows', txOutRows', txInRows', assetOutRows', assetMintRows', scriptRows') where - (txRows', txOutRows', txInRows', assetOutRows', assetMintRows') = - foldr foldTxGroup (txRows, txOutRows, txInRows, assetOutRows, assetMintRows) txGroups + (txRows', txOutRows', txInRows', assetOutRows', assetMintRows', scriptRows') = + foldr foldTxGroup (txRows, txOutRows, txInRows, assetOutRows, assetMintRows, scriptRows) txGroups foldTxGroup :: TxRowGroup - -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow]) - -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow]) - foldTxGroup (txRow, txInRows, txOutGroups, assetMintRows) (txRows, txOutRows, txInRows', assetOutRows, assetMintRows') = - (txRow : txRows, txOutRows', foldr (:) txInRows' txInRows, assetOutRows', foldr (:) assetMintRows' assetMintRows) + -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow]) + -> ([TxRow], [TxOutRow], [TxInRow], [AssetOutRow], [AssetMintRow], [ScriptRow]) + foldTxGroup (txRow, txInRows, txOutGroups, assetMintRows, scripts) (txRows, txOutRows, txInRows', assetOutRows, assetMintRows', scripts') = + ( txRow : txRows + , txOutRows' + , foldr (:) txInRows' txInRows + , assetOutRows' + , foldr (:) assetMintRows' assetMintRows + , foldr (:) scripts' scripts + ) where (txOutRows', assetOutRows') = foldr foldTxOutGroup (txOutRows, assetOutRows) txOutGroups @@ -414,6 +427,18 @@ copyAssetMints conn = copyBuilder CopyAssetMints conn "assetMint (txId, slotNo, policyId, name, quantity)" . foldMap encodeRecord +copyScripts + :: (MonadInjectEvent r QuerySelector s m, MonadUnliftIO m) + => PS.Connection + -> [ScriptRow] + -> m () +copyScripts conn rows = do + let query = [sql| INSERT INTO chain.script VALUES (?,?,?) ON CONFLICT (id) DO NOTHING |] + withEvent CopyScripts \ev -> do + count <- liftIO $ executeMany conn query rows + addField ev count + pure () + copyBuilder :: ( MonadInjectEvent r QuerySelector s m , MonadUnliftIO m diff --git a/marlowe-chain-sync/deploy/scripts.sql b/marlowe-chain-sync/deploy/scripts.sql index f11a30364d..db689f85b0 100644 --- a/marlowe-chain-sync/deploy/scripts.sql +++ b/marlowe-chain-sync/deploy/scripts.sql @@ -12,7 +12,7 @@ TRUNCATE chain.txOut CASCADE; TRUNCATE chain.assetOut; TRUNCATE chain.assetMint; -CREATE TYPE chain.SCRIPTLANG as ENUM ('SimpleScript', 'PlutusV1', 'PlutusV2', 'PlutusV3'); +CREATE TYPE chain.SCRIPTLANG as ENUM ('MultiSig', 'Timelock', 'PlutusV1', 'PlutusV2', 'PlutusV3'); CREATE TABLE chain.script ( id BYTEA PRIMARY KEY diff --git a/marlowe-chain-sync/marlowe-chain-copy/Main.hs b/marlowe-chain-sync/marlowe-chain-copy/Main.hs index edd7aecdf2..5fb8cff3ed 100644 --- a/marlowe-chain-sync/marlowe-chain-copy/Main.hs +++ b/marlowe-chain-sync/marlowe-chain-copy/Main.hs @@ -30,7 +30,7 @@ import Cardano.Api ( getBlockHeader, ) import Cardano.Api.ChainSync.Client (ClientStIdle (..), ClientStNext (..)) -import Control.Monad (join, when) +import Control.Monad (guard, join, unless, when) import Data.ByteString.Lazy (toChunks) import Data.Csv (ToRecord) import Data.Csv.Incremental (encode, encodeRecord) @@ -39,7 +39,7 @@ import Data.Functor (void) import Data.Int (Int64) import Data.String (IsString (..)) import Data.Version (showVersion) -import Database.PostgreSQL.Simple (Connection, Query, close, connectPostgreSQL, execute_) +import Database.PostgreSQL.Simple (Connection, Query, close, connectPostgreSQL, executeMany, execute_) import Database.PostgreSQL.Simple.Copy (copy_, putCopyData, putCopyEnd, putCopyError) import Database.PostgreSQL.Simple.SqlQQ (sql) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Cardano (blockToRows) @@ -67,6 +67,7 @@ import UnliftIO ( atomically, bracket, finally, + flushTBQueue, mask, newTBQueueIO, onException, @@ -104,6 +105,7 @@ main = do txInRowQueue <- newTBQueueIO maxTxInsInQueue assetOutRowQueue <- newTBQueueIO maxAssetOutsInQueue assetMintRowQueue <- newTBQueueIO maxAssetMintsInQueue + scriptQueue <- newTBQueueIO maxBlocksInQueue bracket (truncateTablesAndDisableIndexes databaseUri) enableIndexes \_ -> runConcurrently do Concurrently $ runBlockProcessor @@ -114,6 +116,7 @@ main = do txInRowQueue assetOutRowQueue assetMintRowQueue + scriptQueue Concurrently $ runCopy databaseUri "block (id, slotNo, blockNo)" blockRowQueue Concurrently $ runCopy databaseUri "tx (blockId, id, slotNo, validityLowerBound, validityUpperBound, metadata, isValid)" txRowQueue @@ -126,6 +129,7 @@ main = do runCopy databaseUri "txIn (txOutId, txOutIx, txInId, slotNo, redeemerDatumBytes, isCollateral)" txInRowQueue Concurrently $ runCopy databaseUri "assetOut (txOutId, txOutIx, slotNo, policyId, name, quantity)" assetOutRowQueue Concurrently $ runCopy databaseUri "assetMint (txId, slotNo, policyId, name, quantity)" assetMintRowQueue + Concurrently $ runInsertScripts databaseUri scriptQueue Concurrently $ runChainSync blockQueue @@ -144,8 +148,9 @@ runBlockProcessor -> TBQueueMaybe TxInRow -> TBQueueMaybe AssetOutRow -> TBQueueMaybe AssetMintRow + -> TBQueueMaybe ScriptRow -> IO () -runBlockProcessor blockQueue blockRowQueue txRowQueue txOutRowQueue txInRowQueue assetOutRowQueue assetMintRowQueue = go +runBlockProcessor blockQueue blockRowQueue txRowQueue txOutRowQueue txInRowQueue assetOutRowQueue assetMintRowQueue scriptQueue = go where go = join $ atomically do mBlock <- readTBQueue blockQueue @@ -161,13 +166,14 @@ runBlockProcessor blockQueue blockRowQueue txRowQueue txOutRowQueue txInRowQueue Just block -> do let (blockRow, txRows) = blockToRows block writeTBQueue blockRowQueue $ Just blockRow - for_ txRows \(txRow, txInRows, txOutRows, txMintRows) -> do + for_ txRows \(txRow, txInRows, txOutRows, txMintRows, scriptRows) -> do writeTBQueue txRowQueue $ Just txRow traverse_ (writeTBQueue txInRowQueue . Just) txInRows for_ txOutRows \(txOutRow, assetOutRows) -> do writeTBQueue txOutRowQueue $ Just txOutRow traverse_ (writeTBQueue assetOutRowQueue . Just) assetOutRows traverse_ (writeTBQueue assetMintRowQueue . Just) txMintRows + traverse_ (writeTBQueue scriptQueue . Just) scriptRows pure go type TBQueueMaybe a = TBQueue (Maybe a) @@ -277,5 +283,17 @@ runCopy dbUri table rowQueue = withConnection dbUri \conn -> mask \restore -> do Right _ -> do putCopyEnd conn +runInsertScripts :: String -> TBQueueMaybe ScriptRow -> IO () +runInsertScripts dbUri rowQueue = withConnection dbUri \conn -> do + let go = do + rows <- atomically do + rows <- flushTBQueue rowQueue + guard $ not $ null rows + pure rows + let (rows', reachedEnd) = foldr (\r (acc, end) -> maybe (acc, True) ((,end) . (: acc)) r) ([], False) rows + _ <- executeMany conn [sql| INSERT INTO chain.script VALUES (?,?,?) ON CONFLICT (id) DO NOTHING |] rows' + unless reachedEnd go + go + withConnection :: (MonadUnliftIO m) => String -> (Connection -> m a) -> m a withConnection uri = bracket (liftIO $ connectPostgreSQL $ fromString uri) (liftIO . close) diff --git a/marlowe-chain-sync/marlowe-chain-sync.cabal b/marlowe-chain-sync/marlowe-chain-sync.cabal index e49f2da616..b2be98657b 100644 --- a/marlowe-chain-sync/marlowe-chain-sync.cabal +++ b/marlowe-chain-sync/marlowe-chain-sync.cabal @@ -100,6 +100,7 @@ library , ouroboros-consensus-cardano , plutus-core ^>=1.21 , plutus-ledger-api ^>=1.21 + , postgresql-simple , scientific , serialise ^>=0.2.6 , sop-core diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs index 44534fe6a3..80a9dba9e6 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs @@ -6,6 +6,7 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Allegra where import Cardano.Ledger.Allegra +import Cardano.Ledger.Allegra.Scripts (Timelock) import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..)) import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (..), ValidityInterval (..)) import Cardano.Ledger.BaseTypes (shelleyProtVer) @@ -13,12 +14,16 @@ import Cardano.Ledger.Binary (serialize') import Cardano.Ledger.Core (TxAuxData) import Cardano.Ledger.Crypto import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..)) import Data.ByteString (ByteString) import Data.Foldable (Foldable (..)) import Data.Int +import qualified Data.Map as Map import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( + hashToBytea, mapStrictMaybe, + originalBytea, shelleyTxInRow, shelleyTxOutRow, ) @@ -30,11 +35,23 @@ allegraTxToRows slotNo blockHash txId ShelleyTx{..} = , shelleyTxInRow slotNo txId <$> Set.toAscList (atbInputs body) , zipWith (allegraTxOutRow slotNo txId) [0 ..] $ toList $ atbOutputs body , [] + , allegraTxScripts wits ) encodeAllegraMetadata :: AllegraTxAuxData (AllegraEra StandardCrypto) -> ByteString encodeAllegraMetadata (AllegraTxAuxData md _) = serialize' shelleyProtVer md +allegraTxScripts :: ShelleyTxWits (AllegraEra StandardCrypto) -> [ScriptRow] +allegraTxScripts ShelleyTxWits{..} = uncurry allegraScriptRow <$> Map.toList scriptWits + +allegraScriptRow :: ScriptHash StandardCrypto -> Timelock (AllegraEra StandardCrypto) -> ScriptRow +allegraScriptRow (ScriptHash hash) script = + ScriptRow + { scriptHash = hashToBytea hash + , scriptBytes = originalBytea script + , scriptLanguage = Timelock + } + allegraTxRow :: (TxAuxData era -> ByteString) -> Int64 diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs index 8a399d1df3..ab82c29503 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs @@ -23,6 +23,9 @@ import Cardano.Ledger.Alonzo.Scripts ( AsItem (..), ) import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), indexRedeemers, txdats') +import Cardano.Ledger.Alonzo +import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..)) +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), ScriptPurpose (Spending), indexedRdmrs, txdats') import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody, AlonzoTxBody (..), AlonzoTxOut (..)) import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits, TxDats) @@ -43,6 +46,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows, maryTxOutRow, maryTxRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( + hashToBytea, mapStrictMaybe, originalBytea, shelleyTxInRow, @@ -64,11 +68,25 @@ alonzoTxToRows slotNo blockHash txId tx@AlonzoTx{..} = , alonzoTxInRows slotNo txId isValid tx (atbInputs body) (atbCollateral body) , zipWith (alonzoTxOutRow slotNo txId $ txdats' wits) [0 ..] $ toList $ atbOutputs body , maryAssetMintRows slotNo txId $ atbMint body + , alonzoTxScripts wits ) encodeAlonzoMetadata :: AlonzoTxAuxData (AlonzoEra StandardCrypto) -> ByteString encodeAlonzoMetadata (AlonzoTxAuxData md _ _) = L.serialize' shelleyProtVer md +alonzoTxScripts :: Alonzo.AlonzoTxWits (AlonzoEra StandardCrypto) -> [ScriptRow] +alonzoTxScripts Alonzo.AlonzoTxWits{..} = uncurry alonzoScriptRow <$> Map.toList txscripts + +alonzoScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (AlonzoEra StandardCrypto) -> ScriptRow +alonzoScriptRow (ScriptHash hash) script = + ScriptRow + { scriptHash = hashToBytea hash + , scriptBytes = originalBytea script + , scriptLanguage = case script of + TimelockScript _ -> Timelock + PlutusScript _ -> PlutusV1 + } + alonzoTxRow :: (TxAuxData era -> ByteString) -> Int64 diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs index 1a673fd8c9..da9572f2d9 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs @@ -6,10 +6,12 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Babbage where import Cardano.Binary (serialize') -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), txdats') +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) -import Cardano.Ledger.Alonzo.TxWits (TxDats, unTxDats) -import Cardano.Ledger.Babbage (BabbageEra, BabbageTxOut) +import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), TxDats, unTxDats) +import Cardano.Ledger.Babbage (AlonzoScript, BabbageEra, BabbageTxOut) +import Cardano.Ledger.Babbage.Core (EraScript (..)) +import Cardano.Ledger.Babbage.Scripts (AlonzoScript (..)) import Cardano.Ledger.Babbage.Tx (IsValid (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..)) import Cardano.Ledger.Binary (Sized (..), shelleyProtVer) @@ -17,13 +19,18 @@ import qualified Cardano.Ledger.Binary as L import Cardano.Ledger.Crypto import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, hashBinaryData) import Cardano.Ledger.Shelley.API (ShelleyTxOut (..), StrictMaybe (..)) +import Cardano.Ledger.Plutus.Data (binaryDataToData, hashBinaryData) +import Cardano.Ledger.Plutus.Language (Plutus (..)) +import qualified Cardano.Ledger.Plutus.Language as P +import Cardano.Ledger.Shelley.API (ScriptHash (..), ShelleyTxOut (..), StrictMaybe (..)) +import Control.Arrow (Arrow (..)) import Data.ByteString (ByteString) import Data.Foldable (Foldable (..)) import Data.Int import qualified Data.Map as Map import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxInRows, alonzoTxRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows, maryTxOutRow) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (originalBytea) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types babbageTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (BabbageEra StandardCrypto) -> TxRowGroup @@ -32,11 +39,35 @@ babbageTxToRows slotNo blockHash txId tx@AlonzoTx{..} = , alonzoTxInRows slotNo txId isValid tx (btbInputs body) (btbCollateral body) , babbageTxOutRows slotNo txId isValid (txdats' wits) (btbCollateralReturn body) $ toList $ btbOutputs body , maryAssetMintRows slotNo txId $ btbMint body + , babbageTxScripts wits $ toList $ btbOutputs body ) encodeBabbageMetadata :: AlonzoTxAuxData (BabbageEra StandardCrypto) -> ByteString encodeBabbageMetadata (AlonzoTxAuxData md _ _) = L.serialize' shelleyProtVer md +babbageTxScripts + :: AlonzoTxWits (BabbageEra StandardCrypto) + -> [Sized (BabbageTxOut (BabbageEra StandardCrypto))] + -> [ScriptRow] +babbageTxScripts AlonzoTxWits{..} outputs = + uncurry babbageScriptRow <$> (Map.toList txscripts <> foldMap babbageReferenceScript outputs) + +babbageReferenceScript + :: Sized (BabbageTxOut (BabbageEra StandardCrypto)) + -> [(ScriptHash StandardCrypto, AlonzoScript (BabbageEra StandardCrypto))] +babbageReferenceScript (Sized (BabbageTxOut _ _ _ ref) _) = foldMap (pure . (hashScript &&& id)) ref + +babbageScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (BabbageEra StandardCrypto) -> ScriptRow +babbageScriptRow (ScriptHash hash) script = + ScriptRow + { scriptHash = hashToBytea hash + , scriptBytes = originalBytea script + , scriptLanguage = case script of + TimelockScript _ -> Timelock + PlutusScript (Plutus P.PlutusV1 _) -> PlutusV1 + PlutusScript _ -> PlutusV2 + } + babbageTxOutRows :: Int64 -> Bytea diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Byron.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Byron.hs index a1060507a4..4c7b27bc14 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Byron.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Byron.hs @@ -57,6 +57,7 @@ byronTxRow slotNo blockHash txId UnsafeTx{..} = , NE.toList $ byronTxInRow slotNo txId <$> txInputs , zipWith (byronTxOutRow slotNo txId) [0 ..] $ NE.toList txOutputs , [] + , [] ) byronTxInRow :: Int64 -> Bytea -> TxIn -> TxInRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Cardano.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Cardano.hs index b5acabd1e2..d30421dc9d 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Cardano.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Cardano.hs @@ -23,14 +23,15 @@ import qualified Ouroboros.Consensus.Byron.Ledger as C blockToRows :: BlockInMode -> BlockRowGroup blockToRows (BlockInMode _ block) = ( BlockRow{..} - , case block of + , txGroups + ) + where + txGroups = case block of ByronBlock (C.ByronBlock (LB.ABOBBlock (LB.ABlock _ body _)) _ _) -> (\tx -> byronTxRow slotNo hash (byronTxId tx) $ taTx tx) <$> aUnTxPayload (LB.bodyTxPayload body) ByronBlock C.ByronBlock{} -> [] _ -> case block of Block _ txs -> txRow <$> txs - ) - where BlockHeader slot headerHash blockNo' = getBlockHeader block hash = serialiseToBytea headerHash slotNo = convertSlotNo slot diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs index 27bd3a5929..888e59aa89 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs @@ -6,6 +6,8 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Conway where import Cardano.Ledger.Allegra.TxBody (StrictMaybe (..)) +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) + import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) import Cardano.Ledger.Alonzo.TxWits (TxDats (..)) import Cardano.Ledger.Babbage (BabbageEra, BabbageTxOut) @@ -46,6 +48,24 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( TxInRow (..), TxRowGroup, ) + +import Cardano.Ledger.Conway.Scripts (AlonzoScript (..)) +import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) +import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..)) +import Cardano.Ledger.Core (EraScript (..), ScriptHash (..)) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Plutus.Language (Plutus (..)) +import qualified Cardano.Ledger.Plutus.Language as P +import Control.Arrow (Arrow (..)) +import Data.ByteString (ByteString) +import Data.Foldable (Foldable (..)) +import Data.Int +import qualified Data.Map as Map +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxInRows, alonzoTxRow) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Babbage (babbageTxOutRows) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types import Unsafe.Coerce (unsafeCoerce) conwayTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (ConwayEra StandardCrypto) -> TxRowGroup @@ -60,11 +80,36 @@ conwayTxToRows slotNo blockHash txId tx@AlonzoTx{..} = (coerceTxOut <$> ctbCollateralReturn body) (coerceTxOut <$> toList (ctbOutputs body)) , maryAssetMintRows slotNo txId $ ctbMint body + , conwayTxScripts wits $ toList $ ctbOutputs body ) encodeConwayMetadata :: AlonzoTxAuxData (ConwayEra StandardCrypto) -> ByteString encodeConwayMetadata (AlonzoTxAuxData md _ _) = L.serialize' shelleyProtVer md +conwayTxScripts + :: AlonzoTxWits (ConwayEra StandardCrypto) + -> [Sized (BabbageTxOut (ConwayEra StandardCrypto))] + -> [ScriptRow] +conwayTxScripts AlonzoTxWits{..} outputs = + uncurry conwayScriptRow <$> (Map.toList txscripts <> foldMap conwayReferenceScript outputs) + +conwayReferenceScript + :: Sized (BabbageTxOut (ConwayEra StandardCrypto)) + -> [(ScriptHash StandardCrypto, AlonzoScript (ConwayEra StandardCrypto))] +conwayReferenceScript (Sized (BabbageTxOut _ _ _ ref) _) = foldMap (pure . (hashScript &&& id)) ref + +conwayScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (ConwayEra StandardCrypto) -> ScriptRow +conwayScriptRow (ScriptHash hash) script = + ScriptRow + { scriptHash = hashToBytea hash + , scriptBytes = originalBytea script + , scriptLanguage = case script of + TimelockScript _ -> Timelock + PlutusScript (Plutus P.PlutusV1 _) -> PlutusV1 + PlutusScript (Plutus P.PlutusV2 _) -> PlutusV2 + PlutusScript (Plutus P.PlutusV3 _) -> PlutusV3 + } + coerceTxOut :: Sized (BabbageTxOut (ConwayEra StandardCrypto)) -> Sized (BabbageTxOut (BabbageEra StandardCrypto)) diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs index 77d15c1dfd..9c91390b55 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs @@ -5,6 +5,7 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary where +import Cardano.Ledger.Allegra.Scripts (Timelock) import qualified Cardano.Ledger.Allegra.Scripts as Allegra import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..)) import Cardano.Ledger.Binary (serialize', shelleyProtVer) @@ -19,6 +20,8 @@ import Cardano.Ledger.Shelley.API ( ShelleyTxOut (ShelleyTxOut), StrictMaybe, ) +import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..)) import Data.ByteString (ByteString) import Data.ByteString.Short (fromShort) import Data.Foldable (Foldable (..)) @@ -35,6 +38,8 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( TxRow, TxRowGroup, ) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea, shelleyTxInRow) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types maryTxToRows :: Int64 -> Bytea -> Bytea -> ShelleyTx (MaryEra StandardCrypto) -> TxRowGroup maryTxToRows slotNo blockHash txId ShelleyTx{..} = @@ -42,11 +47,23 @@ maryTxToRows slotNo blockHash txId ShelleyTx{..} = , shelleyTxInRow slotNo txId <$> Set.toAscList (mtbInputs body) , zipWith (maryTxOutRow slotNo txId) [0 ..] $ toList $ mtbOutputs body , maryAssetMintRows slotNo txId $ mtbMint body + , maryTxScripts wits ) encodeMaryMetadata :: AllegraTxAuxData (MaryEra StandardCrypto) -> ByteString encodeMaryMetadata (AllegraTxAuxData md _) = serialize' shelleyProtVer md +maryTxScripts :: ShelleyTxWits (MaryEra StandardCrypto) -> [ScriptRow] +maryTxScripts ShelleyTxWits{..} = uncurry maryScriptRow <$> Map.toList scriptWits + +maryScriptRow :: ScriptHash StandardCrypto -> Timelock (MaryEra StandardCrypto) -> ScriptRow +maryScriptRow (ScriptHash hash) script = + ScriptRow + { scriptHash = hashToBytea hash + , scriptBytes = originalBytea script + , scriptLanguage = Timelock + } + maryTxRow :: (TxAuxData era -> ByteString) -> Int64 diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs index a3b6ef34ff..dc223f7a86 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs @@ -12,12 +12,14 @@ import Cardano.Ledger.Crypto import Cardano.Ledger.SafeHash (SafeToHash (..)) import Cardano.Ledger.Shelley import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..)) import Data.Binary.Put (runPut) import Data.Bits ((.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Foldable (Foldable (..)) import Data.Int +import qualified Data.Map as Map import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Byron (AddressFields (..), byronAddressFields) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types @@ -43,8 +45,20 @@ shelleyTxRow slotNo blockHash txId ShelleyTx{..} = , shelleyTxInRow slotNo txId <$> Set.toAscList (stbInputs body) , zipWith (shelleyTxOutRow slotNo txId) [0 ..] $ toList $ stbOutputs body , [] + , shelleyTxScripts wits ) +shelleyTxScripts :: ShelleyTxWits (ShelleyEra StandardCrypto) -> [ScriptRow] +shelleyTxScripts ShelleyTxWits{..} = uncurry shelleyScriptRow <$> Map.toList scriptWits + +shelleyScriptRow :: ScriptHash StandardCrypto -> MultiSig (ShelleyEra StandardCrypto) -> ScriptRow +shelleyScriptRow (ScriptHash hash) script = + ScriptRow + { scriptHash = hashToBytea hash + , scriptBytes = originalBytea script + , scriptLanguage = MultiSig + } + mapStrictMaybe :: (a -> b) -> StrictMaybe a -> Maybe b mapStrictMaybe f = \case SNothing -> Nothing diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs index f28da40843..586eea102f 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs @@ -3,19 +3,26 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types where -import Cardano.Api +import Cardano.Api hiding (ScriptLanguage) import Data.ByteString (ByteString) import Data.ByteString.Base16 (encodeBase16) +import qualified Data.ByteString.Char8 as BS import Data.Csv import Data.Int import Data.Text.Encoding (encodeUtf8) +import Database.PostgreSQL.Simple (ToRow) +import qualified Database.PostgreSQL.Simple.ToField as PS import GHC.Generics (Generic) newtype Bytea = Bytea ByteString + deriving (Show, Read, Eq) instance ToField Bytea where toField (Bytea bs) = "\\x" <> encodeUtf8 (encodeBase16 bs) +instance PS.ToField Bytea where + toField (Bytea bs) = PS.EscapeByteA bs + newtype SqlBool = SqlBool Bool instance ToField SqlBool where @@ -98,10 +105,23 @@ instance ToRecord AssetMintRow type BlockRowGroup = (BlockRow, [TxRowGroup]) -type TxRowGroup = (TxRow, [TxInRow], [TxOutRowGroup], [AssetMintRow]) +type TxRowGroup = (TxRow, [TxInRow], [TxOutRowGroup], [AssetMintRow], [ScriptRow]) type TxOutRowGroup = (TxOutRow, [AssetOutRow]) +data ScriptRow = ScriptRow + { scriptHash :: !Bytea + , scriptBytes :: !Bytea + , scriptLanguage :: !ScriptLanguage + } + deriving (Generic, ToRow) + +data ScriptLanguage = MultiSig | Timelock | PlutusV1 | PlutusV2 | PlutusV3 + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) + +instance PS.ToField ScriptLanguage where + toField = PS.Escape . BS.pack . show + serialiseToBytea :: (SerialiseAsRawBytes a) => a -> Bytea serialiseToBytea = Bytea . serialiseToRawBytes From 931eca24767fe4c936a333433b14885869c0e685 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 7 Feb 2024 16:07:14 -0500 Subject: [PATCH 06/18] Implement getScripts query --- .../ChainIndexer/Database/PostgreSQL.hs | 2 +- marlowe-chain-sync/deploy/scripts.sql | 3 - .../Language/Marlowe/Runtime/ChainSync/Gen.hs | 36 ++++++++ .../Marlowe/Runtime/ChainSync/Database.hs | 13 ++- .../Runtime/ChainSync/Database/PostgreSQL.hs | 44 +++++++++ .../Marlowe/Runtime/ChainSync/QueryServer.hs | 2 + marlowe-chain-sync/marlowe-chain-copy/Main.hs | 2 +- marlowe-chain-sync/marlowe-chain-sync.cabal | 1 + marlowe-chain-sync/revert/scripts.sql | 2 - .../Language/Marlowe/Runtime/ChainSync/Api.hs | 89 ++++++++++++++++++- .../ChainSync/Database/PostgreSQL/Allegra.hs | 1 - .../ChainSync/Database/PostgreSQL/Alonzo.hs | 4 - .../ChainSync/Database/PostgreSQL/Babbage.hs | 7 -- .../ChainSync/Database/PostgreSQL/Conway.hs | 7 -- .../ChainSync/Database/PostgreSQL/Mary.hs | 1 - .../ChainSync/Database/PostgreSQL/Shelley.hs | 1 - .../ChainSync/Database/PostgreSQL/Types.hs | 8 -- 17 files changed, 182 insertions(+), 41 deletions(-) diff --git a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs index 1c590d2b50..b9734bc16d 100644 --- a/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs +++ b/marlowe-chain-sync/chain-indexer/Language/Marlowe/Runtime/ChainIndexer/Database/PostgreSQL.hs @@ -433,7 +433,7 @@ copyScripts -> [ScriptRow] -> m () copyScripts conn rows = do - let query = [sql| INSERT INTO chain.script VALUES (?,?,?) ON CONFLICT (id) DO NOTHING |] + let query = [sql| INSERT INTO chain.script VALUES (?,?) ON CONFLICT (id) DO NOTHING |] withEvent CopyScripts \ev -> do count <- liftIO $ executeMany conn query rows addField ev count diff --git a/marlowe-chain-sync/deploy/scripts.sql b/marlowe-chain-sync/deploy/scripts.sql index db689f85b0..15ed8aaf57 100644 --- a/marlowe-chain-sync/deploy/scripts.sql +++ b/marlowe-chain-sync/deploy/scripts.sql @@ -12,12 +12,9 @@ TRUNCATE chain.txOut CASCADE; TRUNCATE chain.assetOut; TRUNCATE chain.assetMint; -CREATE TYPE chain.SCRIPTLANG as ENUM ('MultiSig', 'Timelock', 'PlutusV1', 'PlutusV2', 'PlutusV3'); - CREATE TABLE chain.script ( id BYTEA PRIMARY KEY , bytes BYTEA NOT NULL - , language chain.SCRIPTLANG NOT NULL ); COMMIT; diff --git a/marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs b/marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs index d1dbc687fc..48b60b321a 100644 --- a/marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs +++ b/marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs @@ -1,5 +1,9 @@ {-# LANGUAGE EmptyCase #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Language.Marlowe.Runtime.ChainSync.Gen where @@ -7,13 +11,18 @@ module Language.Marlowe.Runtime.ChainSync.Gen where import Cardano.Api ( AddressAny (..), AlonzoEraOnwards (..), + AnyShelleyBasedEra (..), AsType (..), + BabbageEra, + BabbageEraOnwards (..), CardanoEra (..), + ConwayEra, EraHistory (..), Key (verificationKeyHash), NetworkId (..), NetworkMagic (..), PlutusScriptVersion (..), + ScriptInEra, SerialiseAsRawBytes (..), ShelleyBasedEra (..), SystemStart (..), @@ -60,6 +69,7 @@ import Test.Gen.Cardano.Api.Typed ( genPlutusScript, genProtocolParameters, genScriptHash, + genScriptInEra, genTx, genVerificationKey, ) @@ -393,6 +403,17 @@ instance Arbitrary AnyCardanoEra where , AnyCardanoEra ConwayEra ] +instance Arbitrary AnyShelleyBasedEra where + arbitrary = + elements + [ AnyShelleyBasedEra ShelleyBasedEraShelley + , AnyShelleyBasedEra ShelleyBasedEraAllegra + , AnyShelleyBasedEra ShelleyBasedEraMary + , AnyShelleyBasedEra ShelleyBasedEraAlonzo + , AnyShelleyBasedEra ShelleyBasedEraBabbage + , AnyShelleyBasedEra ShelleyBasedEraConway + ] + instance Query.ArbitraryRequest ChainSyncQuery where arbitraryTag = elements @@ -414,6 +435,8 @@ instance Query.ArbitraryRequest ChainSyncQuery where TagGetNodeTip -> pure GetNodeTip TagGetTip -> pure GetTip TagGetEra -> pure GetEra + TagGetScripts BabbageEraOnwardsBabbage -> GetScripts BabbageEraOnwardsBabbage <$> arbitrary + TagGetScripts BabbageEraOnwardsConway -> GetScripts BabbageEraOnwardsConway <$> arbitrary arbitraryResult = \case TagGetSecurityParameter -> arbitrary @@ -427,6 +450,8 @@ instance Query.ArbitraryRequest ChainSyncQuery where TagGetNodeTip -> arbitrary TagGetTip -> arbitrary TagGetEra -> arbitrary + TagGetScripts BabbageEraOnwardsBabbage -> arbitrary + TagGetScripts BabbageEraOnwardsConway -> arbitrary shrinkReq = \case GetSecurityParameter -> [] @@ -438,6 +463,7 @@ instance Query.ArbitraryRequest ChainSyncQuery where GetNodeTip -> [] GetTip -> [] GetEra -> [] + GetScripts era scripts -> GetScripts era <$> shrink scripts shrinkResult = \case TagGetSecurityParameter -> shrink @@ -451,6 +477,14 @@ instance Query.ArbitraryRequest ChainSyncQuery where TagGetNodeTip -> shrink TagGetTip -> shrink TagGetEra -> shrink + TagGetScripts BabbageEraOnwardsBabbage -> shrink + TagGetScripts BabbageEraOnwardsConway -> shrink + +instance Arbitrary (ScriptInEra BabbageEra) where + arbitrary = hedgehog $ genScriptInEra ShelleyBasedEraBabbage + +instance Arbitrary (ScriptInEra ConwayEra) where + arbitrary = hedgehog $ genScriptInEra ShelleyBasedEraConway genEraHistory :: Gen EraHistory genEraHistory = @@ -525,6 +559,8 @@ instance Query.RequestEq ChainSyncQuery where TagGetNodeTip -> (==) TagGetTip -> (==) TagGetEra -> (==) + TagGetScripts BabbageEraOnwardsBabbage -> (==) + TagGetScripts BabbageEraOnwardsConway -> (==) instance Command.ArbitraryCommand ChainSyncCommand where arbitraryTag = diff --git a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database.hs b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database.hs index 2fd2f5992a..92bb70e455 100644 --- a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database.hs +++ b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database.hs @@ -3,8 +3,11 @@ module Language.Marlowe.Runtime.ChainSync.Database where +import Cardano.Api (BabbageEraOnwards, ScriptInEra) import Data.List.NonEmpty (NonEmpty) -import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint, GetUTxOsQuery, Move, UTxOs) +import Data.Map (Map) +import Data.Set (Set) +import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint, GetUTxOsQuery, Move, ScriptHash, UTxOs) import Numeric.Natural (Natural) -- Queries @@ -15,6 +18,9 @@ newtype GetTip m = GetTip newtype GetUTxOs m = GetUTxOs {runGetUTxOs :: GetUTxOsQuery -> m UTxOs} +newtype GetScripts m = GetScripts + {runGetScripts :: forall era. BabbageEraOnwards era -> Set ScriptHash -> m (Map ScriptHash (ScriptInEra era))} + data MoveResult err result = RollForward result BlockHeader ChainPoint | RollBack ChainPoint ChainPoint @@ -39,6 +45,9 @@ newtype Collect err result m = Collect hoistGetUTxOs :: (forall a. m a -> n a) -> GetUTxOs m -> GetUTxOs n hoistGetUTxOs transformation = GetUTxOs . fmap transformation . runGetUTxOs +hoistGetScripts :: (forall a. m a -> n a) -> GetScripts m -> GetScripts n +hoistGetScripts transformation GetScripts{..} = GetScripts \era -> transformation . runGetScripts era + hoistGetTip :: (forall a. m a -> n a) -> GetTip m -> GetTip n hoistGetTip transformation = GetTip . transformation . runGetTip @@ -65,6 +74,7 @@ hoistCollectResult transformation = \case data DatabaseQueries m = DatabaseQueries { getUTxOs :: GetUTxOs m + , getScripts :: GetScripts m , getTip :: GetTip m , moveClient :: MoveClient m , scan :: Scan m @@ -74,6 +84,7 @@ hoistDatabaseQueries :: (Functor m) => (forall a. m a -> n a) -> DatabaseQueries hoistDatabaseQueries transformation DatabaseQueries{..} = DatabaseQueries { getUTxOs = hoistGetUTxOs transformation getUTxOs + , getScripts = hoistGetScripts transformation getScripts , getTip = hoistGetTip transformation getTip , moveClient = hoistMoveClient transformation moveClient , scan = hoistScan transformation scan diff --git a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs index b7ed89413b..fa0a500662 100644 --- a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs +++ b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs @@ -31,8 +31,11 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL ( databaseQueries, ) where +import Cardano.Api (BabbageEraOnwards (..), ShelleyBasedEra (..)) +import Cardano.Api.Shelley (fromShelleyBasedScript) import qualified Cardano.Api.Shelley as C import Cardano.Binary (unsafeDeserialize') +import Cardano.Ledger.Binary (DecCBOR (decCBOR), decodeFullAnnotator, shelleyProtVer) import Control.Applicative ((<|>)) import Control.Arrow (Arrow (..), (***)) import Control.Foldl (Fold (Fold)) @@ -44,6 +47,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.Foldable (fold) import Data.Functor ((<&>)) import Data.Int (Int16, Int64) @@ -81,6 +85,7 @@ import Language.Marlowe.Runtime.ChainSync.Database ( MoveResult (..), Scan (..), hoistCollect, + hoistGetScripts, hoistGetTip, hoistGetUTxOs, hoistMoveClient, @@ -106,6 +111,7 @@ databaseQueries databaseQueries pool networkId = DatabaseQueries (hoistGetUTxOs (transact "getUTxOs") getUTxOs) + (hoistGetScripts (transact "getScripts") getScripts) (hoistGetTip (transact "getTip") getTip) (hoistMoveClient (transact "moveClient") $ moveClient networkId) (Scan $ fmap (pure . hoistCollect (transact "collect")) . mkCollect networkId) @@ -123,6 +129,44 @@ databaseQueries pool networkId = throwIO ex Right a -> pure a +-- GetScripts + +getScripts :: Database.GetScripts HT.Transaction +getScripts = Database.GetScripts go + where + go :: forall era. C.BabbageEraOnwards era -> Set ScriptHash -> HT.Transaction (Map ScriptHash (C.ScriptInEra era)) + go era scripts + | Set.null scripts = pure mempty + | otherwise = + Map.fromDistinctAscList . fmap mapRow . V.toList + <$> HT.statement + (params scripts) + [vectorStatement| + SELECT id :: bytea, bytes :: bytea + FROM chain.script + WHERE id = ANY($1 :: bytea[]) + ORDER BY id + |] + where + params = V.fromList . fmap unScriptHash . Set.toList + + mapRow :: (ByteString, ByteString) -> (ScriptHash, C.ScriptInEra era) + mapRow = case era of + BabbageEraOnwardsBabbage -> \(scriptHash, scriptBytes) -> + ( ScriptHash scriptHash + , fromShelleyBasedScript ShelleyBasedEraBabbage $ + either (error . show) id $ + decodeFullAnnotator shelleyProtVer "Script" decCBOR $ + LBS.fromStrict scriptBytes + ) + BabbageEraOnwardsConway -> \(scriptHash, scriptBytes) -> + ( ScriptHash scriptHash + , fromShelleyBasedScript ShelleyBasedEraConway $ + either (error . show) id $ + decodeFullAnnotator shelleyProtVer "Script" decCBOR $ + LBS.fromStrict scriptBytes + ) + -- Scan mkCollect :: C.NetworkId -> ChainPoint -> Move err result -> Collect err result HT.Transaction diff --git a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/QueryServer.hs b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/QueryServer.hs index c8870941f1..d06f76dcbe 100644 --- a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/QueryServer.hs +++ b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/QueryServer.hs @@ -33,6 +33,7 @@ data ChainSyncQueryServerDependencies m = ChainSyncQueryServerDependencies -> QueryInMode result -> m (Either AcquiringFailure result) , getUTxOs :: Database.GetUTxOs m + , getScripts :: Database.GetScripts m , getTip :: Database.GetTip m , nodeTip :: STM ChainPoint } @@ -62,6 +63,7 @@ chainSyncQueryServer ChainSyncQueryServerDependencies{..} = ServerSource $ pure GetNodeTip -> atomically nodeTip GetTip -> runGetTip getTip GetEra -> either (fail . show) pure =<< queryLocalNodeState Nothing QueryCurrentEra + GetScripts era scripts -> Database.runGetScripts getScripts era scripts } queryGenesisParameters :: (forall era. GenesisParameters era -> a) -> m a diff --git a/marlowe-chain-sync/marlowe-chain-copy/Main.hs b/marlowe-chain-sync/marlowe-chain-copy/Main.hs index 5fb8cff3ed..613dd7088a 100644 --- a/marlowe-chain-sync/marlowe-chain-copy/Main.hs +++ b/marlowe-chain-sync/marlowe-chain-copy/Main.hs @@ -291,7 +291,7 @@ runInsertScripts dbUri rowQueue = withConnection dbUri \conn -> do guard $ not $ null rows pure rows let (rows', reachedEnd) = foldr (\r (acc, end) -> maybe (acc, True) ((,end) . (: acc)) r) ([], False) rows - _ <- executeMany conn [sql| INSERT INTO chain.script VALUES (?,?,?) ON CONFLICT (id) DO NOTHING |] rows' + _ <- executeMany conn [sql| INSERT INTO chain.script VALUES (?,?) ON CONFLICT (id) DO NOTHING |] rows' unless reachedEnd go go diff --git a/marlowe-chain-sync/marlowe-chain-sync.cabal b/marlowe-chain-sync/marlowe-chain-sync.cabal index b2be98657b..1df59e60fc 100644 --- a/marlowe-chain-sync/marlowe-chain-sync.cabal +++ b/marlowe-chain-sync/marlowe-chain-sync.cabal @@ -131,6 +131,7 @@ library libchainsync , bytestring >=0.10.12 && <0.12 , cardano-api:{cardano-api, internal} ^>=8.39.2.0 , cardano-binary + , cardano-ledger-binary ^>=1.2 , co-log ^>=0.6 , containers ^>=0.6.5 , eventuo11y >=0.9 && <0.11 diff --git a/marlowe-chain-sync/revert/scripts.sql b/marlowe-chain-sync/revert/scripts.sql index 33c98a3e80..c927f28099 100644 --- a/marlowe-chain-sync/revert/scripts.sql +++ b/marlowe-chain-sync/revert/scripts.sql @@ -4,6 +4,4 @@ BEGIN; DROP TABLE chain.script; -DROP TYPE chain.SCRIPTLANG; - COMMIT; diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs index fe4184c73c..e88aa045e0 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -19,10 +20,14 @@ import Cardano.Api ( AlonzoEraOnwards (..), AnyCardanoEra (..), AsType (..), + BabbageEra, + BabbageEraOnwards (..), CardanoEra (..), + ConwayEra, EraHistory (..), NetworkId (..), NetworkMagic (..), + ScriptInEra (..), SerialiseAsRawBytes (..), Tx, deserialiseFromBech32, @@ -33,11 +38,13 @@ import Cardano.Api ( ) import qualified Cardano.Api as C import qualified Cardano.Api as Cardano -import Cardano.Api.Shelley (ProtocolParameters) +import Cardano.Api.Shelley (ProtocolParameters, fromShelleyBasedScript, toShelleyScript) import qualified Cardano.Api.Shelley as Cardano import qualified Cardano.Ledger.BaseTypes as Base import qualified Cardano.Ledger.BaseTypes as C +import Cardano.Ledger.Binary (Annotator, DecCBOR (..), decodeFullAnnotator) import Cardano.Ledger.Credential (ptrCertIx, ptrSlotNo, ptrTxIx) +import Cardano.Ledger.SafeHash (SafeToHash (..)) import Cardano.Ledger.Slot (EpochSize) import Codec.Serialise (deserialiseOrFail, serialise) import Control.Applicative ((<|>)) @@ -59,11 +66,12 @@ import Data.Aeson.Text (encodeToLazyText) import Data.Aeson.Types (Parser, parseFail, toJSONKeyText) import qualified Data.Attoparsec.ByteString.Char8 as Atto import Data.Bifunctor (Bifunctor (..), bimap) -import Data.Binary (Binary (..), get, getWord8, put, putWord8) +import Data.Binary (Binary (..), Get, get, getWord8, put, putWord8) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Base16 (decodeBase16, encodeBase16) import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as LBS import Data.Foldable (Foldable (..)) import Data.Function (on) import Data.Functor (($>)) @@ -377,9 +385,9 @@ fromJSONEncodedTransactionMetadata :: A.Value -> Maybe TransactionMetadata fromJSONEncodedTransactionMetadata = \case A.Object (Map.toList . KeyMap.toMapText -> props) -> TransactionMetadata . Map.fromList <$> for props \(key, value) -> do - label <- fmap fromInteger $ readMaybe . T.unpack $ key + lbl <- fmap fromInteger $ readMaybe . T.unpack $ key value' <- fromJSONEncodedMetadata value - pure (label, value') + pure (lbl, value') _ -> Nothing toCardanoTxMetadata :: TransactionMetadata -> C.TxMetadata @@ -1084,6 +1092,7 @@ data ChainSyncQuery a where GetNodeTip :: ChainSyncQuery ChainPoint GetTip :: ChainSyncQuery ChainPoint GetEra :: ChainSyncQuery AnyCardanoEra + GetScripts :: BabbageEraOnwards era -> Set ScriptHash -> ChainSyncQuery (Map ScriptHash (ScriptInEra era)) type ChainSyncQueryClientSelector = QueryClientSelector ChainSyncQuery @@ -1193,6 +1202,20 @@ renderChainSyncQueryOTel = \case ) ] } + GetScripts era scripts -> + RequestRenderedOTel + { requestName = "get-scripts" + , requestAttributes = + [ + ( "era" + , case era of + BabbageEraOnwardsBabbage -> "babbage" + BabbageEraOnwardsConway -> "conway" + ) + , ("scripts", toAttribute $ fmap (T.pack . show) $ Set.toList scripts) + ] + , responseAttributes = \result -> [("scripts", toAttribute $ fmap (T.pack . show) $ Map.keys result)] + } summaryAttributes :: NonEmpty xs EraSummary -> Counting.Exactly xs Text -> [(Text, Attribute)] summaryAttributes (NonEmptyOne summary) (Counting.Exactly (K era :* _)) = @@ -1272,6 +1295,8 @@ instance Query.RequestVariations ChainSyncQuery where , Query.SomeTag TagGetNodeTip , Query.SomeTag TagGetTip , Query.SomeTag TagGetEra + , Query.SomeTag $ TagGetScripts BabbageEraOnwardsBabbage + , Query.SomeTag $ TagGetScripts BabbageEraOnwardsConway ] requestVariations = \case TagGetSecurityParameter -> pure GetSecurityParameter @@ -1283,6 +1308,7 @@ instance Query.RequestVariations ChainSyncQuery where TagGetNodeTip -> pure GetNodeTip TagGetTip -> pure GetTip TagGetEra -> pure GetEra + TagGetScripts era -> GetScripts era <$> variations resultVariations = \case TagGetSecurityParameter -> variations TagGetNetworkId -> Mainnet NE.:| [Testnet $ NetworkMagic 0] @@ -1293,6 +1319,37 @@ instance Query.RequestVariations ChainSyncQuery where TagGetNodeTip -> variations TagGetTip -> variations TagGetEra -> variations + TagGetScripts BabbageEraOnwardsBabbage -> variations + TagGetScripts BabbageEraOnwardsConway -> variations + +instance Variations (ScriptInEra BabbageEra) where + variations = + pure $ + ScriptInEra C.PlutusScriptV1InBabbage $ + C.PlutusScript C.PlutusScriptV1 $ + C.examplePlutusScriptAlwaysSucceeds C.WitCtxTxIn + +instance Variations (ScriptInEra ConwayEra) where + variations = + pure $ + ScriptInEra C.PlutusScriptV1InConway $ + C.PlutusScript C.PlutusScriptV1 $ + C.examplePlutusScriptAlwaysSucceeds C.WitCtxTxIn + +instance Binary (ScriptInEra BabbageEra) where + put = put . originalBytes . toShelleyScript + get = do + bytes <- get + fromShelleyBasedScript C.ShelleyBasedEraBabbage <$> getDecodeFull bytes + +instance Binary (ScriptInEra ConwayEra) where + put = put . originalBytes . toShelleyScript + get = do + bytes <- get + fromShelleyBasedScript C.ShelleyBasedEraConway <$> getDecodeFull bytes + +getDecodeFull :: (DecCBOR (Annotator a)) => LBS.ByteString -> Get a +getDecodeFull = either (fail . show) pure . decodeFullAnnotator Base.shelleyProtVer "getDecodeFull" decCBOR instance Query.Request ChainSyncQuery where data Tag ChainSyncQuery result where @@ -1305,6 +1362,7 @@ instance Query.Request ChainSyncQuery where TagGetNodeTip :: Query.Tag ChainSyncQuery ChainPoint TagGetTip :: Query.Tag ChainSyncQuery ChainPoint TagGetEra :: Query.Tag ChainSyncQuery AnyCardanoEra + TagGetScripts :: BabbageEraOnwards era -> Query.Tag ChainSyncQuery (Map ScriptHash (ScriptInEra era)) tagEq TagGetSecurityParameter TagGetSecurityParameter = Just Refl tagEq TagGetSecurityParameter _ = Nothing tagEq TagGetNetworkId TagGetNetworkId = Just Refl @@ -1323,6 +1381,10 @@ instance Query.Request ChainSyncQuery where tagEq TagGetTip _ = Nothing tagEq TagGetEra TagGetEra = Just Refl tagEq TagGetEra _ = Nothing + tagEq (TagGetScripts BabbageEraOnwardsBabbage) (TagGetScripts BabbageEraOnwardsBabbage) = Just Refl + tagEq (TagGetScripts BabbageEraOnwardsBabbage) _ = Nothing + tagEq (TagGetScripts BabbageEraOnwardsConway) (TagGetScripts BabbageEraOnwardsConway) = Just Refl + tagEq (TagGetScripts BabbageEraOnwardsConway) _ = Nothing tagFromReq = \case GetSecurityParameter -> TagGetSecurityParameter GetNetworkId -> TagGetNetworkId @@ -1333,6 +1395,7 @@ instance Query.Request ChainSyncQuery where GetNodeTip -> TagGetNodeTip GetTip -> TagGetTip GetEra -> TagGetEra + GetScripts era _ -> TagGetScripts era deriving instance Show (Query.Tag ChainSyncQuery a) deriving instance Eq (Query.Tag ChainSyncQuery a) @@ -1356,6 +1419,12 @@ instance Query.BinaryRequest ChainSyncQuery where GetNodeTip -> putWord8 0x07 GetTip -> putWord8 0x08 GetEra -> putWord8 0x09 + GetScripts era scripts -> do + putWord8 0x0a + putWord8 case era of + BabbageEraOnwardsBabbage -> 0x00 + BabbageEraOnwardsConway -> 0x01 + put scripts getReq = do tag <- getWord8 case tag of @@ -1375,6 +1444,12 @@ instance Query.BinaryRequest ChainSyncQuery where 0x07 -> pure $ Query.SomeRequest GetNodeTip 0x08 -> pure $ Query.SomeRequest GetTip 0x09 -> pure $ Query.SomeRequest GetEra + 0x10 -> do + tag' <- getWord8 + case tag' of + 0x00 -> Query.SomeRequest . GetScripts BabbageEraOnwardsBabbage <$> get + 0x01 -> Query.SomeRequest . GetScripts BabbageEraOnwardsConway <$> get + _ -> fail "Invalid BabbageEraOnwards tag" _ -> fail "Invalid ChainSyncQuery tag" putResult = \case TagGetSecurityParameter -> put @@ -1391,6 +1466,8 @@ instance Query.BinaryRequest ChainSyncQuery where TagGetNodeTip -> put TagGetTip -> put TagGetEra -> put + TagGetScripts BabbageEraOnwardsBabbage -> put + TagGetScripts BabbageEraOnwardsConway -> put getResult = \case TagGetSecurityParameter -> get TagGetNetworkId -> maybe Mainnet (Testnet . NetworkMagic) <$> get @@ -1409,6 +1486,8 @@ instance Query.BinaryRequest ChainSyncQuery where TagGetNodeTip -> get TagGetTip -> get TagGetEra -> get + TagGetScripts BabbageEraOnwardsBabbage -> get + TagGetScripts BabbageEraOnwardsConway -> get instance Query.ShowRequest ChainSyncQuery where showsPrecResult p = \case @@ -1434,6 +1513,7 @@ instance Query.ShowRequest ChainSyncQuery where TagGetNodeTip -> showsPrec p TagGetTip -> showsPrec p TagGetEra -> showsPrec p + TagGetScripts _ -> showsPrec p instance Query.OTelRequest ChainSyncQuery where reqTypeName _ = "chain_sync" @@ -1447,6 +1527,7 @@ instance Query.OTelRequest ChainSyncQuery where TagGetNodeTip -> "node_tip" TagGetTip -> "tip" TagGetEra -> "era" + TagGetScripts _ -> "scripts" unInterpreter :: Interpreter xs -> Summary xs unInterpreter = unsafeCoerce diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs index 80a9dba9e6..8e237610c1 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs @@ -49,7 +49,6 @@ allegraScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = originalBytea script - , scriptLanguage = Timelock } allegraTxRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs index ab82c29503..ba201bb9b6 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs @@ -24,7 +24,6 @@ import Cardano.Ledger.Alonzo.Scripts ( ) import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), indexRedeemers, txdats') import Cardano.Ledger.Alonzo -import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..)) import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), ScriptPurpose (Spending), indexedRdmrs, txdats') import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody, AlonzoTxBody (..), AlonzoTxOut (..)) @@ -82,9 +81,6 @@ alonzoScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = originalBytea script - , scriptLanguage = case script of - TimelockScript _ -> Timelock - PlutusScript _ -> PlutusV1 } alonzoTxRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs index da9572f2d9..282ad10c23 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs @@ -11,7 +11,6 @@ import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), TxDats, unTxDats) import Cardano.Ledger.Babbage (AlonzoScript, BabbageEra, BabbageTxOut) import Cardano.Ledger.Babbage.Core (EraScript (..)) -import Cardano.Ledger.Babbage.Scripts (AlonzoScript (..)) import Cardano.Ledger.Babbage.Tx (IsValid (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..)) import Cardano.Ledger.Binary (Sized (..), shelleyProtVer) @@ -20,8 +19,6 @@ import Cardano.Ledger.Crypto import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, hashBinaryData) import Cardano.Ledger.Shelley.API (ShelleyTxOut (..), StrictMaybe (..)) import Cardano.Ledger.Plutus.Data (binaryDataToData, hashBinaryData) -import Cardano.Ledger.Plutus.Language (Plutus (..)) -import qualified Cardano.Ledger.Plutus.Language as P import Cardano.Ledger.Shelley.API (ScriptHash (..), ShelleyTxOut (..), StrictMaybe (..)) import Control.Arrow (Arrow (..)) import Data.ByteString (ByteString) @@ -62,10 +59,6 @@ babbageScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = originalBytea script - , scriptLanguage = case script of - TimelockScript _ -> Timelock - PlutusScript (Plutus P.PlutusV1 _) -> PlutusV1 - PlutusScript _ -> PlutusV2 } babbageTxOutRows diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs index 888e59aa89..13909091f5 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs @@ -54,8 +54,6 @@ import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..)) import Cardano.Ledger.Core (EraScript (..), ScriptHash (..)) import Cardano.Ledger.Crypto -import Cardano.Ledger.Plutus.Language (Plutus (..)) -import qualified Cardano.Ledger.Plutus.Language as P import Control.Arrow (Arrow (..)) import Data.ByteString (ByteString) import Data.Foldable (Foldable (..)) @@ -103,11 +101,6 @@ conwayScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = originalBytea script - , scriptLanguage = case script of - TimelockScript _ -> Timelock - PlutusScript (Plutus P.PlutusV1 _) -> PlutusV1 - PlutusScript (Plutus P.PlutusV2 _) -> PlutusV2 - PlutusScript (Plutus P.PlutusV3 _) -> PlutusV3 } coerceTxOut diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs index 9c91390b55..35084cdbe3 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs @@ -61,7 +61,6 @@ maryScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = originalBytea script - , scriptLanguage = Timelock } maryTxRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs index dc223f7a86..1cb2279ce8 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs @@ -56,7 +56,6 @@ shelleyScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = originalBytea script - , scriptLanguage = MultiSig } mapStrictMaybe :: (a -> b) -> StrictMaybe a -> Maybe b diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs index 586eea102f..370e133bf3 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Types.hs @@ -6,7 +6,6 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types where import Cardano.Api hiding (ScriptLanguage) import Data.ByteString (ByteString) import Data.ByteString.Base16 (encodeBase16) -import qualified Data.ByteString.Char8 as BS import Data.Csv import Data.Int import Data.Text.Encoding (encodeUtf8) @@ -112,16 +111,9 @@ type TxOutRowGroup = (TxOutRow, [AssetOutRow]) data ScriptRow = ScriptRow { scriptHash :: !Bytea , scriptBytes :: !Bytea - , scriptLanguage :: !ScriptLanguage } deriving (Generic, ToRow) -data ScriptLanguage = MultiSig | Timelock | PlutusV1 | PlutusV2 | PlutusV3 - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) - -instance PS.ToField ScriptLanguage where - toField = PS.Escape . BS.pack . show - serialiseToBytea :: (SerialiseAsRawBytes a) => a -> Bytea serialiseToBytea = Bytea . serialiseToRawBytes From 233fcc5a933d16eb95ddf73a6f6881c2b3e13228 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 7 Feb 2024 19:25:26 -0500 Subject: [PATCH 07/18] Implement getRoleCurrencies query --- marlowe-runtime/.golden/MarloweQuery/golden | 22 +++++++++ .../Language/Marlowe/Protocol/Query/Client.hs | 5 ++ .../Language/Marlowe/Protocol/Query/Server.hs | 6 ++- .../Language/Marlowe/Protocol/Query/Types.hs | 46 +++++++++++++++++++ .../sync/Language/Marlowe/Runtime/Sync.hs | 3 ++ .../Language/Marlowe/Runtime/Sync/Database.hs | 11 +++++ .../Runtime/Sync/Database/PostgreSQL.hs | 1 + .../Marlowe/Runtime/Sync/QueryServer.hs | 1 + .../Language/Marlowe/Protocol/QuerySpec.hs | 18 ++++++++ .../Marlowe/Runtime/Transaction/Api.hs | 16 +++++++ 10 files changed, 128 insertions(+), 1 deletion(-) diff --git a/marlowe-runtime/.golden/MarloweQuery/golden b/marlowe-runtime/.golden/MarloweQuery/golden index 3eb6f5b011..f70135e00a 100644 --- a/marlowe-runtime/.golden/MarloweQuery/golden +++ b/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 diff --git a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Client.hs b/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Client.hs index 3b7ee403b9..e53ae0814f 100644 --- a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Client.hs +++ b/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 diff --git a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Server.hs b/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Server.hs index 0a44f448c6..6ed776a7cc 100644 --- a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Server.hs +++ b/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 diff --git a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs b/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs index 85ac175ae0..6ca8deaff7 100644 --- a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs +++ b/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 = (==) diff --git a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync.hs b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync.hs index 2b396b2453..cdae5a35f7 100644 --- a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync.hs +++ b/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 = diff --git a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database.hs b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database.hs index 5c2d49615d..2d7d4e329c 100644 --- a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database.hs +++ b/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 diff --git a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs index 19d3768fa2..0d0fd19332 100644 --- a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs +++ b/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) diff --git a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/QueryServer.hs b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/QueryServer.hs index a2417632a5..110943a3f8 100644 --- a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/QueryServer.hs +++ b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/QueryServer.hs @@ -30,5 +30,6 @@ queryServer QueryServerDependencies{..} = getWithdrawals getPayouts getPayout + getRoleCurrencies where DatabaseQueries{..} = databaseQueries diff --git a/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs b/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs index b698a6375d..cc88239c0e 100644 --- a/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs +++ b/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 diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index d708bc07a7..3146ba305f 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -54,6 +54,7 @@ module Language.Marlowe.Runtime.Transaction.Api ( mkMint, optimizeRoleTokenFilter, rewriteRoleTokenFilter, + roleTokenFilterToRoleCurrencyFilter, ) where import Cardano.Api ( @@ -153,6 +154,7 @@ import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap import Data.Semigroup.Foldable (Foldable1 (foldMap1)) import qualified Data.Set as Set +import Language.Marlowe.Protocol.Query.Types (RoleCurrencyFilter (..)) import Network.Protocol.Codec.Spec (Variations (..), varyAp) import Network.Protocol.Handshake.Types (HasSignature (..)) import Network.Protocol.Job.Types @@ -890,6 +892,20 @@ evalRoleTokenFilter f roleTokenContract roleToken = go f optimizeRoleTokenFilter :: (Ord c, Ord p, Ord t, IsToken t p) => RoleTokenFilter' c p t -> RoleTokenFilter' c p t optimizeRoleTokenFilter = rewrite rewriteRoleTokenFilter +roleTokenFilterToRoleCurrencyFilter :: RoleTokenFilter -> RoleCurrencyFilter +roleTokenFilterToRoleCurrencyFilter = go + where + go :: RoleTokenFilter -> RoleCurrencyFilter + go = \case + RoleTokensOr f1 f2 -> go f1 <> go f2 + RoleTokensAnd f1 f2 -> go f1 <> go f2 + RoleTokensNot f' -> go f' + RoleTokenFilterAny -> RoleCurrencyFilterAny + RoleTokenFilterNone -> mempty + RoleTokenFilterByContracts contracts -> RoleCurrencyFilter mempty contracts + RoleTokenFilterByPolicyIds policies -> RoleCurrencyFilter policies mempty + RoleTokenFilterByTokens tokens -> RoleCurrencyFilter (Set.map policyId tokens) mempty + rewriteRoleTokenFilter :: (Ord c, Ord p, Ord t, IsToken t p) => RoleTokenFilter' c p t -> Maybe (RoleTokenFilter' c p t) rewriteRoleTokenFilter = \case RoleTokenFilterAny -> Nothing From 0e0fef9117b5f3ca0d12a96592901d9e16212b67 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Thu, 8 Feb 2024 14:57:22 -0500 Subject: [PATCH 08/18] Implement getRoleCurrencies query --- marlowe-runtime/.golden/MarloweQuery/golden | 46 +++-- .../Marlowe/Runtime/Transaction/Gen.hs | 1 + marlowe-runtime/marlowe-runtime.cabal | 1 + .../Language/Marlowe/Protocol/Query/Types.hs | 35 ++-- .../Runtime/Sync/Database/PostgreSQL.hs | 3 +- .../Database/PostgreSQL/GetRoleCurrencies.hs | 177 ++++++++++++++++++ .../Language/Marlowe/Protocol/QuerySpec.hs | 26 ++- .../Marlowe/Runtime/Transaction/Api.hs | 29 ++- 8 files changed, 271 insertions(+), 47 deletions(-) create mode 100644 marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetRoleCurrencies.hs diff --git a/marlowe-runtime/.golden/MarloweQuery/golden b/marlowe-runtime/.golden/MarloweQuery/golden index f70135e00a..5e36cf5ed5 100644 --- a/marlowe-runtime/.golden/MarloweQuery/golden +++ b/marlowe-runtime/.golden/MarloweQuery/golden @@ -106,20 +106,28 @@ 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 (RoleCurrencyAnd RoleCurrencyFilterNone RoleCurrencyFilterNone))) +Binary: 0100000a000303 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilterByContract (fromList [ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}])))) +Binary: 0100000a04000000000000000100000000000000000001 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilterByContract (fromList [ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}])))) +Binary: 0100000a0400000000000000010000000000000001610001 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilterByContract (fromList [])))) +Binary: 0100000a040000000000000000 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilterByPolicy (fromList [""])))) +Binary: 0100000a0500000000000000010000000000000000 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilterByPolicy (fromList ["61"])))) +Binary: 0100000a050000000000000001000000000000000161 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyFilterByPolicy (fromList [])))) +Binary: 0100000a050000000000000000 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyNot RoleCurrencyFilterNone))) +Binary: 0100000a0203 +Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies (RoleCurrencyOr RoleCurrencyFilterNone RoleCurrencyFilterNone))) +Binary: 0100000a010303 Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies RoleCurrencyFilterAny)) -Binary: 0100000a02 +Binary: 0100000a06 Show: MsgRequest Nothing (ReqLeaf (ReqRoleCurrencies RoleCurrencyFilterNone)) -Binary: 0100000a00 +Binary: 0100000a03 Show: MsgRequest Nothing (ReqLeaf (ReqTransaction "")) Binary: 010000030000000000000000 Show: MsgRequest Nothing (ReqLeaf (ReqTransaction "61")) @@ -6050,12 +6058,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 [RoleCurrency {rolePolicyId = "", roleContract = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, active = False}]) +Binary: 000000000000000100000000000000000000000000000000000100 +Show: MsgRespond (fromList [RoleCurrency {rolePolicyId = "", roleContract = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, active = True}]) +Binary: 000000000000000100000000000000000000000000000000000101 +Show: MsgRespond (fromList [RoleCurrency {rolePolicyId = "", roleContract = ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}, active = False}]) +Binary: 00000000000000010000000000000000000000000000000161000100 +Show: MsgRespond (fromList [RoleCurrency {rolePolicyId = "61", roleContract = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, active = False}]) +Binary: 00000000000000010000000000000001610000000000000000000100 Show: MsgRespond (fromList []) Binary: 0000000000000000 Show: MsgRespond Nothing diff --git a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs index 95bda65ea2..d69207c513 100644 --- a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs +++ b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs @@ -571,6 +571,7 @@ instance CommandVariations MarloweTxCommand where , SomeTag $ TagApplyInputs Core.MarloweV1 , SomeTag $ TagWithdraw Core.MarloweV1 , SomeTag TagSubmit + , SomeTag TagBurn ] cmdVariations = \case TagCreate Core.MarloweV1 -> diff --git a/marlowe-runtime/marlowe-runtime.cabal b/marlowe-runtime/marlowe-runtime.cabal index 19e9310145..0af817e079 100644 --- a/marlowe-runtime/marlowe-runtime.cabal +++ b/marlowe-runtime/marlowe-runtime.cabal @@ -430,6 +430,7 @@ library sync Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextSteps Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetPayout Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetPayouts + Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetRoleCurrencies Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTip Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTipForContract Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTransaction diff --git a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs b/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs index 6ca8deaff7..0e42c811e9 100644 --- a/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs +++ b/marlowe-runtime/sync-api/Language/Marlowe/Protocol/Query/Types.hs @@ -7,6 +7,7 @@ module Language.Marlowe.Protocol.Query.Types where import Cardano.Api (NetworkId) +import Control.Monad (join) import Data.Aeson (FromJSON, ToJSON (..), Value (String), object, (.=)) import Data.Bifunctor (Bifunctor (..)) import Data.Binary (Binary (..), getWord8, putWord8) @@ -118,26 +119,34 @@ data RuntimeStatus = RuntimeStatus data RoleCurrency = RoleCurrency { rolePolicyId :: PolicyId , roleContract :: ContractId + , active :: Bool } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary, Variations) data RoleCurrencyFilter - = RoleCurrencyFilterNone - | RoleCurrencyFilter (Set PolicyId) (Set ContractId) + = RoleCurrencyAnd RoleCurrencyFilter RoleCurrencyFilter + | RoleCurrencyOr RoleCurrencyFilter RoleCurrencyFilter + | RoleCurrencyNot RoleCurrencyFilter + | RoleCurrencyFilterNone + | RoleCurrencyFilterByContract (Set ContractId) + | RoleCurrencyFilterByPolicy (Set PolicyId) | 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 + deriving anyclass (Binary, ToJSON) + +instance Variations RoleCurrencyFilter where + variations = + join $ + NE.fromList + [ pure (RoleCurrencyOr RoleCurrencyFilterNone RoleCurrencyFilterNone) + , pure (RoleCurrencyAnd RoleCurrencyFilterNone RoleCurrencyFilterNone) + , pure (RoleCurrencyNot RoleCurrencyFilterNone) + , pure RoleCurrencyFilterNone + , pure RoleCurrencyFilterAny + , RoleCurrencyFilterByContract <$> variations + , RoleCurrencyFilterByPolicy <$> variations + ] data MarloweSyncRequest a where ReqStatus :: MarloweSyncRequest RuntimeStatus diff --git a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs index 0d0fd19332..e348b2ee94 100644 --- a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs +++ b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL.hs @@ -13,6 +13,7 @@ import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextHeaders (getNext import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetNextSteps (getNextSteps) import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetPayout (getPayout) import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetPayouts (getPayouts) +import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetRoleCurrencies (getRoleCurrencies) import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTip (getTip) import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTipForContract (getTipForContract) import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetTransaction (getTransaction) @@ -39,4 +40,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) + (T.transaction T.Serializable T.Read . getRoleCurrencies) diff --git a/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetRoleCurrencies.hs b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetRoleCurrencies.hs new file mode 100644 index 0000000000..f611e500b0 --- /dev/null +++ b/marlowe-runtime/sync/Language/Marlowe/Runtime/Sync/Database/PostgreSQL/GetRoleCurrencies.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetRoleCurrencies where + +import Control.Arrow (Arrow (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.RWS (RWST (..), state, tell) +import Data.ByteString (ByteString) +import Data.Int (Int16) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isNothing) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString (..)) +import qualified Data.Vector as V +import qualified Hasql.Decoders as Decoders +import Hasql.DynamicSyntax.Ast +import Hasql.DynamicSyntax.Schema (allNull, cte, tableColumn, wildcard) +import Hasql.DynamicSyntax.Statement +import qualified Hasql.Transaction as HT +import Language.Marlowe.Protocol.Query.Types +import Language.Marlowe.Runtime.ChainSync.Api (PolicyId (PolicyId, unPolicyId), TxId (..), TxOutRef (..)) +import Language.Marlowe.Runtime.Core.Api (ContractId (..)) +import Language.Marlowe.Runtime.Schema (equals, leftJoinOn, naturalJoin, unnestParams, withCTEs) +import qualified Language.Marlowe.Runtime.Schema as Schema +import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetContractState (decodeContractId) +import Language.Marlowe.Runtime.Sync.Database.PostgreSQL.GetHeaders (parenthesize) +import Numeric.Natural (Natural) + +getRoleCurrencies :: RoleCurrencyFilter -> HT.Transaction (Set RoleCurrency) +getRoleCurrencies RoleCurrencyFilterNone = pure mempty +getRoleCurrencies cFilter = + Set.fromDistinctAscList <$> HT.statement () stmt + where + stmt = buildStatement decodeResultRow Decoders.rowList do + (whereClause, _, ctes) <- runRWST (compileFilter cFilter) () (0, 0) + let withClause = withCTEs False ctes + let selectClause = + NormalSimpleSelect + ( NormalTargeting $ + tableColumn @"rolesCurrency" Schema.contractTxOut + :. tableColumn @"txId" Schema.createTxOut + :. tableColumn @"txIx" Schema.createTxOut + :. tableColumn @"txId" (allNull Schema.applyTx) + :. TargetListNil + ) + Nothing + ( Just $ + pure $ + Schema.createTxOut + `naturalJoin` Schema.contractTxOut + `leftJoinOnClose` Schema.applyTx + ) + (Just whereClause) + Nothing + Nothing + Nothing + let sortClause = + NE.fromList + [ AscDescSortBy (tableColumn @"rolesCurrency" Schema.contractTxOut) Nothing Nothing + , AscDescSortBy (tableColumn @"txId" Schema.createTxOut) Nothing Nothing + , AscDescSortBy (tableColumn @"txIx" Schema.createTxOut) Nothing Nothing + ] + pure $ SelectPreparableStmt $ Left $ SelectNoParens withClause (Left selectClause) (Just sortClause) Nothing Nothing + +leftJoinOnClose :: (IsTableRef a, IsTableRef b) => a -> b -> TableRef +leftJoinOnClose = leftJoinOn expr + where + expr = + (tableColumn @"txId" Schema.createTxOut `equals` tableColumn @"createTxId" Schema.applyTx) + `AndAExpr` (tableColumn @"txIx" Schema.createTxOut `equals` tableColumn @"createTxIx" Schema.applyTx) + `AndAExpr` (IsnullAExpr $ tableColumn @"outputTxIx" Schema.applyTx) + +type ContractsColumns = + '[ '("txId", SqlBytea, NotNull) + , '("txIx", SqlInt2, NotNull) + ] + +type PoliciesColumns = + '[ '("rolesCurrency", SqlBytea, NotNull) + ] + +compileFilter :: RoleCurrencyFilter -> RWST () [CommonTableExpr] (Natural, Natural) StatementBuilder AExpr +compileFilter = \case + RoleCurrencyAnd a b -> do + a' <- compileFilter a + b' <- compileFilter b + pure $ parenthesize a' `AndAExpr` parenthesize b' + RoleCurrencyOr a b -> do + a' <- compileFilter a + b' <- compileFilter b + pure $ parenthesize a' `OrAExpr` parenthesize b' + RoleCurrencyNot a -> NotAExpr . parenthesize <$> compileFilter a + RoleCurrencyFilterNone -> pure $ toAExpr False + RoleCurrencyFilterAny -> pure $ toAExpr True + RoleCurrencyFilterByContract contracts -> do + contractTableNumber <- state \(c, p) -> (c, (succ c, p)) + let contracts' = V.fromList $ Set.toList $ Set.map ((txId &&& txIx) . unContractId) contracts + contractTxIdsParam <- lift $ param $ unTxId . fst <$> contracts' + contractTxIxsParam <- lift $ param $ fromIntegral @_ @Int16 . snd <$> contracts' + let contractsTable = Schema.tempTable @ContractsColumns $ fromString $ "contracts" <> show contractTableNumber + let contractsCte = + cte contractsTable . simpleSelectPreparableStmt $ + NormalSimpleSelect + (wildcard contractsTable) + Nothing + (Just $ pure $ unnestParams (NE.fromList [contractTxIdsParam, contractTxIxsParam]) Nothing) + Nothing + Nothing + Nothing + Nothing + let selectClause = + NormalSimpleSelect + (wildcard contractsTable) + Nothing + (Just $ pure $ toTableRef contractsTable) + ( Just $ + AndAExpr + (tableColumn @"txId" Schema.createTxOut `equals` tableColumn @"txId" contractsTable) + (tableColumn @"txIx" Schema.createTxOut `equals` tableColumn @"txIx" contractsTable) + ) + Nothing + Nothing + Nothing + tell [contractsCte] + pure $ + toAExpr $ + ExistsCExpr $ + NoParensSelectWithParens $ + SelectNoParens + Nothing + (Left selectClause) + Nothing + Nothing + Nothing + RoleCurrencyFilterByPolicy policies -> do + policyTableNumber <- state \(c, p) -> (p, (c, succ p)) + policiesParam <- lift $ param $ V.fromList $ unPolicyId <$> Set.toList policies + let policiesTable = Schema.tempTable @PoliciesColumns $ fromString $ "policies" <> show policyTableNumber + let policiesCte = + cte policiesTable . simpleSelectPreparableStmt $ + NormalSimpleSelect + (wildcard policiesTable) + Nothing + (Just $ pure $ unnestParams (pure policiesParam) Nothing) + Nothing + Nothing + Nothing + Nothing + let selectClause = + NormalSimpleSelect + (wildcard policiesTable) + Nothing + (Just $ pure $ toTableRef policiesTable) + (Just $ tableColumn @"rolesCurrency" Schema.contractTxOut `equals` tableColumn @"rolesCurrency" policiesTable) + Nothing + Nothing + Nothing + tell [policiesCte] + pure $ + toAExpr $ + ExistsCExpr $ + NoParensSelectWithParens $ + SelectNoParens + Nothing + (Left selectClause) + Nothing + Nothing + Nothing + +decodeResultRow :: ByteString -> ByteString -> Int16 -> Maybe ByteString -> RoleCurrency +decodeResultRow policyId txId txIx closeTx = + RoleCurrency + { rolePolicyId = PolicyId policyId + , roleContract = decodeContractId txId txIx + , active = isNothing closeTx + } diff --git a/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs b/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs index cc88239c0e..e3c2380ec9 100644 --- a/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs +++ b/marlowe-runtime/test/Language/Marlowe/Protocol/QuerySpec.hs @@ -96,16 +96,28 @@ instance ArbitraryRequest MarloweSyncRequest where TagRoleCurrencies -> shrink instance Arbitrary RoleCurrency where - arbitrary = RoleCurrency <$> arbitrary <*> arbitrary + arbitrary = RoleCurrency <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink instance Arbitrary RoleCurrencyFilter where - arbitrary = - frequency - [ (1, pure RoleCurrencyFilterNone) - , (1, pure RoleCurrencyFilterAny) - , (10, RoleCurrencyFilter <$> arbitrary <*> arbitrary) - ] + arbitrary = sized \case + 0 -> + frequency + [ (1, pure RoleCurrencyFilterNone) + , (1, pure RoleCurrencyFilterAny) + , (5, RoleCurrencyFilterByContract <$> arbitrary) + , (5, RoleCurrencyFilterByPolicy <$> arbitrary) + ] + size -> + frequency + [ (1, pure RoleCurrencyFilterNone) + , (1, pure RoleCurrencyFilterAny) + , (5, resize (size `div` 2) $ RoleCurrencyOr <$> arbitrary <*> arbitrary) + , (5, resize (size `div` 2) $ RoleCurrencyAnd <$> arbitrary <*> arbitrary) + , (3, resize (size - 1) $ RoleCurrencyNot <$> arbitrary) + , (5, RoleCurrencyFilterByContract <$> arbitrary) + , (5, RoleCurrencyFilterByPolicy <$> arbitrary) + ] shrink = genericShrink instance Arbitrary SomeContractState where diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index 3146ba305f..6ceb768576 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -859,7 +859,20 @@ data RoleTokenFilter' c p t | RoleTokenFilterByPolicyIds (Set p) | RoleTokenFilterByTokens (Set t) deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (Variations, Binary) + deriving anyclass (Binary) + +instance (Variations c, Variations p, Variations t) => Variations (RoleTokenFilter' c p t) where + variations = + join + [ pure (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone) + , pure (RoleTokensAnd RoleTokenFilterNone RoleTokenFilterNone) + , pure (RoleTokensNot RoleTokenFilterNone) + , pure RoleTokenFilterNone + , pure RoleTokenFilterAny + , RoleTokenFilterByContracts <$> variations + , RoleTokenFilterByPolicyIds <$> variations + , RoleTokenFilterByTokens <$> variations + ] instance Plated (RoleTokenFilter' c p t) where plate f = \case @@ -897,14 +910,14 @@ roleTokenFilterToRoleCurrencyFilter = go where go :: RoleTokenFilter -> RoleCurrencyFilter go = \case - RoleTokensOr f1 f2 -> go f1 <> go f2 - RoleTokensAnd f1 f2 -> go f1 <> go f2 - RoleTokensNot f' -> go f' + RoleTokensOr f1 f2 -> go f1 `RoleCurrencyOr` go f2 + RoleTokensAnd f1 f2 -> go f1 `RoleCurrencyAnd` go f2 + RoleTokensNot f' -> RoleCurrencyNot $ go f' RoleTokenFilterAny -> RoleCurrencyFilterAny - RoleTokenFilterNone -> mempty - RoleTokenFilterByContracts contracts -> RoleCurrencyFilter mempty contracts - RoleTokenFilterByPolicyIds policies -> RoleCurrencyFilter policies mempty - RoleTokenFilterByTokens tokens -> RoleCurrencyFilter (Set.map policyId tokens) mempty + RoleTokenFilterNone -> RoleCurrencyFilterNone + RoleTokenFilterByContracts contracts -> RoleCurrencyFilterByContract contracts + RoleTokenFilterByPolicyIds policies -> RoleCurrencyFilterByPolicy policies + RoleTokenFilterByTokens tokens -> RoleCurrencyFilterByPolicy (Set.map policyId tokens) rewriteRoleTokenFilter :: (Ord c, Ord p, Ord t, IsToken t p) => RoleTokenFilter' c p t -> Maybe (RoleTokenFilter' c p t) rewriteRoleTokenFilter = \case From 52284c92f5cca51fda0891737c0fbc06f19db305 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 9 Feb 2024 11:01:27 -0500 Subject: [PATCH 09/18] Add integration tests for getRoleCurrencies --- .../Runtime/Integration/MarloweQuery.hs | 106 ++++++++++++++++++ 1 file changed, 106 insertions(+) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs index 73f312d53c..4ccf8f9288 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs @@ -33,6 +33,7 @@ import Language.Marlowe.Protocol.Query.Client ( getContractHeaders, getContractState, getPayouts, + getRoleCurrencies, getTransaction, getTransactions, getWithdrawal, @@ -84,6 +85,7 @@ spec = describe "MarloweQuery" $ aroundAll setup do getWithdrawalSpec describe "GetPayouts" $ paginatedQuerySpec GetPayouts runMarloweQueryIntegrationTest bulkSyncTest + getRoleCurrenciesSpec data GetHeaders = GetHeaders data GetWithdrawals = GetWithdrawals @@ -425,6 +427,110 @@ getWithdrawalSpec = describe "getWithdrawal" do actual <- getWithdrawal case fst contract1Step5 of WithdrawTx _ WithdrawTxInEra{..} -> fromCardanoTxId $ getTxId txBody liftIO $ actual `shouldBe` Just (contract1Step5Withdrawal testData) +getRoleCurrenciesSpec :: SpecWith MarloweQueryTestData +getRoleCurrenciesSpec = describe "getRoleCurrencies" do + for_ allRoleCurrencyFilters \rcFilter -> + it (show rcFilter) $ runMarloweQueryIntegrationTest \testData -> do + let actualFilter = convertRoleCurrencyFilter testData rcFilter + let expected = evalTestRoleCurrencyFilter testData rcFilter + actual <- getRoleCurrencies actualFilter + liftIO $ actual `shouldBe` expected + +data TestRoleCurrencyFilter + = TestAnd TestRoleCurrencyFilter TestRoleCurrencyFilter + | TestOr TestRoleCurrencyFilter TestRoleCurrencyFilter + | TestNot TestRoleCurrencyFilter + | TestAny + | TestNone + | TestByContract (Set (WithUnknown (RefSym GetHeaders))) + | TestByPolicy (Set (WithUnknown (RefSym GetHeaders))) + deriving (Show) + +allRoleCurrencyFilters :: [TestRoleCurrencyFilter] +allRoleCurrencyFilters = go (2 :: Int) + where + go depthBudget = + TestAny + : TestNone + : [ TestByContract c + | c <- + (Set.singleton Unknown :) $ + Set.toList $ + Set.powerSet $ + Set.fromList $ + Known <$> [minBound .. maxBound] + ] + ++ [ TestByPolicy c + | c <- + (Set.singleton Unknown :) $ + Set.toList $ + Set.powerSet $ + Set.fromList $ + Known <$> [minBound .. maxBound] + ] + ++ if depthBudget > 0 + then do + let nextLayer = go $ depthBudget - 1 + let firstInNextLayer = head nextLayer + (TestAnd <$> nextLayer <*> pure firstInNextLayer) + ++ (TestAnd firstInNextLayer <$> nextLayer) + ++ (TestOr <$> nextLayer <*> pure firstInNextLayer) + ++ (TestOr firstInNextLayer <$> nextLayer) + ++ (TestNot <$> nextLayer) + else [] + +evalTestRoleCurrencyFilter :: MarloweQueryTestData -> TestRoleCurrencyFilter -> Set RoleCurrency +evalTestRoleCurrencyFilter MarloweQueryTestData{..} = go + where + go = \case + TestAnd f g -> go f `Set.intersection` go g + TestOr f g -> go f <> go g + TestNot f -> go TestAny `Set.difference` go f + TestAny -> Set.fromList $ Map.elems roleCurrenciesByContract + TestNone -> mempty + TestByContract contracts -> Set.fromList $ Map.elems $ Map.restrictKeys roleCurrenciesByContract contracts + TestByPolicy policies -> Set.fromList $ Map.elems $ Map.restrictKeys roleCurrenciesByContract policies + roleCurrenciesByContract = + Map.fromList + [ (Known Contract1, standardContractRoleCurrency' contract1 False) + , (Known Contract2, standardContractRoleCurrency' contract2 False) + , (Known Contract3, standardContractRoleCurrency' contract3 False) + , (Known Contract4, standardContractRoleCurrency' contract4 True) + ] + +standardContractRoleCurrency' :: StandardContractInit 'V1 -> Bool -> RoleCurrency +standardContractRoleCurrency' contract active = + RoleCurrency + { rolePolicyId = standardContractRoleCurrency contract + , roleContract = standardContractId contract + , .. + } + +convertRoleCurrencyFilter :: MarloweQueryTestData -> TestRoleCurrencyFilter -> RoleCurrencyFilter +convertRoleCurrencyFilter MarloweQueryTestData{..} = go + where + go = \case + TestAnd f g -> RoleCurrencyAnd (go f) (go g) + TestOr f g -> RoleCurrencyOr (go f) (go g) + TestNot f -> RoleCurrencyNot $ go f + TestAny -> RoleCurrencyFilterAny + TestNone -> RoleCurrencyFilterNone + TestByContract contracts -> RoleCurrencyFilterByContract $ Set.map convertContractId contracts + TestByPolicy policies -> RoleCurrencyFilterByPolicy $ Set.map convertPolicyId policies + + convertContractId Unknown = + ContractId $ TxOutRef "0000000000000000000000000000000000000000000000000000000000000000" 1 + convertContractId (Known Contract1) = standardContractId contract1 + convertContractId (Known Contract2) = standardContractId contract2 + convertContractId (Known Contract3) = standardContractId contract3 + convertContractId (Known Contract4) = standardContractId contract4 + + convertPolicyId Unknown = "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + convertPolicyId (Known Contract1) = standardContractRoleCurrency contract1 + convertPolicyId (Known Contract2) = standardContractRoleCurrency contract2 + convertPolicyId (Known Contract3) = standardContractRoleCurrency contract3 + convertPolicyId (Known Contract4) = standardContractRoleCurrency contract4 + setup :: ActionWith MarloweQueryTestData -> IO () setup runSpec = withLocalMarloweRuntime $ runIntegrationTest do runtime <- ask From c87dc9c83cd2632d8d47bce3f95e300d73efb79c Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Sat, 10 Feb 2024 07:12:02 -0500 Subject: [PATCH 10/18] Implement burning --- .../Marlowe/Runtime/Transaction/Gen.hs | 5 +- marlowe-runtime/marlowe-runtime.cabal | 2 +- marlowe-runtime/marlowe-tx/Logging.hs | 3 + marlowe-runtime/marlowe-tx/Main.hs | 28 +++ .../runtime/Language/Marlowe/Runtime.hs | 1 + .../Marlowe/Runtime/Transaction/Api.hs | 11 +- .../Language/Marlowe/Runtime/Transaction.hs | 2 + .../Marlowe/Runtime/Transaction/Burn.hs | 206 +++++++++++++++++- .../Runtime/Transaction/Constraints.hs | 15 +- .../Marlowe/Runtime/Transaction/Server.hs | 23 +- 10 files changed, 267 insertions(+), 29 deletions(-) diff --git a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs index d69207c513..78a522b357 100644 --- a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs +++ b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs @@ -390,7 +390,10 @@ instance Arbitrary BurnError where frequency [ (5, BurnRolesActive <$> arbitrary) , (1, pure BurnNoTokens) - , (3, BurnBalancingError <$> arbitrary) + , (1, pure BurnFromCardanoError) + , (3, BurnConstraintError <$> arbitrary) + , (3, BurnEraUnsupported <$> arbitrary) + , (3, BurnInvalidPolicyId <$> arbitrary) ] shrink = genericShrink diff --git a/marlowe-runtime/marlowe-runtime.cabal b/marlowe-runtime/marlowe-runtime.cabal index 0af817e079..9d2cb0b789 100644 --- a/marlowe-runtime/marlowe-runtime.cabal +++ b/marlowe-runtime/marlowe-runtime.cabal @@ -700,7 +700,7 @@ executable marlowe-tx , hs-opentelemetry-sdk ^>=0.0.3 , marlowe-chain-sync ==0.0.6 , marlowe-protocols ==0.3.0.0 - , marlowe-runtime:{marlowe-runtime, contract-api, tx, tx-api} ==0.0.6 + , marlowe-runtime:{marlowe-runtime, contract-api, sync-api, tx, tx-api} ==0.0.6 , network >=3.1 && <4 , optparse-applicative ^>=0.16.1 , text ^>=2.0 diff --git a/marlowe-runtime/marlowe-tx/Logging.hs b/marlowe-runtime/marlowe-tx/Logging.hs index 62e9119ee1..b891535c7c 100644 --- a/marlowe-runtime/marlowe-tx/Logging.hs +++ b/marlowe-runtime/marlowe-tx/Logging.hs @@ -7,6 +7,7 @@ module Logging ( ) where import Control.Monad.Event.Class (Inject (..)) +import Language.Marlowe.Protocol.Query.Types (MarloweQuery) import Language.Marlowe.Runtime.ChainSync.Api ( ChainSyncCommand, ChainSyncQueryClientSelector, @@ -43,6 +44,7 @@ data RootSelector f where ChainSyncJobClient :: TcpClientSelector (Handshake (Job ChainSyncCommand)) f -> RootSelector f ChainSyncQueryClient :: PeerT.TcpClientSelector ChainSyncQueryClientSelector f -> RootSelector f ChainSeekClient :: PeerT.TcpClientSelector RuntimeChainSeekClientSelector f -> RootSelector f + MarloweQueryClient :: TcpClientSelector (Handshake MarloweQuery) f -> RootSelector f ContractQueryClient :: TcpClientSelector (Handshake (Query ContractRequest)) f -> RootSelector f Server :: TcpServerSelector (Handshake (Job MarloweTxCommand)) f -> RootSelector f App :: TransactionServerSelector f -> RootSelector f @@ -75,6 +77,7 @@ renderRootSelectorOTel = \case ChainSyncQueryClient sel -> PeerT.renderTcpClientSelectorOTel renderChainSyncQueryClientSelector sel ChainSeekClient sel -> PeerT.renderTcpClientSelectorOTel renderChainSeekClientSelectorOTel sel ContractQueryClient sel -> renderTcpClientSelectorOTel sel + MarloweQueryClient sel -> renderTcpClientSelectorOTel sel Server sel -> renderTcpServerSelectorOTel sel App sel -> renderTransactionServerSelectorOTel sel LoadWalletContext sel -> renderLoadWalletContextSelectorOTel sel diff --git a/marlowe-runtime/marlowe-tx/Main.hs b/marlowe-runtime/marlowe-tx/Main.hs index 83e4c3eaf2..a259bf5c0e 100644 --- a/marlowe-runtime/marlowe-tx/Main.hs +++ b/marlowe-runtime/marlowe-tx/Main.hs @@ -14,6 +14,7 @@ import Control.Concurrent.Component.Run (AppM, runAppMTraced) import qualified Data.Text as T import Data.Time (NominalDiffTime) import Data.Version (showVersion) +import Language.Marlowe.Protocol.Query.Client (MarloweQueryClient) import Language.Marlowe.Runtime.ChainSync.Api ( BlockNo (..), ChainSyncQuery (..), @@ -114,6 +115,9 @@ run Options{..} = flip runComponent_ () proc _ -> do contractQueryConnector :: Connector (QueryClient ContractRequest) (AppM Span RootSelector) contractQueryConnector = tcpClientTraced (injectSelector ContractQueryClient) contractHost contractQueryPort queryClientPeer + marloweQueryConnector :: Connector MarloweQueryClient (AppM Span RootSelector) + marloweQueryConnector = tcpClientTraced (injectSelector MarloweQueryClient) syncHost marloweQueryPort queryClientPeer + MarloweTx{..} <- transaction -< @@ -170,6 +174,8 @@ data Options = Options , chainSeekHost :: HostName , contractQueryPort :: PortNumber , contractHost :: HostName + , marloweQueryPort :: PortNumber + , syncHost :: HostName , port :: PortNumber , host :: HostName , submitConfirmationBlocks :: BlockNo @@ -189,6 +195,8 @@ getOptions = execParser $ info (helper <*> versionOption <*> parser) infoMod <*> chainSeekHostParser <*> contractQueryPortParser <*> contractHostParser + <*> marloweQueryPortParser + <*> syncHostParser <*> portParser <*> hostParser <*> submitConfirmationBlocksParser @@ -241,6 +249,16 @@ getOptions = execParser $ info (helper <*> versionOption <*> parser) infoMod , showDefault ] + marloweQueryPortParser = + option auto $ + mconcat + [ long "marlowe-query-port" + , value 3726 + , metavar "PORT_NUMBER" + , help "The port number of the marlowe query server." + , showDefault + ] + portParser = option auto $ mconcat @@ -271,6 +289,16 @@ getOptions = execParser $ info (helper <*> versionOption <*> parser) infoMod , showDefault ] + syncHostParser = + strOption $ + mconcat + [ long "sync-host" + , value "127.0.0.1" + , metavar "HOST_NAME" + , help "The host name of the marlowe sync server." + , showDefault + ] + hostParser = strOption $ mconcat diff --git a/marlowe-runtime/runtime/Language/Marlowe/Runtime.hs b/marlowe-runtime/runtime/Language/Marlowe/Runtime.hs index 79dd2b9f7c..1e86150e03 100644 --- a/marlowe-runtime/runtime/Language/Marlowe/Runtime.hs +++ b/marlowe-runtime/runtime/Language/Marlowe/Runtime.hs @@ -179,6 +179,7 @@ marloweRuntime = proc MarloweRuntimeDependencies{..} -> do let marloweBulkSyncServerSource = unnestServerSource $ MarloweSync.bulkSyncServerSource <$> mMarloweSync let marloweBulkSyncConnector = directConnector serveMarloweBulkSyncClient marloweBulkSyncServerSource let marloweQueryServerSource = unnestServerSource $ MarloweSync.queryServerSource <$> mMarloweSync + let marloweQueryConnector = directConnector serveQueryClient marloweQueryServerSource mMarloweContract <- supervisor "marlowe-contract" contract -< ContractDependencies{..} diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index 6ceb768576..49558a6d5a 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -814,7 +814,7 @@ instance Binary BurnTx where _ -> fail $ "Invalid era tag value: " <> show eraTag data BurnTxInEra era = BurnTxInEra - { burnedTokens :: Chain.Assets + { burnedTokens :: Chain.Tokens , txBody :: TxBody era } @@ -843,9 +843,14 @@ data Account data BurnError = BurnEraUnsupported AnyCardanoEra - | BurnRolesActive (Set AssetId) + | BurnRolesActive (Set PolicyId) + | BurnInvalidPolicyId (Set PolicyId) | BurnNoTokens - | BurnBalancingError String + | BurnFromCardanoError + | -- FIXME most of this error is not relevant to burning, but due to the current + -- constraint solving being too marlowe-specific, and because we use the + -- final balancing pipeline for burning, we sadly need to use this type here. + BurnConstraintError ConstraintError deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary, ToJSON, Variations) diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs index fbbc630691..78b66e727a 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs @@ -23,6 +23,7 @@ import Data.Maybe (catMaybes, mapMaybe, maybeToList) import qualified Data.Set as Set import Data.String (fromString) import Data.Time (NominalDiffTime) +import Language.Marlowe.Protocol.Query.Client (MarloweQueryClient) import Language.Marlowe.Runtime.ChainSync.Api ( ChainSyncQuery, PlutusScript (..), @@ -75,6 +76,7 @@ data TransactionDependencies m = TransactionDependencies , getCurrentScripts :: forall v. MarloweVersion v -> MarloweScripts , analysisTimeout :: NominalDiffTime , mkRoleTokenMintingPolicy :: MkRoleTokenMintingPolicy m + , marloweQueryConnector :: Connector MarloweQueryClient m } data MarloweTx m = MarloweTx diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs index 681bfe7ee1..ed99d4fbc9 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs @@ -1,21 +1,213 @@ +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-unused-record-wildcards #-} module Language.Marlowe.Runtime.Transaction.Burn where -import Cardano.Api (BabbageEraOnwards) -import Cardano.Api.Shelley (LedgerProtocolParameters) -import Control.Error (ExceptT) -import Language.Marlowe.Runtime.Transaction.Api (BurnError, BurnTxInEra, RoleTokenFilter) -import Language.Marlowe.Runtime.Transaction.Constraints (WalletContext (..)) +import Cardano.Api (BabbageEraOnwards, BuildTx, ScriptInEra, SystemStart, TxBodyContent (..), defaultTxBodyContent) +import qualified Cardano.Api as C +import Cardano.Api.Shelley (LedgerProtocolParameters, PlutusScriptOrReferenceInput (..), ReferenceScript (..)) +import Control.Error (ExceptT, note, throwE) +import Control.Monad (unless, when) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.Except (except) +import Data.Bifunctor (Bifunctor (..)) +import Data.Coerce (coerce) +import Data.Foldable (Foldable (..)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Language.Marlowe.Protocol.Query.Types (RoleCurrency (..)) +import Language.Marlowe.Runtime.Cardano.Api ( + toCardanoAddressInEra, + toCardanoLovelace, + toCardanoPolicyId, + toCardanoTxIn, + toCardanoTxOutValue, + tokensToCardanoValue, + ) +import Language.Marlowe.Runtime.ChainSync.Api ( + Address, + AssetId (..), + Assets (..), + ChainSyncQuery (..), + PolicyId (..), + ScriptHash (..), + Tokens (..), + TransactionOutput (..), + TxOutRef, + UTxOs (..), + ) +import Language.Marlowe.Runtime.Core.Api (MarloweVersion (..)) +import Language.Marlowe.Runtime.Transaction.Api ( + BurnError (..), + BurnTxInEra (..), + RoleTokenFilter, + evalRoleTokenFilter, + ) +import Language.Marlowe.Runtime.Transaction.Constraints ( + HelpersContext (..), + PayoutContext (PayoutContext), + WalletContext (..), + adjustTxForMinUtxo, + balanceTx, + selectCoins, + ) +import Network.Protocol.Connection (Connector, runConnector) +import Network.Protocol.Query.Client (QueryClient, request) import UnliftIO (MonadUnliftIO) burnRoleTokens :: (MonadUnliftIO m) - => BabbageEraOnwards era + => SystemStart + -> C.EraHistory + -> Connector (QueryClient ChainSyncQuery) m + -> BabbageEraOnwards era -> LedgerProtocolParameters era -> WalletContext + -> Set RoleCurrency -> RoleTokenFilter -> ExceptT BurnError m (BurnTxInEra era) -burnRoleTokens era protocol WalletContext{..} tokenFilter = undefined +burnRoleTokens start history chainQueryConnector era protocol walletCtx@WalletContext{..} currencies tokenFilter = do + -- convert role currency info into a list + let currenciesList = Set.toList currencies + -- collect the policy IDs which are used by active contracts + let activeCurrencies = Set.fromList $ mapMaybe activeCurrency currenciesList + -- define a mapping of policyId to contracts which use them for role tokens. + let contractIdsByPolicyId = Map.fromListWith (<>) do + RoleCurrency{..} <- currenciesList + pure (rolePolicyId, Set.singleton roleContract) + -- Splits assets into ones which match the burn filter, and ones that don't. + let partitionAssets :: Map AssetId a -> (Map AssetId a, Map AssetId a) + partitionAssets = Map.partitionWithKey \token _ -> + any (flip (evalRoleTokenFilter tokenFilter) token) $ + fold $ + Map.lookup (policyId token) contractIdsByPolicyId + -- Processes a single output from the wallet's UTxO. + let processInput + :: TxOutRef + -> TransactionOutput + -> ( Map TxOutRef (Tokens, (Address, Assets)) + , Set PolicyId + ) + processInput txIn TransactionOutput{address, assets = assets@(Assets lovelace (Tokens tokens))} = + case partitionAssets tokens of + (toBurn, toKeep) + | Map.null toBurn -> mempty + | otherwise -> + ( Map.singleton txIn (Tokens toBurn, (address, Assets lovelace $ Tokens toKeep)) + , Set.intersection activeCurrencies $ Set.map policyId $ Map.keysSet toBurn + ) + -- Fold over the wallet's UTxO, selecting outputs to use as transaction inputs and looking for any + -- matching currencies which are still active. + let (inputs, activeOwnedCurrencies) = Map.foldMapWithKey processInput $ unUTxOs availableUtxos + -- If the burn includes active role tokens, abort + unless (Set.null activeOwnedCurrencies) $ throwE $ BurnRolesActive activeOwnedCurrencies + -- If the burn is empty, abort + when (Map.null inputs) $ throwE BurnNoTokens + -- Fetch all the minting scripts needed to burn the tokens. + let policyScriptHashes = foldMap (scriptHashesFromTokens . fst) inputs + scripts <- lift $ runConnector chainQueryConnector $ request $ GetScripts era policyScriptHashes + -- If there are policies for which scripts can't be found, abort. + let missingScriptHashes = Set.difference policyScriptHashes $ Map.keysSet scripts + unless (Set.null missingScriptHashes) $ throwE $ BurnRolesActive $ Set.mapMonotonic coerce missingScriptHashes + -- Build the transaction body + txBodyContent <- except $ note BurnFromCardanoError $ buildBurn era inputs scripts + -- FIXME there is no reason we need these except that selectCoins and balanceTx require them. Refactor + -- those two functions to remove these dummy contexts. + let scriptCtx = Right $ PayoutContext mempty mempty + let helpersCtx = + HelpersContext + { currentHelperScripts = mempty + , helperPolicyId = "" + , helperScriptStates = mempty + } + txBody <- + except $ + first BurnConstraintError $ + adjustTxForMinUtxo era protocol Nothing txBodyContent + >>= selectCoins era protocol MarloweV1 scriptCtx walletCtx helpersCtx + >>= balanceTx era start (C.toLedgerEpochInfo history) protocol MarloweV1 scriptCtx walletCtx helpersCtx + let burnedTokens = foldMap fst inputs + pure BurnTxInEra{..} + +scriptHashesFromTokens :: Tokens -> Set ScriptHash +scriptHashesFromTokens = Set.map (ScriptHash . unPolicyId . policyId) . Map.keysSet . unTokens + +assetsFromUtxos :: UTxOs -> Assets +assetsFromUtxos = foldMap assets . unUTxOs + +activeCurrency :: RoleCurrency -> Maybe PolicyId +activeCurrency RoleCurrency{..} + | active = Just rolePolicyId + | otherwise = Nothing + +buildBurn + :: forall era + . BabbageEraOnwards era + -> Map TxOutRef (Tokens, (Address, Assets)) + -> Map ScriptHash (ScriptInEra era) + -> Maybe (TxBodyContent BuildTx era) +buildBurn era inputs scripts = do + txIns <- traverse buildInput $ Map.keys inputs + (outputsWithTokens, adaOnlyOutputs) <- fold <$> traverse (uncurry buildOutput . snd) inputs + let txOuts = mergeAdaOnly adaOnlyOutputs <> outputsWithTokens + txMintValue <- buildMint + pure (defaultTxBodyContent shelleyEra){txIns, txOuts, txMintValue} + where + shelleyEra :: C.ShelleyBasedEra era + shelleyEra = C.babbageEraOnwardsToShelleyBasedEra era + + maryEraOnwards :: C.MaryEraOnwards era + maryEraOnwards = C.babbageEraOnwardsToMaryEraOnwards era + + buildInput :: TxOutRef -> Maybe (C.TxIn, C.BuildTxWith BuildTx (C.Witness C.WitCtxTxIn era)) + buildInput = fmap (,C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) . toCardanoTxIn + + buildOutput :: Address -> Assets -> Maybe ([C.TxOut C.CtxTx era], [(C.AddressInEra era, C.Lovelace)]) + buildOutput address assets@(Assets lovelace (Tokens tokens)) = do + address' <- toCardanoAddressInEra (C.babbageEraOnwardsToCardanoEra era) address + let lovelace' = toCardanoLovelace lovelace + if Map.null tokens + then pure ([], [(address', lovelace')]) + else do + value <- toCardanoTxOutValue maryEraOnwards assets + pure ([C.TxOut address' value C.TxOutDatumNone ReferenceScriptNone], []) + + mergeAdaOnly :: [(C.AddressInEra era, C.Lovelace)] -> [C.TxOut C.CtxTx era] + mergeAdaOnly = fmap (uncurry buildAdaOnlyOutput) . Map.toList . Map.fromListWith (<>) + + buildAdaOnlyOutput :: C.AddressInEra era -> C.Lovelace -> C.TxOut C.CtxTx era + buildAdaOnlyOutput address lovelace = + C.TxOut address (C.lovelaceToTxOutValue shelleyEra lovelace) C.TxOutDatumNone ReferenceScriptNone + + buildMint :: Maybe (C.TxMintValue BuildTx era) + buildMint = do + (value, witnesses) <- fold <$> traverse (buildAssetMint . fst) inputs + pure $ C.TxMintValue maryEraOnwards (C.negateValue value) (C.BuildTxWith witnesses) + + buildAssetMint :: Tokens -> Maybe (C.Value, Map C.PolicyId (C.ScriptWitness C.WitCtxMint era)) + buildAssetMint tokens@(Tokens tokenMap) = do + value <- tokensToCardanoValue tokens + witnesses <- fold <$> traverse buildMintWitness (Map.keys $ Map.mapKeys policyId tokenMap) + pure (value, witnesses) + + buildMintWitness :: PolicyId -> Maybe (Map C.PolicyId (C.ScriptWitness C.WitCtxMint era)) + buildMintWitness policyId = do + policyId' <- toCardanoPolicyId policyId + C.ScriptInEra lang script <- Map.lookup (coerce policyId) scripts + witness <- case script of + C.PlutusScript v script' -> + pure $ + C.PlutusScriptWitness + lang + v + (PScript script') + C.NoScriptDatumForMint + (C.unsafeHashableScriptData $ C.ScriptDataConstructor 1 []) -- This corresponds to the Burn action in the validator. + (C.ExecutionUnits 0 0) + _ -> Nothing + pure $ Map.singleton policyId' witness diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs index 7d8121020c..9e2a4401ad 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Constraints.hs @@ -41,7 +41,7 @@ module Language.Marlowe.Runtime.Transaction.Constraints ( solveInitialTxBodyContent, ) where -import Cardano.Api (unsafeHashableScriptData) +import Cardano.Api (TxBodyContent (..), unsafeHashableScriptData) import qualified Cardano.Api as C import qualified Cardano.Api.Shelley as C import Control.Applicative ((<|>)) @@ -1061,27 +1061,16 @@ solveInitialTxBodyContent era protocol marloweVersion scriptCtx WalletContext{.. txExtraKeyWits <- solveTxExtraKeyWits txMintValue <- solveTxMintValue pure - C.TxBodyContent + (C.defaultTxBodyContent shelleyEra) { txIns - , txInsCollateral = C.TxInsCollateralNone , txInsReference , txOuts - , txTotalCollateral = C.TxTotalCollateralNone - , txReturnCollateral = C.TxReturnCollateralNone - , txFee = C.TxFeeExplicit shelleyEra 0 , txValidityLowerBound , txValidityUpperBound , txMetadata - , txAuxScripts = C.TxAuxScriptsNone , txExtraKeyWits , txProtocolParams = C.BuildTxWith $ Just protocol - , txProposalProcedures = Nothing - , txVotingProcedures = Nothing - , txWithdrawals = C.TxWithdrawalsNone - , txCertificates = C.TxCertificatesNone - , txUpdateProposal = C.TxUpdateProposalNone , txMintValue - , txScriptValidity = C.TxScriptValidityNone } where shelleyEra :: C.ShelleyBasedEra era diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs index 0e2884912e..ab9071f7f3 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs @@ -69,6 +69,7 @@ import Data.Time (NominalDiffTime, UTCTime, nominalDiffTimeToSeconds) import Data.Void (Void) import Language.Marlowe.Analysis.Safety.Types (SafetyError (SafetyAnalysisTimeout)) import qualified Language.Marlowe.Core.V1.Semantics as V1 +import Language.Marlowe.Protocol.Query.Client (MarloweQueryClient, getRoleCurrencies) import Language.Marlowe.Runtime.Cardano.Api ( fromCardanoAddressInEra, fromCardanoLovelace, @@ -129,6 +130,8 @@ import Language.Marlowe.Runtime.Transaction.Api ( WithdrawError (..), WithdrawTx (..), WithdrawTxInEra (..), + optimizeRoleTokenFilter, + roleTokenFilterToRoleCurrencyFilter, ) import Language.Marlowe.Runtime.Transaction.BuildConstraints ( MkRoleTokenMintingPolicy, @@ -199,6 +202,7 @@ data TransactionServerDependencies m = TransactionServerDependencies , loadMarloweContext :: LoadMarloweContext m , loadPayoutContext :: LoadPayoutContext m , loadHelpersContext :: LoadHelpersContext m + , marloweQueryConnector :: Connector MarloweQueryClient m , chainSyncQueryConnector :: Connector (QueryClient ChainSyncQuery) m , contractQueryConnector :: Connector (QueryClient ContractRequest) m , getTip :: STM Chain.ChainPoint @@ -306,6 +310,10 @@ transactionServer = component "tx-job-server" \TransactionServerDependencies{..} Burn addresses tokenFilter -> withEvent ExecWithdraw \_ -> execBurn + systemStart + eraHistory + chainSyncQueryConnector + marloweQueryConnector era ledgerProtocolParameters loadWalletContext @@ -700,15 +708,22 @@ execExceptT = fmap (either (flip SendMsgFail ()) (flip SendMsgSucceed ())) . run execBurn :: (MonadUnliftIO m, IsCardanoEra era) - => CardanoEra era + => SystemStart + -> EraHistory + -> Connector (QueryClient ChainSyncQuery) m + -> Connector MarloweQueryClient m + -> CardanoEra era -> LedgerProtocolParameters era -> LoadWalletContext m -> WalletAddresses -> RoleTokenFilter -> m (ServerStCmd MarloweTxCommand Void BurnError BurnTx m ()) -execBurn era protocol loadWalletContext addresses tokenFilter = execExceptT do +execBurn start history chainQueryConnector marloweQueryConnector era protocol loadWalletContext addresses tokenFilter = execExceptT do eon <- toBabbageEraOnwards (BurnEraUnsupported $ AnyCardanoEra era) era - when (tokenFilter == RoleTokenFilterNone) $ throwE BurnNoTokens + let tokenFilter' = optimizeRoleTokenFilter tokenFilter + when (tokenFilter' == RoleTokenFilterNone) $ throwE BurnNoTokens walletContext <- lift $ loadWalletContext addresses - burnTx <- burnRoleTokens eon protocol walletContext tokenFilter + currencies <- + lift $ runConnector marloweQueryConnector $ getRoleCurrencies $ roleTokenFilterToRoleCurrencyFilter tokenFilter' + burnTx <- burnRoleTokens start history chainQueryConnector eon protocol walletContext currencies tokenFilter' pure $ BurnTx eon burnTx From eb89fa6d0ef84b0cb7730ff0674af659b1ea8cdb Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Sat, 10 Feb 2024 15:20:25 -0500 Subject: [PATCH 11/18] Add burn integration tests --- .../src/Control/Monad/Trans/Marlowe/Class.hs | 14 ++++++ .../Marlowe/Runtime/Integration/Basic.hs | 44 +++++++++---------- .../Marlowe/Runtime/Integration/Common.hs | 10 +++++ .../Runtime/Integration/StandardContract.hs | 23 ++++++++-- 4 files changed, 66 insertions(+), 25 deletions(-) diff --git a/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs b/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs index 4dc22d7475..fb0a97bde1 100644 --- a/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs +++ b/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs @@ -48,11 +48,14 @@ import Language.Marlowe.Runtime.Core.Api ( import Language.Marlowe.Runtime.Transaction.Api ( Account, ApplyInputsError, + BurnError, + BurnTx, ContractCreated, CreateError, InputsApplied, JobId (..), MarloweTxCommand (..), + RoleTokenFilter, RoleTokensConfig, SubmitError, SubmitStatus, @@ -307,6 +310,17 @@ withdraw withdraw version wallet payouts = runMarloweTxClient $ liftCommand $ Withdraw version wallet payouts +-- | Withdraw funds that have been paid out to a role in a contract. +burn + :: (MonadMarlowe m) + => WalletAddresses + -- ^ The wallet addresses to use when constructing the transaction. + -> RoleTokenFilter + -- ^ A filter that identifies which role tokens to burn. + -> m (Either BurnError BurnTx) +burn wallet tFilter = + runMarloweTxClient $ liftCommand $ Burn wallet tFilter + -- | Submit a signed transaction via the Marlowe Runtime. Waits for completion -- with exponential back-off in the polling. submitAndWait diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs index 184bd044fe..a272070ab9 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs @@ -8,6 +8,7 @@ module Language.Marlowe.Runtime.Integration.Basic where import Cardano.Api (getTxId) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Functor (void) import qualified Data.Map as Map import Data.Maybe (fromJust) import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime) @@ -25,7 +26,7 @@ import qualified Language.Marlowe.Protocol.BulkSync.Client as BulkSync import qualified Language.Marlowe.Protocol.HeaderSync.Client as HeaderSync import qualified Language.Marlowe.Protocol.Sync.Client as MarloweSync import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) -import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..), BlockHeader, TxOutRef (..)) +import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..), BlockHeader, Tokens (..), TxOutRef (..)) import Language.Marlowe.Runtime.Client ( createContract, runMarloweBulkSyncClient, @@ -57,6 +58,8 @@ import Language.Marlowe.Runtime.Integration.ApplyInputs (utcTimeToPOSIXTime) import Language.Marlowe.Runtime.Integration.Common import Language.Marlowe.Runtime.Integration.StandardContract import Language.Marlowe.Runtime.Transaction.Api ( + BurnTx (..), + BurnTxInEra (..), ContractCreated (..), ContractCreatedInEra (..), InputsApplied (..), @@ -212,7 +215,6 @@ spec = describe "Basic scenarios" do -- 27. Cancel -- 28. Done pure $ bulkSyncRequestNextExpectWait $ pure $ BulkSync.SendMsgCancel $ BulkSync.SendMsgDone () - startClient -- This is an adaptation of https://nbviewer.org/gist/bwbush/4e8a7196902bfdb0f7f6f7f4a6e3e643 @@ -260,7 +262,7 @@ basicScenarioWithCreator createStandardContractArg = do partyAWallet <- getGenesisWallet 0 partyBWallet <- getGenesisWallet 1 let -- 1. Start MarloweHeaderSyncClient (request next) - startDiscoveryClient :: Integration TxOutRef + startDiscoveryClient :: Integration (StandardContractClosed 'V1) startDiscoveryClient = runMarloweHeaderSyncClient $ HeaderSync.MarloweHeaderSyncClient $ pure @@ -279,20 +281,20 @@ basicScenarioWithCreator createStandardContractArg = do continueWithNewHeaders contract = pure $ HeaderSync.SendMsgRequestNext $ headerSyncExpectWait do -- 8. Deposit funds fundsDeposited <- makeInitialDeposit contract - txOutRef <- runMarloweSyncClient $ marloweSyncClient contract fundsDeposited + closed <- runMarloweSyncClient $ marloweSyncClient contract fundsDeposited -- 33. Poll -- 34. Expect wait -- 35. Cancel -- 36. Done - pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone txOutRef + pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone closed -- 9. Start MarloweSyncClient (follow contract) marloweSyncClient :: StandardContractInit 'V1 -> StandardContractFundsDeposited 'V1 - -> MarloweSync.MarloweSyncClient Integration TxOutRef + -> MarloweSync.MarloweSyncClient Integration (StandardContractClosed 'V1) marloweSyncClient StandardContractInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do - let ContractCreated _ ContractCreatedInEra{contractId, rolesCurrency} = contractCreated + let ContractCreated _ ContractCreatedInEra{contractId} = contractCreated pure $ MarloweSync.SendMsgFollowContract contractId -- 10. Expect contract found @@ -324,7 +326,7 @@ basicScenarioWithCreator createStandardContractArg = do StandardContractNotified{..} <- sendNotify -- 21. Deposit as party B - StandardContractClosed{..} <- makeReturnDeposit + closed@StandardContractClosed{..} <- makeReturnDeposit -- 22. Withdraw as party A (WithdrawTx _ WithdrawTxInEra{txBody = withdrawTxBody}, withdrawBlock) <- withdrawPartyAFunds @@ -350,21 +352,19 @@ basicScenarioWithCreator createStandardContractArg = do -- 30. Expect wait -- 31. Cancel -- 32. Done - let InputsApplied _ InputsAppliedInEra{output} = notified - TransactionScriptOutput{utxo = notifyTxOutRef} <- expectJust "Failed to obtain deposit output" $ scriptOutput output - pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone notifyTxOutRef + pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone closed - txOutRef <- startDiscoveryClient - -- 37. Start MarloweSyncClient (follow a tx in the contract) - -- 38. Expect contract not found - runMarloweSyncClient $ - MarloweSync.MarloweSyncClient $ - pure $ - MarloweSync.SendMsgFollowContract (ContractId txOutRef) $ - MarloweSync.ClientStFollow - { recvMsgContractFound = \_ _ _ -> fail "Expected contract not found, got contract found" - , recvMsgContractNotFound = pure () - } + StandardContractClosed{..} <- startDiscoveryClient + -- 37. Burn role tokens + BurnTx era BurnTxInEra{burnedTokens = burnedByToken, txBody} <- burnPartyARoleTokenByToken + BurnTx _ BurnTxInEra{burnedTokens = burnedByContractId} <- burnPartyARoleTokenByContractId + BurnTx _ BurnTxInEra{burnedTokens = burnedByPolicyId} <- burnPartyARoleTokenByPolicyId + BurnTx _ BurnTxInEra{burnedTokens = burnedByAny} <- burnPartyARoleTokenByAny + liftIO $ burnedByToken `shouldBe` Tokens (Map.singleton (AssetId rolesCurrency "Party A") 1) + liftIO $ burnedByToken `shouldBe` burnedByContractId + liftIO $ burnedByContractId `shouldBe` burnedByPolicyId + liftIO $ burnedByPolicyId `shouldBe` burnedByAny + void $ submit partyAWallet era txBody inputsAppliedToUnspentContractOutput :: ContractCreated 'V1 -> InputsApplied 'V1 -> UnspentContractOutput inputsAppliedToUnspentContractOutput created (InputsApplied _ InputsAppliedInEra{..}) = case output of diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs index a35efd117a..627ba41382 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs @@ -104,11 +104,13 @@ import Language.Marlowe.Runtime.Core.Api ( import Language.Marlowe.Runtime.Discovery.Api (ContractHeader (..)) import Language.Marlowe.Runtime.History.Api (ContractStep, CreateStep (..), MarloweBlock) import Language.Marlowe.Runtime.Transaction.Api ( + BurnTx, ContractCreated (..), ContractCreatedInEra (..), InputsApplied (..), InputsAppliedInEra (..), MarloweTxCommand (..), + RoleTokenFilter, SubmitError, WalletAddresses (..), WithdrawTx (..), @@ -422,6 +424,14 @@ withdraw Wallet{..} payouts = do result <- Client.withdraw MarloweV1 addresses payouts expectRight "Failed to create withdraw transaction" result +burn + :: Wallet + -> RoleTokenFilter + -> Integration BurnTx +burn Wallet{..} tokenFilter = do + result <- Client.burn addresses tokenFilter + expectRight "Failed to create burn transaction" result + timeout :: NominalDiffTime timeout = secondsToNominalDiffTime 2 diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs index 9375f59201..55f22c471d 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs @@ -16,7 +16,7 @@ import Language.Marlowe.Extended.V1 (ada) import Language.Marlowe.Protocol.Load.Client (pushContract) import Language.Marlowe.Protocol.Query.Types (PayoutHeader (..)) import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) -import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, TxId) +import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..), BlockHeader, PolicyId, TxId) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Client (createContract, runMarloweLoadClient) import Language.Marlowe.Runtime.Core.Api ( @@ -35,6 +35,7 @@ import Language.Marlowe.Runtime.Discovery.Api (ContractHeader) import Language.Marlowe.Runtime.Integration.Common ( Integration, Wallet (..), + burn, choose, contractCreatedToContractHeader, deposit, @@ -46,11 +47,13 @@ import Language.Marlowe.Runtime.Integration.Common ( ) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api ( + BurnTx, ContractCreated (..), ContractCreatedInEra (..), Destination (ToAddress), InputsApplied (..), InputsAppliedInEra (..), + RoleTokenFilter' (..), RoleTokensConfig (..), WalletAddresses (changeAddress), WithdrawTx (..), @@ -108,6 +111,11 @@ data StandardContractNotified v = StandardContractNotified data StandardContractClosed v = StandardContractClosed { withdrawPartyAFunds :: Integration (WithdrawTx v, BlockHeader) + , rolesCurrency :: PolicyId + , burnPartyARoleTokenByToken :: Integration BurnTx + , burnPartyARoleTokenByContractId :: Integration BurnTx + , burnPartyARoleTokenByPolicyId :: Integration BurnTx + , burnPartyARoleTokenByAny :: Integration BurnTx , returnDeposited :: InputsApplied v , returnDepositBlock :: BlockHeader } @@ -169,7 +177,7 @@ createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAW Nothing mempty (Right contractHash) - contractCreated@(ContractCreated era0 ContractCreatedInEra{contractId, txBody = createTxBody}) <- + contractCreated@(ContractCreated era0 ContractCreatedInEra{contractId, txBody = createTxBody, rolesCurrency}) <- expectRight "failed to create standard contract" result createdBlock <- submit partyAWallet era0 createTxBody @@ -225,14 +233,23 @@ createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAW 100_000_000 returnDepositBlock <- submit partyBWallet era4 returnTxBody + let mkBurn = burn partyAWallet pure StandardContractClosed - { returnDepositBlock + { rolesCurrency + , returnDepositBlock , returnDeposited , withdrawPartyAFunds = do withdrawTx@(WithdrawTx era5 WithdrawTxInEra{txBody = withdrawTxBody}) <- withdraw partyAWallet $ Map.keysSet $ payouts output (withdrawTx,) <$> submit partyAWallet era5 withdrawTxBody + , burnPartyARoleTokenByToken = + mkBurn $ RoleTokenFilterByTokens $ Set.singleton $ AssetId rolesCurrency "Party A" + , burnPartyARoleTokenByContractId = + mkBurn $ RoleTokenFilterByContracts $ Set.singleton contractId + , burnPartyARoleTokenByPolicyId = + mkBurn $ RoleTokenFilterByPolicyIds $ Set.singleton rolesCurrency + , burnPartyARoleTokenByAny = mkBurn RoleTokenFilterAny } } } From a13653471d079c021e11ec83ce607986cf65b5a7 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 26 Feb 2024 14:29:29 -0500 Subject: [PATCH 12/18] Update script serialization --- .../Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs | 6 +++--- .../Runtime/ChainSync/Database/PostgreSQL/Allegra.hs | 4 ++-- .../Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs | 3 ++- .../Runtime/ChainSync/Database/PostgreSQL/Babbage.hs | 4 ++-- .../Runtime/ChainSync/Database/PostgreSQL/Conway.hs | 4 ++-- .../Runtime/ChainSync/Database/PostgreSQL/Mary.hs | 7 ++++++- .../Runtime/ChainSync/Database/PostgreSQL/Shelley.hs | 9 ++++++--- 7 files changed, 23 insertions(+), 14 deletions(-) diff --git a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs index fa0a500662..17b0bef6e0 100644 --- a/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs +++ b/marlowe-chain-sync/libchainsync/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL.hs @@ -35,7 +35,7 @@ import Cardano.Api (BabbageEraOnwards (..), ShelleyBasedEra (..)) import Cardano.Api.Shelley (fromShelleyBasedScript) import qualified Cardano.Api.Shelley as C import Cardano.Binary (unsafeDeserialize') -import Cardano.Ledger.Binary (DecCBOR (decCBOR), decodeFullAnnotator, shelleyProtVer) +import Cardano.Ledger.Binary (DecCBOR (decCBOR), decodeFullAnnotator) import Control.Applicative ((<|>)) import Control.Arrow (Arrow (..), (***)) import Control.Foldl (Fold (Fold)) @@ -156,14 +156,14 @@ getScripts = Database.GetScripts go ( ScriptHash scriptHash , fromShelleyBasedScript ShelleyBasedEraBabbage $ either (error . show) id $ - decodeFullAnnotator shelleyProtVer "Script" decCBOR $ + decodeFullAnnotator maxBound "Script" decCBOR $ LBS.fromStrict scriptBytes ) BabbageEraOnwardsConway -> \(scriptHash, scriptBytes) -> ( ScriptHash scriptHash , fromShelleyBasedScript ShelleyBasedEraConway $ either (error . show) id $ - decodeFullAnnotator shelleyProtVer "Script" decCBOR $ + decodeFullAnnotator maxBound "Script" decCBOR $ LBS.fromStrict scriptBytes ) diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs index 8e237610c1..b2a9f1795e 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Allegra.hs @@ -23,7 +23,7 @@ import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( hashToBytea, mapStrictMaybe, - originalBytea, + serializeBytea, shelleyTxInRow, shelleyTxOutRow, ) @@ -48,7 +48,7 @@ allegraScriptRow :: ScriptHash StandardCrypto -> Timelock (AllegraEra StandardCr allegraScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = originalBytea script + , scriptBytes = serializeBytea shelleyProtVer script } allegraTxRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs index ba201bb9b6..26ce15d2c6 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs @@ -48,6 +48,7 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( hashToBytea, mapStrictMaybe, originalBytea, + serializeBytea, shelleyTxInRow, ) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( @@ -80,7 +81,7 @@ alonzoScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (AlonzoEra Standard alonzoScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = originalBytea script + , scriptBytes = serializeBytea shelleyProtVer script } alonzoTxRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs index 282ad10c23..2f58ed6874 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs @@ -27,7 +27,7 @@ import Data.Int import qualified Data.Map as Map import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxInRows, alonzoTxRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows, maryTxOutRow) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea, serializeBytea) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types babbageTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (BabbageEra StandardCrypto) -> TxRowGroup @@ -58,7 +58,7 @@ babbageScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (BabbageEra Standa babbageScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = originalBytea script + , scriptBytes = serializeBytea shelleyProtVer script } babbageTxOutRows diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs index 13909091f5..1db2548cef 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs @@ -62,7 +62,7 @@ import qualified Data.Map as Map import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxInRows, alonzoTxRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Babbage (babbageTxOutRows) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, serializeBytea) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types import Unsafe.Coerce (unsafeCoerce) @@ -100,7 +100,7 @@ conwayScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (ConwayEra Standard conwayScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = originalBytea script + , scriptBytes = serializeBytea shelleyProtVer script } coerceTxOut diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs index 35084cdbe3..a0f4e37823 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs @@ -39,6 +39,11 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( TxRowGroup, ) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea, shelleyTxInRow) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( + hashToBytea, + serializeBytea, + shelleyTxInRow, + ) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types maryTxToRows :: Int64 -> Bytea -> Bytea -> ShelleyTx (MaryEra StandardCrypto) -> TxRowGroup @@ -60,7 +65,7 @@ maryScriptRow :: ScriptHash StandardCrypto -> Timelock (MaryEra StandardCrypto) maryScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = originalBytea script + , scriptBytes = serializeBytea shelleyProtVer script } maryTxRow diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs index 1cb2279ce8..15d2ce5a69 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Shelley.hs @@ -6,8 +6,8 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley where import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.Address (BootstrapAddress (..), putPtr, serialiseAddr) -import Cardano.Ledger.BaseTypes (TxIx (..), shelleyProtVer) -import Cardano.Ledger.Binary (serialize') +import Cardano.Ledger.BaseTypes (TxIx (..), Version, shelleyProtVer) +import Cardano.Ledger.Binary (EncCBOR, serialize') import Cardano.Ledger.Crypto import Cardano.Ledger.SafeHash (SafeToHash (..)) import Cardano.Ledger.Shelley @@ -55,9 +55,12 @@ shelleyScriptRow :: ScriptHash StandardCrypto -> MultiSig (ShelleyEra StandardCr shelleyScriptRow (ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = originalBytea script + , scriptBytes = serializeBytea shelleyProtVer script } +serializeBytea :: (EncCBOR a) => Version -> a -> Bytea +serializeBytea v = Bytea . serialize' v + mapStrictMaybe :: (a -> b) -> StrictMaybe a -> Maybe b mapStrictMaybe f = \case SNothing -> Nothing From b38ed23f5d089a438d3e159b9e9c4432302d5603 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 26 Feb 2024 14:46:15 -0500 Subject: [PATCH 13/18] Fix burn tx building --- .../Marlowe/Runtime/Transaction/Burn.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs index ed99d4fbc9..e7a530f1bc 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs @@ -5,7 +5,15 @@ module Language.Marlowe.Runtime.Transaction.Burn where -import Cardano.Api (BabbageEraOnwards, BuildTx, ScriptInEra, SystemStart, TxBodyContent (..), defaultTxBodyContent) +import Cardano.Api ( + BabbageEraOnwards, + BuildTx, + BuildTxWith (..), + ScriptInEra, + SystemStart, + TxBodyContent (..), + defaultTxBodyContent, + ) import qualified Cardano.Api as C import Cardano.Api.Shelley (LedgerProtocolParameters, PlutusScriptOrReferenceInput (..), ReferenceScript (..)) import Control.Error (ExceptT, note, throwE) @@ -115,7 +123,7 @@ burnRoleTokens start history chainQueryConnector era protocol walletCtx@WalletCo let missingScriptHashes = Set.difference policyScriptHashes $ Map.keysSet scripts unless (Set.null missingScriptHashes) $ throwE $ BurnRolesActive $ Set.mapMonotonic coerce missingScriptHashes -- Build the transaction body - txBodyContent <- except $ note BurnFromCardanoError $ buildBurn era inputs scripts + txBodyContent <- except $ note BurnFromCardanoError $ buildBurn era protocol inputs scripts -- FIXME there is no reason we need these except that selectCoins and balanceTx require them. Refactor -- those two functions to remove these dummy contexts. let scriptCtx = Right $ PayoutContext mempty mempty @@ -148,15 +156,16 @@ activeCurrency RoleCurrency{..} buildBurn :: forall era . BabbageEraOnwards era + -> LedgerProtocolParameters era -> Map TxOutRef (Tokens, (Address, Assets)) -> Map ScriptHash (ScriptInEra era) -> Maybe (TxBodyContent BuildTx era) -buildBurn era inputs scripts = do +buildBurn era protocol inputs scripts = do txIns <- traverse buildInput $ Map.keys inputs (outputsWithTokens, adaOnlyOutputs) <- fold <$> traverse (uncurry buildOutput . snd) inputs let txOuts = mergeAdaOnly adaOnlyOutputs <> outputsWithTokens txMintValue <- buildMint - pure (defaultTxBodyContent shelleyEra){txIns, txOuts, txMintValue} + pure (defaultTxBodyContent shelleyEra){txIns, txOuts, txMintValue, txProtocolParams = BuildTxWith $ Just protocol} where shelleyEra :: C.ShelleyBasedEra era shelleyEra = C.babbageEraOnwardsToShelleyBasedEra era From ba0f3cedcd1009968bb47867d06e72f44f7d59b1 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 6 Mar 2024 09:00:31 -0500 Subject: [PATCH 14/18] WIP web API for role token burning --- .../src/Language/Marlowe/Runtime/Web/API.hs | 23 ++++ .../src/Language/Marlowe/Runtime/Web/Types.hs | 130 +++++++++++++++++- 2 files changed, 152 insertions(+), 1 deletion(-) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs index d072b8a1a5..2b26905877 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs @@ -190,6 +190,7 @@ type API = ( "contracts" :> ContractsAPI :<|> "withdrawals" :> WithdrawalsAPI :<|> "payouts" :> PayoutsAPI + :<|> "role-token-burns" :> BurnsAPI :<|> "healthcheck" :> ( Summary "Test server status" :> Description "Check if the server is running and ready to respond to requests." @@ -198,6 +199,26 @@ type API = ) ) +-- | /role-token-burns sub-API +type BurnsAPI = + BurnsAPI + :<|> PostBurnsAPI + :<|> Capture "burnId" TxId :> BurnAPI + +-- | POST /role-token-burns sub-API +type PostBurnsAPI = + Summary "Burn role tokens" + :> Description + "Build an unsigned (Cardano) transaction body which burns role tokens matching a filter. \ + \Role tokens used by active contracts will not be burned and the request will fail if active role tokens are included. \ + \To submit the signed transaction, use the PUT /role-token-burns/{burnId} endpoint." + :> OperationId "burnRoleTokens" + :> RenameResponseSchema "BurnRoleTokensResponse" + :> ( ReqBody '[JSON] PostBurnRequest :> PostTxAPI (PostCreated '[JSON] (PostBurnResponse CardanoTxBody)) + :<|> ReqBody '[JSON] PostBurnRequest + :> PostTxAPI (PostCreated '[TxJSON BurnTx] (PostBurnResponse CardanoTx)) + ) + -- | /contracts sub-API type ContractsAPI = GetContractsAPI @@ -563,6 +584,8 @@ type PostWithdrawalsResponse tx = WithLink "withdrawal" (WithdrawTxEnvelope tx) data WithdrawTx +data BurnTx + instance Accept (TxJSON WithdrawTx) where contentType _ = "application" // "vendor.iog.marlowe-runtime.withdraw-tx-json" diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs index 43595d863f..6d76ce3752 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs @@ -18,8 +18,9 @@ import Control.Monad (unless, (<=<)) import Data.Aeson import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as AMap +import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Text (encodeToLazyText) -import Data.Aeson.Types (Parser, parseFail, toJSONKeyText) +import Data.Aeson.Types (JSONPathElement (..), Parser, parseFail, prependFailure, toJSONKeyText, typeMismatch) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -30,6 +31,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.OpenApi ( AdditionalProperties (..), + Definitions, HasAdditionalProperties (..), HasType (..), NamedSchema (..), @@ -37,6 +39,7 @@ import Data.OpenApi ( OpenApiType (..), Reference (..), Referenced (..), + Schema, ToParamSchema, ToSchema, declareSchema, @@ -50,8 +53,10 @@ import Data.OpenApi ( toParamSchema, ) import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Declare (Declare) import Data.OpenApi.Schema (ToSchema (..)) import Data.Set (Set) +import qualified Data.Set as Set import Data.String (IsString (..)) import Data.Text (Text, intercalate, splitOn) import qualified Data.Text as T @@ -1373,3 +1378,126 @@ instance ToParamSchema NetworkId where mempty & oneOf ?~ [Inline (mempty & type_ ?~ OpenApiString), Inline (mempty & type_ ?~ OpenApiInteger)] & OpenApi.description ?~ "The latest known point in the chain on a peer." + +data RoleTokenFilter + = RoleTokenAnd RoleTokenFilter RoleTokenFilter + | RoleTokenOr RoleTokenFilter RoleTokenFilter + | RoleTokenNot RoleTokenFilter + | RoleTokenFilterNone + | RoleTokenFilterByContracts (Set TxOutRef) + | RoleTokenFilterByPolicies (Set PolicyId) + | RoleTokenFilterByTokens (Set AssetId) + | RoleTokenFilterAny + deriving stock (Show, Eq, Ord, Generic) + +instance ToJSON RoleTokenFilter where + toJSON = \case + RoleTokenAnd a b -> object ["and" .= (a, b)] + RoleTokenOr a b -> object ["or" .= (a, b)] + RoleTokenNot a -> object ["not" .= a] + RoleTokenFilterNone -> toJSON False + RoleTokenFilterByContracts contracts -> object ["contract_id" .= contracts] + RoleTokenFilterByPolicies policies -> object ["roles_currency" .= policies] + RoleTokenFilterByTokens tokens -> object ["role_tokens" .= tokens] + RoleTokenFilterAny -> toJSON True + +instance FromJSON RoleTokenFilter where + parseJSON = + prependFailure "Parsing RoleTokenFilter failed" . \case + Object o -> case KeyMap.toList o of + [(k, v)] -> case k of + "and" -> uncurry RoleTokenAnd <$> parseJSON v Key "and" + "or" -> uncurry RoleTokenOr <$> parseJSON v Key "or" + "not" -> RoleTokenNot <$> parseJSON v Key "not" + "contract_id" -> RoleTokenFilterByContracts <$> parseSetOrSingle v Key "contract_id" + "roles_currency" -> RoleTokenFilterByPolicies <$> parseSetOrSingle v Key "roles_currency" + "role_tokens" -> RoleTokenFilterByTokens <$> parseSetOrSingle v Key "role_tokens" + _ -> fail $ "Unexpected key: " <> show k + _ -> fail "Unexpected number of keys, expected exactly 1." + Bool True -> pure RoleTokenFilterAny + Bool False -> pure RoleTokenFilterNone + v -> typeMismatch "object|boolean" v + +parseSetOrSingle :: (FromJSON a, Ord a) => Value -> Parser (Set a) +parseSetOrSingle = \case + Array arr -> parseJSON $ Array arr + v -> Set.singleton <$> parseJSON v + +instance ToSchema RoleTokenFilter where + declareNamedSchema _ = do + roleTokenFilterSchema <- declareSchemaRef $ Proxy @RoleTokenFilter + roleTokenFilterPairSchema <- declareSchemaRef $ Proxy @(RoleTokenFilter, RoleTokenFilter) + let setOrSingleSchema + :: forall a + . (ToSchema a) + => Proxy a + -> Declare (Definitions Schema) (Referenced Schema) + setOrSingleSchema p = do + singleSchema <- declareSchemaRef p + setSchema <- declareSchemaRef $ Proxy @(Set a) + pure $ Inline $ mempty & oneOf ?~ [singleSchema, setSchema] + txOutRefSchema <- setOrSingleSchema $ Proxy @TxOutRef + policyIdSchema <- setOrSingleSchema $ Proxy @PolicyId + assetIdSchema <- setOrSingleSchema $ Proxy @AssetId + let andSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens matched by both sub-filters." + & required .~ ["and"] + & properties .~ [("and", roleTokenFilterPairSchema)] + orSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens matched by either sub-filter." + & required .~ ["or"] + & properties .~ [("or", roleTokenFilterPairSchema)] + notSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens not matched by the sub-filter." + & required .~ ["not"] + & properties .~ [("not", roleTokenFilterSchema)] + anySchema = + mempty + & type_ ?~ OpenApiBoolean + & OpenApi.description ?~ "Matches any role token." + & enum_ ?~ [Bool True] + noneSchema = + mempty + & type_ ?~ OpenApiBoolean + & OpenApi.description ?~ "Matches no role token." + & enum_ ?~ [Bool False] + contractsSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens used by the given contract(s)." + & required .~ ["contract_id"] + & properties .~ [("contract_id", txOutRefSchema)] + policiesSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens with the given currency symbol(s)." + & required .~ ["roles_currency"] + & properties .~ [("roles_currency", policyIdSchema)] + tokensSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches only the given role token(s)." + & required .~ ["role_tokens"] + & properties .~ [("role_tokens", assetIdSchema)] + pure $ + NamedSchema (Just "RoleTokenFilter") $ + mempty + & OpenApi.description ?~ "A filter that selects role tokens for burning." + & oneOf + ?~ fmap + Inline + [ andSchema + , orSchema + , notSchema + , anySchema + , noneSchema + , contractsSchema + , policiesSchema + , tokensSchema + ] From 191a1e75212b285b414f2bde9303b5cea99c9e8e Mon Sep 17 00:00:00 2001 From: Nicolas Henin Date: Wed, 20 Mar 2024 11:48:59 +0100 Subject: [PATCH 15/18] refactored runtime-web into a DDD manner --- .../.golden/ChainSeekQuery/golden | 24 + marlowe-chain-sync/marlowe-chain-copy/Main.hs | 1 + marlowe-chain-sync/marlowe-chain-sync.cabal | 2 +- .../ChainSync/Database/PostgreSQL/Alonzo.hs | 5 +- .../ChainSync/Database/PostgreSQL/Babbage.hs | 35 +- .../ChainSync/Database/PostgreSQL/Conway.hs | 41 +- .../ChainSync/Database/PostgreSQL/Mary.hs | 45 +- .../marlowe-integration-tests.cabal | 2 +- .../Language/Marlowe/Runtime/Web/Common.hs | 18 +- .../Runtime/Web/Contracts/Contract/Get.hs | 6 +- .../Web/Contracts/Contract/Next/Get.hs | 5 +- .../Runtime/Web/Contracts/Contract/Post.hs | 21 +- .../Runtime/Web/Contracts/Contract/Put.hs | 35 +- .../Marlowe/Runtime/Web/Contracts/Get.hs | 6 +- .../Runtime/Web/Contracts/Transactions/Get.hs | 5 +- .../Contracts/Transactions/Transaction/Get.hs | 8 +- .../Transactions/Transaction/Post.hs | 24 +- .../Contracts/Transactions/Transaction/Put.hs | 27 +- .../Marlowe/Runtime/Web/StandardContract.hs | 36 +- .../Marlowe/Runtime/Web/Withdrawal/Post.hs | 17 +- .../Marlowe/Runtime/Web/Withdrawal/Put.hs | 18 +- .../src/Test/Integration/Marlowe/Local.hs | 16 +- marlowe-runtime-web/app/Main.hs | 61 +- marlowe-runtime-web/marlowe-runtime-web.cabal | 118 +- .../{Server/OpenAPI.hs => OpenAPIServer.hs} | 74 +- .../Web/{Server.hs => RuntimeServer.hs} | 73 +- .../Marlowe/Runtime/Web/Server/REST.hs | 19 - .../src/Language/Marlowe/Runtime/Web.hs | 7 - .../src/Language/Marlowe/Runtime/Web/API.hs | 713 ++------ .../Marlowe/Runtime/Web/Adapter/ByteString.hs | 14 + .../Marlowe/Runtime/Web/Adapter/CommaList.hs | 58 + .../Marlowe/Runtime/Web/Adapter/Links.hs | 149 ++ .../Marlowe/Runtime/Web/Adapter/Pagination.hs | 39 + .../Marlowe/Runtime/Web/Adapter/Servant.hs | 113 ++ .../Runtime/Web/Adapter/Server}/ApiError.hs | 4 +- .../Web/Adapter}/Server/ContractClient.hs | 4 +- .../Runtime/Web/Adapter}/Server/DTO.hs | 164 +- .../Runtime/Web/Adapter}/Server/Monad.hs | 8 +- .../Runtime/Web/Adapter}/Server/SyncClient.hs | 6 +- .../Runtime/Web/Adapter}/Server/TxClient.hs | 199 ++- .../Runtime/Web/Adapter}/Server/Util.hs | 2 +- .../Marlowe/Runtime/Web/Adapter/URI.hs | 21 + .../Language/Marlowe/Runtime/Web/Burn/API.hs | 42 + .../Language/Marlowe/Runtime/Web/Client.hs | 84 +- .../Marlowe/Runtime/Web/Contract/API.hs | 326 ++++ .../Marlowe/Runtime/Web/Contract/Next/API.hs | 48 + .../Runtime/Web/Contract/Next/Client.hs | 73 + .../Runtime/Web/{ => Contract}/Next/Schema.hs | 4 +- .../Runtime/Web/Contract/Next/Server.hs} | 18 +- .../Marlowe/Runtime/Web/Contract/Server.hs} | 97 +- .../Runtime/Web/Contract/Source/Server.hs} | 30 +- .../Runtime/Web/Contract/Transaction/API.hs | 115 ++ .../Web/Contract/Transaction/Server.hs} | 80 +- .../Marlowe/Runtime/Web/Core/Address.hs | 64 + .../Marlowe/Runtime/Web/Core/Asset.hs | 82 + .../Marlowe/Runtime/Web/Core/Base16.hs | 61 + .../Marlowe/Runtime/Web/Core/BlockHeader.hs | 30 + .../Runtime/Web/Core/MarloweVersion.hs | 58 + .../Marlowe/Runtime/Web/Core/Metadata.hs | 77 + .../Marlowe/Runtime/Web/Core/NetworkId.hs | 68 + .../Marlowe/Runtime/Web/Core/Object/Schema.hs | 23 + .../Marlowe/Runtime/Web/Core/Party.hs | 42 + .../Marlowe/Runtime/Web/Core/Roles.hs | 492 ++++++ .../Marlowe/Runtime/Web/Core/Script.hs | 45 + .../{Orphans.hs => Core/Semantics/Schema.hs} | 2 +- .../Language/Marlowe/Runtime/Web/Core/Tip.hs | 110 ++ .../Language/Marlowe/Runtime/Web/Core/Tx.hs | 212 +++ .../Marlowe/Runtime/Web/Payout/API.hs | 179 ++ .../Marlowe/Runtime/Web/Payout/Server.hs} | 49 +- .../Language/Marlowe/Runtime/Web/Server.hs | 24 + .../Language/Marlowe/Runtime/Web/Status.hs | 26 + .../Language/Marlowe/Runtime/Web/Tx/API.hs | 390 +++++ .../src/Language/Marlowe/Runtime/Web/Types.hs | 1503 ----------------- .../Marlowe/Runtime/Web/Withdrawal/API.hs | 175 ++ .../Marlowe/Runtime/Web/Withdrawal/Server.hs} | 68 +- marlowe-runtime-web/test/Spec.hs | 53 +- .../.golden/Job MarloweTxCommand/golden | 194 +++ 77 files changed, 4624 insertions(+), 2563 deletions(-) rename marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/{Server/OpenAPI.hs => OpenAPIServer.hs} (87%) rename marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/{Server.hs => RuntimeServer.hs} (83%) delete mode 100644 marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST.hs delete mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/ByteString.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/CommaList.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Links.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Pagination.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Servant.hs rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST => src/Language/Marlowe/Runtime/Web/Adapter/Server}/ApiError.hs (99%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web => src/Language/Marlowe/Runtime/Web/Adapter}/Server/ContractClient.hs (95%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web => src/Language/Marlowe/Runtime/Web/Adapter}/Server/DTO.hs (82%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web => src/Language/Marlowe/Runtime/Web/Adapter}/Server/Monad.hs (95%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web => src/Language/Marlowe/Runtime/Web/Adapter}/Server/SyncClient.hs (96%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web => src/Language/Marlowe/Runtime/Web/Adapter}/Server/TxClient.hs (57%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web => src/Language/Marlowe/Runtime/Web/Adapter}/Server/Util.hs (97%) create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/URI.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/API.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Client.hs rename marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/{ => Contract}/Next/Schema.hs (98%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST/Contracts/Next.hs => src/Language/Marlowe/Runtime/Web/Contract/Next/Server.hs} (75%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST/Contracts.hs => src/Language/Marlowe/Runtime/Web/Contract/Server.hs} (81%) rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST/ContractSources.hs => src/Language/Marlowe/Runtime/Web/Contract/Source/Server.hs} (85%) create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST/Transactions.hs => src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs} (80%) create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Address.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Asset.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Base16.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/BlockHeader.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/MarloweVersion.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Metadata.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/NetworkId.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Object/Schema.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Party.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Script.hs rename marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/{Orphans.hs => Core/Semantics/Schema.hs} (99%) create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tip.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/API.hs rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST/Payouts.hs => src/Language/Marlowe/Runtime/Web/Payout/Server.hs} (64%) create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Status.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs delete mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/API.hs rename marlowe-runtime-web/{server/Language/Marlowe/Runtime/Web/Server/REST/Withdrawals.hs => src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs} (80%) diff --git a/marlowe-chain-sync/.golden/ChainSeekQuery/golden b/marlowe-chain-sync/.golden/ChainSeekQuery/golden index 92c2f54864..b96b3af07a 100644 --- a/marlowe-chain-sync/.golden/ChainSeekQuery/golden +++ b/marlowe-chain-sync/.golden/ChainSeekQuery/golden @@ -2,6 +2,18 @@ Show: MsgDone Nothing Binary: 0000 Show: MsgRequest Nothing (ReqBin (ReqLeaf GetSecurityParameter) (ReqLeaf GetSecurityParameter)) Binary: 01000100010001 +Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsBabbage (fromList [""]))) +Binary: 0100000a0000000000000000010000000000000000 +Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsBabbage (fromList ["61"]))) +Binary: 0100000a000000000000000001000000000000000161 +Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsBabbage (fromList []))) +Binary: 0100000a000000000000000000 +Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsConway (fromList [""]))) +Binary: 0100000a0100000000000000010000000000000000 +Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsConway (fromList ["61"]))) +Binary: 0100000a010000000000000001000000000000000161 +Show: MsgRequest Nothing (ReqLeaf (GetScripts BabbageEraOnwardsConway (fromList []))) +Binary: 0100000a010000000000000000 Show: MsgRequest Nothing (ReqLeaf (GetUTxOs (GetUTxOsAtAddresses (fromList [""])))) Binary: 010000060100000000000000010000000000000000 Show: MsgRequest Nothing (ReqLeaf (GetUTxOs (GetUTxOsAtAddresses (fromList ["61"])))) @@ -128,6 +140,18 @@ Show: MsgRespond (UTxOs {unUTxOs = fromList [(TxOutRef {txId = "61", txIx = TxIx Binary: 000000000000000100000000000000016100010000000000000000000000000000000100000000000000000000 Show: MsgRespond (UTxOs {unUTxOs = fromList []}) Binary: 0000000000000000 +Show: MsgRespond (fromList [("",ScriptInEra PlutusScriptV1InBabbage (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))]) +Binary: 0000000000000001000000000000000000000000000000084701000022220011 +Show: MsgRespond (fromList [("",ScriptInEra PlutusScriptV1InConway (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))]) +Binary: 0000000000000001000000000000000000000000000000084701000022220011 +Show: MsgRespond (fromList [("61",ScriptInEra PlutusScriptV1InBabbage (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))]) +Binary: 000000000000000100000000000000016100000000000000084701000022220011 +Show: MsgRespond (fromList [("61",ScriptInEra PlutusScriptV1InConway (PlutusScript PlutusScriptV1 (PlutusScriptSerialised "G\SOH\NUL\NUL\"\"\NUL\DC1")))]) +Binary: 000000000000000100000000000000016100000000000000084701000022220011 +Show: MsgRespond (fromList []) +Binary: 0000000000000000 +Show: MsgRespond (fromList []) +Binary: 0000000000000000 Show: MsgRespond 1 Binary: 0000000000000001 Show: MsgRespond Genesis diff --git a/marlowe-chain-sync/marlowe-chain-copy/Main.hs b/marlowe-chain-sync/marlowe-chain-copy/Main.hs index 613dd7088a..a596fbcb2a 100644 --- a/marlowe-chain-sync/marlowe-chain-copy/Main.hs +++ b/marlowe-chain-sync/marlowe-chain-copy/Main.hs @@ -47,6 +47,7 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( AssetMintRow, AssetOutRow, BlockRow, + ScriptRow, TxInRow, TxOutRow, TxRow, diff --git a/marlowe-chain-sync/marlowe-chain-sync.cabal b/marlowe-chain-sync/marlowe-chain-sync.cabal index 1df59e60fc..12dc9125c7 100644 --- a/marlowe-chain-sync/marlowe-chain-sync.cabal +++ b/marlowe-chain-sync/marlowe-chain-sync.cabal @@ -131,7 +131,7 @@ library libchainsync , bytestring >=0.10.12 && <0.12 , cardano-api:{cardano-api, internal} ^>=8.39.2.0 , cardano-binary - , cardano-ledger-binary ^>=1.2 + , cardano-ledger-binary ^>=1.3 , co-log ^>=0.6 , containers ^>=0.6.5 , eventuo11y >=0.9 && <0.11 diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs index 26ce15d2c6..8c1b4f04e5 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs @@ -14,6 +14,7 @@ import Cardano.Ledger.Allegra.Core ( ) import Cardano.Ledger.Alonzo ( AlonzoEra, + AlonzoScript, AlonzoTxAuxData, AlonzoTxOut, ) @@ -23,8 +24,6 @@ import Cardano.Ledger.Alonzo.Scripts ( AsItem (..), ) import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), indexRedeemers, txdats') -import Cardano.Ledger.Alonzo -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), ScriptPurpose (Spending), indexedRdmrs, txdats') import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody, AlonzoTxBody (..), AlonzoTxOut (..)) import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits, TxDats) @@ -34,6 +33,7 @@ import qualified Cardano.Ledger.Binary as L import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Plutus.Data (dataToBinaryData) import Cardano.Ledger.Shelley.API ( + ScriptHash (..), ShelleyTxOut (ShelleyTxOut), StrictMaybe, TxIn, @@ -53,6 +53,7 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( ) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( Bytea (..), + ScriptRow (..), SqlBool (..), TxInRow (..), TxOutRow (datumBytes, datumHash), diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs index 2f58ed6874..06dbc3271c 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Babbage.hs @@ -15,20 +15,38 @@ import Cardano.Ledger.Babbage.Tx (IsValid (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..)) import Cardano.Ledger.Binary (Sized (..), shelleyProtVer) import qualified Cardano.Ledger.Binary as L -import Cardano.Ledger.Crypto +import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, hashBinaryData) -import Cardano.Ledger.Shelley.API (ShelleyTxOut (..), StrictMaybe (..)) -import Cardano.Ledger.Plutus.Data (binaryDataToData, hashBinaryData) import Cardano.Ledger.Shelley.API (ScriptHash (..), ShelleyTxOut (..), StrictMaybe (..)) import Control.Arrow (Arrow (..)) import Data.ByteString (ByteString) import Data.Foldable (Foldable (..)) -import Data.Int +import Data.Int (Int16, Int64) import qualified Data.Map as Map import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxInRows, alonzoTxRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows, maryTxOutRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea, serializeBytea) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( + Bytea (..), + ScriptRow (..), + SqlBool (SqlBool), + TxOutRow ( + TxOutRow, + address, + addressHeader, + addressPaymentCredential, + addressStakeAddressReference, + datumBytes, + datumHash, + isCollateral, + lovelace, + slotNo, + txId, + txIx + ), + TxOutRowGroup, + TxRowGroup, + ) babbageTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (BabbageEra StandardCrypto) -> TxRowGroup babbageTxToRows slotNo blockHash txId tx@AlonzoTx{..} = @@ -51,11 +69,12 @@ babbageTxScripts AlonzoTxWits{..} outputs = babbageReferenceScript :: Sized (BabbageTxOut (BabbageEra StandardCrypto)) - -> [(ScriptHash StandardCrypto, AlonzoScript (BabbageEra StandardCrypto))] + -> [(Cardano.Ledger.Shelley.API.ScriptHash StandardCrypto, AlonzoScript (BabbageEra StandardCrypto))] babbageReferenceScript (Sized (BabbageTxOut _ _ _ ref) _) = foldMap (pure . (hashScript &&& id)) ref -babbageScriptRow :: ScriptHash StandardCrypto -> AlonzoScript (BabbageEra StandardCrypto) -> ScriptRow -babbageScriptRow (ScriptHash hash) script = +babbageScriptRow + :: Cardano.Ledger.Shelley.API.ScriptHash StandardCrypto -> AlonzoScript (BabbageEra StandardCrypto) -> ScriptRow +babbageScriptRow (Cardano.Ledger.Shelley.API.ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash , scriptBytes = serializeBytea shelleyProtVer script diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs index 1db2548cef..2d523b24e1 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs @@ -12,10 +12,8 @@ import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..)) import Cardano.Ledger.Alonzo.TxWits (TxDats (..)) import Cardano.Ledger.Babbage (BabbageEra, BabbageTxOut) import Cardano.Ledger.Babbage.Tx ( - AlonzoTx (..), IsValid (..), indexRedeemers, - txdats', ) import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) import Cardano.Ledger.Binary (Sized (..), shelleyProtVer) @@ -29,41 +27,38 @@ import Cardano.Ledger.Conway.Core ( Era (EraCrypto), EraTx (Tx), ) -import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (ConwaySpending)) +import Cardano.Ledger.Conway.Scripts ( + AlonzoScript (..), + ConwayPlutusPurpose (ConwaySpending), + ) import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) +import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..)) +import Cardano.Ledger.Core (EraScript (..), ScriptHash (..)) import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Plutus.Data (dataToBinaryData) import Cardano.Ledger.Shelley.API (TxIn) +import Control.Arrow (Arrow (..)) import Data.ByteString (ByteString) import Data.Foldable (Foldable (..)) import Data.Int (Int64) +import qualified Data.Map as Map import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxRow) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Babbage (babbageTxOutRows) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (originalBytea, shelleyTxInRow) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( + hashToBytea, + originalBytea, + serializeBytea, + shelleyTxInRow, + ) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( Bytea, + ScriptRow (..), SqlBool (SqlBool), TxInRow (..), TxRowGroup, ) - -import Cardano.Ledger.Conway.Scripts (AlonzoScript (..)) -import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) -import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..)) -import Cardano.Ledger.Core (EraScript (..), ScriptHash (..)) -import Cardano.Ledger.Crypto -import Control.Arrow (Arrow (..)) -import Data.ByteString (ByteString) -import Data.Foldable (Foldable (..)) -import Data.Int -import qualified Data.Map as Map -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxInRows, alonzoTxRow) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Babbage (babbageTxOutRows) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, serializeBytea) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types import Unsafe.Coerce (unsafeCoerce) conwayTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (ConwayEra StandardCrypto) -> TxRowGroup @@ -122,12 +117,12 @@ conwayTxInRows ) => Int64 -> Bytea - -> IsValid + -> Cardano.Ledger.Babbage.Tx.IsValid -> Tx era -> Set.Set (TxIn StandardCrypto) -> Set.Set (TxIn StandardCrypto) -> [TxInRow] -conwayTxInRows slot txId (IsValid isValid) tx inputs collateralInputs +conwayTxInRows slot txId (Cardano.Ledger.Babbage.Tx.IsValid isValid) tx inputs collateralInputs | isValid = conwayTxInRow slot txId tx <$> Set.toAscList inputs | otherwise = do TxInRow{..} <- shelleyTxInRow slot txId <$> Set.toAscList collateralInputs @@ -149,6 +144,6 @@ conwayTxInRow conwayTxInRow slotNo txInId tx txIn = (shelleyTxInRow slotNo txInId txIn) { redeemerDatumBytes = do - (datum, _) <- indexRedeemers tx $ ConwaySpending (AsItem txIn) + (datum, _) <- Cardano.Ledger.Babbage.Tx.indexRedeemers tx $ ConwaySpending (AsItem txIn) pure $ originalBytea $ dataToBinaryData datum } diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs index a0f4e37823..13dfa10937 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Mary.hs @@ -11,16 +11,16 @@ import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..)) import Cardano.Ledger.Binary (serialize', shelleyProtVer) import Cardano.Ledger.Core (TxAuxData) import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Mary (MaryEra, ShelleyTx, ShelleyTxOut) +import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Mary.TxBody (MaryTxBody (..)) import Cardano.Ledger.Mary.Value (AssetName (..), MaryValue (..), MultiAsset (..), PolicyID (..)) import Cardano.Ledger.Shelley.API ( - ScriptHash (ScriptHash), - ShelleyTx (ShelleyTx, auxiliaryData, body, wits), + ScriptHash (..), + ShelleyTx (..), ShelleyTxOut (ShelleyTxOut), + ShelleyTxWits, StrictMaybe, ) -import Cardano.Ledger.Shelley.API import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..)) import Data.ByteString (ByteString) import Data.ByteString.Short (fromShort) @@ -29,25 +29,23 @@ import Data.Int (Int16, Int64) import qualified Data.Map as Map import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Allegra (allegraTxOutRow, allegraTxRow) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, shelleyTxInRow) +import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( + hashToBytea, + serializeBytea, + shelleyTxInRow, + ) import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types ( AssetMintRow (AssetMintRow), AssetOutRow (AssetOutRow), Bytea (..), + ScriptRow (..), TxOutRowGroup, TxRow, TxRowGroup, ) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (hashToBytea, originalBytea, shelleyTxInRow) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley ( - hashToBytea, - serializeBytea, - shelleyTxInRow, - ) -import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types -maryTxToRows :: Int64 -> Bytea -> Bytea -> ShelleyTx (MaryEra StandardCrypto) -> TxRowGroup -maryTxToRows slotNo blockHash txId ShelleyTx{..} = +maryTxToRows :: Int64 -> Bytea -> Bytea -> Cardano.Ledger.Shelley.API.ShelleyTx (MaryEra StandardCrypto) -> TxRowGroup +maryTxToRows slotNo blockHash txId Cardano.Ledger.Shelley.API.ShelleyTx{..} = ( maryTxRow encodeMaryMetadata slotNo blockHash txId (mtbValidityInterval body) auxiliaryData , shelleyTxInRow slotNo txId <$> Set.toAscList (mtbInputs body) , zipWith (maryTxOutRow slotNo txId) [0 ..] $ toList $ mtbOutputs body @@ -58,14 +56,14 @@ maryTxToRows slotNo blockHash txId ShelleyTx{..} = encodeMaryMetadata :: AllegraTxAuxData (MaryEra StandardCrypto) -> ByteString encodeMaryMetadata (AllegraTxAuxData md _) = serialize' shelleyProtVer md -maryTxScripts :: ShelleyTxWits (MaryEra StandardCrypto) -> [ScriptRow] +maryTxScripts :: Cardano.Ledger.Shelley.API.ShelleyTxWits (MaryEra StandardCrypto) -> [ScriptRow] maryTxScripts ShelleyTxWits{..} = uncurry maryScriptRow <$> Map.toList scriptWits -maryScriptRow :: ScriptHash StandardCrypto -> Timelock (MaryEra StandardCrypto) -> ScriptRow -maryScriptRow (ScriptHash hash) script = +maryScriptRow :: Cardano.Ledger.Shelley.API.ScriptHash StandardCrypto -> Timelock (MaryEra StandardCrypto) -> ScriptRow +maryScriptRow (Cardano.Ledger.Shelley.API.ScriptHash hash) script = ScriptRow { scriptHash = hashToBytea hash - , scriptBytes = serializeBytea shelleyProtVer script + , scriptBytes = Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley.serializeBytea shelleyProtVer script } maryTxRow @@ -74,14 +72,15 @@ maryTxRow -> Bytea -> Bytea -> Allegra.ValidityInterval - -> StrictMaybe (TxAuxData era) + -> Cardano.Ledger.Shelley.API.StrictMaybe (TxAuxData era) -> TxRow maryTxRow encodeMetadata slotNo blockHash txId Allegra.ValidityInterval{..} = allegraTxRow encodeMetadata slotNo blockHash txId Allegra.ValidityInterval{..} -maryTxOutRow :: Int64 -> Bytea -> Int16 -> ShelleyTxOut (MaryEra StandardCrypto) -> TxOutRowGroup -maryTxOutRow slotNo txId txIx (ShelleyTxOut addr (MaryValue lovelace assets)) = - case allegraTxOutRow slotNo txId txIx (ShelleyTxOut addr lovelace) of +maryTxOutRow + :: Int64 -> Bytea -> Int16 -> Cardano.Ledger.Shelley.API.ShelleyTxOut (MaryEra StandardCrypto) -> TxOutRowGroup +maryTxOutRow slotNo txId txIx (Cardano.Ledger.Shelley.API.ShelleyTxOut addr (MaryValue lovelace assets)) = + case allegraTxOutRow slotNo txId txIx (Cardano.Ledger.Shelley.API.ShelleyTxOut addr lovelace) of (txOut, _) -> ( txOut , multiAssetRows (AssetOutRow txId txIx slotNo) assets @@ -92,6 +91,6 @@ maryAssetMintRows slotNo txId = multiAssetRows (AssetMintRow txId slotNo) multiAssetRows :: (Bytea -> Bytea -> Int64 -> row) -> MultiAsset StandardCrypto -> [row] multiAssetRows mkRow (MultiAsset assets) = do - (PolicyID (ScriptHash policyId), tokens) <- Map.toAscList assets + (PolicyID (Cardano.Ledger.Shelley.API.ScriptHash policyId), tokens) <- Map.toAscList assets (AssetName token, quantity) <- Map.toAscList tokens pure $ mkRow (hashToBytea policyId) (Bytea $ fromShort token) (fromInteger quantity) diff --git a/marlowe-integration-tests/marlowe-integration-tests.cabal b/marlowe-integration-tests/marlowe-integration-tests.cabal index 8056a8581f..f0373954ab 100644 --- a/marlowe-integration-tests/marlowe-integration-tests.cabal +++ b/marlowe-integration-tests/marlowe-integration-tests.cabal @@ -106,7 +106,7 @@ executable marlowe-integration-tests , marlowe-integration , marlowe-object:{marlowe-object, gen} , marlowe-protocols - , marlowe-runtime-web:{marlowe-runtime-web, server} + , marlowe-runtime-web , marlowe-runtime:{marlowe-runtime, contract, contract-api, sync-api, tx-api} , marlowe-test , mtl diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs index a5ba01fd3b..9b70ec0f58 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs @@ -35,10 +35,13 @@ import Language.Marlowe.Core.V1.Semantics.Types ( Input (NormalInput), InputContent (IChoice, IDeposit, INotify), ) -import Language.Marlowe.Runtime.Integration.Common hiding (choose, deposit, notify, withdraw) +import Language.Marlowe.Runtime.Integration.Common ( + Wallet (..), + expectJust, + ) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (ContractOrSourceId (..)) -import qualified Language.Marlowe.Runtime.Web as Web + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client ( getContract, getTransaction, @@ -50,7 +53,14 @@ import Language.Marlowe.Runtime.Web.Client ( putTransaction, putWithdrawal, ) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Base16 as Web +import qualified Language.Marlowe.Runtime.Web.Core.BlockHeader as Web +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import qualified PlutusLedgerApi.V2 as PV2 import Servant.Client.Streaming (ClientM) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Get.hs index 8ce738a444..f65f9a0dbe 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Get.hs @@ -6,10 +6,12 @@ import qualified Control.Monad.Reader as Reader import Data.Functor (void) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (Wallet, getGenesisWallet, runIntegrationTest, runWebClient) -import qualified Language.Marlowe.Runtime.Web as Web + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (getContract) import Language.Marlowe.Runtime.Web.Common (createCloseContract, waitUntilConfirmed) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) import Servant.Client.Streaming (ResponseF (Response, responseStatusCode)) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Next/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Next/Get.hs index a24e81daeb..f8937ee2a8 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Next/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Next/Get.hs @@ -7,12 +7,11 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Control.Monad.Reader as Reader import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (Wallet, getGenesisWallet, runIntegrationTest, runWebClient) -import qualified Language.Marlowe.Runtime.Web.Types as Web import qualified Data.Time as Time +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (getContract, getContractNext) import Language.Marlowe.Runtime.Web.Common (createCloseContract, waitUntilConfirmed) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) import Servant.Client.Streaming (ResponseF (Response, responseStatusCode)) @@ -23,6 +22,8 @@ import Data.Functor (void) import Language.Marlowe.Core.V1.Next (Next (..)) import Language.Marlowe.Core.V1.Next.Applicables (emptyApplicables) import Language.Marlowe.Core.V1.Next.CanReduce (CanReduce (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web spec :: Spec spec = describe "GET /contract/{contractId}/next" $ aroundAll setup do diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs index dd4663edb8..ba0f49f34c 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs @@ -25,14 +25,27 @@ import Data.Text (Text) import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime) import qualified Language.Marlowe.Core.V1.Semantics.Types as V1 import Language.Marlowe.Runtime.Integration.ApplyInputs (utcTimeToPOSIXTime) -import Language.Marlowe.Runtime.Integration.Common +import Language.Marlowe.Runtime.Integration.Common ( + Wallet (addresses), + expectJust, + expectRight, + getGenesisWallet, + runIntegrationTest, + runWebClient, + ) import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), CreateTxEnvelope (..)) -import qualified Language.Marlowe.Runtime.Web as Web +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (FromDTO (..), ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (postContract) -import Language.Marlowe.Runtime.Web.Server.DTO (FromDTO (..), ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Core.Address as Web +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web + +import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web + +import Language.Marlowe.Runtime.Web.Tx.API import Network.URI (parseURI) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Put.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Put.hs index ffe7445a50..af7a8c3385 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Put.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Put.hs @@ -4,15 +4,42 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Time (getCurrentTime, secondsToNominalDiffTime) -import Language.Marlowe.Runtime.Integration.Common +import Language.Marlowe.Runtime.Integration.Common ( + Wallet (Wallet, addresses, signingKeys), + expectJust, + getGenesisWallet, + runIntegrationTest, + runWebClient, + ) import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), RoleTokenConfig (..), RoleTokenRecipient (ClosedRole)) -import qualified Language.Marlowe.Runtime.Web as Web +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (postContract, putContract) import Language.Marlowe.Runtime.Web.Common (signShelleyTransaction') -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web + +import Language.Marlowe.Runtime.Web.Contract.API ( + ContractOrSourceId (ContractOrSourceId), + PostContractsRequest ( + accounts, + contract, + metadata, + minUTxODeposit, + roles, + tags, + threadTokenName, + version + ), + ) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import Language.Marlowe.Runtime.Web.Core.Roles ( + RoleTokenConfig (RoleTokenConfig), + RoleTokenRecipient (ClosedRole), + ) +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web + +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Test.Hspec (Spec, describe, it) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Get.hs index b657600393..dec363c58f 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Get.hs @@ -7,10 +7,12 @@ import Data.Functor (void) import Data.Proxy (Proxy (Proxy)) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (Wallet, getGenesisWallet, runIntegrationTest, runWebClient) -import qualified Language.Marlowe.Runtime.Web as Web + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (Page (..), getContracts) import Language.Marlowe.Runtime.Web.Common (createCloseContract) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) import Servant.Client.Streaming (ResponseF (Response, responseStatusCode)) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs index e8f7c8267e..ce452a0811 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs @@ -8,11 +8,12 @@ import Data.Functor (void) import Data.Proxy (Proxy (Proxy)) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (Wallet, getGenesisWallet, runIntegrationTest, runWebClient) -import qualified Language.Marlowe.Runtime.Web as Web +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (Page (..), getTransactions) import Language.Marlowe.Runtime.Web.Common (applyCloseTransaction, createCloseContract) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web import Language.Marlowe.Runtime.Web.StandardContract (createFullyExecutedStandardContract) +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) import Servant.Client.Streaming (ResponseF (Response, responseStatusCode)) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs index a89a4ffbd8..5e4768871f 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs @@ -7,10 +7,14 @@ import Control.Exception (throw) import Data.Functor (void) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (getGenesisWallet, runIntegrationTest, runWebClient) -import qualified Language.Marlowe.Runtime.Web as Web +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (getTransaction) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Core.Asset as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import qualified Language.Marlowe.Runtime.Web.Payout.API as Web import Language.Marlowe.Runtime.Web.StandardContract (createFullyExecutedStandardContract) + +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) import Servant.Client.Streaming (ResponseF (Response, responseStatusCode)) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs index 005a197f98..f1cafa277c 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs @@ -7,15 +7,31 @@ import qualified Data.Set as Set import Data.Time (getCurrentTime, secondsToNominalDiffTime) import Language.Marlowe.Core.V1.Semantics.Types (Input (NormalInput), InputContent (IDeposit)) import Language.Marlowe.Extended.V1 (ada) -import Language.Marlowe.Runtime.Integration.Common +import Language.Marlowe.Runtime.Integration.Common ( + Wallet (addresses), + expectJust, + getGenesisWallet, + runIntegrationTest, + runWebClient, + ) import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), RoleTokenConfig (..), RoleTokenRecipient (ClosedRole)) -import qualified Language.Marlowe.Runtime.Web as Web +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (postContract, postTransaction) import Language.Marlowe.Runtime.Web.Common (submitContract) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web + +import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import Language.Marlowe.Runtime.Web.Core.Roles ( + RoleTokenConfig (RoleTokenConfig), + RoleTokenRecipient (ClosedRole), + ) +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web + +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Test.Hspec (Spec, describe, it) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs index b2c382990c..0f1a1d2586 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs @@ -16,11 +16,32 @@ import Language.Marlowe.Runtime.Integration.Common ( import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), RoleTokenConfig (..), RoleTokenRecipient (ClosedRole)) -import qualified Language.Marlowe.Runtime.Web as Web +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (postContract, postTransaction, putTransaction) import Language.Marlowe.Runtime.Web.Common (signShelleyTransaction', submitContract) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web + +import Language.Marlowe.Runtime.Web.Contract.API ( + ContractOrSourceId (ContractOrSourceId), + PostContractsRequest ( + accounts, + contract, + metadata, + minUTxODeposit, + roles, + tags, + threadTokenName, + version + ), + ) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import Language.Marlowe.Runtime.Web.Core.Roles ( + RoleTokenConfig (RoleTokenConfig), + RoleTokenRecipient (ClosedRole), + ) +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Test.Hspec (Spec, describe, it) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs index 5559bf287a..cf7525e7cc 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs @@ -19,19 +19,8 @@ import Language.Marlowe.Runtime.Integration.Common (Wallet (..), expectJust) import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web ( - ApplyInputsTxEnvelope, - BlockHeader, - CardanoTxBody, - ContractOrSourceId (..), - CreateTxEnvelope, - PayoutHeader (..), - PayoutStatus (..), - RoleTokenConfig (..), - RoleTokenRecipient (ClosedRole), - WithdrawTxEnvelope, - ) -import qualified Language.Marlowe.Runtime.Web as Web + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (Page (..), getPayouts, postContract, postContractSource) import Language.Marlowe.Runtime.Web.Common ( choose, @@ -42,8 +31,25 @@ import Language.Marlowe.Runtime.Web.Common ( submitWithdrawal, withdraw, ) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) -import Language.Marlowe.Runtime.Web.Types (PostContractSourceResponse (..)) +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import Language.Marlowe.Runtime.Web.Payout.API (PayoutHeader (payoutId), PayoutStatus (..)) + +import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..), PostContractSourceResponse (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import Language.Marlowe.Runtime.Web.Core.BlockHeader ( + BlockHeader, + ) +import qualified Language.Marlowe.Runtime.Web.Core.Metadata as Web +import Language.Marlowe.Runtime.Web.Core.Roles (RoleTokenConfig (..), RoleTokenRecipient (..)) +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web +import Language.Marlowe.Runtime.Web.Tx.API ( + ApplyInputsTxEnvelope (transactionId), + CardanoTxBody, + CreateTxEnvelope (contractId), + WithdrawTxEnvelope, + ) +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Pipes (yield) import Servant.Client.Streaming (ClientM) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs index f88ebb53c9..69ae9eb445 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs @@ -2,12 +2,18 @@ module Language.Marlowe.Runtime.Web.Withdrawal.Post where import Data.Functor (void) import qualified Data.Set as Set -import Language.Marlowe.Runtime.Integration.Common +import Language.Marlowe.Runtime.Integration.Common ( + Wallet (addresses), + getGenesisWallet, + runIntegrationTest, + runWebClient, + ) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (PayoutHeader (..), PayoutStatus (..)) -import qualified Language.Marlowe.Runtime.Web as Web + import Language.Marlowe.Runtime.Web.Client (Page (..), getPayouts, postWithdrawal) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) +import Language.Marlowe.Runtime.Web.Payout.API (PayoutHeader (..), PayoutStatus (..)) import Language.Marlowe.Runtime.Web.StandardContract ( StandardContractChoiceMade (..), StandardContractClosed (..), @@ -16,6 +22,9 @@ import Language.Marlowe.Runtime.Web.StandardContract ( StandardContractNotified (..), createStandardContract, ) + +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Test.Hspec (Spec, describe, it) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs index f1b5cb9b6d..f2a2a2441d 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs @@ -2,13 +2,19 @@ module Language.Marlowe.Runtime.Web.Withdrawal.Put where import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Set as Set -import Language.Marlowe.Runtime.Integration.Common +import Language.Marlowe.Runtime.Integration.Common ( + Wallet (Wallet, addresses, signingKeys), + getGenesisWallet, + runIntegrationTest, + runWebClient, + ) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web (PayoutHeader (..)) -import qualified Language.Marlowe.Runtime.Web as Web + import Language.Marlowe.Runtime.Web.Client (Page (..), getPayouts, postWithdrawal, putWithdrawal) import Language.Marlowe.Runtime.Web.Common (signShelleyTransaction') -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO)) + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) +import Language.Marlowe.Runtime.Web.Payout.API (PayoutHeader (..), PayoutStatus (..)) import Language.Marlowe.Runtime.Web.StandardContract ( StandardContractChoiceMade (..), StandardContractClosed (..), @@ -17,7 +23,9 @@ import Language.Marlowe.Runtime.Web.StandardContract ( StandardContractNotified (..), createStandardContract, ) -import Language.Marlowe.Runtime.Web.Types (PayoutStatus (..)) + +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Test.Hspec (Spec, describe, it) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration/src/Test/Integration/Marlowe/Local.hs b/marlowe-integration/src/Test/Integration/Marlowe/Local.hs index 7190dde55e..7d67de8796 100644 --- a/marlowe-integration/src/Test/Integration/Marlowe/Local.hs +++ b/marlowe-integration/src/Test/Integration/Marlowe/Local.hs @@ -45,13 +45,13 @@ import Colog (cmap, fmtMessage, logTextHandle) import Control.Arrow (returnA) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) -import Control.Concurrent.Component +import Control.Concurrent.Component (Component (unComponent)) import Control.Concurrent.Component.Run (AppM, runAppM) import Control.DeepSeq (NFData) import Control.Exception (bracketOnError, catch, onException, throw, try) import Control.Monad (when, (<=<)) -import Control.Monad.Catch hiding (bracketOnError, catch, onException, try) -import Control.Monad.Event.Class +import Control.Monad.Catch (SomeException (..)) +import Control.Monad.Event.Class (Inject (..), NoopEventT (..)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (ReaderT (..), runReaderT) @@ -116,9 +116,13 @@ import qualified Language.Marlowe.Runtime.Sync.Database as Sync import qualified Language.Marlowe.Runtime.Sync.Database.PostgreSQL as Sync import Language.Marlowe.Runtime.Transaction (mkCommandLineRoleTokenMintingPolicy) import Language.Marlowe.Runtime.Web.Client (healthcheck) -import Language.Marlowe.Runtime.Web.Server (ServerDependencies (..), server) +import Language.Marlowe.Runtime.Web.RuntimeServer (ServerDependencies (..), runtimeServer) import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.Protocol.Connection +import Network.Protocol.Connection ( + Connector, + directConnector, + ihoistConnector, + ) import Network.Protocol.Driver (TcpServerDependencies (TcpServerDependencies), tcpServer) import Network.Protocol.Driver.Trace (HasSpanContext (..)) import Network.Protocol.Peer.Trace (defaultSpanContext) @@ -557,7 +561,7 @@ testContainer = proc TestContainerDependencies{..} -> do -< TcpServerDependencies "127.0.0.1" (fromIntegral proxyPort) serverSource marloweRuntimeServerDirectPeer - server + runtimeServer -< ServerDependencies { openAPIEnabled = False diff --git a/marlowe-runtime-web/app/Main.hs b/marlowe-runtime-web/app/Main.hs index 0bf3101b4b..360afcbf3d 100644 --- a/marlowe-runtime-web/app/Main.hs +++ b/marlowe-runtime-web/app/Main.hs @@ -18,18 +18,67 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Version (showVersion) import Language.Marlowe.Runtime.Client (connectToMarloweRuntimeTraced) -import Language.Marlowe.Runtime.Web.Server -import Network.HTTP.Types +import Language.Marlowe.Runtime.Web.RuntimeServer ( + ServeRequest (..), + ServeRequestField (ReqField, ResField), + ServerDependencies ( + ServerDependencies, + accessControlAllowOriginAll, + connector, + openAPIEnabled, + runApplication + ), + ServerSelector (..), + runtimeServer, + ) +import Network.HTTP.Types ( + HeaderName, + HttpVersion (HttpVersion, httpMajor, httpMinor), + Status (statusCode), + hContentLength, + hUserAgent, + ) import Network.Protocol.Driver.Trace (TcpClientSelector, renderTcpClientSelectorOTel, sockAddrToAttributes) import Network.Socket (PortNumber) -import Network.Wai +import Network.Wai ( + Request ( + httpVersion, + rawPathInfo, + remoteHost, + requestBodyLength, + requestHeaders, + requestMethod + ), + RequestBodyLength (ChunkedBody, KnownLength), + responseHeaders, + responseStatus, + ) import Network.Wai.Handler.Warp ( run, ) import Observe.Event (injectSelector) import Observe.Event.Render.OpenTelemetry (OTelRendered (..), RenderSelectorOTel) -import OpenTelemetry.Trace -import Options +import OpenTelemetry.Trace ( + InstrumentationLibrary ( + InstrumentationLibrary, + libraryName, + libraryVersion + ), + PrimitiveAttribute (IntAttribute, TextAttribute), + SpanKind (Server), + ToAttribute (toAttribute), + ) +import Options ( + Options ( + Options, + accessControlAllowOriginAll, + openAPIEnabled, + port, + runtimeHost, + runtimePort + ), + getOptions, + ) import Paths_marlowe_runtime_web (version) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) @@ -50,7 +99,7 @@ main = do , runApplication = run $ fromIntegral port , connector } - runComponent_ server dependencies + runComponent_ runtimeServer dependencies where instrumentationLibrary = InstrumentationLibrary diff --git a/marlowe-runtime-web/marlowe-runtime-web.cabal b/marlowe-runtime-web/marlowe-runtime-web.cabal index b11616a8da..211ecf66d3 100644 --- a/marlowe-runtime-web/marlowe-runtime-web.cabal +++ b/marlowe-runtime-web/marlowe-runtime-web.cabal @@ -54,27 +54,82 @@ library hs-source-dirs: src visibility: public exposed-modules: - Language.Marlowe.Runtime.Web - Language.Marlowe.Runtime.Web.Client - Language.Marlowe.Runtime.Web.Types - - other-modules: + Language.Marlowe.Runtime.Web.Adapter.ByteString + Language.Marlowe.Runtime.Web.Adapter.CommaList + Language.Marlowe.Runtime.Web.Adapter.Links + Language.Marlowe.Runtime.Web.Adapter.Pagination + Language.Marlowe.Runtime.Web.Adapter.Servant + Language.Marlowe.Runtime.Web.Adapter.Server.ApiError + Language.Marlowe.Runtime.Web.Adapter.Server.ContractClient + Language.Marlowe.Runtime.Web.Adapter.Server.DTO + Language.Marlowe.Runtime.Web.Adapter.Server.Monad + Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient + Language.Marlowe.Runtime.Web.Adapter.Server.TxClient + Language.Marlowe.Runtime.Web.Adapter.Server.Util + Language.Marlowe.Runtime.Web.Adapter.URI Language.Marlowe.Runtime.Web.API - Language.Marlowe.Runtime.Web.Next.Schema - Language.Marlowe.Runtime.Web.Orphans + Language.Marlowe.Runtime.Web.Burn.API + Language.Marlowe.Runtime.Web.Client + Language.Marlowe.Runtime.Web.Contract.API + Language.Marlowe.Runtime.Web.Contract.Next.API + Language.Marlowe.Runtime.Web.Contract.Next.Client + Language.Marlowe.Runtime.Web.Contract.Next.Schema + Language.Marlowe.Runtime.Web.Contract.Next.Server + Language.Marlowe.Runtime.Web.Contract.Server + Language.Marlowe.Runtime.Web.Contract.Source.Server + Language.Marlowe.Runtime.Web.Contract.Transaction.API + Language.Marlowe.Runtime.Web.Contract.Transaction.Server + Language.Marlowe.Runtime.Web.Core.Address + Language.Marlowe.Runtime.Web.Core.Asset + Language.Marlowe.Runtime.Web.Core.Base16 + Language.Marlowe.Runtime.Web.Core.BlockHeader + Language.Marlowe.Runtime.Web.Core.MarloweVersion + Language.Marlowe.Runtime.Web.Core.Metadata + Language.Marlowe.Runtime.Web.Core.NetworkId + Language.Marlowe.Runtime.Web.Core.Object.Schema + Language.Marlowe.Runtime.Web.Core.Party + Language.Marlowe.Runtime.Web.Core.Roles + Language.Marlowe.Runtime.Web.Core.Script + Language.Marlowe.Runtime.Web.Core.Semantics.Schema + Language.Marlowe.Runtime.Web.Core.Tip + Language.Marlowe.Runtime.Web.Core.Tx + Language.Marlowe.Runtime.Web.Payout.API + Language.Marlowe.Runtime.Web.Payout.Server + Language.Marlowe.Runtime.Web.Server + Language.Marlowe.Runtime.Web.Status + Language.Marlowe.Runtime.Web.Tx.API + Language.Marlowe.Runtime.Web.Withdrawal.API + Language.Marlowe.Runtime.Web.Withdrawal.Server build-depends: , aeson ^>=2.2 + , async >=2.2 && <3 + , async-components ==0.1.1.0 , base >=4.9 && <5 , base16 ^>=0.3.2 , bytestring >=0.10.12 && <0.12 + , cardano-api ^>=8.39.2.0 + , cardano-ledger-alonzo ^>=1.6 + , cardano-ledger-binary ^>=1.3 + , cardano-ledger-core ^>=1.10 + , co-log ^>=0.6 , containers ^>=0.6.5 + , errors >=2.3 && <3 + , eventuo11y >=0.9 && <0.11 + , eventuo11y-extras ==0.1.1.0 + , exceptions >=0.10 && <0.12 , http-media ^>=0.8 , lens >=5.2 && <6 , marlowe-cardano ==0.2.1.0 + , marlowe-chain-sync ==0.0.6 + , marlowe-client ==0.0.6 , marlowe-object ==0.2.0.1 + , marlowe-protocols ==0.3.0.0 + , marlowe-runtime:{marlowe-runtime, contract-api, proxy-api, sync-api, tx-api} ==0.0.6 + , monad-control ^>=1 , mtl >=2.2 && <3 , network-uri >=2.6 && <3 + , nonempty-containers ^>=0.3.4 , openapi3 >=3.2 && <4 , parsec ^>=3.1.14 , pipes ^>=4.3.16 @@ -86,8 +141,12 @@ library , servant-pagination >=2.5 && <3 , servant-pipes ^>=0.16 , servant-server ^>=0.20 + , stm ^>=2.5 + , stm-delay ^>=0.1.1 , text ^>=2.0 , time >=1.9 && <2 + , transformers-base ^>=0.4 + , unliftio-core ^>=0.2 , wai >=3.2 && <4 library server @@ -95,71 +154,34 @@ library server hs-source-dirs: server visibility: public exposed-modules: - Language.Marlowe.Runtime.Web.Server - Language.Marlowe.Runtime.Web.Server.DTO - Language.Marlowe.Runtime.Web.Server.Monad - Language.Marlowe.Runtime.Web.Server.OpenAPI - Language.Marlowe.Runtime.Web.Server.Util - - other-modules: - Language.Marlowe.Runtime.Web.Server.ContractClient - Language.Marlowe.Runtime.Web.Server.REST - Language.Marlowe.Runtime.Web.Server.REST.ApiError - Language.Marlowe.Runtime.Web.Server.REST.Contracts - Language.Marlowe.Runtime.Web.Server.REST.Contracts.Next - Language.Marlowe.Runtime.Web.Server.REST.ContractSources - Language.Marlowe.Runtime.Web.Server.REST.Payouts - Language.Marlowe.Runtime.Web.Server.REST.Transactions - Language.Marlowe.Runtime.Web.Server.REST.Withdrawals - Language.Marlowe.Runtime.Web.Server.SyncClient - Language.Marlowe.Runtime.Web.Server.TxClient - Paths_marlowe_runtime_web + Language.Marlowe.Runtime.Web.OpenAPIServer + Language.Marlowe.Runtime.Web.RuntimeServer + other-modules: Paths_marlowe_runtime_web build-depends: , aeson ^>=2.2 - , async >=2.2 && <3 , async-components ==0.1.1.0 , base >=4.9 && <5 - , bytestring >=0.10.12 && <0.12 - , cardano-api ^>=8.39.2.0 - , cardano-ledger-alonzo ^>=1.6 - , cardano-ledger-binary ^>=1.3 - , cardano-ledger-core ^>=1.10 , co-log ^>=0.6 - , containers ^>=0.6.5 - , errors >=2.3 && <3 , eventuo11y >=0.9 && <0.11 , eventuo11y-extras ==0.1.1.0 - , exceptions >=0.10 && <0.12 - , http-media ^>=0.8 , http-types , insert-ordered-containers >=0.2.5 && <0.3 , lens >=5.2 && <6 , lens-aeson ^>=1.2 - , marlowe-cardano ==0.2.1.0 , marlowe-chain-sync ==0.0.6 - , marlowe-client ==0.0.6 - , marlowe-object ==0.2.0.1 , marlowe-protocols ==0.3.0.0 , marlowe-runtime-web ==0.0.6 - , marlowe-runtime:{marlowe-runtime, contract-api, proxy-api, sync-api, tx-api} ==0.0.6 - , monad-control ^>=1 + , marlowe-runtime:{marlowe-runtime, proxy-api, sync-api} ==0.0.6 , mtl >=2.2 && <3 - , nonempty-containers ^>=0.3.4 , openapi3 >=3.2 && <4 - , pipes ^>=4.3.16 - , plutus-ledger-api ^>=1.21 , servant ^>=0.20 , servant-openapi3 ^>=2.0 , servant-pagination >=2.5 && <3 , servant-pipes ^>=0.16 , servant-server ^>=0.20 - , stm ^>=2.5 - , stm-delay ^>=0.1.1 , string-conversions ^>=0.4 , text ^>=2.0 - , time >=1.9 && <2 - , transformers-base ^>=0.4 , unliftio-core ^>=0.2 , wai >=3.2 && <4 , wai-cors ^>=0.2 diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/OpenAPIServer.hs similarity index 87% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs rename to marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/OpenAPIServer.hs index 732582d559..7bf57d42c4 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/OpenAPI.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/OpenAPIServer.hs @@ -6,20 +6,70 @@ -- | This module defines the API and server for serving the Open API -- specification. -module Language.Marlowe.Runtime.Web.Server.OpenAPI where +module Language.Marlowe.Runtime.Web.OpenAPIServer where import Control.Applicative ((<|>)) -import Control.Lens hiding (allOf, anyOf) +import Control.Lens ((%~), (&), (.~), (?~)) import qualified Control.Lens as Optics import Control.Monad.Reader (ReaderT (runReaderT)) import qualified Control.Monad.Reader as Reader import qualified Control.Monad.Trans as Trans -import Data.Aeson -import Data.Aeson.Lens +import Data.Aeson (ToJSON (toJSON), Value (Array)) +import Data.Aeson.Lens (atKey, key, members) import qualified Data.HashMap.Strict.InsOrd as IOHM import qualified Data.List as List import qualified Data.Maybe as Maybe -import Data.OpenApi hiding (Server) +import Data.OpenApi ( + Definitions, + HasComponents (components), + HasContent (content), + HasDefault (default_), + HasDelete (delete), + HasDescription (description), + HasEnum (enum_), + HasGet (get), + HasHead (head_), + HasHeaders (headers), + HasInfo (info), + HasItems (items), + HasLicense (license), + HasName (name), + HasOneOf (oneOf), + HasOpenapi (openapi), + HasOptions (options), + HasParameters (parameters), + HasPatch (patch), + HasPaths (paths), + HasPost (post), + HasProperties (properties), + HasPut (put), + HasRequestBodies (requestBodies), + HasRequestBody (requestBody), + HasRequired (required), + HasResponses (responses), + HasSchema (schema), + HasSchemas (schemas), + HasServers (servers), + HasTitle (title), + HasTrace (trace), + HasType (type_), + HasVersion (version), + Header, + License (License, _licenseName, _licenseUrl), + MediaTypeObject, + OpenApi, + OpenApiItems (OpenApiItemsObject), + OpenApiType (OpenApiArray, OpenApiString), + Operation, + Param, + Reference (Reference), + Referenced (..), + RequestBody, + Response, + Schema, + ToParamSchema (..), + URL (URL), + ) import Data.OpenApi.Internal (OpenApiSpecVersion (..)) import Data.String (fromString) import Data.Text (Text) @@ -28,11 +78,17 @@ import qualified Data.Text as Text import Data.Version (makeVersion, showVersion) import GHC.Exts (toList) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import qualified Language.Marlowe.Runtime.Web as Web +import qualified Language.Marlowe.Runtime.Web.API as Web import qualified Paths_marlowe_runtime_web -import Servant hiding (Param) +import Servant ( + Get, + HasServer (ServerT), + JSON, + Proxy (..), + type (:>), + ) import Servant.OpenApi (toOpenApi) -import Servant.Pagination +import Servant.Pagination (AcceptRanges, ContentRange, Ranges) instance ToParamSchema (Ranges fields resource) where toParamSchema _ = @@ -260,7 +316,7 @@ lintOpenApi oa = schemaDefinitionLints <> pathParametersLints <> pathOperationLi openApi :: OpenApiWithEmptySecurity openApi = OpenApiWithEmptySecurity $ - toOpenApi Web.api + toOpenApi Web.runtimeApi & info %~ (title .~ "Marlowe Runtime REST API") . (version .~ T.pack (showVersion Paths_marlowe_runtime_web.version)) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs similarity index 83% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs rename to marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs index c86c7dc647..9fb03ea36a 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs @@ -12,21 +12,25 @@ -- | This module defines the top-level aggregate process (HTTP server and -- worker processes) for running the web server. -module Language.Marlowe.Runtime.Web.Server ( - APIWithOpenAPI, +module Language.Marlowe.Runtime.Web.RuntimeServer ( + RuntimeAPIWithOpenAPI, ServeRequest (..), ServeRequestField (..), ServerDependencies (..), ServerSelector (..), - server, - serverWithOpenAPI, + runtimeServer, + runtimeServerWithOpenAPI, ) where import Colog (LogAction, Message, cmap, fmtMessage, logException, logTextStdout, usingLoggerT) -import Control.Concurrent.Component +import Control.Concurrent.Component (Component, component_) import Control.Concurrent.Component.Run (AppM (..)) import Control.Exception (Exception (..), SomeException (..), catch) -import Control.Monad.Event.Class +import Control.Monad.Event.Class ( + Inject (..), + MonadEvent (askBackend), + withEventFields, + ) import Control.Monad.IO.Unlift (liftIO, withRunInIO) import Control.Monad.Reader (ReaderT (ReaderT), runReaderT) import Data.Aeson (Value (..), (.=)) @@ -38,20 +42,20 @@ import Language.Marlowe.Protocol.Query.Client (getStatus) import Language.Marlowe.Protocol.Types (MarloweRuntime) import Language.Marlowe.Runtime.ChainSync.Api (TxId) import Language.Marlowe.Runtime.Core.Api (ContractId) -import Language.Marlowe.Runtime.Web (RuntimeStatus) -import qualified Language.Marlowe.Runtime.Web as Web -import Language.Marlowe.Runtime.Web.Server.ContractClient ( +import qualified Language.Marlowe.Runtime.Web.API as Web ( + RuntimeAPI, + runtimeApi, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.ContractClient ( ContractClient (..), ContractClientDependencies (..), GetContract, ImportBundle, contractClient, ) -import Language.Marlowe.Runtime.Web.Server.DTO (toDTO) -import Language.Marlowe.Runtime.Web.Server.Monad (AppEnv (..), ServerM (..)) -import qualified Language.Marlowe.Runtime.Web.Server.OpenAPI as OpenAPI -import qualified Language.Marlowe.Runtime.Web.Server.REST as REST -import Language.Marlowe.Runtime.Web.Server.SyncClient ( +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (toDTO) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad (AppEnv (..), ServerM (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient ( LoadContract, LoadContractHeaders, LoadPayout, @@ -64,7 +68,7 @@ import Language.Marlowe.Runtime.Web.Server.SyncClient ( SyncClientDependencies (..), syncClient, ) -import Language.Marlowe.Runtime.Web.Server.TxClient ( +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient ( ApplyInputs, CreateContract, Submit, @@ -73,6 +77,11 @@ import Language.Marlowe.Runtime.Web.Server.TxClient ( Withdraw, txClient, ) +import qualified Language.Marlowe.Runtime.Web.OpenAPIServer as OpenAPI +import qualified Language.Marlowe.Runtime.Web.Server as REST + +import Language.Marlowe.Runtime.Web.Core.Object.Schema () +import Language.Marlowe.Runtime.Web.Status (RuntimeStatus) import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (badGateway502, internalServerError500) import Network.Protocol.Connection (Connector, runConnector) @@ -84,7 +93,21 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsRes import Observe.Event (reference) import Observe.Event.Backend (Event (addField)) import Observe.Event.Explicit (injectSelector) -import Servant hiding (Server, respond) +import Servant ( + Application, + Context (EmptyContext, (:.)), + ErrorFormatter, + ErrorFormatters (bodyParserErrorFormatter), + HasServer (ServerT, hoistServerWithContext), + JSON, + Proxy (..), + ServerError (errBody, errHeaders), + defaultErrorFormatters, + err400, + getAcceptHeader, + serveWithContext, + type (:<|>) (..), + ) import Servant.API.ContentTypes (handleAcceptH) import Servant.Pipes () @@ -104,13 +127,13 @@ data ServerSelector transport f where instance Inject ServeRequest (ServerSelector transport) where inject = injectSelector Http -type APIWithOpenAPI = OpenAPI.API :<|> Web.API +type RuntimeAPIWithOpenAPI = OpenAPI.API :<|> Web.RuntimeAPI -apiWithOpenApi :: Proxy APIWithOpenAPI -apiWithOpenApi = Proxy +runtimeApiWithOpenApi :: Proxy RuntimeAPIWithOpenAPI +runtimeApiWithOpenApi = Proxy -serverWithOpenAPI :: ServerT APIWithOpenAPI ServerM -serverWithOpenAPI = OpenAPI.server :<|> REST.server +runtimeServerWithOpenAPI :: ServerT RuntimeAPIWithOpenAPI ServerM +runtimeServerWithOpenAPI = OpenAPI.server :<|> REST.server customFormatters :: ErrorFormatters customFormatters = @@ -187,8 +210,8 @@ data ServerDependencies r s = ServerDependencies access to some resources from the other worker processes. -} -server :: (Inject ServeRequest s) => Component (AppM r s) (ServerDependencies r s) () -server = proc deps@ServerDependencies{connector} -> do +runtimeServer :: (Inject ServeRequest s) => Component (AppM r s) (ServerDependencies r s) () +runtimeServer = proc deps@ServerDependencies{connector} -> do TxClient{..} <- txClient -< TxClientDependencies{..} SyncClient{..} <- syncClient @@ -269,8 +292,8 @@ webServer = component_ "web-server" \WebServerDependencies{..} -> withRunInIO \r let _logAction = cmap fmtMessage logTextStdout let middleware = corsMiddleware accessControlAllowOriginAll . exceptionMiddleware _logAction let mkApp - | openAPIEnabled = serveServerM getStatusIO apiWithOpenApi AppEnv{..} serverWithOpenAPI - | otherwise = serveServerM getStatusIO Web.api AppEnv{..} REST.server + | openAPIEnabled = serveServerM getStatusIO runtimeApiWithOpenApi AppEnv{..} runtimeServerWithOpenAPI + | otherwise = serveServerM getStatusIO Web.runtimeApi AppEnv{..} REST.server liftIO $ middleware mkApp req \res -> runInIO do addField ev $ ResField res liftIO $ handleRes res diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST.hs deleted file mode 100644 index 12b8bbd95d..0000000000 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - --- | This module defines a server for the root REST API. -module Language.Marlowe.Runtime.Web.Server.REST where - -import Language.Marlowe.Runtime.Web -import Language.Marlowe.Runtime.Web.Server.Monad (ServerM) -import qualified Language.Marlowe.Runtime.Web.Server.REST.Contracts as Contracts -import qualified Language.Marlowe.Runtime.Web.Server.REST.Payouts as Payouts -import qualified Language.Marlowe.Runtime.Web.Server.REST.Withdrawals as Withdrawals -import Servant - -server :: ServerT API ServerM -server = Contracts.server :<|> Withdrawals.server :<|> Payouts.server :<|> healthcheckServer - -healthcheckServer :: ServerM NoContent -healthcheckServer = pure NoContent diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web.hs deleted file mode 100644 index ccb23c18dc..0000000000 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Language.Marlowe.Runtime.Web ( - module Language.Marlowe.Runtime.Web.API, - module Language.Marlowe.Runtime.Web.Types, -) where - -import Language.Marlowe.Runtime.Web.API -import Language.Marlowe.Runtime.Web.Types diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs index 2b26905877..d7029e47b9 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs @@ -15,113 +15,154 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | This module specifies the Marlowe Runtime Web API as a Servant API type. -module Language.Marlowe.Runtime.Web.API where +module Language.Marlowe.Runtime.Web.API (runtimeApi, RuntimeAPI) where -import Control.Lens hiding ((.=)) +import Control.Lens (Bifunctor (bimap)) import Control.Monad (guard, replicateM, unless, (<=<)) -import Data.Aeson +import Data.Aeson ( + FromJSON (parseJSON), + KeyValue ((.=)), + ToJSON (toJSON), + eitherDecode, + encode, + object, + withObject, + (.:), + ) import Data.Aeson.Types (parseFail) -import qualified Data.Aeson.Types as A import Data.Bits (Bits (shiftL), (.|.)) import qualified Data.ByteString as BS import Data.Char (digitToInt) import Data.Functor (void, ($>)) +import Data.Kind (Type) import qualified Data.Map as Map -import Data.OpenApi ( - Definitions, - NamedSchema (..), - OpenApiType (..), - Referenced (..), - Schema, - ToSchema, - allOperations, - declareNamedSchema, - declareSchemaRef, - operationId, - properties, - required, - type_, - ) -import Data.OpenApi.Declare (Declare) import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Typeable (Typeable) +import Data.Text.Encoding (encodeUtf8) import Data.Version (Version) import Data.Word (Word8) import GHC.Base (Symbol) -import GHC.Exts (IsList (..)) -import GHC.Generics (Generic) -import GHC.Show (showSpace) import GHC.TypeLits (KnownSymbol, symbolVal) -import Language.Marlowe.Core.V1.Next -import Language.Marlowe.Runtime.Web.Next.Schema () +import Language.Marlowe.Runtime.Web.Adapter.Servant ( + OperationId, + RenameResponseSchema, + WithRuntimeStatus, + ) -import Data.Kind (Type) -import Data.Text.Encoding (encodeUtf8) -import Language.Marlowe.Core.V1.Semantics.Types (Contract) -import Language.Marlowe.Object.Types (Label, ObjectBundle) -import Language.Marlowe.Runtime.Web.Types -import Network.HTTP.Media ((//)) +import Language.Marlowe.Runtime.Web.Adapter.Links ( + FromJSONWithLinks (..), + HasLinkParser (..), + ToJSONWithLinks (..), + WithLink (..), + ) +import Language.Marlowe.Runtime.Web.Contract.API ( + ContractHeader (..), + ContractState (..), + ContractsAPI, + GetContractAPI, + PostContractsResponse, + ) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () +import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( + GetTransactionAPI, + GetTransactionsAPI, + PostTransactionsResponse, + ) + +import Language.Marlowe.Runtime.Web.Payout.API (GetPayoutAPI, PayoutHeader (..), PayoutState (..), PayoutsAPI) + +import Language.Marlowe.Runtime.Web.Core.NetworkId +import Language.Marlowe.Runtime.Web.Core.Tip +import Language.Marlowe.Runtime.Web.Core.Tx +import Language.Marlowe.Runtime.Web.Status +import Language.Marlowe.Runtime.Web.Tx.API +import Language.Marlowe.Runtime.Web.Withdrawal.API ( + GetWithdrawalAPI, + PostWithdrawalsResponse, + WithdrawalHeader (..), + WithdrawalsAPI, + ) import Network.Wai (mapResponseHeaders) -import Pipes (Producer) -import Servant +import Servant ( + Capture, + Capture', + Context ((:.)), + Description, + FromHttpApiData (parseUrlPiece), + Get, + HasLink (..), + HasServer (..), + Header, + Header', + Headers, + IsElem, + JSON, + Link, + MimeRender, + NoContent, + Proxy (..), + Stream, + Summary, + ToHttpApiData (toUrlPiece), + Verb, + linkURI, + safeLink, + type (:<|>), + type (:>), + ) +import Servant.API (MimeRender (..), MimeUnrender) +import Servant.API.ContentTypes (MimeUnrender (..)) import Servant.Client (HasClient (..)) import Servant.Client.Core (RunClient) import Servant.OpenApi (HasOpenApi (toOpenApi)) -import Servant.Pagination +import Servant.Pagination ( + AcceptRanges (..), + ContentRange (ContentRange), + HasPagination (RangeType), + ) import Servant.Server.Internal.RouteResult (RouteResult (..)) import Servant.Server.Internal.RoutingApplication (RoutingApplication) import Text.Parsec (char, digit, eof, hexDigit, many1, runParser, string) import Text.Parsec.String (Parser) import Text.Read (readMaybe) -api :: Proxy API -api = Proxy +runtimeApi :: Proxy RuntimeAPI +runtimeApi = Proxy -data WithRuntimeStatus api - -data OperationId (name :: Symbol) - -data RenameResponseSchema (name :: Symbol) - -data RenameSchema (name :: Symbol) a - -instance (KnownSymbol name, ToSchema a) => ToSchema (RenameSchema name a) where - declareNamedSchema _ = do - NamedSchema _ schema <- declareNamedSchema $ Proxy @a - pure $ NamedSchema (Just $ T.pack $ symbolVal $ Proxy @name) schema - -instance (HasServer sub ctx) => HasServer (OperationId name :> sub) ctx where - type ServerT (OperationId name :> sub) m = ServerT sub m - route _ = route $ Proxy @sub - hoistServerWithContext _ = hoistServerWithContext $ Proxy @sub +type RuntimeAPI = + WithRuntimeStatus + ( "contracts" :> ContractsAPI + :<|> "withdrawals" :> WithdrawalsAPI + :<|> "payouts" :> PayoutsAPI + -- :<|> "role-tokens" :> "burn" :> BurnsAPI + :<|> "healthcheck" + :> ( Summary "Test server status" + :> Description "Check if the server is running and ready to respond to requests." + :> OperationId "healthcheck" + :> Get '[JSON] NoContent + ) + ) -instance (HasClient m api) => HasClient m (OperationId name :> api) where - type Client m (OperationId name :> api) = Client m api - clientWithRoute m _ = clientWithRoute m $ Proxy @api - hoistClientMonad m _ = hoistClientMonad m $ Proxy @api +-- | Todo : Move these MimeRender and MimeUnrender instances to their appropriate module +-- | For now, they are here because toJSON `WithLink" has a dependency on these RuntimeApi types and runtimeApi` +instance MimeRender (TxJSON ApplyInputsTx) (PostTransactionsResponse CardanoTx) where + mimeRender _ = encode . toJSON -instance (KnownSymbol name, HasOpenApi api) => HasOpenApi (OperationId name :> api) where - toOpenApi _ = - toOpenApi (Proxy @api) - & allOperations . operationId ?~ T.pack (symbolVal $ Proxy @name) +instance MimeUnrender (TxJSON ApplyInputsTx) (PostTransactionsResponse CardanoTx) where + mimeUnrender _ = eitherDecode -instance (HasServer sub ctx) => HasServer (RenameResponseSchema name :> sub) ctx where - type ServerT (RenameResponseSchema name :> sub) m = ServerT sub m - route _ = route $ Proxy @sub - hoistServerWithContext _ = hoistServerWithContext $ Proxy @sub +instance MimeRender (TxJSON ContractTx) (PostContractsResponse CardanoTx) where + mimeRender _ = encode . toJSON -instance (HasClient m api) => HasClient m (RenameResponseSchema name :> api) where - type Client m (RenameResponseSchema name :> api) = Client m api - clientWithRoute m _ = clientWithRoute m $ Proxy @api - hoistClientMonad m _ = hoistClientMonad m $ Proxy @api +instance MimeUnrender (TxJSON ContractTx) (PostContractsResponse CardanoTx) where + mimeUnrender _ = eitherDecode -instance (KnownSymbol name, HasOpenApi (AddRenameSchema name api)) => HasOpenApi (RenameResponseSchema name :> api) where - toOpenApi _ = toOpenApi $ Proxy @(AddRenameSchema name api) +instance MimeRender (TxJSON WithdrawTx) (PostWithdrawalsResponse CardanoTx) where + mimeRender _ = encode . toJSON -type instance IsElem' e (WithRuntimeStatus api) = IsElem e api +instance MimeUnrender (TxJSON WithdrawTx) (PostWithdrawalsResponse CardanoTx) where + mimeUnrender _ = eitherDecode instance (HasServer api ctx) => HasServer (WithRuntimeStatus api) (IO RuntimeStatus ': ctx) where type ServerT (WithRuntimeStatus api) m = ServerT api m @@ -166,16 +207,6 @@ type family AddStatusHeaders api where Stream method status framing ct (Headers (AppendStatusHeaders hs) a) AddStatusHeaders (Stream cTypes status framing ct a) = Stream cTypes status framing ct (Headers StatusHeaders a) -type family AddRenameSchema name api where - AddRenameSchema name (path :> api) = path :> AddRenameSchema name api - AddRenameSchema name (a :<|> b) = AddRenameSchema name a :<|> AddRenameSchema name b - AddRenameSchema name (Verb method cTypes status (Headers hs a)) = - Verb method cTypes status (Headers hs (RenameSchema name a)) - AddRenameSchema name (Verb method cTypes status a) = Verb method cTypes status (RenameSchema name a) - AddRenameSchema name (Stream method status framing ct (Headers hs a)) = - Stream method status framing ct (Headers hs (RenameSchema name a)) - AddRenameSchema name (Stream cTypes status framing ct a) = Stream cTypes status framing ct (RenameSchema name a) - instance (RunClient m, HasClient m (AddStatusHeaders api)) => HasClient m (WithRuntimeStatus api) where type Client m (WithRuntimeStatus api) = Client m (AddStatusHeaders api) clientWithRoute m _ = clientWithRoute m $ Proxy @(AddStatusHeaders api) @@ -184,242 +215,33 @@ instance (RunClient m, HasClient m (AddStatusHeaders api)) => HasClient m (WithR instance (HasOpenApi (AddStatusHeaders api)) => HasOpenApi (WithRuntimeStatus api) where toOpenApi _ = toOpenApi $ Proxy @(AddStatusHeaders api) --- | The REST API of the Marlowe Runtime -type API = - WithRuntimeStatus - ( "contracts" :> ContractsAPI - :<|> "withdrawals" :> WithdrawalsAPI - :<|> "payouts" :> PayoutsAPI - :<|> "role-token-burns" :> BurnsAPI - :<|> "healthcheck" - :> ( Summary "Test server status" - :> Description "Check if the server is running and ready to respond to requests." - :> OperationId "healthcheck" - :> Get '[JSON] NoContent - ) - ) - --- | /role-token-burns sub-API -type BurnsAPI = - BurnsAPI - :<|> PostBurnsAPI - :<|> Capture "burnId" TxId :> BurnAPI - --- | POST /role-token-burns sub-API -type PostBurnsAPI = - Summary "Burn role tokens" - :> Description - "Build an unsigned (Cardano) transaction body which burns role tokens matching a filter. \ - \Role tokens used by active contracts will not be burned and the request will fail if active role tokens are included. \ - \To submit the signed transaction, use the PUT /role-token-burns/{burnId} endpoint." - :> OperationId "burnRoleTokens" - :> RenameResponseSchema "BurnRoleTokensResponse" - :> ( ReqBody '[JSON] PostBurnRequest :> PostTxAPI (PostCreated '[JSON] (PostBurnResponse CardanoTxBody)) - :<|> ReqBody '[JSON] PostBurnRequest - :> PostTxAPI (PostCreated '[TxJSON BurnTx] (PostBurnResponse CardanoTx)) - ) - --- | /contracts sub-API -type ContractsAPI = - GetContractsAPI - :<|> PostContractsAPI - :<|> Capture "contractId" TxOutRef :> ContractAPI - :<|> "sources" :> ContractSourcesAPI - --- | /withdrawals sub-API -type WithdrawalsAPI = - GetWithdrawalsAPI - :<|> PostWithdrawalsAPI - :<|> Capture "withdrawalId" TxId :> WithdrawalAPI - --- | /payouts sub-API -type PayoutsAPI = - GetPayoutsAPI - :<|> Capture "payoutId" TxOutRef :> GetPayoutAPI - --- | GET /contracts sub-API -type GetContractsAPI = - Summary "Get contracts" - :> Description - "Get contracts published on chain. \ - \Results are returned in pages, with paging being specified by request headers." - :> OperationId "getContracts" - :> QueryParams "roleCurrency" PolicyId - :> QueryParams "tag" Text - :> QueryParams "partyAddress" Address - :> QueryParams "partyRole" AssetId - :> RenameResponseSchema "GetContractsResponse" - :> PaginatedGet '["contractId"] GetContractsResponse - -type GetContractsResponse = WithLink "transactions" (WithLink "contract" ContractHeader) - -instance HasNamedLink ContractHeader API "contract" where +instance HasNamedLink ContractHeader RuntimeAPI "contract" where type - Endpoint ContractHeader API "contract" = + Endpoint ContractHeader RuntimeAPI "contract" = "contracts" :> Capture "contractId" TxOutRef :> GetContractAPI namedLink _ _ mkLink ContractHeader{..} = Just $ mkLink contractId -instance HasNamedLink ContractHeader API "transactions" where +instance HasNamedLink ContractHeader RuntimeAPI "transactions" where type - Endpoint ContractHeader API "transactions" = + Endpoint ContractHeader RuntimeAPI "transactions" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" :> GetTransactionsAPI namedLink _ _ mkLink ContractHeader{..} = guard (status == Confirmed) $> mkLink contractId -type PostContractsResponse tx = WithLink "contract" (CreateTxEnvelope tx) - -data TxJSON a - -data ContractTx - -instance Accept (TxJSON ContractTx) where - contentType _ = "application" // "vendor.iog.marlowe-runtime.contract-tx-json" - -instance MimeRender (TxJSON ContractTx) (PostContractsResponse CardanoTx) where - mimeRender _ = encode . toJSON - -instance MimeUnrender (TxJSON ContractTx) (PostContractsResponse CardanoTx) where - mimeUnrender _ = eitherDecode - -instance HasNamedLink (CreateTxEnvelope tx) API "contract" where +instance HasNamedLink (CreateTxEnvelope tx) RuntimeAPI "contract" where type - Endpoint (CreateTxEnvelope tx) API "contract" = + Endpoint (CreateTxEnvelope tx) RuntimeAPI "contract" = "contracts" :> Capture "contractId" TxOutRef :> GetContractAPI namedLink _ _ mkLink CreateTxEnvelope{..} = Just $ mkLink contractId --- | POST /contracts sub-API -type PostContractsAPI = - Summary "Create a new contract" - :> Description - "Build an unsigned (Cardano) transaction body which opens a new Marlowe contract. \ - \This unsigned transaction must be signed by a wallet (such as a CIP-30 or CIP-45 wallet) before being submitted. \ - \To submit the signed transaction, use the PUT /contracts/{contractId} endpoint." - :> OperationId "createContract" - :> RenameResponseSchema "CreateContractResponse" - :> Header' - '[Optional, Strict, Description "Where to send staking rewards for the Marlowe script outputs of this contract."] - "X-Stake-Address" - StakeAddress - :> ( ReqBody '[JSON] PostContractsRequest :> PostTxAPI (PostCreated '[JSON] (PostContractsResponse CardanoTxBody)) - :<|> ReqBody '[JSON] PostContractsRequest :> PostTxAPI (PostCreated '[TxJSON ContractTx] (PostContractsResponse CardanoTx)) - ) - --- | /contracts/:contractId sub-API -type ContractAPI = - GetContractAPI - :<|> Summary "Submit contract to chain" - :> Description - "Submit a signed (Cardano) transaction that opens a new Marlowe contract. \ - \The transaction must have originally been created by the POST /contracts endpoint. \ - \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ - \it will not wait for the transaction to be published in a block. \ - \Use the GET /contracts/{contractId} endpoint to poll the on-chain status." - :> OperationId "submitContract" - :> PutSignedTxAPI - :<|> "next" :> NextAPI - :<|> "transactions" :> TransactionsAPI - --- | GET /contracts/:contractId sub-API -type GetContractAPI = - Summary "Get contract by ID" - :> OperationId "getContractById" - :> RenameResponseSchema "GetContractResponse" - :> Get '[JSON] GetContractResponse - -type GetContractResponse = WithLink "transactions" ContractState - -instance HasNamedLink ContractState API "transactions" where +instance HasNamedLink ContractState RuntimeAPI "transactions" where type - Endpoint ContractState API "transactions" = + Endpoint ContractState RuntimeAPI "transactions" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" :> GetTransactionsAPI namedLink _ _ mkLink ContractState{..} = guard (status == Confirmed) $> mkLink contractId -type NextAPI = GETNextContinuationAPI - --- | GET /contracts/:contractId/next/continuation sub-API -type GETNextContinuationAPI = - Summary "Get next contract steps" - :> Description "Get inputs which could be performed on a contract withing a time range by the requested parties." - :> OperationId "getNextStepsForContract" - :> QueryParam' '[Required, Description "The beginning of the validity range."] "validityStart" UTCTime - :> QueryParam' '[Required, Description "The end of the validity range."] "validityEnd" UTCTime - :> QueryParams "party" Party - :> Get '[JSON] Next - --- | /contracts/sources sub-API -type ContractSourcesAPI = - PostContractSourcesAPI - :<|> Capture "contractSourceId" ContractSourceId :> ContractSourceAPI - --- | /contracts/sources/:contractSourceId sub-API -type ContractSourceAPI = - GetContractSourceAPI - :<|> "adjacency" - :> Summary "Get adjacent contract source IDs by ID" - :> Description - "Get the contract source IDs which are adjacent to a contract source (they appear directly in the contract source)." - :> OperationId "getContractSourceAdjacency" - :> GetContractSourceIdsAPI - :<|> "closure" - :> Summary "Get contract source closure by ID" - :> Description - "Get the contract source IDs which appear in the full hierarchy of a contract source (including the ID of the contract source its self)." - :> OperationId "getContractSourceClosure" - :> GetContractSourceIdsAPI - -type PostContractSourcesAPI = - Summary "Upload contract sources" - :> Description - "Upload a bundle of marlowe objects as contract sources. This API supports request body streaming, with newline \ - \framing between request bundles." - :> OperationId "createContractSources" - :> QueryParam' '[Required, Description "The label of the top-level contract object in the bundle(s)."] "main" Label - :> StreamBody NewlineFraming JSON (Producer ObjectBundle IO ()) - :> Post '[JSON] PostContractSourceResponse - -type GetContractSourceAPI = - Summary "Get contract source by ID" - :> OperationId "getContractSourceById" - :> QueryFlag "expand" - :> Get '[JSON] Contract - -type GetContractSourceIdsAPI = RenameResponseSchema "ContractSourceIds" :> Get '[JSON] (ListObject ContractSourceId) - --- | /contracts/:contractId/transactions sub-API -type TransactionsAPI = - GetTransactionsAPI - :<|> PostTransactionsAPI - :<|> Capture "transactionId" TxId :> TransactionAPI - -data ApplyInputsTx - -instance Accept (TxJSON ApplyInputsTx) where - contentType _ = "application" // "vendor.iog.marlowe-runtime.apply-inputs-tx-json" - -instance MimeRender (TxJSON ApplyInputsTx) (PostTransactionsResponse CardanoTx) where - mimeRender _ = encode . toJSON - -instance MimeUnrender (TxJSON ApplyInputsTx) (PostTransactionsResponse CardanoTx) where - mimeUnrender _ = eitherDecode - --- | POST /contracts/:contractId/transactions sub-API -type PostTransactionsAPI = - Summary "Apply inputs to contract" - :> Description - "Build an unsigned (Cardano) transaction body which applies inputs to an open Marlowe contract. \ - \This unsigned transaction must be signed by a wallet (such as a CIP-30 or CIP-45 wallet) before being submitted. \ - \To submit the signed transaction, use the PUT /contracts/{contractId}/transactions/{transactionId} endpoint." - :> OperationId "applyInputsToContract" - :> RenameResponseSchema "ApplyInputsResponse" - :> ( ReqBody '[JSON] PostTransactionsRequest :> PostTxAPI (PostCreated '[JSON] (PostTransactionsResponse CardanoTxBody)) - :<|> ReqBody '[JSON] PostTransactionsRequest - :> PostTxAPI (PostCreated '[TxJSON ApplyInputsTx] (PostTransactionsResponse CardanoTx)) - ) - -type PostTransactionsResponse tx = WithLink "transaction" (ApplyInputsTxEnvelope tx) - -instance HasNamedLink (ApplyInputsTxEnvelope tx) API "transaction" where +instance HasNamedLink (ApplyInputsTxEnvelope tx) RuntimeAPI "transaction" where type - Endpoint (ApplyInputsTxEnvelope tx) API "transaction" = + Endpoint (ApplyInputsTxEnvelope tx) RuntimeAPI "transaction" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" @@ -427,21 +249,9 @@ instance HasNamedLink (ApplyInputsTxEnvelope tx) API "transaction" where :> GetTransactionAPI namedLink _ _ mkLink ApplyInputsTxEnvelope{..} = Just $ mkLink contractId transactionId --- | GET /contracts/:contractId/transactions sub-API -type GetTransactionsAPI = - Summary "Get transactions for contract" - :> Description - "Get published transactions for a contract. \ - \Results are returned in pages, with paging being specified by request headers." - :> OperationId "getTransactionsForContract" - :> RenameResponseSchema "GetTransactionsResponse" - :> PaginatedGet '["transactionId"] GetTransactionsResponse - -type GetTransactionsResponse = WithLink "transaction" TxHeader - -instance HasNamedLink TxHeader API "transaction" where +instance HasNamedLink TxHeader RuntimeAPI "transaction" where type - Endpoint TxHeader API "transaction" = + Endpoint TxHeader RuntimeAPI "transaction" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" @@ -449,33 +259,9 @@ instance HasNamedLink TxHeader API "transaction" where :> GetTransactionAPI namedLink _ _ mkLink TxHeader{..} = Just $ mkLink contractId transactionId --- | /contracts/:contractId/transactions/:transactionId sub-API -type TransactionAPI = - GetTransactionAPI - :<|> Summary "Submit contract input application" - :> Description - "Submit a signed (Cardano) transaction that applies inputs to an open Marlowe contract. \ - \The transaction must have originally been created by the POST /contracts/{contractId}/transactions endpoint. \ - \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ - \it will not wait for the transaction to be published in a block. \ - \Use the GET /contracts/{contractId}/transactions/{transactionId} endpoint to poll the on-chain status." - :> OperationId "submitContractTransaction" - :> PutSignedTxAPI - --- | GET /contracts/:contractId/transactions/:transactionId sub-API -type GetTransactionAPI = - Summary "Get contract transaction by ID" - :> OperationId "getContractTransactionById" - :> RenameResponseSchema "GetTransactionResponse" - :> Get '[JSON] GetTransactionResponse - -type GetTransactionResponse = WithLink "previous" (WithLink "next" Tx) - -type PutSignedTxAPI = ReqBody '[JSON] TextEnvelope :> PutAccepted '[JSON] NoContent - -instance HasNamedLink Tx API "previous" where +instance HasNamedLink Tx RuntimeAPI "previous" where type - Endpoint Tx API "previous" = + Endpoint Tx RuntimeAPI "previous" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" @@ -483,9 +269,9 @@ instance HasNamedLink Tx API "previous" where :> GetTransactionAPI namedLink _ _ mkLink Tx{..} = guard (inputUtxo /= contractId) $> mkLink contractId (txId inputUtxo) -instance HasNamedLink Tx API "next" where +instance HasNamedLink Tx RuntimeAPI "next" where type - Endpoint Tx API "next" = + Endpoint Tx RuntimeAPI "next" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" @@ -493,66 +279,27 @@ instance HasNamedLink Tx API "next" where :> GetTransactionAPI namedLink _ _ mkLink Tx{..} = mkLink contractId <$> consumingTx --- | GET /contracts/:contractId/withdrawals sub-API -type GetWithdrawalsAPI = - Summary "Get withdrawals" - :> Description - "Get published withdrawal transactions. \ - \Results are returned in pages, with paging being specified by request headers." - :> OperationId "getWithdrawals" - :> QueryParams "roleCurrency" PolicyId - :> RenameResponseSchema "GetWithdrawalsResponse" - :> PaginatedGet '["withdrawalId"] GetWithdrawalsResponse - -type GetWithdrawalsResponse = WithLink "withdrawal" WithdrawalHeader - -instance HasNamedLink WithdrawalHeader API "withdrawal" where +instance HasNamedLink WithdrawalHeader RuntimeAPI "withdrawal" where type - Endpoint WithdrawalHeader API "withdrawal" = + Endpoint WithdrawalHeader RuntimeAPI "withdrawal" = "withdrawals" :> Capture "withdrawalId" TxId :> GetWithdrawalAPI namedLink _ _ mkLink WithdrawalHeader{..} = Just $ mkLink withdrawalId --- | GET /payouts sub-API -type GetPayoutsAPI = - Summary "Get role payouts" - :> Description - "Get payouts to parties from role-based contracts. \ - \Results are returned in pages, with paging being specified by request headers." - :> OperationId "getPayouts" - :> QueryParams "contractId" TxOutRef - :> QueryParams "roleToken" AssetId - :> QueryParam' - '[Optional, Description "Whether to include available or withdrawn payouts in the results."] - "status" - PayoutStatus - :> RenameResponseSchema "GetPayoutsResponse" - :> PaginatedGet '["payoutId"] GetPayoutsResponse - -type GetPayoutsResponse = WithLink "payout" PayoutHeader - -instance HasNamedLink PayoutHeader API "payout" where +instance HasNamedLink PayoutHeader RuntimeAPI "payout" where type - Endpoint PayoutHeader API "payout" = + Endpoint PayoutHeader RuntimeAPI "payout" = "payouts" :> Capture "payoutId" TxOutRef :> GetPayoutAPI namedLink _ _ mkLink PayoutHeader{..} = Just $ mkLink payoutId -type GetPayoutAPI = - Summary "Get payout by ID" - :> OperationId "getPayoutById" - :> RenameResponseSchema "GetPayoutResponse" - :> Get '[JSON] GetPayoutResponse - -type GetPayoutResponse = WithLink "contract" (WithLink "transaction" (WithLink "withdrawal" PayoutState)) - -instance HasNamedLink PayoutState API "contract" where +instance HasNamedLink PayoutState RuntimeAPI "contract" where type - Endpoint PayoutState API "contract" = + Endpoint PayoutState RuntimeAPI "contract" = "contracts" :> Capture "contractId" TxOutRef :> GetContractAPI namedLink _ _ mkLink PayoutState{..} = Just $ mkLink contractId -instance HasNamedLink PayoutState API "transaction" where +instance HasNamedLink PayoutState RuntimeAPI "transaction" where type - Endpoint PayoutState API "transaction" = + Endpoint PayoutState RuntimeAPI "transaction" = "contracts" :> Capture "contractId" TxOutRef :> "transactions" @@ -560,88 +307,18 @@ instance HasNamedLink PayoutState API "transaction" where :> GetTransactionAPI namedLink _ _ mkLink PayoutState{..} = Just $ mkLink contractId $ txId payoutId -instance HasNamedLink PayoutState API "withdrawal" where +instance HasNamedLink PayoutState RuntimeAPI "withdrawal" where type - Endpoint PayoutState API "withdrawal" = + Endpoint PayoutState RuntimeAPI "withdrawal" = "withdrawals" :> Capture "withdrawalId" TxId :> GetWithdrawalAPI namedLink _ _ mkLink PayoutState{..} = mkLink <$> withdrawalId --- | POST /contracts sub-API -type PostWithdrawalsAPI = - Summary "Withdraw payouts" - :> Description - "Build an unsigned (Cardano) transaction body which withdraws available payouts from a role payout validator. \ - \This unsigned transaction must be signed by a wallet (such as a CIP-30 or CIP-45 wallet) before being submitted. \ - \To submit the signed transaction, use the PUT /withdrawals/{withdrawalId} endpoint." - :> OperationId "withdrawPayouts" - :> RenameResponseSchema "WithdrawPayoutsResponse" - :> ( ReqBody '[JSON] PostWithdrawalsRequest :> PostTxAPI (PostCreated '[JSON] (PostWithdrawalsResponse CardanoTxBody)) - :<|> ReqBody '[JSON] PostWithdrawalsRequest - :> PostTxAPI (PostCreated '[TxJSON WithdrawTx] (PostWithdrawalsResponse CardanoTx)) - ) - -type PostWithdrawalsResponse tx = WithLink "withdrawal" (WithdrawTxEnvelope tx) - -data WithdrawTx - -data BurnTx - -instance Accept (TxJSON WithdrawTx) where - contentType _ = "application" // "vendor.iog.marlowe-runtime.withdraw-tx-json" - -instance MimeRender (TxJSON WithdrawTx) (PostWithdrawalsResponse CardanoTx) where - mimeRender _ = encode . toJSON - -instance MimeUnrender (TxJSON WithdrawTx) (PostWithdrawalsResponse CardanoTx) where - mimeUnrender _ = eitherDecode - -instance HasNamedLink (WithdrawTxEnvelope tx) API "withdrawal" where +instance HasNamedLink (WithdrawTxEnvelope tx) RuntimeAPI "withdrawal" where type - Endpoint (WithdrawTxEnvelope tx) API "withdrawal" = + Endpoint (WithdrawTxEnvelope tx) RuntimeAPI "withdrawal" = "withdrawals" :> Capture "withdrawalId" TxId :> GetWithdrawalAPI namedLink _ _ mkLink WithdrawTxEnvelope{..} = Just $ mkLink withdrawalId --- | /contracts/:contractId/withdrawals/:withdrawalId sub-API -type WithdrawalAPI = - GetWithdrawalAPI - :<|> Summary "Submit payout withdrawal" - :> Description - "Submit a signed (Cardano) transaction that withdraws available payouts from a role payout validator. \ - \The transaction must have originally been created by the POST /withdrawals endpoint. \ - \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ - \it will not wait for the transaction to be published in a block. \ - \Use the GET /withdrawals/{withdrawalId} endpoint to poll the on-chain status." - :> OperationId "submitWithdrawal" - :> PutSignedTxAPI - --- | GET /contracts/:contractId/withdrawals/:withdrawalId sub-API -type GetWithdrawalAPI = - Summary "Get withdrawal by ID" - :> OperationId "getWithdrawalById" - :> Get '[JSON] Withdrawal - --- | Helper type for defining generic paginated GET endpoints -type PaginatedGet rangeFields resource = - Header "Range" (Ranges rangeFields resource) - :> GetPartialContent '[JSON] (PaginatedResponse rangeFields resource) - --- | Helper type for describing the response type of generic paginated APIs -type PaginatedResponse fields resource = - Headers (Header "Total-Count" Int ': PageHeaders fields resource) (ListObject resource) - -newtype ListObject a = ListObject {results :: [a]} - deriving (Eq, Show, Ord, Functor, Generic) - -instance (ToJSON a) => ToJSON (ListObject a) -instance (FromJSON a) => FromJSON (ListObject a) -instance (ToSchema a) => ToSchema (ListObject a) - -type PostTxAPI api = - Header' '[Required, Strict] "X-Change-Address" Address - :> Header "X-Address" (CommaList Address) - :> Header "X-Collateral-UTxO" (CommaList TxOutRef) - :> api - class ParseHttpApiData a where urlPieceParser :: Parser a @@ -666,9 +343,6 @@ instance ParseHttpApiData TxId where octets <- replicateM 32 octet pure $ TxId $ BS.pack octets -class (HasLink endpoint) => HasLinkParser endpoint where - linkParser :: Bool -> Proxy endpoint -> Parser (MkLink endpoint a -> a) - instance (KnownSymbol seg, HasLinkParser endpoint) => HasLinkParser (seg :> endpoint) where linkParser isStart _ = do unless isStart $ void $ char '/' @@ -723,44 +397,9 @@ instance (HasNamedLink a api name) => HasNamedLink (WithLink name' a) api name w IncludeLink _ a -> namedLink api' name mkLink a OmitLink a -> namedLink api' name mkLink a -data WithLink (name :: Symbol) a where - IncludeLink :: Proxy name -> a -> WithLink name a - OmitLink :: a -> WithLink name a - -retractLink :: WithLink name a -> a -retractLink (IncludeLink _ a) = a -retractLink (OmitLink a) = a - -deriving instance Typeable (WithLink name a) - -instance (Show a, KnownSymbol name) => Show (WithLink name a) where - showsPrec p (IncludeLink name a) = - showParen - (p >= 11) - ( showString "IncludeLink (Proxy @" - . showSpace - . showsPrec 11 (symbolVal name) - . showString ")" - . showSpace - . showsPrec 11 a - ) - showsPrec p (OmitLink a) = - showParen - (p >= 11) - ( showString "OmitLink" - . showSpace - . showsPrec 11 a - ) - -class ToJSONWithLinks a where - toJSONWithLinks :: a -> ([(String, Link)], Value) - -class FromJSONWithLinks a where - fromJSONWithLinks :: ([(String, String)], Value) -> A.Parser a - instance {-# OVERLAPPING #-} - ( HasNamedLink a API name + ( HasNamedLink a RuntimeAPI name , ToJSONWithLinks a , KnownSymbol name ) @@ -769,15 +408,12 @@ instance toJSONWithLinks (IncludeLink name a) = (maybe links (: links) link, value) where (links, value) = toJSONWithLinks a - link = (symbolVal name,) <$> namedLink api name (safeLink api $ Proxy @(Endpoint a API name)) a + link = (symbolVal name,) <$> namedLink runtimeApi name (safeLink runtimeApi $ Proxy @(Endpoint a RuntimeAPI name)) a toJSONWithLinks (OmitLink a) = toJSONWithLinks a -instance {-# OVERLAPPING #-} (ToJSON a) => ToJSONWithLinks a where - toJSONWithLinks a = ([], toJSON a) - instance {-# OVERLAPPING #-} - ( HasLinkParser (Endpoint a API name) + ( HasLinkParser (Endpoint a RuntimeAPI name) , FromJSONWithLinks a , KnownSymbol name ) @@ -787,15 +423,12 @@ instance let mUri = lookup (symbolVal $ Proxy @name) links case mUri of Nothing -> OmitLink <$> fromJSONWithLinks (links, value) - Just uri -> case runParser (linkParser True (Proxy @(Endpoint a API name))) () "" uri of + Just uri -> case runParser (linkParser True (Proxy @(Endpoint a RuntimeAPI name))) () "" uri of Right _ -> IncludeLink (Proxy @name) <$> fromJSONWithLinks (links, value) Left err -> parseFail $ show err -instance {-# OVERLAPPING #-} (FromJSON a) => FromJSONWithLinks a where - fromJSONWithLinks = parseJSON . snd - instance - ( HasNamedLink a API name + ( HasNamedLink a RuntimeAPI name , ToJSONWithLinks a , KnownSymbol name ) @@ -810,7 +443,7 @@ instance ] instance - ( HasLinkParser (Endpoint a API name) + ( HasLinkParser (Endpoint a RuntimeAPI name) , FromJSONWithLinks a , KnownSymbol name ) @@ -823,54 +456,6 @@ instance links <- Map.toList <$> obj .: "links" pure (links, value) -instance (HasPagination resource field) => HasPagination (WithLink name resource) field where - type RangeType (WithLink name resource) field = RangeType resource field - getFieldValue p (IncludeLink _ resource) = getFieldValue p resource - getFieldValue p (OmitLink resource) = getFieldValue p resource - -class ToSchemaWithLinks a where - declareNamedSchemaWithLinks :: Proxy a -> Declare (Definitions Schema) ([String], Referenced Schema) - -instance - {-# OVERLAPPING #-} - ( ToSchemaWithLinks a - , KnownSymbol name - ) - => ToSchemaWithLinks (WithLink name a) - where - declareNamedSchemaWithLinks _ = do - (links, namedSchema) <- declareNamedSchemaWithLinks (Proxy @a) - pure (symbolVal (Proxy @name) : links, namedSchema) - -instance {-# OVERLAPPING #-} (ToSchema a) => ToSchemaWithLinks a where - declareNamedSchemaWithLinks p = ([],) <$> declareSchemaRef p - -instance - ( Typeable a - , ToSchemaWithLinks a - , KnownSymbol name - ) - => ToSchema (WithLink name a) - where - declareNamedSchema _ = do - (links, schema) <- declareNamedSchemaWithLinks (Proxy @(WithLink name a)) - stringSchema <- declareSchemaRef (Proxy @String) - pure $ - NamedSchema Nothing $ - mempty - & type_ ?~ OpenApiObject - & required .~ ["resource", "links"] - & properties - .~ [ ("resource", schema) - , - ( "links" - , Inline $ - mempty - & type_ ?~ OpenApiObject - & properties .~ fromList ((,stringSchema) . fromString <$> links) - ) - ] - class ContentRangeFromHttpApiData fields resource where contentRangeFromHttpApiData :: Text -> Text -> Text -> Either Text (ContentRange fields resource) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/ByteString.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/ByteString.hs new file mode 100644 index 0000000000..742041c426 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/ByteString.hs @@ -0,0 +1,14 @@ +module Language.Marlowe.Runtime.Web.Adapter.ByteString ( + hasLength, +) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.Text as T +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () + +hasLength :: Int -> ByteString -> Either T.Text ByteString +hasLength l bytes + | BS.length bytes == l = pure bytes + | otherwise = Left $ "Expected " <> T.pack (show l) <> " bytes" diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/CommaList.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/CommaList.hs new file mode 100644 index 0000000000..621961853a --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/CommaList.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Marlowe.Runtime.Web.Adapter.CommaList ( + CommaList (..), +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Char (isSpace) +import Data.OpenApi ( + HasType (..), + OpenApiType (..), + ToParamSchema, + ToSchema, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Exts (IsList) +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData (parseQueryParam, parseUrlPiece), + ToHttpApiData (toQueryParam, toUrlPiece), + ) + +newtype CommaList a = CommaList {unCommaList :: [a]} + deriving (Eq, Ord, Generic, Functor) + deriving newtype (Show, ToJSON, FromJSON, IsList) + +instance ToParamSchema (CommaList a) where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "A comma-separated list of values" + +instance (ToSchema a) => ToSchema (CommaList a) + +instance (ToHttpApiData a) => ToHttpApiData (CommaList a) where + toUrlPiece = T.intercalate "," . fmap toUrlPiece . unCommaList + toQueryParam = T.intercalate "," . fmap toQueryParam . unCommaList + +instance (FromHttpApiData a) => FromHttpApiData (CommaList a) where + parseUrlPiece = + fmap CommaList + . traverse (parseUrlPiece . T.dropWhileEnd isSpace . T.dropWhile isSpace) + . splitOnNonEmpty "," + parseQueryParam = + fmap CommaList + . traverse (parseQueryParam . T.dropWhileEnd isSpace . T.dropWhile isSpace) + . splitOnNonEmpty "," + +splitOnNonEmpty :: Text -> Text -> [Text] +splitOnNonEmpty sep t + | T.null t = [] + | otherwise = T.splitOn sep t diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Links.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Links.hs new file mode 100644 index 0000000000..8a9dfc19d2 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Links.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Language.Marlowe.Runtime.Web.Adapter.Links ( + WithLink (..), + retractLink, + HasLinkParser (..), + ToJSONWithLinks (..), + FromJSONWithLinks (..), + ToSchemaWithLinks (..), +) where + +import Data.Data (Proxy, Typeable) +import Data.OpenApi ( + Definitions, + NamedSchema (..), + OpenApiType (..), + Referenced (..), + Schema, + ToSchema, + declareSchemaRef, + properties, + required, + type_, + ) +import GHC.Base (Symbol) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () + +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson (FromJSON (..), ToJSON (toJSON), Value) +import qualified Data.Aeson.Types as A +import Data.OpenApi.Declare (Declare) +import Data.OpenApi.Schema (ToSchema (..)) +import GHC.Exts (IsList (fromList), IsString (fromString)) +import GHC.Show (showSpace) +import Servant ( + HasLink (..), + Link, + Proxy (..), + ) +import Servant.Pagination ( + HasPagination (RangeType, getFieldValue), + ) +import Text.Parsec.String (Parser) + +data WithLink (name :: Symbol) a where + IncludeLink :: Proxy name -> a -> WithLink name a + OmitLink :: a -> WithLink name a + +class ToJSONWithLinks a where + toJSONWithLinks :: a -> ([(String, Link)], Value) + +class FromJSONWithLinks a where + fromJSONWithLinks :: ([(String, String)], Value) -> A.Parser a + +instance {-# OVERLAPPING #-} (FromJSON a) => FromJSONWithLinks a where + fromJSONWithLinks = parseJSON . snd + +class ToSchemaWithLinks a where + declareNamedSchemaWithLinks :: Proxy a -> Declare (Definitions Schema) ([String], Referenced Schema) + +class (HasLink endpoint) => HasLinkParser endpoint where + linkParser :: Bool -> Proxy endpoint -> Parser (MkLink endpoint a -> a) + +instance (HasPagination resource field) => HasPagination (WithLink name resource) field where + type RangeType (WithLink name resource) field = RangeType resource field + getFieldValue p (IncludeLink _ resource) = getFieldValue p resource + getFieldValue p (OmitLink resource) = getFieldValue p resource + +instance {-# OVERLAPPING #-} (ToJSON a) => ToJSONWithLinks a where + toJSONWithLinks a = ([], toJSON a) + +retractLink :: WithLink name a -> a +retractLink (IncludeLink _ a) = a +retractLink (OmitLink a) = a + +deriving instance Typeable (WithLink name a) + +instance {-# OVERLAPPING #-} (ToSchema a) => ToSchemaWithLinks a where + declareNamedSchemaWithLinks p = ([],) <$> declareSchemaRef p + +instance + {-# OVERLAPPING #-} + ( ToSchemaWithLinks a + , KnownSymbol name + ) + => ToSchemaWithLinks (WithLink name a) + where + declareNamedSchemaWithLinks _ = do + (links, namedSchema) <- declareNamedSchemaWithLinks (Proxy @a) + pure (symbolVal (Proxy @name) : links, namedSchema) + +instance + ( Typeable a + , ToSchemaWithLinks a + , KnownSymbol name + ) + => ToSchema (WithLink name a) + where + declareNamedSchema _ = do + (links, schema) <- declareNamedSchemaWithLinks (Proxy @(WithLink name a)) + stringSchema <- declareSchemaRef (Proxy @String) + pure $ + NamedSchema Nothing $ + mempty + & type_ ?~ OpenApiObject + & required .~ ["resource", "links"] + & properties + .~ [ ("resource", schema) + , + ( "links" + , Inline $ + mempty + & type_ ?~ OpenApiObject + & properties .~ fromList ((,stringSchema) . fromString <$> links) + ) + ] + +instance (Show a, KnownSymbol name) => Show (WithLink name a) where + showsPrec p (IncludeLink name a) = + showParen + (p >= 11) + ( showString "IncludeLink (Proxy @" + . showSpace + . showsPrec 11 (symbolVal name) + . showString ")" + . showSpace + . showsPrec 11 a + ) + showsPrec p (OmitLink a) = + showParen + (p >= 11) + ( showString "OmitLink" + . showSpace + . showsPrec 11 a + ) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Pagination.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Pagination.hs new file mode 100644 index 0000000000..3ba6f2a0bd --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Pagination.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Adapter.Pagination (PaginatedGet, PaginatedResponse) where + +import Servant.Pagination ( + PageHeaders, + Ranges, + ) + +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () + +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject) +import Servant ( + GetPartialContent, + Header, + Headers, + JSON, + type (:>), + ) + +-- | Helper type for defining generic paginated GET endpoints +type PaginatedGet rangeFields resource = + Header "Range" (Ranges rangeFields resource) + :> GetPartialContent '[JSON] (PaginatedResponse rangeFields resource) + +-- | Helper type for describing the response type of generic paginated APIs +type PaginatedResponse fields resource = + Headers (Header "Total-Count" Int ': PageHeaders fields resource) (ListObject resource) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Servant.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Servant.hs new file mode 100644 index 0000000000..f0a658548f --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Servant.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Language.Marlowe.Runtime.Web.Adapter.Servant ( + WithRuntimeStatus, + OperationId, + RenameResponseSchema, + RenameSchema, + ListObject (..), + AddRenameSchema, +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, ToJSON) +import Data.OpenApi ( + NamedSchema (..), + ToSchema, + allOperations, + declareNamedSchema, + operationId, + ) +import qualified Data.Text as T +import GHC.Base (Symbol) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () + +import Servant ( + HasServer (..), + Headers, + IsElem, + IsElem', + Proxy (..), + Stream, + Verb, + type (:<|>), + type (:>), + ) +import Servant.Client (HasClient (..)) +import Servant.OpenApi (HasOpenApi (toOpenApi)) + +data WithRuntimeStatus api + +data OperationId (name :: Symbol) + +data RenameResponseSchema (name :: Symbol) + +data RenameSchema (name :: Symbol) a + +type family AddRenameSchema name api where + AddRenameSchema name (path :> api) = path :> AddRenameSchema name api + AddRenameSchema name (a :<|> b) = AddRenameSchema name a :<|> AddRenameSchema name b + AddRenameSchema name (Verb method cTypes status (Headers hs a)) = + Verb method cTypes status (Headers hs (RenameSchema name a)) + AddRenameSchema name (Verb method cTypes status a) = Verb method cTypes status (RenameSchema name a) + AddRenameSchema name (Stream method status framing ct (Headers hs a)) = + Stream method status framing ct (Headers hs (RenameSchema name a)) + AddRenameSchema name (Stream cTypes status framing ct a) = Stream cTypes status framing ct (RenameSchema name a) + +instance (KnownSymbol name, ToSchema a) => ToSchema (RenameSchema name a) where + declareNamedSchema _ = do + NamedSchema _ schema <- declareNamedSchema $ Proxy @a + pure $ NamedSchema (Just $ T.pack $ symbolVal $ Proxy @name) schema + +instance (HasServer sub ctx) => HasServer (OperationId name :> sub) ctx where + type ServerT (OperationId name :> sub) m = ServerT sub m + route _ = route $ Proxy @sub + hoistServerWithContext _ = hoistServerWithContext $ Proxy @sub + +instance (HasClient m api) => HasClient m (OperationId name :> api) where + type Client m (OperationId name :> api) = Client m api + clientWithRoute m _ = clientWithRoute m $ Proxy @api + hoistClientMonad m _ = hoistClientMonad m $ Proxy @api + +instance (KnownSymbol name, HasOpenApi api) => HasOpenApi (OperationId name :> api) where + toOpenApi _ = + toOpenApi (Proxy @api) + & allOperations . operationId ?~ T.pack (symbolVal $ Proxy @name) + +instance (HasServer sub ctx) => HasServer (RenameResponseSchema name :> sub) ctx where + type ServerT (RenameResponseSchema name :> sub) m = ServerT sub m + route _ = route $ Proxy @sub + hoistServerWithContext _ = hoistServerWithContext $ Proxy @sub + +instance (HasClient m api) => HasClient m (RenameResponseSchema name :> api) where + type Client m (RenameResponseSchema name :> api) = Client m api + clientWithRoute m _ = clientWithRoute m $ Proxy @api + hoistClientMonad m _ = hoistClientMonad m $ Proxy @api + +instance (KnownSymbol name, HasOpenApi (AddRenameSchema name api)) => HasOpenApi (RenameResponseSchema name :> api) where + toOpenApi _ = toOpenApi $ Proxy @(AddRenameSchema name api) + +type instance IsElem' e (WithRuntimeStatus api) = IsElem e api + +-- | A wrapper for a list of objects. +newtype ListObject a = ListObject {results :: [a]} + deriving (Eq, Show, Ord, Functor, GHC.Generics.Generic) + +instance (ToJSON a) => ToJSON (ListObject a) +instance (FromJSON a) => FromJSON (ListObject a) +instance (ToSchema a) => ToSchema (ListObject a) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ApiError.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/ApiError.hs similarity index 99% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ApiError.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/ApiError.hs index a45003d06c..3002085e7f 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ApiError.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/ApiError.hs @@ -8,7 +8,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Language.Marlowe.Runtime.Web.Server.REST.ApiError where +module Language.Marlowe.Runtime.Web.Adapter.Server.ApiError where import Control.Monad.Except (MonadError (throwError)) import Data.Aeson (ToJSON (toJSON), Value (Null), encode, object, (.=)) @@ -25,7 +25,7 @@ import Language.Marlowe.Runtime.Transaction.Api ( LoadMarloweContextError (..), WithdrawError (..), ) -import Language.Marlowe.Runtime.Web.Server.DTO (DTO, HasDTO, ToDTO, toDTO) +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (DTO, HasDTO, ToDTO, toDTO) import Servant (ServerError (ServerError)) data ApiError = ApiError diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/ContractClient.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/ContractClient.hs similarity index 95% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/ContractClient.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/ContractClient.hs index 0cc4b69ce8..af6ecb36cd 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/ContractClient.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/ContractClient.hs @@ -2,10 +2,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -module Language.Marlowe.Runtime.Web.Server.ContractClient where +module Language.Marlowe.Runtime.Web.Adapter.Server.ContractClient where import Control.Arrow (arr) -import Control.Concurrent.Component +import Control.Concurrent.Component (Component) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Marlowe.Class (runClientStreaming) import Data.List (find) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/DTO.hs similarity index 82% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/DTO.hs index 60fed4d0f1..7c332b09f2 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/DTO.hs @@ -10,11 +10,10 @@ -- the web server. DTOs are the types served by the API, which notably include -- no cardano-api dependencies and have nice JSON representations. This module -- describes how they are mapped to the internal API types of the runtime. -module Language.Marlowe.Runtime.Web.Server.DTO where +module Language.Marlowe.Runtime.Web.Adapter.Server.DTO where import Cardano.Api ( AsType (..), - BabbageEraOnwards (..), HasTextEnvelope, HasTypeProxy, IsCardanoEra (..), @@ -30,7 +29,6 @@ import Cardano.Api ( deserialiseAddress, deserialiseFromCBOR, deserialiseFromTextEnvelope, - getTxId, metadataValueToJsonNoSchema, proxyToAsType, serialiseToCBOR, @@ -97,7 +95,7 @@ import Language.Marlowe.Protocol.Query.Types ( Withdrawal (..), ) import qualified Language.Marlowe.Protocol.Query.Types as Query -import Language.Marlowe.Runtime.Cardano.Api (cardanoEraToAsType, fromCardanoTxId) +import Language.Marlowe.Runtime.Cardano.Api (cardanoEraToAsType) import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..), fromBech32, toBech32) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Core.Api ( @@ -118,8 +116,24 @@ import qualified Language.Marlowe.Runtime.Core.Api as Core.Api (Payout (..)) import qualified Language.Marlowe.Runtime.Discovery.Api as Discovery import Language.Marlowe.Runtime.Transaction.Api (Account (..)) import qualified Language.Marlowe.Runtime.Transaction.Api as Tx -import qualified Language.Marlowe.Runtime.Web as Web -import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx (..), TempTxStatus (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Address as Web +import qualified Language.Marlowe.Runtime.Web.Core.Asset as Web +import qualified Language.Marlowe.Runtime.Web.Core.Base16 as Web +import qualified Language.Marlowe.Runtime.Web.Core.BlockHeader as Web +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web +import qualified Language.Marlowe.Runtime.Web.Core.Metadata as Web +import qualified Language.Marlowe.Runtime.Web.Core.NetworkId as Web +import qualified Language.Marlowe.Runtime.Web.Core.Party as Web +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web +import qualified Language.Marlowe.Runtime.Web.Core.Script as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tip as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import qualified Language.Marlowe.Runtime.Web.Payout.API as Web + +import qualified Language.Marlowe.Runtime.Web.Status as Web +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Network.HTTP.Media (MediaType, parseAccept) import qualified PlutusLedgerApi.V2 as PV2 import Servant.Pagination (IsRangeType) @@ -135,18 +149,10 @@ class HasDTO a where class (HasDTO a) => ToDTO a where toDTO :: a -> DTO a --- | States that a type can be encoded as a DTO given a tx status. -class (HasDTO a) => ToDTOWithTxStatus a where - toDTOWithTxStatus :: TempTxStatus -> a -> DTO a - -- | States that a type can be decoded from a DTO. class (HasDTO a) => FromDTO a where fromDTO :: DTO a -> Maybe a --- | States that a type can be encoded as a DTO given a tx status. -class (HasDTO a) => FromDTOWithTxStatus a where - fromDTOWithTxStatus :: DTO a -> Maybe (TempTxStatus, a) - fromDTOThrow :: (MonadError e m, FromDTO a) => e -> DTO a -> m a fromDTOThrow e = maybe (throwError e) pure . fromDTO @@ -557,136 +563,6 @@ instance ToDTO SomeTransaction where utcToPOSIXTime :: UTCTime -> PV2.POSIXTime utcToPOSIXTime = PV2.POSIXTime . floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds -instance HasDTO TempTxStatus where - type DTO TempTxStatus = Web.TxStatus - -instance ToDTO TempTxStatus where - toDTO Unsigned = Web.Unsigned - toDTO Submitted = Web.Submitted - -instance FromDTO TempTxStatus where - fromDTO Web.Unsigned = Just Unsigned - fromDTO Web.Submitted = Just Submitted - fromDTO _ = Nothing - -instance HasDTO (TempTx Tx.ContractCreatedInEra) where - type DTO (TempTx Tx.ContractCreatedInEra) = Web.ContractState - -instance ToDTO (TempTx Tx.ContractCreatedInEra) where - toDTO (TempTx era _ status tx) = toDTOWithTxStatus status $ Tx.ContractCreated era tx - -instance HasDTO (TempTx Tx.InputsAppliedInEra) where - type DTO (TempTx Tx.InputsAppliedInEra) = Web.Tx - -instance ToDTO (TempTx Tx.InputsAppliedInEra) where - toDTO (TempTx era _ status tx) = toDTOWithTxStatus status $ Tx.InputsApplied era tx - -instance HasDTO (TempTx Tx.WithdrawTxInEra) where - type DTO (TempTx Tx.WithdrawTxInEra) = Web.Withdrawal - -instance ToDTO (TempTx Tx.WithdrawTxInEra) where - toDTO (TempTx era _ status tx) = toDTOWithTxStatus status $ Tx.WithdrawTx era tx - -instance HasDTO (Tx.ContractCreated v) where - type DTO (Tx.ContractCreated v) = Web.ContractState - -instance HasDTO (Tx.WithdrawTx v) where - type DTO (Tx.WithdrawTx v) = Web.Withdrawal - -instance ToDTOWithTxStatus (Tx.WithdrawTx v) where - toDTOWithTxStatus status (Tx.WithdrawTx _ Tx.WithdrawTxInEra{txBody}) = - Web.Withdrawal - { withdrawalId = toDTO $ fromCardanoTxId $ getTxId txBody - , payouts = mempty -- TODO the information cannot be recovered here. Push creating Withdrawn to marlowe-tx. - , status = toDTO status - , block = Nothing - } - -instance ToDTOWithTxStatus (Tx.ContractCreated v) where - toDTOWithTxStatus status (Tx.ContractCreated era Tx.ContractCreatedInEra{..}) = - Web.ContractState - { contractId = toDTO contractId - , roleTokenMintingPolicyId = toDTO rolesCurrency - , version = case version of - MarloweV1 -> Web.V1 - , tags = fold $ toDTO $ marloweMetadata metadata - , metadata = toDTO $ transactionMetadata metadata - , status = toDTO status - , block = Nothing - , initialContract = case version of - MarloweV1 -> Sem.marloweContract datum - , initialState = case version of - MarloweV1 -> Sem.marloweState datum - , currentContract = case version of - MarloweV1 -> Just $ Sem.marloweContract datum - , state = case version of - MarloweV1 -> Just $ Sem.marloweState datum - , assets = toDTO assets - , utxo = Nothing - , txBody = case status of - Unsigned -> Just case era of - BabbageEraOnwardsBabbage -> toDTO txBody - BabbageEraOnwardsConway -> toDTO txBody - Submitted -> Nothing - , unclaimedPayouts = [] - } - -instance HasDTO (Tx.InputsApplied v) where - type DTO (Tx.InputsApplied v) = Web.Tx - -instance ToDTOWithTxStatus (Tx.InputsApplied v) where - toDTOWithTxStatus status (Tx.InputsApplied era Tx.InputsAppliedInEra{..}) = - Web.Tx - { contractId = toDTO contractId - , transactionId = toDTO $ fromCardanoTxId $ getTxId txBody - , tags = fold $ toDTO $ marloweMetadata metadata - , metadata = toDTO $ transactionMetadata metadata - , status = toDTO status - , block = Nothing - , inputUtxo = toDTO $ utxo input - , inputContract = case (version, input) of - (MarloweV1, TransactionScriptOutput{..}) -> Sem.marloweContract datum - , inputState = case (version, input) of - (MarloweV1, TransactionScriptOutput{..}) -> Sem.marloweState datum - , inputs = case version of - MarloweV1 -> inputs - , outputUtxo = toDTO $ utxo <$> scriptOutput output - , outputContract = case version of - MarloweV1 -> Sem.marloweContract . datum <$> scriptOutput output - , outputState = case version of - MarloweV1 -> Sem.marloweState . datum <$> scriptOutput output - , assets = maybe emptyAssets (\Core.TransactionScriptOutput{..} -> toDTO assets) $ scriptOutput output - , consumingTx = Nothing - , invalidBefore = invalidBefore - , invalidHereafter = invalidHereafter - , payouts = case version of - MarloweV1 -> - (\(payoutId, Core.Api.Payout{..}) -> Web.Payout (toDTO payoutId) (toDTO . tokenName $ datum) (toDTO assets)) - <$> M.toList (payouts output) - , reconstructedSemanticInput - , reconstructedSemanticOutput = case (version, input) of - (MarloweV1, TransactionScriptOutput{..}) -> - V1.computeTransaction - reconstructedSemanticInput - (Sem.marloweState datum) - (Sem.marloweContract datum) - , txBody = case status of - Unsigned -> Just case era of - BabbageEraOnwardsBabbage -> toDTO txBody - BabbageEraOnwardsConway -> toDTO txBody - Submitted -> Nothing - } - where - reconstructedSemanticInput = case version of - MarloweV1 -> - V1.TransactionInput - { txInputs = inputs - , txInterval = - ( utcToPOSIXTime invalidBefore - , utcToPOSIXTime invalidHereafter - 1 - ) - } - emptyAssets :: Web.Assets emptyAssets = Web.Assets 0 $ Web.Tokens mempty diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Monad.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs similarity index 95% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Monad.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs index af5285155e..a7f9888356 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Monad.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs @@ -7,7 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | Defines a custom Monad for the web server's handler functions to run in. -module Language.Marlowe.Runtime.Web.Server.Monad where +module Language.Marlowe.Runtime.Web.Adapter.Server.Monad where import Colog (LogAction, Message, hoistLogAction) import Control.Concurrent.Component.Run (AppM, unAppM) @@ -20,8 +20,8 @@ import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) import Control.Monad.Trans.Control (MonadBaseControl) import Language.Marlowe.Runtime.ChainSync.Api (TxId) import Language.Marlowe.Runtime.Core.Api (ContractId) -import Language.Marlowe.Runtime.Web.Server.ContractClient (GetContract, ImportBundle) -import Language.Marlowe.Runtime.Web.Server.SyncClient ( +import Language.Marlowe.Runtime.Web.Adapter.Server.ContractClient (GetContract, ImportBundle) +import Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient ( LoadContract, LoadContractHeaders, LoadPayout, @@ -31,7 +31,7 @@ import Language.Marlowe.Runtime.Web.Server.SyncClient ( LoadWithdrawal, LoadWithdrawals, ) -import Language.Marlowe.Runtime.Web.Server.TxClient (ApplyInputs, CreateContract, Submit, Submit', Withdraw) +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (ApplyInputs, CreateContract, Submit, Submit', Withdraw) import Observe.Event (EventBackend) import Pipes (MFunctor (..)) import Servant diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs similarity index 96% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs index 10ca8e31a4..beeef244c9 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/SyncClient.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs @@ -2,7 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -module Language.Marlowe.Runtime.Web.Server.SyncClient where +module Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient where import Control.Arrow (arr) import Control.Concurrent.Component @@ -44,8 +44,8 @@ import Language.Marlowe.Runtime.Core.Api ( ) import Language.Marlowe.Runtime.Discovery.Api (ContractHeader) import Language.Marlowe.Runtime.Transaction.Api (ContractCreatedInEra, InputsAppliedInEra (..), WithdrawTxInEra (..)) -import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx (..)) -import Language.Marlowe.Runtime.Web.Server.Util (applyRangeToAscList) +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.Util (applyRangeToAscList) import Network.Protocol.Connection (Connector, runConnector) import Servant.Pagination diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs similarity index 57% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs index 00f2345c34..0c6ca0e921 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/TxClient.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs @@ -1,15 +1,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# HLINT ignore "Use fewer imports" #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -module Language.Marlowe.Runtime.Web.Server.TxClient where +module Language.Marlowe.Runtime.Web.Adapter.Server.TxClient where import Cardano.Api (BabbageEraOnwards, Tx, getTxId) import Colog (Message, WithLog) import Control.Concurrent.Async (concurrently_) -import Control.Concurrent.Component +import Control.Concurrent.Component (Component, component) import Control.Concurrent.STM ( STM, TMVar, @@ -28,7 +32,7 @@ import Control.Concurrent.STM ( import Control.Concurrent.STM.Delay (newDelay, waitDelay) import Control.Exception (SomeException, try) import Control.Monad (when, (<=<)) -import Control.Monad.Event.Class +import Control.Monad.Event.Class (MonadEvent (localBackend)) import Control.Monad.IO.Unlift (MonadUnliftIO, liftIO, withRunInIO) import Data.Foldable (for_) import Data.Kind (Type) @@ -65,10 +69,52 @@ import Language.Marlowe.Runtime.Transaction.Api ( WithdrawTx (..), WithdrawTxInEra (..), ) +import qualified Language.Marlowe.Runtime.Transaction.Api as Tx +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Network.Protocol.Connection (Connector, runConnector) -import Network.Protocol.Job.Client +import Network.Protocol.Job.Client ( + ClientStAwait (SendMsgPoll), + ClientStCmd ( + ClientStCmd, + recvMsgAwait, + recvMsgFail, + recvMsgSucceed + ), + ClientStInit (SendMsgExec), + JobClient (JobClient), + liftCommand, + ) import Observe.Event.Backend (setAncestorEventBackend) +import Cardano.Api ( + BabbageEraOnwards (..), + ) +import qualified Data.Map as M +import qualified Language.Marlowe.Core.V1.Semantics as Sem + +import Data.Foldable (Foldable (..)) +import Data.Time (nominalDiffTimeToSeconds) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import qualified Language.Marlowe.Core.V1.Semantics as V1 +import Language.Marlowe.Runtime.ChainSync.Api (AssetId (..)) +import Language.Marlowe.Runtime.Core.Api as Runetime.Core.Api ( + MarloweTransactionMetadata (..), + MarloweVersion (..), + TransactionOutput (..), + TransactionScriptOutput (..), + ) +import qualified Language.Marlowe.Runtime.Core.Api as Core +import qualified Language.Marlowe.Runtime.Core.Api as Core.Api (Payout (..)) +import qualified Language.Marlowe.Runtime.Web.Core.Asset as Web +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web +import qualified Language.Marlowe.Runtime.Web.Payout.API as Web + +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (FromDTO (..), HasDTO (..), ToDTO (..)) +import qualified PlutusLedgerApi.V2 as PV2 + newtype TxClientDependencies m = TxClientDependencies { connector :: Connector MarloweRuntimeClient m } @@ -268,3 +314,146 @@ toSubmitted (TempTx era v _ tx) = TempTx era v Submitted tx toUnsigned :: TempTx tx -> TempTx tx toUnsigned (TempTx era v _ tx) = TempTx era v Unsigned tx + +-- | States that a type can be encoded as a DTO given a tx status. +class (HasDTO a) => ToDTOWithTxStatus a where + toDTOWithTxStatus :: TempTxStatus -> a -> DTO a + +-- | States that a type can be encoded as a DTO given a tx status. +class (HasDTO a) => FromDTOWithTxStatus a where + fromDTOWithTxStatus :: DTO a -> Maybe (TempTxStatus, a) + +instance HasDTO TempTxStatus where + type DTO TempTxStatus = Web.TxStatus + +instance ToDTO TempTxStatus where + toDTO Unsigned = Web.Unsigned + toDTO Submitted = Web.Submitted + +instance FromDTO TempTxStatus where + fromDTO Web.Unsigned = Just Unsigned + fromDTO Web.Submitted = Just Submitted + fromDTO _ = Nothing + +instance HasDTO (TempTx Tx.ContractCreatedInEra) where + type DTO (TempTx Tx.ContractCreatedInEra) = Web.ContractState + +instance ToDTO (TempTx Tx.ContractCreatedInEra) where + toDTO (TempTx era _ status tx) = toDTOWithTxStatus status $ Tx.ContractCreated era tx + +instance HasDTO (TempTx Tx.InputsAppliedInEra) where + type DTO (TempTx Tx.InputsAppliedInEra) = Web.Tx + +instance ToDTO (TempTx Tx.InputsAppliedInEra) where + toDTO (TempTx era _ status tx) = toDTOWithTxStatus status $ Tx.InputsApplied era tx + +instance HasDTO (TempTx Tx.WithdrawTxInEra) where + type DTO (TempTx Tx.WithdrawTxInEra) = Web.Withdrawal + +instance ToDTO (TempTx Tx.WithdrawTxInEra) where + toDTO (TempTx era _ status tx) = toDTOWithTxStatus status $ Tx.WithdrawTx era tx + +instance HasDTO (Tx.ContractCreated v) where + type DTO (Tx.ContractCreated v) = Web.ContractState + +instance HasDTO (Tx.WithdrawTx v) where + type DTO (Tx.WithdrawTx v) = Web.Withdrawal + +instance ToDTOWithTxStatus (Tx.WithdrawTx v) where + toDTOWithTxStatus status (Tx.WithdrawTx _ Tx.WithdrawTxInEra{txBody}) = + Web.Withdrawal + { withdrawalId = toDTO $ fromCardanoTxId $ getTxId txBody + , payouts = mempty -- TODO the information cannot be recovered here. Push creating Withdrawn to marlowe-tx. + , status = toDTO status + , block = Nothing + } + +instance ToDTOWithTxStatus (Tx.ContractCreated v) where + toDTOWithTxStatus status (Tx.ContractCreated era Tx.ContractCreatedInEra{..}) = + Web.ContractState + { contractId = toDTO contractId + , roleTokenMintingPolicyId = toDTO rolesCurrency + , version = case version of + MarloweV1 -> Web.V1 + , tags = fold $ toDTO $ marloweMetadata metadata + , metadata = toDTO $ transactionMetadata metadata + , status = toDTO status + , block = Nothing + , initialContract = case version of + MarloweV1 -> Sem.marloweContract datum + , initialState = case version of + MarloweV1 -> Sem.marloweState datum + , currentContract = case version of + MarloweV1 -> Just $ Sem.marloweContract datum + , state = case version of + MarloweV1 -> Just $ Sem.marloweState datum + , assets = toDTO assets + , utxo = Nothing + , txBody = case status of + Unsigned -> Just case era of + BabbageEraOnwardsBabbage -> toDTO txBody + BabbageEraOnwardsConway -> toDTO txBody + Submitted -> Nothing + , unclaimedPayouts = [] + } + +instance HasDTO (Tx.InputsApplied v) where + type DTO (Tx.InputsApplied v) = Web.Tx + +instance ToDTOWithTxStatus (Tx.InputsApplied v) where + toDTOWithTxStatus status (Tx.InputsApplied era Tx.InputsAppliedInEra{..}) = + Web.Tx + { contractId = toDTO contractId + , transactionId = toDTO $ fromCardanoTxId $ getTxId txBody + , tags = fold $ toDTO $ marloweMetadata metadata + , metadata = toDTO $ transactionMetadata metadata + , status = toDTO status + , block = Nothing + , inputUtxo = toDTO $ utxo input + , inputContract = case (version, input) of + (MarloweV1, TransactionScriptOutput{..}) -> Sem.marloweContract datum + , inputState = case (version, input) of + (MarloweV1, TransactionScriptOutput{..}) -> Sem.marloweState datum + , inputs = case version of + MarloweV1 -> inputs + , outputUtxo = toDTO $ utxo <$> scriptOutput output + , outputContract = case version of + MarloweV1 -> Sem.marloweContract . Runetime.Core.Api.datum <$> scriptOutput output + , outputState = case version of + MarloweV1 -> Sem.marloweState . Runetime.Core.Api.datum <$> scriptOutput output + , assets = maybe emptyAssets (\Core.TransactionScriptOutput{..} -> toDTO assets) $ scriptOutput output + , consumingTx = Nothing + , invalidBefore = invalidBefore + , invalidHereafter = invalidHereafter + , payouts = case version of + MarloweV1 -> + (\(payoutId, Core.Api.Payout{..}) -> Web.Payout (toDTO payoutId) (toDTO . tokenName $ datum) (toDTO assets)) + <$> M.toList (payouts output) + , reconstructedSemanticInput + , reconstructedSemanticOutput = case (version, input) of + (MarloweV1, TransactionScriptOutput{..}) -> + V1.computeTransaction + reconstructedSemanticInput + (Sem.marloweState datum) + (Sem.marloweContract datum) + , txBody = case status of + Unsigned -> Just case era of + BabbageEraOnwardsBabbage -> toDTO txBody + BabbageEraOnwardsConway -> toDTO txBody + Submitted -> Nothing + } + where + reconstructedSemanticInput = case version of + MarloweV1 -> + V1.TransactionInput + { txInputs = inputs + , txInterval = + ( utcToPOSIXTime invalidBefore + , utcToPOSIXTime invalidHereafter - 1 + ) + } +emptyAssets :: Web.Assets +emptyAssets = Web.Assets 0 $ Web.Tokens mempty + +utcToPOSIXTime :: UTCTime -> PV2.POSIXTime +utcToPOSIXTime = PV2.POSIXTime . floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Util.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Util.hs similarity index 97% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Util.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Util.hs index a09fc8774e..3b516ebc87 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Util.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Util.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -module Language.Marlowe.Runtime.Web.Server.Util where +module Language.Marlowe.Runtime.Web.Adapter.Server.Util where import Data.Function (on) import qualified Data.List as List diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/URI.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/URI.hs new file mode 100644 index 0000000000..52c54941ac --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/URI.hs @@ -0,0 +1,21 @@ +module Language.Marlowe.Runtime.Web.Adapter.URI ( + uriFromJSON, + uriToJSON, +) where + +import Data.Aeson.Types ( + Parser, + Value (String), + parseFail, + withText, + ) +import Network.URI (parseURI) +import Servant (URI) + +import qualified Data.Text as T + +uriFromJSON :: Value -> Parser URI +uriFromJSON = withText "URI" $ maybe (parseFail "invalid URI") pure . parseURI . T.unpack + +uriToJSON :: URI -> Value +uriToJSON = String . T.pack . show diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs new file mode 100644 index 0000000000..6e0176fbbc --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | This module specifies the Marlowe Runtime Web API as a Servant API type. +module Language.Marlowe.Runtime.Web.Burn.API (BurnsAPI) where + +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () + +import Language.Marlowe.Runtime.Web.Adapter.Servant (OperationId, RenameResponseSchema) +import Servant ( + Description, + Summary, + type (:>), + ) + +type BurnsAPI = PostBurnsAPI + +-- :<|> Capture "burnId" TxId :> BurnAPI + +-- | POST /role-token-burns sub-API +type PostBurnsAPI = + Summary "Burn role tokens" + :> Description + "Build an unsigned (Cardano) transaction body which burns role tokens matching a filter. \ + \Role tokens used by active contracts will not be burned and the request will fail if active role tokens are included. \ + \To submit the signed transaction, use the PUT /role-token-burns/{burnId} endpoint." + :> OperationId "burnRoleTokens" + :> RenameResponseSchema "BurnRoleTokensResponse" + +-- :> ( ReqBody '[JSON] PostBurnRequest :> PostTxAPI (PostCreated '[JSON] (PostBurnResponse CardanoTxBody)) +-- :<|> ReqBody '[JSON] PostBurnRequest :> PostTxAPI (PostCreated '[TxJSON BurnTx] (PostBurnResponse CardanoTx)) +-- ) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs index f73157601a..e91d0e2996 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs @@ -59,23 +59,70 @@ import Data.Proxy (Proxy (..)) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) -import Data.Time (UTCTime) import Data.Version (Version) import GHC.TypeLits (KnownSymbol, symbolVal) -import Language.Marlowe.Core.V1.Next import Language.Marlowe.Core.V1.Semantics.Types (Contract) import Language.Marlowe.Object.Types (Label, ObjectBundle) -import Language.Marlowe.Runtime.Web (GetPayoutsResponse) -import Language.Marlowe.Runtime.Web.API ( - API, + +import Language.Marlowe.Runtime.Web.API (RuntimeAPI, runtimeApi) +import Language.Marlowe.Runtime.Web.Adapter.CommaList ( + CommaList (CommaList), + ) +import Language.Marlowe.Runtime.Web.Adapter.Links (retractLink) +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject (..)) +import Language.Marlowe.Runtime.Web.Contract.API ( + ContractHeader, + ContractSourceId, + ContractState, GetContractsResponse, + PostContractSourceResponse, + PostContractsRequest, + ) +import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( GetTransactionsResponse, + ) +import Language.Marlowe.Runtime.Web.Core.Address ( + Address, + StakeAddress, + ) +import Language.Marlowe.Runtime.Web.Core.Asset ( + AssetId, + PolicyId, + ) + +import Language.Marlowe.Runtime.Web.Contract.Next.Client (getContractNext) +import Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId) +import Language.Marlowe.Runtime.Web.Core.Tip (ChainTip) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope, + TxId, + TxOutRef, + ) +import Language.Marlowe.Runtime.Web.Payout.API ( + GetPayoutsResponse, + PayoutHeader, + PayoutState, + PayoutStatus, + ) +import Language.Marlowe.Runtime.Web.Status ( + RuntimeStatus (RuntimeStatus), + ) +import Language.Marlowe.Runtime.Web.Tx.API ( + ApplyInputsTxEnvelope, + CardanoTx, + CardanoTxBody, + CreateTxEnvelope, + Tx, + TxHeader, + WithdrawTxEnvelope, + ) +import Language.Marlowe.Runtime.Web.Withdrawal.API ( GetWithdrawalsResponse, - ListObject (..), - api, - retractLink, + PostTransactionsRequest, + PostWithdrawalsRequest, + Withdrawal, + WithdrawalHeader, ) -import Language.Marlowe.Runtime.Web.Types import Pipes (Producer) import Servant (HasResponseHeader, ResponseHeader (..), getResponse, lookupResponseHeader, type (:<|>) ((:<|>))) import Servant.API (Headers) @@ -85,8 +132,10 @@ import qualified Servant.Client.Streaming as ServantStreaming import Servant.Pagination (ExtractRange (extractRange), HasPagination (..), PutRange (..), Range, Ranges) import Servant.Pipes () -client :: Client ClientM API -client = ServantStreaming.client api +import Language.Marlowe.Runtime.Web.Core.Object.Schema () + +client :: Client ClientM RuntimeAPI +client = ServantStreaming.client runtimeApi data Page field resource = Page { totalCount :: Int @@ -136,6 +185,7 @@ getContractsStatus roleCurrencies tags partyAddresses partyRoles range = do (putRange <$> range) totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response nextRanges <- headerValue $ lookupResponseHeader @"Next-Range" response + let ListObject items = getResponse response status <- extractStatus response pure @@ -281,18 +331,6 @@ getContractStatus contractId = do getContract :: TxOutRef -> ClientM ContractState getContract = fmap snd . getContractStatus -getContractNextStatus :: TxOutRef -> UTCTime -> UTCTime -> [Party] -> ClientM (RuntimeStatus, Next) -getContractNextStatus contractId validityStart validityEnd parties = do - let contractsClient :<|> _ = client - let _ :<|> _ :<|> contractApi :<|> _ = contractsClient - let _ :<|> _ :<|> next' :<|> _ = contractApi contractId - response <- next' validityStart validityEnd parties - status <- extractStatus response - pure (status, getResponse response) - -getContractNext :: TxOutRef -> UTCTime -> UTCTime -> [Party] -> ClientM Next -getContractNext = (fmap . fmap . fmap . fmap) snd . getContractNextStatus - putContractStatus :: TxOutRef -> TextEnvelope -> ClientM RuntimeStatus putContractStatus contractId tx = do let contractsClient :<|> _ = client diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs new file mode 100644 index 0000000000..83f2a0198e --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Contract.API ( + ContractHeader (..), + ContractState (..), + ContractsAPI, + ContractAPI, + GetContractAPI, + GetContractResponse, + ContractSourcesAPI, + ContractSourceAPI, + ContractSourceId (..), + GetContractsAPI, + GetContractsResponse, + PostContractsRequest (..), + PostContractsResponse, + PostContractSourceResponse (..), + ContractOrSourceId (..), +) where + +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON (toJSON), + Value (String), + withText, + ) +import Data.Map (Map) +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Language.Marlowe.Core.V1.Semantics.Types (Contract) +import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics +import Language.Marlowe.Object.Types (Label, ObjectBundle) +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink) +import Language.Marlowe.Runtime.Web.Adapter.Pagination (PaginatedGet) +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject, OperationId, RenameResponseSchema) +import Language.Marlowe.Runtime.Web.Contract.Next.API (NextAPI) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () +import Language.Marlowe.Runtime.Web.Contract.Transaction.API (TransactionsAPI) +import Language.Marlowe.Runtime.Web.Core.Address ( + Address, + StakeAddress, + ) +import Language.Marlowe.Runtime.Web.Core.Asset ( + AssetId, + Assets, + PolicyId, + ) +import Language.Marlowe.Runtime.Web.Core.MarloweVersion ( + MarloweVersion, + ) +import Language.Marlowe.Runtime.Web.Core.Party (Party) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope, + TxOutRef, + TxStatus, + ) +import Language.Marlowe.Runtime.Web.Payout.API (Payout) + +import Language.Marlowe.Runtime.Web.Core.BlockHeader ( + BlockHeader, + ) +import Language.Marlowe.Runtime.Web.Core.Metadata (Metadata) +import Language.Marlowe.Runtime.Web.Core.Roles (RolesConfig) +import Pipes (Producer) +import Servant ( + Capture, + Description, + FromHttpApiData, + Get, + Header', + JSON, + NewlineFraming, + Optional, + Post, + PostCreated, + Proxy (..), + QueryFlag, + QueryParam', + QueryParams, + ReqBody, + Required, + StreamBody, + Strict, + Summary, + ToHttpApiData, + type (:<|>), + type (:>), + ) +import Servant.API (FromHttpApiData (..)) +import Servant.Pagination ( + HasPagination (RangeType, getFieldValue), + ) + +import Control.Lens ((&), (?~)) +import Control.Monad ((<=<)) +import Data.Aeson.Types (parseFail) +import Data.ByteString (ByteString) +import Data.OpenApi ( + HasOneOf (oneOf), + HasPattern (pattern), + HasType (type_), + NamedSchema (NamedSchema), + OpenApiType (OpenApiString), + ToParamSchema (..), + ToSchema (..), + declareSchemaRef, + ) +import qualified Data.OpenApi as OpenApi +import qualified Data.Text as T +import Language.Marlowe.Runtime.Web.Adapter.ByteString (hasLength) +import Language.Marlowe.Runtime.Web.Core.Base16 (Base16 (..)) +import Language.Marlowe.Runtime.Web.Tx.API + +type ContractsAPI = + GetContractsAPI + :<|> PostContractsAPI + :<|> Capture "contractId" TxOutRef :> ContractAPI + :<|> "sources" :> ContractSourcesAPI + +-- | GET /contracts sub-API +type GetContractsAPI = + Summary "Get contracts" + :> Description + "Get contracts published on chain. \ + \Results are returned in pages, with paging being specified by request headers." + :> OperationId "getContracts" + :> QueryParams "roleCurrency" PolicyId + :> QueryParams "tag" Text + :> QueryParams "partyAddress" Address + :> QueryParams "partyRole" AssetId + :> RenameResponseSchema "GetContractsResponse" + :> PaginatedGet '["contractId"] GetContractsResponse + +type GetContractsResponse = WithLink "transactions" (WithLink "contract" ContractHeader) + +-- | POST /contracts sub-API +type PostContractsAPI = + Summary "Create a new contract" + :> Description + "Build an unsigned (Cardano) transaction body which opens a new Marlowe contract. \ + \This unsigned transaction must be signed by a wallet (such as a CIP-30 or CIP-45 wallet) before being submitted. \ + \To submit the signed transaction, use the PUT /contracts/{contractId} endpoint." + :> OperationId "createContract" + :> RenameResponseSchema "CreateContractResponse" + :> Header' + '[Optional, Strict, Description "Where to send staking rewards for the Marlowe script outputs of this contract."] + "X-Stake-Address" + StakeAddress + :> ( ReqBody '[JSON] PostContractsRequest :> PostTxAPI (PostCreated '[JSON] (PostContractsResponse CardanoTxBody)) + :<|> ReqBody '[JSON] PostContractsRequest :> PostTxAPI (PostCreated '[TxJSON ContractTx] (PostContractsResponse CardanoTx)) + ) + +-- | /contracts/:contractId sub-API +type ContractAPI = + GetContractAPI + :<|> Summary "Submit contract to chain" + :> Description + "Submit a signed (Cardano) transaction that opens a new Marlowe contract. \ + \The transaction must have originally been created by the POST /contracts endpoint. \ + \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ + \it will not wait for the transaction to be published in a block. \ + \Use the GET /contracts/{contractId} endpoint to poll the on-chain status." + :> OperationId "submitContract" + :> PutSignedTxAPI + :<|> "next" :> NextAPI + :<|> "transactions" :> TransactionsAPI + +type GetContractAPI = + Summary "Get contract by ID" + :> OperationId "getContractById" + :> RenameResponseSchema "GetContractResponse" + :> Get '[JSON] GetContractResponse + +type GetContractResponse = WithLink "transactions" ContractState + +-- | /contracts/sources sub-API +type ContractSourcesAPI = + PostContractSourcesAPI + :<|> Capture "contractSourceId" ContractSourceId :> ContractSourceAPI + +-- | /contracts/sources/:contractSourceId sub-API +type ContractSourceAPI = + GetContractSourceAPI + :<|> "adjacency" + :> Summary "Get adjacent contract source IDs by ID" + :> Description + "Get the contract source IDs which are adjacent to a contract source (they appear directly in the contract source)." + :> OperationId "getContractSourceAdjacency" + :> GetContractSourceIdsAPI + :<|> "closure" + :> Summary "Get contract source closure by ID" + :> Description + "Get the contract source IDs which appear in the full hierarchy of a contract source (including the ID of the contract source its self)." + :> OperationId "getContractSourceClosure" + :> GetContractSourceIdsAPI + +type PostContractSourcesAPI = + Summary "Upload contract sources" + :> Description + "Upload a bundle of marlowe objects as contract sources. This API supports request body streaming, with newline \ + \framing between request bundles." + :> OperationId "createContractSources" + :> QueryParam' '[Required, Description "The label of the top-level contract object in the bundle(s)."] "main" Label + :> StreamBody NewlineFraming JSON (Producer ObjectBundle IO ()) + :> Post '[JSON] PostContractSourceResponse + +type GetContractSourceAPI = + Summary "Get contract source by ID" + :> OperationId "getContractSourceById" + :> QueryFlag "expand" + :> Get '[JSON] Contract + +type GetContractSourceIdsAPI = RenameResponseSchema "ContractSourceIds" :> Get '[JSON] (ListObject ContractSourceId) + +type PostContractsResponse tx = WithLink "contract" (CreateTxEnvelope tx) + +data ContractState = ContractState + { contractId :: TxOutRef + , roleTokenMintingPolicyId :: PolicyId + , version :: MarloweVersion + , tags :: Map Text Metadata + , metadata :: Map Word64 Metadata + , status :: TxStatus + , block :: Maybe BlockHeader + , initialContract :: Semantics.Contract + , initialState :: Semantics.State + , currentContract :: Maybe Semantics.Contract + , state :: Maybe Semantics.State + , utxo :: Maybe TxOutRef + , assets :: Assets + , txBody :: Maybe TextEnvelope + , unclaimedPayouts :: [Payout] + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data ContractHeader = ContractHeader + { contractId :: TxOutRef + , roleTokenMintingPolicyId :: PolicyId + , version :: MarloweVersion + , tags :: Map Text Metadata + , metadata :: Map Word64 Metadata + , status :: TxStatus + , block :: Maybe BlockHeader + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) + +data PostContractSourceResponse = PostContractSourceResponse + { contractSourceId :: ContractSourceId + , intermediateIds :: Map Label ContractSourceId + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) + +data PostContractsRequest = PostContractsRequest + { tags :: Map Text Metadata + , metadata :: Map Word64 Metadata + , version :: MarloweVersion + , roles :: Maybe RolesConfig + , threadTokenName :: Maybe Text + , contract :: ContractOrSourceId + , accounts :: Map Party Assets + , minUTxODeposit :: Maybe Word64 + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +newtype ContractSourceId = ContractSourceId {unContractSourceId :: ByteString} + deriving (Eq, Ord, Generic) + deriving (Show, ToHttpApiData, ToJSON) via Base16 + +instance FromHttpApiData ContractSourceId where + parseUrlPiece = fmap ContractSourceId . (hasLength 32 . unBase16 <=< parseUrlPiece) + +instance FromJSON ContractSourceId where + parseJSON = + withText "ContractSourceId" $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance ToSchema ContractSourceId where + declareNamedSchema = pure . NamedSchema (Just "ContractSourceId") . toParamSchema + +instance ToParamSchema ContractSourceId where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "The hex-encoded identifier of a Marlowe contract source" + & pattern ?~ "^[a-fA-F0-9]{64}$" + +newtype ContractOrSourceId = ContractOrSourceId (Either Semantics.Contract ContractSourceId) + deriving (Show, Eq, Ord, Generic) + +instance FromJSON ContractOrSourceId where + parseJSON = + fmap ContractOrSourceId . \case + String "close" -> pure $ Left Semantics.Close + String s -> Right <$> parseJSON (String s) + j -> Left <$> parseJSON j + +instance ToJSON ContractOrSourceId where + toJSON = \case + ContractOrSourceId (Left contract) -> toJSON contract + ContractOrSourceId (Right hash) -> toJSON hash + +instance ToSchema ContractOrSourceId where + declareNamedSchema _ = do + contractSchema <- declareSchemaRef $ Proxy @Semantics.Contract + contractSourceIdSchema <- declareSchemaRef $ Proxy @ContractSourceId + pure $ + NamedSchema Nothing $ + mempty + & oneOf ?~ [contractSchema, contractSourceIdSchema] + +instance HasPagination ContractHeader "contractId" where + type RangeType ContractHeader "contractId" = TxOutRef + getFieldValue _ ContractHeader{..} = contractId diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/API.hs new file mode 100644 index 0000000000..7fbe23f7be --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/API.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Contract.Next.API (nextApi, NextAPI) where + +import Data.Time (UTCTime) +import Language.Marlowe.Core.V1.Next (Next) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () + +import Language.Marlowe.Runtime.Web.Adapter.Servant (OperationId) + +import Language.Marlowe.Runtime.Web.Core.Party (Party) +import Servant ( + Description, + Get, + JSON, + Proxy (..), + QueryParam', + QueryParams, + Required, + Summary, + type (:>), + ) + +nextApi :: Proxy NextAPI +nextApi = Proxy + +type NextAPI = GETNextContinuationAPI + +-- | GET /contracts/:contractId/next/continuation sub-API +type GETNextContinuationAPI = + Summary "Get next contract steps" + :> Description "Get inputs which could be performed on a contract withing a time range by the requested parties." + :> OperationId "getNextStepsForContract" + :> QueryParam' '[Required, Description "The beginning of the validity range."] "validityStart" UTCTime + :> QueryParam' '[Required, Description "The end of the validity range."] "validityEnd" UTCTime + :> QueryParams "party" Party + :> Get '[JSON] Next diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Client.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Client.hs new file mode 100644 index 0000000000..2da7cb8feb --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Client.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module Language.Marlowe.Runtime.Web.Contract.Next.Client ( + getContractNext, +) where + +import Control.Monad.IO.Class (liftIO) +import Data.Proxy (Proxy (..)) +import Data.Time (UTCTime) +import Data.Version (Version) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Language.Marlowe.Core.V1.Next (Next) + +import Language.Marlowe.Runtime.Web.API (RuntimeAPI, runtimeApi) +import Language.Marlowe.Runtime.Web.Core.Party (Party) + +import Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId) +import Language.Marlowe.Runtime.Web.Core.Tip (ChainTip) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TxOutRef, + ) +import Language.Marlowe.Runtime.Web.Status ( + RuntimeStatus (RuntimeStatus), + ) +import Servant (HasResponseHeader, ResponseHeader (..), getResponse, lookupResponseHeader, type (:<|>) ((:<|>))) +import Servant.API (Headers) +import Servant.Client (Client) +import Servant.Client.Streaming (ClientM) +import qualified Servant.Client.Streaming as ServantStreaming +import Servant.Pipes () + +import Language.Marlowe.Runtime.Web.Core.Object.Schema () + +runtimeClient :: Client ClientM RuntimeAPI +runtimeClient = ServantStreaming.client runtimeApi + +getContractNextStatus :: TxOutRef -> UTCTime -> UTCTime -> [Party] -> ClientM (RuntimeStatus, Next) +getContractNextStatus contractId validityStart validityEnd parties = do + let contractsClient :<|> _ = runtimeClient + let _ :<|> _ :<|> contractApi :<|> _ = contractsClient + let _ :<|> _ :<|> next' :<|> _ = contractApi contractId + response <- next' validityStart validityEnd parties + status <- extractStatus response + pure (status, getResponse response) + +getContractNext :: TxOutRef -> UTCTime -> UTCTime -> [Party] -> ClientM Next +getContractNext = (fmap . fmap . fmap . fmap) snd . getContractNextStatus + +reqHeaderValue :: forall name a. (KnownSymbol name) => ResponseHeader name a -> ClientM a +reqHeaderValue = \case + Header a -> pure a + UndecodableHeader _ -> liftIO $ fail $ "Unable to decode header " <> symbolVal (Proxy @name) + MissingHeader -> liftIO $ fail $ "Required header missing " <> symbolVal (Proxy @name) + +extractStatus + :: ( HasResponseHeader "X-Node-Tip" ChainTip hs + , HasResponseHeader "X-Runtime-Chain-Tip" ChainTip hs + , HasResponseHeader "X-Runtime-Tip" ChainTip hs + , HasResponseHeader "X-Network-Id" NetworkId hs + , HasResponseHeader "X-Runtime-Version" Version hs + ) + => Headers hs a + -> ClientM RuntimeStatus +extractStatus response = + RuntimeStatus + <$> (reqHeaderValue $ lookupResponseHeader @"X-Node-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Chain-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Network-Id" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Version" response) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Next/Schema.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Schema.hs similarity index 98% rename from marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Next/Schema.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Schema.hs index 1429d18617..436911a33f 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Next/Schema.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Schema.hs @@ -5,7 +5,7 @@ {-# HLINT ignore "Use fewer imports" #-} -module Language.Marlowe.Runtime.Web.Next.Schema ( +module Language.Marlowe.Runtime.Web.Contract.Next.Schema ( ) where @@ -22,7 +22,7 @@ import Data.OpenApi ( ) import Data.Proxy (Proxy (Proxy)) -import Language.Marlowe.Runtime.Web.Orphans () +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () import Language.Marlowe.Core.V1.Next (Next) import Language.Marlowe.Core.V1.Next.Applicables (ApplicableInputs) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts/Next.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Server.hs similarity index 75% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts/Next.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Server.hs index cf48d12bd0..7673b2c3c5 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts/Next.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Next/Server.hs @@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} --- | This module defines a server for the /contracts/:ContractId/next REST API. -module Language.Marlowe.Runtime.Web.Server.REST.Contracts.Next ( +module Language.Marlowe.Runtime.Web.Contract.Next.Server ( server, ) where @@ -14,12 +13,15 @@ import Language.Marlowe.Core.V1.Semantics.Types (Contract, Environment, State) import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Language.Marlowe.Runtime.Core.Api hiding (Contract, State) -import Language.Marlowe.Runtime.Web (ContractState (ContractState, currentContract, state), NextAPI, Party, TxOutRef) -import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO), fromDTOThrow) - -import Language.Marlowe.Runtime.Web.Server.Monad (ServerM, loadContract) -import Language.Marlowe.Runtime.Web.Server.REST.ApiError (badRequest', badRequest'', notFoundWithErrorCode) +import Language.Marlowe.Runtime.Core.Api (ContractId) +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO), fromDTOThrow) + +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError (badRequest', badRequest'', notFoundWithErrorCode) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad (ServerM, loadContract) +import Language.Marlowe.Runtime.Web.Contract.API (ContractState (..)) +import Language.Marlowe.Runtime.Web.Contract.Next.API (NextAPI) +import Language.Marlowe.Runtime.Web.Core.Party (Party) +import Language.Marlowe.Runtime.Web.Core.Tx (TxOutRef) import Servant (throwError) import Servant.Server (HasServer (ServerT)) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs similarity index 81% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs index 4ea21f6172..27bc335511 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE GADTs #-} -- | This module defines a server for the /contracts REST API. -module Language.Marlowe.Runtime.Web.Server.REST.Contracts where +module Language.Marlowe.Runtime.Web.Contract.Server (server) where import Cardano.Api (BabbageEra, BabbageEraOnwards (..), ConwayEra, TxBody, makeSignedTransaction) import qualified Cardano.Api as Cardano @@ -24,31 +25,86 @@ import Language.Marlowe.Runtime.Core.Api ( ) import qualified Language.Marlowe.Runtime.Core.Api as Core import Language.Marlowe.Runtime.Transaction.Api (ContractCreated (..), ContractCreatedInEra (..), WalletAddresses (..)) -import Language.Marlowe.Runtime.Web hiding (Unsigned) -import Language.Marlowe.Runtime.Web.Server.DTO -import Language.Marlowe.Runtime.Web.Server.Monad ( - ServerM, - createContract, - loadContract, - loadContractHeaders, - submitContract, +import Language.Marlowe.Runtime.Web.Adapter.CommaList ( + CommaList (unCommaList), + ) +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink (..)) +import Language.Marlowe.Runtime.Web.Adapter.Pagination ( + PaginatedResponse, ) -import Language.Marlowe.Runtime.Web.Server.REST.ApiError ( +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError ( ApiError (ApiError), badRequest', notFound', rangeNotSatisfiable', throwDTOError, ) -import qualified Language.Marlowe.Runtime.Web.Server.REST.ApiError as ApiError -import qualified Language.Marlowe.Runtime.Web.Server.REST.ContractSources as ContractSources -import qualified Language.Marlowe.Runtime.Web.Server.REST.Contracts.Next as Next -import qualified Language.Marlowe.Runtime.Web.Server.REST.Transactions as Transactions -import Language.Marlowe.Runtime.Web.Server.REST.Withdrawals (TxBodyInAnyEra (..)) -import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx (TempTx), TempTxStatus (Unsigned)) -import Language.Marlowe.Runtime.Web.Server.Util (makeSignedTxWithWitnessKeys) -import Servant -import Servant.Pagination +import qualified Language.Marlowe.Runtime.Web.Adapter.Server.ApiError as ApiError +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO ( + FromDTO (fromDTO), + ShelleyTxWitness (..), + ToDTO (toDTO), + fromDTOThrow, + fromPaginationRange, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + ServerM, + createContract, + loadContract, + loadContractHeaders, + submitContract, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (TempTx), TempTxStatus (Unsigned)) +import Language.Marlowe.Runtime.Web.Adapter.Server.Util (makeSignedTxWithWitnessKeys) +import Language.Marlowe.Runtime.Web.Contract.API ( + ContractAPI, + ContractHeader, + ContractOrSourceId (..), + ContractsAPI, + GetContractResponse, + GetContractsResponse, + PostContractsRequest (..), + PostContractsResponse, + unContractSourceId, + ) +import qualified Language.Marlowe.Runtime.Web.Contract.Next.Server as Next +import qualified Language.Marlowe.Runtime.Web.Contract.Source.Server as ContractSources +import qualified Language.Marlowe.Runtime.Web.Contract.Transaction.Server as Transactions +import Language.Marlowe.Runtime.Web.Core.Address ( + Address, + StakeAddress, + ) +import Language.Marlowe.Runtime.Web.Core.Asset ( + AssetId, + PolicyId, + ) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope (..), + TxOutRef, + ) +import Language.Marlowe.Runtime.Web.Withdrawal.Server (TxBodyInAnyEra (..)) + +import Language.Marlowe.Runtime.Web.Tx.API ( + CardanoTx, + CardanoTxBody, + CreateTxEnvelope (CreateTxEnvelope), + ) +import Servant ( + HasServer (ServerT), + NoContent (..), + Proxy (Proxy), + addHeader, + throwError, + type (:<|>) ((:<|>)), + ) +import Servant.Pagination ( + ExtractRange (extractRange), + HasPagination (getDefaultRange), + Range, + Ranges, + returnRange, + ) server :: ServerT ContractsAPI ServerM server = @@ -150,9 +206,6 @@ get roleCurrencies' tags' partyAddresses' partyRoles' ranges = do let response = IncludeLink (Proxy @"transactions") . IncludeLink (Proxy @"contract") <$> headers' addHeader totalCount . fmap ListObject <$> returnRange range response -toContractHeader :: ContractState -> ContractHeader -toContractHeader ContractState{..} = ContractHeader{..} - contractServer :: TxOutRef -> ServerT ContractAPI ServerM contractServer contractId = getOne contractId diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ContractSources.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Source/Server.hs similarity index 85% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ContractSources.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Source/Server.hs index 1cbd49d954..ca0f28c07e 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ContractSources.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Source/Server.hs @@ -1,4 +1,6 @@ -module Language.Marlowe.Runtime.Web.Server.REST.ContractSources where +{-# LANGUAGE ExplicitNamespaces #-} + +module Language.Marlowe.Runtime.Web.Contract.Source.Server (server) where import Data.Aeson (object) import Data.Aeson.Types ((.=)) @@ -14,14 +16,30 @@ import Language.Marlowe.Object.Types (Label, ObjectBundle) import Language.Marlowe.Protocol.Transfer.Types (ImportError (..)) import Language.Marlowe.Runtime.ChainSync.Api (DatumHash (..)) import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency (..)) -import Language.Marlowe.Runtime.Web (ContractSourceAPI, ContractSourcesAPI, ListObject (..)) -import Language.Marlowe.Runtime.Web.Server.Monad -import Language.Marlowe.Runtime.Web.Server.REST.ApiError (badRequest', badRequest'') -import Language.Marlowe.Runtime.Web.Types (ContractSourceId (..), PostContractSourceResponse (..)) + +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError (badRequest', badRequest'') +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + ServerM, + getContract, + importBundle, + ) +import Language.Marlowe.Runtime.Web.Contract.API ( + ContractSourceAPI, + ContractSourceId (..), + ContractSourcesAPI, + PostContractSourceResponse (..), + ) + import Pipes (MFunctor (..), Producer, liftIO, (>->)) import qualified Pipes.Prelude as Pipes import qualified PlutusLedgerApi.V2 as PV2 -import Servant +import Servant ( + HasServer (ServerT), + err404, + throwError, + type (:<|>) ((:<|>)), + ) server :: ServerT ContractSourcesAPI ServerM server = diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs new file mode 100644 index 0000000000..80fd3ece3d --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Contract.Transaction.API ( + TransactionsAPI, + GetTransactionsAPI, + GetTransactionsResponse, + TransactionAPI, + GetTransactionAPI, + GetTransactionResponse, + PostTransactionsResponse, +) where + +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () + +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink) +import Language.Marlowe.Runtime.Web.Adapter.Pagination (PaginatedGet) +import Language.Marlowe.Runtime.Web.Adapter.Servant ( + OperationId, + RenameResponseSchema, + ) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Language.Marlowe.Runtime.Web.Core.Tx +import Language.Marlowe.Runtime.Web.Tx.API ( + ApplyInputsTx, + ApplyInputsTxEnvelope, + CardanoTx, + CardanoTxBody, + PostTxAPI, + PutSignedTxAPI, + Tx, + TxHeader, + TxJSON, + ) +import Language.Marlowe.Runtime.Web.Withdrawal.API ( + PostTransactionsRequest, + ) +import Servant ( + Capture, + Description, + Get, + JSON, + PostCreated, + ReqBody, + Summary, + type (:<|>), + type (:>), + ) + +-- | /contracts/:contractId/transactions sub-API +type TransactionsAPI = + GetTransactionsAPI + :<|> PostTransactionsAPI + :<|> Capture "transactionId" TxId :> TransactionAPI + +-- | GET /contracts/:contractId/transactions sub-API +type GetTransactionsAPI = + Summary "Get transactions for contract" + :> Description + "Get published transactions for a contract. \ + \Results are returned in pages, with paging being specified by request headers." + :> OperationId "getTransactionsForContract" + :> RenameResponseSchema "GetTransactionsResponse" + :> PaginatedGet '["transactionId"] GetTransactionsResponse + +type GetTransactionsResponse = WithLink "transaction" TxHeader + +-- | /contracts/:contractId/transactions/:transactionId sub-API +type TransactionAPI = + GetTransactionAPI + :<|> Summary "Submit contract input application" + :> Description + "Submit a signed (Cardano) transaction that applies inputs to an open Marlowe contract. \ + \The transaction must have originally been created by the POST /contracts/{contractId}/transactions endpoint. \ + \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ + \it will not wait for the transaction to be published in a block. \ + \Use the GET /contracts/{contractId}/transactions/{transactionId} endpoint to poll the on-chain status." + :> OperationId "submitContractTransaction" + :> PutSignedTxAPI + +-- | GET /contracts/:contractId/transactions/:transactionId sub-API +type GetTransactionAPI = + Summary "Get contract transaction by ID" + :> OperationId "getContractTransactionById" + :> RenameResponseSchema "GetTransactionResponse" + :> Get '[JSON] GetTransactionResponse + +type GetTransactionResponse = WithLink "previous" (WithLink "next" Tx) + +-- | POST /contracts/:contractId/transactions sub-API +type PostTransactionsAPI = + Summary "Apply inputs to contract" + :> Description + "Build an unsigned (Cardano) transaction body which applies inputs to an open Marlowe contract. \ + \This unsigned transaction must be signed by a wallet (such as a CIP-30 or CIP-45 wallet) before being submitted. \ + \To submit the signed transaction, use the PUT /contracts/{contractId}/transactions/{transactionId} endpoint." + :> OperationId "applyInputsToContract" + :> RenameResponseSchema "ApplyInputsResponse" + :> ( ReqBody '[JSON] PostTransactionsRequest :> PostTxAPI (PostCreated '[JSON] (PostTransactionsResponse CardanoTxBody)) + :<|> ReqBody '[JSON] PostTransactionsRequest + :> PostTxAPI (PostCreated '[TxJSON ApplyInputsTx] (PostTransactionsResponse CardanoTx)) + ) + +type PostTransactionsResponse tx = WithLink "transaction" (ApplyInputsTxEnvelope tx) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Transactions.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs similarity index 80% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Transactions.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs index e889d67758..03c3a11282 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Transactions.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE GADTs #-} -- | This module defines a server for the /contracts/:contractId/transactions REST API. -module Language.Marlowe.Runtime.Web.Server.REST.Transactions where +module Language.Marlowe.Runtime.Web.Contract.Transaction.Server (server) where import Cardano.Api (BabbageEra, BabbageEraOnwards (..), ConwayEra, TxBody, getTxId, makeSignedTransaction) import qualified Cardano.Api as Cardano @@ -21,29 +22,74 @@ import Language.Marlowe.Runtime.Core.Api ( ) import qualified Language.Marlowe.Runtime.Core.Api as Core import Language.Marlowe.Runtime.Transaction.Api (InputsApplied (..), InputsAppliedInEra (..), WalletAddresses (..)) -import Language.Marlowe.Runtime.Web hiding (Unsigned) -import Language.Marlowe.Runtime.Web.Server.DTO -import Language.Marlowe.Runtime.Web.Server.Monad ( - ServerM, - applyInputs, - loadTransaction, - loadTransactions, - submitTransaction, +import Language.Marlowe.Runtime.Web.Adapter.CommaList ( + CommaList (unCommaList), ) -import Language.Marlowe.Runtime.Web.Server.REST.ApiError ( +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink (..)) +import Language.Marlowe.Runtime.Web.Adapter.Pagination ( + PaginatedResponse, + ) +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError ( ApiError (ApiError), badRequest', notFound', rangeNotSatisfiable', throwDTOError, ) -import qualified Language.Marlowe.Runtime.Web.Server.REST.ApiError as ApiError -import Language.Marlowe.Runtime.Web.Server.REST.Withdrawals (TxBodyInAnyEra (..)) -import Language.Marlowe.Runtime.Web.Server.SyncClient (LoadTxError (..)) -import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx (TempTx), TempTxStatus (..)) -import Language.Marlowe.Runtime.Web.Server.Util (makeSignedTxWithWitnessKeys) -import Servant -import Servant.Pagination +import qualified Language.Marlowe.Runtime.Web.Adapter.Server.ApiError as ApiError +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO ( + FromDTO (fromDTO), + ShelleyTxWitness (..), + ToDTO (toDTO), + fromDTOThrow, + fromPaginationRange, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + ServerM, + applyInputs, + loadTransaction, + loadTransactions, + submitTransaction, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient (LoadTxError (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (TempTx), TempTxStatus (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.Util (makeSignedTxWithWitnessKeys) +import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( + GetTransactionResponse, + GetTransactionsResponse, + PostTransactionsResponse, + TransactionAPI, + TransactionsAPI, + ) +import Language.Marlowe.Runtime.Web.Core.Address (Address) +import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope (..), TxId, TxOutRef) +import Language.Marlowe.Runtime.Web.Withdrawal.Server (TxBodyInAnyEra (..)) + +import Language.Marlowe.Runtime.Web.Tx.API ( + ApplyInputsTxEnvelope (ApplyInputsTxEnvelope), + CardanoTx, + CardanoTxBody, + TxHeader, + ) +import Language.Marlowe.Runtime.Web.Withdrawal.API ( + PostTransactionsRequest (..), + ) +import Servant ( + HasServer (ServerT), + NoContent (..), + Proxy (Proxy), + addHeader, + throwError, + type (:<|>) ((:<|>)), + ) +import Servant.Pagination ( + ExtractRange (extractRange), + HasPagination (getDefaultRange), + Range, + Ranges, + returnRange, + ) server :: TxOutRef -> ServerT TransactionsAPI ServerM server contractId = diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Address.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Address.hs new file mode 100644 index 0000000000..d68f5d80db --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Address.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Core.Address ( + Address (..), + StakeAddress (..), +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, ToJSON) +import Data.OpenApi ( + HasType (..), + NamedSchema (..), + OpenApiType (..), + ToParamSchema, + ToSchema, + example, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Servant ( + FromHttpApiData, + ) +import Servant.API (ToHttpApiData) + +newtype Address = Address {unAddress :: T.Text} + deriving (Eq, Ord, Generic) + deriving newtype (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON) + +instance ToSchema Address where + declareNamedSchema = pure . NamedSchema (Just "Address") . toParamSchema + +instance ToParamSchema Address where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "A cardano address, in Bech32 format" + & example ?~ "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" + +newtype StakeAddress = StakeAddress {unStakeAddress :: T.Text} + deriving (Eq, Ord, Generic) + deriving newtype (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON) + +instance ToSchema StakeAddress where + declareNamedSchema = pure . NamedSchema (Just "StakeAddress") . toParamSchema + +instance ToParamSchema StakeAddress where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "A cardano stake address, in Bech32 format" + & example ?~ "stake1ux7lyy9nhecm033qsmel9awnr22up6jadlzkrxufr78w82gsfsn0d" diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Asset.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Asset.hs new file mode 100644 index 0000000000..ef1f30d8e2 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Asset.hs @@ -0,0 +1,82 @@ +module Language.Marlowe.Runtime.Web.Core.Asset ( + Assets (..), + Tokens (..), + AssetId (..), + PolicyId (..), +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.ByteString (ByteString) +import Data.Map (Map) +import Data.OpenApi ( + HasType (..), + NamedSchema (..), + OpenApiType (..), + ToParamSchema, + ToSchema, + pattern, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Core.Base16 (Base16 (..)) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData (parseUrlPiece), + ToHttpApiData (toUrlPiece), + ) + +data Assets = Assets + { lovelace :: Integer + , tokens :: Tokens + } + deriving (Eq, Show, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, ToSchema) + +newtype Tokens = Tokens {unTokens :: Map PolicyId (Map Text Integer)} + deriving (Eq, Show, Ord, Generic) + deriving newtype (ToJSON, FromJSON, ToSchema) + +newtype PolicyId = PolicyId {unPolicyId :: ByteString} + deriving (Eq, Ord, Generic) + deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, ToJSONKey, FromJSON, FromJSONKey) via Base16 + +instance ToSchema PolicyId where + declareNamedSchema proxy = pure $ NamedSchema (Just "PolicyId") $ toParamSchema proxy + +instance ToParamSchema PolicyId where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "The hex-encoded minting policy ID for a native Cardano token" + & pattern ?~ "^[a-fA-F0-9]*$" + +data AssetId = AssetId + { policyId :: PolicyId + , assetName :: Text + } + deriving (Show, Eq, Ord, Generic) + +instance ToSchema AssetId +instance FromJSON AssetId +instance ToJSON AssetId + +instance ToParamSchema AssetId where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description + ?~ "A minting policy ID and a token name identifying a specific asset type. Encoded as policyId.tokenName." + & pattern ?~ "^[a-fA-F0-9]*\\..*$" + +instance FromHttpApiData AssetId where + parseUrlPiece piece = case T.breakOn "." piece of + (_, "") -> Left "Expected ^[a-fA-F0-9]*(\\.).*$" + (policyId, tokenNameStartingWitPeriodCharacter) -> AssetId <$> parseUrlPiece policyId <*> parseUrlPiece (T.drop 1 tokenNameStartingWitPeriodCharacter) + +instance ToHttpApiData AssetId where + toUrlPiece AssetId{..} = toUrlPiece policyId <> "." <> toUrlPiece assetName diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Base16.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Base16.hs new file mode 100644 index 0000000000..d18c449817 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Base16.hs @@ -0,0 +1,61 @@ +module Language.Marlowe.Runtime.Web.Core.Base16 (Base16 (..)) where + +import Data.Aeson ( + FromJSON (parseJSON), + FromJSONKey (fromJSONKey), + FromJSONKeyFunction (FromJSONKeyTextParser), + ToJSON (toJSON), + ToJSONKey (toJSONKey), + Value (String), + withText, + ) +import Data.Aeson.Types (parseFail, toJSONKeyText) +import Data.ByteString (ByteString) +import Data.ByteString.Base16 (decodeBase16, encodeBase16) +import Data.OpenApi ( + NamedSchema (..), + ToSchema, + declareSchema, + ) +import Data.OpenApi.Schema (ToSchema (..)) +import Data.String (IsString (..)) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData (parseUrlPiece), + Proxy (..), + ToHttpApiData (toUrlPiece), + ) + +-- | A newtype for Base16 decoding and encoding ByteStrings +newtype Base16 = Base16 {unBase16 :: ByteString} + deriving (Eq, Ord) + +instance Show Base16 where + show = T.unpack . encodeBase16 . unBase16 + +instance IsString Base16 where + fromString = either (error . T.unpack) Base16 . decodeBase16 . encodeUtf8 . T.pack + +instance ToJSON Base16 where + toJSON = String . toUrlPiece + +instance ToJSONKey Base16 where + toJSONKey = toJSONKeyText toUrlPiece + +instance FromJSON Base16 where + parseJSON = + withText "Base16" $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance FromJSONKey Base16 where + fromJSONKey = FromJSONKeyTextParser $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance ToHttpApiData Base16 where + toUrlPiece = encodeBase16 . unBase16 + +instance FromHttpApiData Base16 where + parseUrlPiece = fmap Base16 . decodeBase16 . encodeUtf8 + +instance ToSchema Base16 where + declareNamedSchema _ = NamedSchema Nothing <$> declareSchema (Proxy @String) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/BlockHeader.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/BlockHeader.hs new file mode 100644 index 0000000000..c3fe465c48 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/BlockHeader.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Core.BlockHeader ( + BlockHeader (..), +) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.OpenApi (ToSchema) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Core.Base16 (Base16) + +data BlockHeader = BlockHeader + { slotNo :: Word64 + , blockNo :: Word64 + , blockHeaderHash :: Base16 + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/MarloweVersion.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/MarloweVersion.hs new file mode 100644 index 0000000000..9680fbc5d6 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/MarloweVersion.hs @@ -0,0 +1,58 @@ +module Language.Marlowe.Runtime.Web.Core.MarloweVersion (MarloweVersion (..)) where + +import Control.Lens ((&), (?~)) +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON (toJSON), + Value (String), + withText, + ) +import Data.Aeson.Types (parseFail) +import Data.Foldable (fold) +import Data.OpenApi ( + HasType (..), + NamedSchema (..), + OpenApiType (..), + ToSchema, + enum_, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Text (intercalate) +import qualified Data.Text as T +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData (parseUrlPiece), + ToHttpApiData (toUrlPiece), + ) + +data MarloweVersion = V1 + deriving (Show, Eq, Ord) + +instance ToJSON MarloweVersion where + toJSON V1 = String "v1" + +instance FromJSON MarloweVersion where + parseJSON = + withText "MarloweVersion" $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance ToHttpApiData MarloweVersion where + toUrlPiece V1 = "v1" + +instance FromHttpApiData MarloweVersion where + parseUrlPiece "v1" = Right V1 + parseUrlPiece _ = + Left $ + fold @[] + [ "expected one of " + , intercalate "; " ["v1"] + ] + +instance ToSchema MarloweVersion where + declareNamedSchema _ = + pure $ + NamedSchema (Just "MarloweVersion") $ + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "A version of the Marlowe language." + & enum_ ?~ ["v1"] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Metadata.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Metadata.hs new file mode 100644 index 0000000000..835524f1e8 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Metadata.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Core.Metadata ( + Metadata (..), +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.OpenApi ( + AdditionalProperties (..), + NamedSchema (..), + OpenApiItems (..), + OpenApiType (..), + Reference (..), + Referenced (..), + ToSchema, + declareSchemaRef, + oneOf, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + Proxy (..), + ) + +newtype Metadata = Metadata {unMetadata :: Value} + deriving (Show, Eq, Ord) + deriving newtype (ToJSON, FromJSON) + +instance ToSchema Metadata where + declareNamedSchema _ = do + integerSchema <- declareSchemaRef $ Proxy @Integer + let metadataSchema = Ref $ Reference "Metadata" + binaryTextSchema = + mempty + & OpenApi.description ?~ "Hex-encoded binary data of up to 64 bytes" + & OpenApi.type_ ?~ OpenApiString + & OpenApi.pattern ?~ "0x[A-Fa-f0-9]{0,128}" + plainTextSchema = + mempty + & OpenApi.description ?~ "Text data of up to 64 characters" + & OpenApi.type_ ?~ OpenApiString + metadataArraySchema = + mempty + & OpenApi.description ?~ "Array of metadata values" + & OpenApi.type_ ?~ OpenApiArray + & OpenApi.items ?~ OpenApiItemsObject metadataSchema + metadataObjectSchema = + mempty + & OpenApi.description ?~ "Object of metadata values" + & OpenApi.type_ ?~ OpenApiObject + & OpenApi.additionalProperties ?~ AdditionalPropertiesSchema metadataSchema + pure $ + NamedSchema (Just "Metadata") $ + mempty + & OpenApi.description ?~ "Arbitrary JSON-encoded transaction metadata" + & oneOf + ?~ [ integerSchema + , Inline binaryTextSchema + , Inline plainTextSchema + , Inline metadataArraySchema + , Inline metadataObjectSchema + ] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/NetworkId.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/NetworkId.hs new file mode 100644 index 0000000000..80bf804a04 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/NetworkId.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId (..)) where + +import Control.Lens ((&), (?~)) +import Data.OpenApi ( + HasType (..), + NamedSchema (..), + OpenApiType (..), + Referenced (..), + ToParamSchema, + ToSchema, + declareSchemaRef, + enum_, + oneOf, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Word (Word32) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData, + Proxy (..), + ToHttpApiData (toUrlPiece), + ) +import Servant.API (FromHttpApiData (..)) + +data NetworkId + = Mainnet + | Testnet Word32 + deriving (Show, Eq, Ord) + +instance ToSchema NetworkId where + declareNamedSchema _ = do + let mainnetSchema = + mempty + & type_ ?~ OpenApiString + & enum_ ?~ ["mainnet"] + testnetSchema <- declareSchemaRef (Proxy @Word32) + pure $ + NamedSchema (Just "NetworkId") $ + mempty + & oneOf ?~ [Inline mainnetSchema, testnetSchema] + +instance ToHttpApiData NetworkId where + toUrlPiece = \case + Mainnet -> "mainnet" + Testnet n -> toUrlPiece n + +instance FromHttpApiData NetworkId where + parseUrlPiece = \case + "mainnet" -> pure Mainnet + n -> Testnet <$> parseUrlPiece n + +instance ToParamSchema NetworkId where + toParamSchema _ = + mempty + & oneOf ?~ [Inline (mempty & type_ ?~ OpenApiString), Inline (mempty & type_ ?~ OpenApiInteger)] + & OpenApi.description ?~ "The latest known point in the chain on a peer." diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Object/Schema.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Object/Schema.hs new file mode 100644 index 0000000000..3968bb0998 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Object/Schema.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Core.Object.Schema () where + +import Language.Marlowe.Object.Types (Label (..)) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData (parseUrlPiece), + ToHttpApiData (toUrlPiece), + ) + +instance ToHttpApiData Label where + toUrlPiece = unLabel + +instance FromHttpApiData Label where + parseUrlPiece = pure . Label diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Party.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Party.hs new file mode 100644 index 0000000000..9fb0193489 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Party.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Core.Party ( + Party (..), +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.OpenApi ( + HasType (type_), + NamedSchema (NamedSchema), + OpenApiType (OpenApiString), + ToParamSchema (..), + ToSchema (..), + ) +import qualified Data.OpenApi as OpenApi +import qualified Data.Text as T +import GHC.Generics (Generic) +import Servant (FromHttpApiData, ToHttpApiData) + +newtype Party = Party {unParty :: T.Text} + deriving (Eq, Ord, Generic) + deriving newtype (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, FromJSONKey, ToJSONKey) + +instance ToSchema Party where + declareNamedSchema proxy = pure $ NamedSchema (Just "Party") $ toParamSchema proxy + +instance ToParamSchema Party where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "Party (A role name or an Address)" diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs new file mode 100644 index 0000000000..8092923ffa --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module defines the request and response types in the Marlowe Runtime +-- | Web API. +module Language.Marlowe.Runtime.Web.Core.Roles ( + RolesConfig (..), + RoleTokenConfig (..), + RoleTokenRecipient (..), + TokenMetadata (..), + TokenMetadataFile (..), + RoleTokenFilter (..), +) where + +import Control.Applicative ((<|>)) +import Control.Lens ((&), (.~), (?~)) +import Control.Monad (unless) +import Data.Aeson ( + FromJSON (parseJSON), + FromJSONKey (fromJSONKey), + FromJSONKeyFunction (FromJSONKeyText), + KeyValue ((.=)), + ToJSON (toJSON), + ToJSONKey (toJSONKey), + Value (Array, Bool, Object, String), + object, + withObject, + withText, + (.:), + (.:?), + (), + ) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as AMap +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (JSONPathElement (..), Parser, prependFailure, toJSONKeyText, typeMismatch) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.OpenApi ( + AdditionalProperties (..), + Definitions, + HasAdditionalProperties (..), + HasType (..), + NamedSchema (..), + OpenApiType (..), + Referenced (..), + Schema, + ToSchema, + declareSchemaRef, + enum_, + oneOf, + properties, + required, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Declare (Declare) +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Traversable (for) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Adapter.URI ( + uriFromJSON, + uriToJSON, + ) +import Language.Marlowe.Runtime.Web.Core.Address (Address (..)) +import Language.Marlowe.Runtime.Web.Core.Asset ( + AssetId, + PolicyId, + ) +import Language.Marlowe.Runtime.Web.Core.Metadata (Metadata) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Language.Marlowe.Runtime.Web.Core.Tx (TxOutRef) +import Servant ( + Proxy (..), + URI, + ) + +data RolesConfig + = UsePolicy PolicyId + | UsePolicyWithOpenRoles PolicyId [Text] + | Mint (Map Text RoleTokenConfig) + deriving (Show, Eq, Ord, Generic) + +instance FromJSON RolesConfig where + parseJSON (String s) = UsePolicy <$> parseJSON (String s) + parseJSON value = + withObject + "RolesConfig" + ( \obj -> + let parseMint = Mint <$> parseJSON value + parseOpen = + do + script <- obj .: "script" + unless (script == ("OpenRole" :: String)) $ fail "AllowedValues: \"OpenRole\"" + UsePolicyWithOpenRoles <$> obj .: "policyId" <*> obj .: "openRoleNames" + in parseOpen <|> parseMint + ) + value + +instance ToJSON RolesConfig where + toJSON (UsePolicy policy) = toJSON policy + toJSON (UsePolicyWithOpenRoles policy openRoleNames) = + object + [ "script" .= ("OpenRole" :: String) + , "policyId" .= policy + , "openRoleNames" .= openRoleNames + ] + toJSON (Mint configs) = toJSON configs + +instance ToSchema RolesConfig where + declareNamedSchema _ = do + policySchema <- declareSchemaRef (Proxy @PolicyId) + mintSchema <- declareSchemaRef (Proxy @(Map Text RoleTokenConfig)) + pure $ + NamedSchema (Just "RolesConfig") $ + mempty + & oneOf ?~ [policySchema, mintSchema] + +data RoleTokenConfig = RoleTokenConfig + { recipients :: RoleTokenRecipients + , metadata :: Maybe TokenMetadata + } + deriving (Show, Eq, Ord, Generic) + +type RoleTokenRecipients = Map RoleTokenRecipient Word64 + +data RoleTokenRecipient + = ClosedRole Address + | OpenRole + deriving (Show, Eq, Ord, Generic) + +roleTokenRecipientToText :: RoleTokenRecipient -> Text +roleTokenRecipientToText = \case + ClosedRole addr -> unAddress addr + OpenRole -> "OpenRole" + +roleTokenRecipientFromText :: Text -> RoleTokenRecipient +roleTokenRecipientFromText = \case + "OpenRole" -> OpenRole + addr -> ClosedRole $ Address addr + +instance ToJSON RoleTokenRecipient where + toJSON = String . roleTokenRecipientToText + +instance ToJSONKey RoleTokenRecipient where + toJSONKey = toJSONKeyText roleTokenRecipientToText + +instance FromJSON RoleTokenRecipient where + parseJSON = withText "RoleTokenRecipient" $ pure . roleTokenRecipientFromText + +instance FromJSONKey RoleTokenRecipient where + fromJSONKey = FromJSONKeyText roleTokenRecipientFromText + +instance FromJSON RoleTokenConfig where + parseJSON (String "OpenRole") = + pure + . flip RoleTokenConfig Nothing + $ Map.singleton OpenRole 1 + parseJSON (String s) = + pure + . flip RoleTokenConfig Nothing + . flip Map.singleton 1 + . ClosedRole + $ Address s + parseJSON value = + withObject + "RoleTokenConfig" + ( \obj -> do + mRecipients <- obj .:? "recipients" + mAddress <- obj .:? "address" + mScriptRole <- do + mScript :: Maybe String <- obj .:? "script" + for + mScript + ( \case + "OpenRole" -> pure OpenRole + _ -> fail "Expected \'OpenRole\"" + ) + metadata <- obj .:? "metadata" + recipients <- case (mRecipients, mAddress, mScriptRole) of + (Just recipients, _, _) -> pure recipients + (_, Just address, _) -> pure $ Map.singleton (ClosedRole address) 1 + (_, _, Just scriptRole) -> pure $ Map.singleton scriptRole 1 + _ -> fail "one of recipients, address, or script required" + pure RoleTokenConfig{..} + ) + value + +instance ToJSON RoleTokenConfig where + toJSON (RoleTokenConfig recipients metadata) = + object + [ "recipients" .= recipients + , "metadata" .= metadata + ] + +instance ToSchema RoleTokenConfig where + declareNamedSchema _ = do + simpleSchema <- declareSchemaRef (Proxy @Address) + metadataSchema <- declareSchemaRef (Proxy @TokenMetadata) + quantitySchema <- declareSchemaRef (Proxy @Word64) + let multiSchema = + mempty + & type_ ?~ OpenApiObject + & required .~ ["recipients"] + & properties + .~ [ + ( "recipients" + , Inline $ + mempty + & type_ ?~ OpenApiObject + & additionalProperties ?~ AdditionalPropertiesSchema quantitySchema + ) + , ("metadata", metadataSchema) + ] + advancedSchema = + mempty + & type_ ?~ OpenApiObject + & required .~ ["address"] + & properties + .~ [ ("address", simpleSchema) + , ("metadata", metadataSchema) + ] + scriptSchema = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "The type of script receiving the role token." + & enum_ ?~ ["OpenRole"] + openSchema = + mempty + & type_ ?~ OpenApiObject + & required .~ ["script"] + & properties + .~ [ ("script", Inline scriptSchema) + , ("metadata", metadataSchema) + ] + pure $ + NamedSchema (Just "RoleTokenConfig") $ + mempty + & oneOf ?~ [Inline multiSchema, simpleSchema, Inline advancedSchema, Inline openSchema] + +data TokenMetadata = TokenMetadata + { name :: Text + , image :: URI + , mediaType :: Maybe Text + , description :: Maybe Text + , files :: Maybe [TokenMetadataFile] + , additionalProps :: Aeson.Object + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TokenMetadata where + parseJSON = + withObject + "TokenMetadata" + ( \obj -> do + imageJSON <- obj .: "image" + let additionalProps = + AMap.delete "name" + . AMap.delete "image" + . AMap.delete "mediaType" + . AMap.delete "description" + . AMap.delete "files" + $ obj + TokenMetadata + <$> obj + .: "name" + <*> uriFromJSON imageJSON + <*> obj + .:? "mediaType" + <*> obj + .:? "description" + <*> obj + .:? "files" + <*> pure additionalProps + ) + +instance ToJSON TokenMetadata where + toJSON TokenMetadata{..} = + object $ + [ "name" .= name + , "image" .= uriToJSON image + , "mediaType" .= mediaType + , "description" .= description + , "files" .= files + ] + <> AMap.toList additionalProps + +instance ToSchema TokenMetadata where + declareNamedSchema _ = do + stringSchema <- declareSchemaRef (Proxy @Text) + filesSchema <- declareSchemaRef (Proxy @[TokenMetadataFile]) + metadataSchema <- declareSchemaRef (Proxy @Metadata) + pure $ + NamedSchema (Just "TokenMetadata") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Metadata for an NFT, as described by https://cips.cardano.org/cips/cip25/" + & required .~ ["name", "image"] + & properties + .~ [ ("name", stringSchema) + , ("image", stringSchema) + , ("mediaType", stringSchema) + , ("description", stringSchema) + , ("files", filesSchema) + ] + & additionalProperties ?~ AdditionalPropertiesSchema metadataSchema + +data TokenMetadataFile = TokenMetadataFile + { name :: Text + , src :: URI + , mediaType :: Text + , additionalProps :: Aeson.Object + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON TokenMetadataFile where + parseJSON = + withObject + "TokenMetadataFile" + ( \obj -> do + srcJSON <- obj .: "src" + let additionalProps = + AMap.delete "name" + . AMap.delete "mediaType" + . AMap.delete "src" + $ obj + TokenMetadataFile + <$> obj + .: "name" + <*> uriFromJSON srcJSON + <*> obj + .: "mediaType" + <*> pure additionalProps + ) + +instance ToJSON TokenMetadataFile where + toJSON TokenMetadataFile{..} = + object $ + [ ("name", toJSON name) + , ("src", uriToJSON src) + , ("mediaType", toJSON mediaType) + ] + <> AMap.toList additionalProps + +instance ToSchema TokenMetadataFile where + declareNamedSchema _ = do + stringSchema <- declareSchemaRef (Proxy @Text) + metadataSchema <- declareSchemaRef (Proxy @Metadata) + pure $ + NamedSchema (Just "TokenMetadataFile") $ + mempty + & type_ ?~ OpenApiObject + & required .~ ["name", "src", "mediaType"] + & properties + .~ [ ("name", stringSchema) + , ("src", stringSchema) + , ("mediaType", stringSchema) + ] + & additionalProperties ?~ AdditionalPropertiesSchema metadataSchema + +data RoleTokenFilter + = RoleTokenAnd RoleTokenFilter RoleTokenFilter + | RoleTokenOr RoleTokenFilter RoleTokenFilter + | RoleTokenNot RoleTokenFilter + | RoleTokenFilterNone + | RoleTokenFilterByContracts (Set TxOutRef) + | RoleTokenFilterByPolicies (Set PolicyId) + | RoleTokenFilterByTokens (Set AssetId) + | RoleTokenFilterAny + deriving stock (Show, Eq, Ord, Generic) + +instance ToJSON RoleTokenFilter where + toJSON = \case + RoleTokenAnd a b -> object ["and" .= (a, b)] + RoleTokenOr a b -> object ["or" .= (a, b)] + RoleTokenNot a -> object ["not" .= a] + RoleTokenFilterNone -> toJSON False + RoleTokenFilterByContracts contracts -> object ["contract_id" .= contracts] + RoleTokenFilterByPolicies policies -> object ["roles_currency" .= policies] + RoleTokenFilterByTokens tokens -> object ["role_tokens" .= tokens] + RoleTokenFilterAny -> toJSON True + +instance FromJSON RoleTokenFilter where + parseJSON = + prependFailure "Parsing RoleTokenFilter failed" . \case + Object o -> case KeyMap.toList o of + [(k, v)] -> case k of + "and" -> uncurry RoleTokenAnd <$> parseJSON v Key "and" + "or" -> uncurry RoleTokenOr <$> parseJSON v Key "or" + "not" -> RoleTokenNot <$> parseJSON v Key "not" + "contract_id" -> RoleTokenFilterByContracts <$> parseSetOrSingle v Key "contract_id" + "roles_currency" -> RoleTokenFilterByPolicies <$> parseSetOrSingle v Key "roles_currency" + "role_tokens" -> RoleTokenFilterByTokens <$> parseSetOrSingle v Key "role_tokens" + _ -> fail $ "Unexpected key: " <> show k + _ -> fail "Unexpected number of keys, expected exactly 1." + Bool True -> pure RoleTokenFilterAny + Bool False -> pure RoleTokenFilterNone + v -> typeMismatch "object|boolean" v + +parseSetOrSingle :: (FromJSON a, Ord a) => Value -> Parser (Set a) +parseSetOrSingle = \case + Array arr -> parseJSON $ Array arr + v -> Set.singleton <$> parseJSON v + +instance ToSchema RoleTokenFilter where + declareNamedSchema _ = do + roleTokenFilterSchema <- declareSchemaRef $ Proxy @RoleTokenFilter + roleTokenFilterPairSchema <- declareSchemaRef $ Proxy @(RoleTokenFilter, RoleTokenFilter) + let setOrSingleSchema + :: forall a + . (ToSchema a) + => Proxy a + -> Declare (Definitions Schema) (Referenced Schema) + setOrSingleSchema p = do + singleSchema <- declareSchemaRef p + setSchema <- declareSchemaRef $ Proxy @(Set a) + pure $ Inline $ mempty & oneOf ?~ [singleSchema, setSchema] + txOutRefSchema <- setOrSingleSchema $ Proxy @TxOutRef + policyIdSchema <- setOrSingleSchema $ Proxy @PolicyId + assetIdSchema <- setOrSingleSchema $ Proxy @AssetId + let andSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens matched by both sub-filters." + & required .~ ["and"] + & properties .~ [("and", roleTokenFilterPairSchema)] + orSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens matched by either sub-filter." + & required .~ ["or"] + & properties .~ [("or", roleTokenFilterPairSchema)] + notSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens not matched by the sub-filter." + & required .~ ["not"] + & properties .~ [("not", roleTokenFilterSchema)] + anySchema = + mempty + & type_ ?~ OpenApiBoolean + & OpenApi.description ?~ "Matches any role token." + & enum_ ?~ [Bool True] + noneSchema = + mempty + & type_ ?~ OpenApiBoolean + & OpenApi.description ?~ "Matches no role token." + & enum_ ?~ [Bool False] + contractsSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens used by the given contract(s)." + & required .~ ["contract_id"] + & properties .~ [("contract_id", txOutRefSchema)] + policiesSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens with the given currency symbol(s)." + & required .~ ["roles_currency"] + & properties .~ [("roles_currency", policyIdSchema)] + tokensSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches only the given role token(s)." + & required .~ ["role_tokens"] + & properties .~ [("role_tokens", assetIdSchema)] + pure $ + NamedSchema (Just "RoleTokenFilter") $ + mempty + & OpenApi.description ?~ "A filter that selects role tokens for burning." + & oneOf + ?~ fmap + Inline + [ andSchema + , orSchema + , notSchema + , anySchema + , noneSchema + , contractsSchema + , policiesSchema + , tokensSchema + ] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Script.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Script.hs new file mode 100644 index 0000000000..a04a7f0200 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Script.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Core.Script (ScriptHash (..)) where + +import Control.Lens ((&), (?~)) +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString (ByteString) +import Data.OpenApi ( + HasType (..), + NamedSchema (..), + OpenApiType (..), + ToParamSchema, + ToSchema, + pattern, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant (ToHttpApiData) + +import Language.Marlowe.Runtime.Web.Core.Base16 (Base16 (..)) + +newtype ScriptHash = ScriptHash {unScriptHash :: ByteString} + deriving (Eq, Ord, Generic) + deriving (Show, ToHttpApiData, ToJSON, FromJSON) via Base16 + +instance ToSchema ScriptHash where + declareNamedSchema proxy = pure $ NamedSchema (Just "ScriptHash") $ toParamSchema proxy + +instance ToParamSchema ScriptHash where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "The hex-encoded hash of a Plutus script" + & pattern ?~ "^[a-fA-F0-9]*$" diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Semantics/Schema.hs similarity index 99% rename from marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Semantics/Schema.hs index b572a9e673..d38fba02df 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Semantics/Schema.hs @@ -5,7 +5,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Language.Marlowe.Runtime.Web.Orphans ( +module Language.Marlowe.Runtime.Web.Core.Semantics.Schema ( ) where diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tip.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tip.hs new file mode 100644 index 0000000000..a667cd9cb8 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tip.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Core.Tip (ChainTip (..)) where + +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson ( + FromJSON (parseJSON), + KeyValue ((.=)), + ToJSON (toJSON), + eitherDecodeStrict, + object, + withObject, + (.:?), + ) +import Data.Aeson.Text (encodeToLazyText) +import Data.Aeson.Types (parseFail) +import Data.Bifunctor (first) +import Data.OpenApi ( + HasType (..), + OpenApiType (..), + Reference (..), + Referenced (..), + ToParamSchema, + oneOf, + properties, + required, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as TL +import Data.Time (UTCTime) +import Data.Time.Format.ISO8601 (iso8601Show) + +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant ( + FromHttpApiData (parseUrlPiece), + Proxy (..), + ToHttpApiData (toUrlPiece), + ) + +import Language.Marlowe.Runtime.Web.Core.BlockHeader ( + BlockHeader, + ) + +data ChainTip + = ChainTipGenesis UTCTime + | ChainTip BlockHeader UTCTime + deriving (Show, Eq, Ord) + +instance ToJSON ChainTip where + toJSON = \case + ChainTipGenesis time -> object ["genesisTimeUTC" .= iso8601Show time] + ChainTip blockHeader time -> + object + [ "blockHeader" .= blockHeader + , "slotTimeUTC" .= iso8601Show time + ] + +instance FromJSON ChainTip where + parseJSON = + withObject + "ChainTip" + ( \obj -> do + genesisTimeUTC <- obj .:? "genesisTimeUTC" + blockHeader <- obj .:? "blockHeader" + slotTimeUTC <- obj .:? "slotTimeUTC" + case (genesisTimeUTC, blockHeader, slotTimeUTC) of + (Nothing, Just blockHeader', Just slotTimeUTC') -> pure $ ChainTip blockHeader' slotTimeUTC' + (Just genesisTimeUTC', Nothing, Nothing) -> pure $ ChainTipGenesis genesisTimeUTC' + _ -> parseFail "Invalid keys, expecting ([\"genesisTimeUTC\"] | [\"blockHeader\", \"slotTimeUTC\"])" + ) + +instance ToHttpApiData ChainTip where + toUrlPiece = TL.toStrict . encodeToLazyText + +instance FromHttpApiData ChainTip where + parseUrlPiece = first T.pack . eitherDecodeStrict . encodeUtf8 + +instance ToParamSchema ChainTip where + toParamSchema _ = + mempty + & oneOf ?~ [Inline genesisSchema, Inline tipSchema] + & OpenApi.description ?~ "The latest known point in the chain on a peer." + where + genesisSchema = + mempty + & type_ ?~ OpenApiObject + & properties + .~ [ ("genesisTimeUTC", Inline $ toParamSchema $ Proxy @UTCTime) + ] + & required .~ ["genesisTimeUTC"] + + tipSchema = + mempty + & type_ ?~ OpenApiObject + & properties + .~ [ ("blockHeader", Ref $ Reference "BlockHeader") + , ("slotTimeUTC", Inline $ toParamSchema $ Proxy @UTCTime) + ] + & required .~ ["blockHeader", "slotTimeUTC"] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs new file mode 100644 index 0000000000..d8128427c1 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Core.Tx ( + TxOutRef (..), + TxId (..), + TextEnvelope (..), + TxStatus (..), +) where + +import Control.Lens ((&), (.~), (?~)) +import Control.Monad ((<=<)) +import Data.Aeson ( + FromJSON (parseJSON), + FromJSONKey (fromJSONKey), + FromJSONKeyFunction (FromJSONKeyTextParser), + ToJSON (toJSON), + ToJSONKey (toJSONKey), + Value (String), + object, + withObject, + withText, + (.:), + ) +import Data.Aeson.Types (parseFail, toJSONKeyText) +import Data.ByteString (ByteString) +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Core.Base16 (Base16 (..)) +import Servant ( + FromHttpApiData (parseUrlPiece), + Proxy (..), + ToHttpApiData (toUrlPiece), + ) + +import Data.OpenApi ( + HasEnum (enum_), + HasType (..), + NamedSchema (..), + OpenApiType (..), + Referenced (..), + ToParamSchema, + ToSchema, + declareSchemaRef, + example, + pattern, + properties, + required, + toParamSchema, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Text (Text, splitOn) +import qualified Data.Text as T +import Data.Word (Word16) +import Language.Marlowe.Runtime.Web.Adapter.ByteString (hasLength) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () + +newtype TxId = TxId {unTxId :: ByteString} + deriving (Eq, Ord, Generic) + deriving (Show, ToHttpApiData, ToJSON) via Base16 + +data TxOutRef = TxOutRef + { txId :: TxId + , txIx :: Word16 + } + deriving (Show, Eq, Ord, Generic) + +data TextEnvelope = TextEnvelope + { teType :: Text + , teDescription :: Text + , teCborHex :: Base16 + } + deriving (Show, Eq, Ord, Generic) + +data TxStatus + = Unsigned + | Submitted + | Confirmed + deriving (Show, Eq, Ord) + +instance FromHttpApiData TxOutRef where + parseUrlPiece t = case splitOn "#" t of + [idText, ixText] -> TxOutRef <$> parseUrlPiece idText <*> parseUrlPiece ixText + _ -> case parseUrlPiece @TxId t of + Right _ -> Left "Expected [a-fA-F0-9]{64}#[0-9]+ (hint: do you need to URL-encode the '#' as \"%23\"?)" + _ -> Left "Expected [a-fA-F0-9]{64}#[0-9]+" + +instance ToHttpApiData TxOutRef where + toUrlPiece TxOutRef{..} = toUrlPiece txId <> "#" <> toUrlPiece txIx + +instance FromJSON TxOutRef where + parseJSON = + withText "TxOutRef" $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance FromJSONKey TxOutRef where + fromJSONKey = FromJSONKeyTextParser $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance ToSchema TxOutRef where + declareNamedSchema _ = + pure $ + NamedSchema (Just "TxOutRef") $ + mempty + & type_ ?~ OpenApiString + & OpenApi.description + ?~ "A reference to a transaction output with a transaction ID and index." + & pattern ?~ "^[a-fA-F0-9]{64}#[0-9]+$" + & example ?~ "98d601c9307dd43307cf68a03aad0086d4e07a789b66919ccf9f7f7676577eb7#1" + +instance ToParamSchema TxOutRef where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description + ?~ "A reference to a transaction output with a transaction ID and index. The value must be URL encoded by replacing the '#' character with %23." + & pattern ?~ "^[a-fA-F0-9]{64}%23[0-9]+$" + & example ?~ "98d601c9307dd43307cf68a03aad0086d4e07a789b66919ccf9f7f7676577eb7%231" + +instance ToJSON TxOutRef where + toJSON = String . toUrlPiece + +instance ToJSONKey TxOutRef where + toJSONKey = toJSONKeyText toUrlPiece + +instance FromHttpApiData TxId where + parseUrlPiece = fmap TxId . (hasLength 32 . unBase16 <=< parseUrlPiece) + +instance FromJSON TxId where + parseJSON = + withText "TxId" $ either (parseFail . T.unpack) pure . parseUrlPiece + +instance ToSchema TxId where + declareNamedSchema = pure . NamedSchema (Just "TxId") . toParamSchema + +instance ToParamSchema TxId where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & OpenApi.description ?~ "The hex-encoded identifier of a Cardano transaction" + & pattern ?~ "^[a-fA-F0-9]{64}$" + +instance ToJSON TextEnvelope where + toJSON TextEnvelope{..} = + object + [ ("type", toJSON teType) + , ("description", toJSON teDescription) + , ("cborHex", toJSON teCborHex) + ] + +instance FromJSON TextEnvelope where + parseJSON = + withObject + "TextEnvelope" + ( \obj -> + TextEnvelope + <$> obj + .: "type" + <*> obj + .: "description" + <*> obj + .: "cborHex" + ) + +instance ToSchema TextEnvelope where + declareNamedSchema _ = do + textSchema <- declareSchemaRef (Proxy @Text) + let typeSchema = + mempty + & type_ ?~ OpenApiString + & OpenApi.description + ?~ "What type of data is encoded in the CBOR Hex. Valid values include \"Tx \", \"TxBody \", and \"ShelleyTxWitness \" where is one of \"BabbageEra\", \"ConwayEra\"." + pure $ + NamedSchema (Just "TextEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & required .~ ["type", "description", "cborHex"] + & properties + .~ [ ("type", Inline typeSchema) + , ("description", textSchema) + , ("cborHex", textSchema) + ] + +instance ToJSON TxStatus where + toJSON Unsigned = String "unsigned" + toJSON Submitted = String "submitted" + toJSON Confirmed = String "confirmed" + +instance FromJSON TxStatus where + parseJSON (String "unsigned") = pure Unsigned + parseJSON (String "submitted") = pure Submitted + parseJSON (String "confirmed") = pure Confirmed + parseJSON _ = parseFail "invalid status" + +instance ToSchema TxStatus where + declareNamedSchema _ = + pure $ + NamedSchema (Just "TxStatus") $ + mempty + & type_ ?~ OpenApiString + & enum_ ?~ ["unsigned", "submitted", "confirmed"] + & OpenApi.description ?~ "The status of a transaction on the local node." diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/API.hs new file mode 100644 index 0000000000..2e44cfeae2 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/API.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Payout.API ( + PayoutHeader (..), + PayoutState (..), + PayoutStatus (..), + Payout (..), + PayoutsAPI, + GetPayoutAPI, + GetPayoutResponse, + GetPayoutsResponse, +) where + +import Control.Lens ((&), (?~)) +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON (toJSON), + Value (String), + withText, + ) +import Data.OpenApi ( + HasEnum (enum_), + HasType (type_), + NamedSchema (NamedSchema), + OpenApiType (OpenApiString), + ToParamSchema (..), + ToSchema (..), + ) +import qualified Data.OpenApi as OpenApi +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink) +import Language.Marlowe.Runtime.Web.Adapter.Pagination (PaginatedGet) +import Language.Marlowe.Runtime.Web.Adapter.Servant ( + OperationId, + RenameResponseSchema, + ) +import Language.Marlowe.Runtime.Web.Core.Address (Address) +import Language.Marlowe.Runtime.Web.Core.Asset (AssetId, Assets) +import Language.Marlowe.Runtime.Web.Core.Tx (TxId, TxOutRef) +import Servant.API ( + Capture, + Description, + FromHttpApiData (parseQueryParam), + Get, + JSON, + Optional, + QueryParam', + QueryParams, + Summary, + ToHttpApiData (toQueryParam), + type (:<|>), + type (:>), + ) +import Servant.Pagination ( + HasPagination (RangeType, getFieldValue), + ) + +data PayoutHeader = PayoutHeader + { payoutId :: TxOutRef + , contractId :: TxOutRef + , withdrawalId :: Maybe TxId + , role :: AssetId + , status :: PayoutStatus + } + deriving (Show, Eq, Ord, Generic) + +data Payout = Payout + { payoutId :: TxOutRef + , role :: Text + , assets :: Assets + } + deriving (FromJSON, ToJSON, ToSchema, Show, Eq, Generic) + +data PayoutStatus + = Available + | Withdrawn + deriving (Show, Eq, Ord, Generic) + +data PayoutState = PayoutState + { payoutId :: TxOutRef + , contractId :: TxOutRef + , withdrawalId :: Maybe TxId + , role :: AssetId + , payoutValidatorAddress :: Address + , status :: PayoutStatus + , assets :: Assets + } + deriving (FromJSON, ToJSON, ToSchema, Show, Eq, Generic) + +-- | /payouts sub-API +type PayoutsAPI = + GetPayoutsAPI + :<|> Capture "payoutId" TxOutRef :> GetPayoutAPI + +type GetPayoutAPI = + Summary "Get payout by ID" + :> OperationId "getPayoutById" + :> RenameResponseSchema "GetPayoutResponse" + :> Get '[JSON] GetPayoutResponse + +type GetPayoutResponse = WithLink "contract" (WithLink "transaction" (WithLink "withdrawal" PayoutState)) + +-- | GET /payouts sub-API +type GetPayoutsAPI = + Summary "Get role payouts" + :> Description + "Get payouts to parties from role-based contracts. \ + \Results are returned in pages, with paging being specified by request headers." + :> OperationId "getPayouts" + :> QueryParams "contractId" TxOutRef + :> QueryParams "roleToken" AssetId + :> QueryParam' + '[Optional, Description "Whether to include available or withdrawn payouts in the results."] + "status" + PayoutStatus + :> RenameResponseSchema "GetPayoutsResponse" + :> PaginatedGet '["payoutId"] GetPayoutsResponse + +type GetPayoutsResponse = WithLink "payout" PayoutHeader + +instance ToJSON PayoutStatus where + toJSON = + String . \case + Available -> "available" + Withdrawn -> "withdrawn" + +instance FromJSON PayoutStatus where + parseJSON = + withText + "PayoutStatus" + ( \str -> case T.toLower str of + "available" -> pure Available + "withdrawn" -> pure Withdrawn + _ -> fail "expected \"available\" or \"withdrawn\"" + ) + +instance ToHttpApiData PayoutStatus where + toQueryParam = \case + Available -> "available" + Withdrawn -> "withdrawn" + +instance FromHttpApiData PayoutStatus where + parseQueryParam str = case T.toLower str of + "available" -> pure Available + "withdrawn" -> pure Withdrawn + _ -> Left "expected \"available\" or \"withdrawn\"" + +instance ToSchema PayoutStatus where + declareNamedSchema = pure . NamedSchema (Just "PayoutStatus") . toParamSchema + +instance ToParamSchema PayoutStatus where + toParamSchema _ = + mempty + & type_ ?~ OpenApiString + & enum_ ?~ ["available", "withdrawn"] + & OpenApi.description + ?~ "The status of a payout. Either it is available to be withdrawn, or it has already been withdrawn." + +instance HasPagination PayoutHeader "payoutId" where + type RangeType PayoutHeader "payoutId" = TxOutRef + getFieldValue _ PayoutHeader{..} = payoutId + +instance ToJSON PayoutHeader +instance FromJSON PayoutHeader +instance ToSchema PayoutHeader diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Payouts.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/Server.hs similarity index 64% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Payouts.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/Server.hs index 99f6ef8330..8f95a8dc8f 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Payouts.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Payout/Server.hs @@ -1,20 +1,55 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -- | This module defines a server for the /payouts REST API. -module Language.Marlowe.Runtime.Web.Server.REST.Payouts where +module Language.Marlowe.Runtime.Web.Payout.Server (server) where import Data.Functor ((<&>)) import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Language.Marlowe.Protocol.Query.Types (Page (..), PayoutFilter (..)) -import Language.Marlowe.Runtime.Web -import Language.Marlowe.Runtime.Web.Server.DTO (FromDTO (..), ToDTO (..), fromDTOThrow, fromPaginationRange) -import Language.Marlowe.Runtime.Web.Server.Monad -import Language.Marlowe.Runtime.Web.Server.REST.ApiError (badRequest', notFound', rangeNotSatisfiable') -import Servant -import Servant.Pagination +import Language.Marlowe.Runtime.Web.Adapter.Links ( + WithLink (IncludeLink), + ) +import Language.Marlowe.Runtime.Web.Adapter.Pagination ( + PaginatedResponse, + ) +import Language.Marlowe.Runtime.Web.Adapter.Servant ( + ListObject (ListObject), + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError (badRequest', notFound', rangeNotSatisfiable') +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (FromDTO (..), ToDTO (..), fromDTOThrow, fromPaginationRange) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + ServerM, + loadPayout, + loadPayouts, + ) +import Language.Marlowe.Runtime.Web.Payout.API ( + GetPayoutResponse, + GetPayoutsResponse, + PayoutHeader, + PayoutStatus (..), + PayoutsAPI, + ) + +import Language.Marlowe.Runtime.Web.Core.Asset (AssetId) +import Language.Marlowe.Runtime.Web.Core.Tx (TxOutRef) +import Servant ( + HasServer (ServerT), + Proxy (Proxy), + addHeader, + throwError, + type (:<|>) ((:<|>)), + ) +import Servant.Pagination ( + ExtractRange (extractRange), + HasPagination (getDefaultRange), + Range, + Ranges, + returnRange, + ) server :: ServerT PayoutsAPI ServerM server = diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs new file mode 100644 index 0000000000..a74997789f --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +-- | This module defines a server for the root REST API. +module Language.Marlowe.Runtime.Web.Server (server) where + +import Language.Marlowe.Runtime.Web.API (RuntimeAPI) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad (ServerM) +import qualified Language.Marlowe.Runtime.Web.Contract.Server as Contracts +import qualified Language.Marlowe.Runtime.Web.Payout.Server as Payouts +import qualified Language.Marlowe.Runtime.Web.Withdrawal.Server as Withdrawals +import Servant ( + HasServer (ServerT), + NoContent (..), + type (:<|>) ((:<|>)), + ) + +server :: ServerT RuntimeAPI ServerM +server = Contracts.server :<|> Withdrawals.server :<|> Payouts.server :<|> healthcheckServer + +healthcheckServer :: ServerM NoContent +healthcheckServer = pure NoContent diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Status.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Status.hs new file mode 100644 index 0000000000..6085687fda --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Status.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Status (RuntimeStatus (..)) where + +import Data.Version (Version) + +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () + +import Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId) +import Language.Marlowe.Runtime.Web.Core.Tip (ChainTip) + +data RuntimeStatus = RuntimeStatus + { nodeTip :: ChainTip + , runtimeChainTip :: ChainTip + , runtimeTip :: ChainTip + , networkId :: NetworkId + , runtimeVersion :: Version + } + deriving (Show, Eq, Ord) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs new file mode 100644 index 0000000000..54df033aad --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Tx.API ( + TxHeader (..), + Tx (..), + CardanoTx, + CardanoTxBody, + ContractTx, + CreateTxEnvelope (..), + ApplyInputsTx, + ApplyInputsTxEnvelope (..), + WithdrawTx, + WithdrawTxEnvelope (..), + BurnTx, + PostTxAPI, + PutSignedTxAPI, + TxJSON, +) where + +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON (toJSON), + object, + withObject, + (.:), + ) +import GHC.Generics (Generic) +import Network.HTTP.Media ((//)) +import Servant ( + Accept, + Header, + Header', + JSON, + NoContent, + Proxy (..), + PutAccepted, + ReqBody, + Required, + Strict, + type (:>), + ) +import Servant.API (Accept (..)) + +import Data.Map (Map) +import Data.OpenApi ( + HasType (..), + NamedSchema (..), + OpenApiType (..), + ToSchema, + declareSchemaRef, + properties, + required, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Word (Word64) +import Language.Marlowe.Analysis.Safety.Types (SafetyError) +import qualified Language.Marlowe.Core.V1.Semantics as V1 +import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics +import Language.Marlowe.Runtime.Web.Adapter.CommaList (CommaList) +import Language.Marlowe.Runtime.Web.Core.Address (Address) +import Language.Marlowe.Runtime.Web.Core.Asset (Assets) +import Language.Marlowe.Runtime.Web.Core.BlockHeader ( + BlockHeader, + ) +import Language.Marlowe.Runtime.Web.Core.Metadata (Metadata) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope, + TxId, + TxOutRef, + TxStatus, + ) +import Language.Marlowe.Runtime.Web.Payout.API (Payout) +import Servant.Pagination ( + HasPagination (RangeType, getFieldValue), + ) + +data TxHeader = TxHeader + { contractId :: TxOutRef + , transactionId :: TxId + , tags :: Map Text Metadata + , metadata :: Map Word64 Metadata + , status :: TxStatus + , block :: Maybe BlockHeader + , utxo :: Maybe TxOutRef + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) + +instance HasPagination TxHeader "transactionId" where + type RangeType TxHeader "transactionId" = TxId + getFieldValue _ TxHeader{..} = transactionId + +data Tx = Tx + { contractId :: TxOutRef + , transactionId :: TxId + , tags :: Map Text Metadata + , metadata :: Map Word64 Metadata + , status :: TxStatus + , block :: Maybe BlockHeader + , inputUtxo :: TxOutRef + , inputContract :: Semantics.Contract + , inputState :: Semantics.State + , inputs :: [Semantics.Input] + , outputUtxo :: Maybe TxOutRef + , outputContract :: Maybe Semantics.Contract + , outputState :: Maybe Semantics.State + , assets :: Assets + , payouts :: [Payout] + , consumingTx :: Maybe TxId + , invalidBefore :: UTCTime + , invalidHereafter :: UTCTime + , reconstructedSemanticInput :: V1.TransactionInput + , reconstructedSemanticOutput :: V1.TransactionOutput + , txBody :: Maybe TextEnvelope + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) + +data TxJSON a +data CardanoTx +data CardanoTxBody +data ContractTx +data ApplyInputsTx +data WithdrawTx +data BurnTx + +type PutSignedTxAPI = ReqBody '[JSON] TextEnvelope :> PutAccepted '[JSON] NoContent + +type PostTxAPI api = + Header' '[Required, Strict] "X-Change-Address" Address + :> Header "X-Address" (CommaList Address) + :> Header "X-Collateral-UTxO" (CommaList TxOutRef) + :> api + +instance Accept (TxJSON ContractTx) where + contentType _ = "application" // "vendor.iog.marlowe-runtime.contract-tx-json" + +instance Accept (TxJSON ApplyInputsTx) where + contentType _ = "application" // "vendor.iog.marlowe-runtime.apply-inputs-tx-json" + +instance Accept (TxJSON WithdrawTx) where + contentType _ = "application" // "vendor.iog.marlowe-runtime.withdraw-tx-json" + +data CreateTxEnvelope tx = CreateTxEnvelope + { contractId :: TxOutRef + , txEnvelope :: TextEnvelope + , safetyErrors :: [SafetyError] + } + deriving (Show, Eq, Generic) + +instance ToJSON (CreateTxEnvelope CardanoTx) where + toJSON CreateTxEnvelope{..} = + object + [ ("contractId", toJSON contractId) + , ("tx", toJSON txEnvelope) + , ("safetyErrors", toJSON safetyErrors) + ] +instance ToJSON (CreateTxEnvelope CardanoTxBody) where + toJSON CreateTxEnvelope{..} = + object + [ ("contractId", toJSON contractId) + , ("txBody", toJSON txEnvelope) + , ("safetyErrors", toJSON safetyErrors) + ] + +instance FromJSON (CreateTxEnvelope CardanoTx) where + parseJSON = + withObject + "CreateTxEnvelope" + ( \obj -> + CreateTxEnvelope + <$> obj + .: "contractId" + <*> obj + .: "tx" + <*> obj + .: "safetyErrors" + ) + +instance FromJSON (CreateTxEnvelope CardanoTxBody) where + parseJSON = + withObject + "CreateTxEnvelope" + ( \obj -> + CreateTxEnvelope + <$> obj + .: "contractId" + <*> obj + .: "txBody" + <*> obj + .: "safetyErrors" + ) + +instance ToSchema (CreateTxEnvelope CardanoTx) where + declareNamedSchema _ = do + contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + safetyErrorsSchema <- declareSchemaRef (Proxy :: Proxy [SafetyError]) + return $ + NamedSchema (Just "CreateTxEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" + & properties + .~ [ ("contractId", contractIdSchema) + , ("tx", txEnvelopeSchema) + , ("safetyErrors", safetyErrorsSchema) + ] + & required .~ ["contractId", "tx"] + +instance ToSchema (CreateTxEnvelope CardanoTxBody) where + declareNamedSchema _ = do + contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + safetyErrorsSchema <- declareSchemaRef (Proxy :: Proxy [SafetyError]) + return $ + NamedSchema (Just "CreateTxBodyEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" + & properties + .~ [ ("contractId", contractIdSchema) + , ("txBody", txEnvelopeSchema) + , ("safetyErrors", safetyErrorsSchema) + ] + & required .~ ["contractId", "txBody"] + +data WithdrawTxEnvelope tx = WithdrawTxEnvelope + { withdrawalId :: TxId + , txEnvelope :: TextEnvelope + } + deriving (Show, Eq, Ord, Generic) + +instance ToJSON (WithdrawTxEnvelope CardanoTx) where + toJSON WithdrawTxEnvelope{..} = + object + [ ("withdrawalId", toJSON withdrawalId) + , ("tx", toJSON txEnvelope) + ] +instance ToJSON (WithdrawTxEnvelope CardanoTxBody) where + toJSON WithdrawTxEnvelope{..} = + object + [ ("withdrawalId", toJSON withdrawalId) + , ("txBody", toJSON txEnvelope) + ] + +instance FromJSON (WithdrawTxEnvelope CardanoTx) where + parseJSON = + withObject + "WithdrawTxEnvelope" + ( \obj -> + WithdrawTxEnvelope + <$> obj .: "withdrawalId" + <*> obj .: "tx" + ) + +instance FromJSON (WithdrawTxEnvelope CardanoTxBody) where + parseJSON = + withObject + "WithdrawTxEnvelope" + ( \obj -> + WithdrawTxEnvelope + <$> obj .: "withdrawalId" + <*> obj .: "txBody" + ) + +instance ToSchema (WithdrawTxEnvelope CardanoTx) where + declareNamedSchema _ = do + withdrawalIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + return $ + NamedSchema (Just "WithdrawTxEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" + & properties + .~ [ ("withdrawalId", withdrawalIdSchema) + , ("tx", txEnvelopeSchema) + ] + & required .~ ["withdrawalId", "tx"] + +instance ToSchema (WithdrawTxEnvelope CardanoTxBody) where + declareNamedSchema _ = do + withdrawalIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + return $ + NamedSchema (Just "WithdrawTxBodyEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" + & properties + .~ [ ("withdrawalId", withdrawalIdSchema) + , ("txBody", txEnvelopeSchema) + ] + & required .~ ["withdrawalId", "txBody"] + +data ApplyInputsTxEnvelope tx = ApplyInputsTxEnvelope + { contractId :: TxOutRef + , transactionId :: TxId + , txEnvelope :: TextEnvelope + } + deriving (Show, Eq, Ord, Generic) + +instance ToJSON (ApplyInputsTxEnvelope CardanoTx) where + toJSON ApplyInputsTxEnvelope{..} = + object + [ ("contractId", toJSON contractId) + , ("transactionId", toJSON transactionId) + , ("tx", toJSON txEnvelope) + ] +instance ToJSON (ApplyInputsTxEnvelope CardanoTxBody) where + toJSON ApplyInputsTxEnvelope{..} = + object + [ ("contractId", toJSON contractId) + , ("transactionId", toJSON transactionId) + , ("txBody", toJSON txEnvelope) + ] + +instance FromJSON (ApplyInputsTxEnvelope CardanoTx) where + parseJSON = + withObject + "ApplyInputsTxEnvelope" + ( \obj -> do + contractId <- obj .: "contractId" + transactionId <- obj .: "transactionId" + txEnvelope <- obj .: "tx" + pure ApplyInputsTxEnvelope{..} + ) + +instance FromJSON (ApplyInputsTxEnvelope CardanoTxBody) where + parseJSON = + withObject + "ApplyInputsTxEnvelope" + ( \obj -> do + contractId <- obj .: "contractId" + transactionId <- obj .: "transactionId" + txEnvelope <- obj .: "txBody" + pure ApplyInputsTxEnvelope{..} + ) + +instance ToSchema (ApplyInputsTxEnvelope CardanoTx) where + declareNamedSchema _ = do + contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) + transactionIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + return $ + NamedSchema (Just "ApplyInputsTxEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" + & properties + .~ [ ("contractId", contractIdSchema) + , ("transactionId", transactionIdSchema) + , ("tx", txEnvelopeSchema) + ] + & required .~ ["contractId", "transactionId", "tx"] + +instance ToSchema (ApplyInputsTxEnvelope CardanoTxBody) where + declareNamedSchema _ = do + contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) + transactionIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + return $ + NamedSchema (Just "ApplyInputsTxEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" + & properties + .~ [ ("contractId", contractIdSchema) + , ("transactionId", transactionIdSchema) + , ("txBody", txEnvelopeSchema) + ] + & required .~ ["contractId", "transactionId", "txBody"] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs deleted file mode 100644 index 6d76ce3752..0000000000 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs +++ /dev/null @@ -1,1503 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | This module defines the request and response types in the Marlowe Runtime --- | Web API. -module Language.Marlowe.Runtime.Web.Types where - -import Control.Applicative ((<|>)) -import Control.Lens hiding ((.=)) -import Control.Monad (unless, (<=<)) -import Data.Aeson -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as AMap -import qualified Data.Aeson.KeyMap as KeyMap -import Data.Aeson.Text (encodeToLazyText) -import Data.Aeson.Types (JSONPathElement (..), Parser, parseFail, prependFailure, toJSONKeyText, typeMismatch) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Base16 (decodeBase16, encodeBase16) -import Data.Char (isSpace) -import Data.Foldable (fold) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.OpenApi ( - AdditionalProperties (..), - Definitions, - HasAdditionalProperties (..), - HasType (..), - NamedSchema (..), - OpenApiItems (..), - OpenApiType (..), - Reference (..), - Referenced (..), - Schema, - ToParamSchema, - ToSchema, - declareSchema, - declareSchemaRef, - enum_, - example, - oneOf, - pattern, - properties, - required, - toParamSchema, - ) -import qualified Data.OpenApi as OpenApi -import Data.OpenApi.Declare (Declare) -import Data.OpenApi.Schema (ToSchema (..)) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String (IsString (..)) -import Data.Text (Text, intercalate, splitOn) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Lazy as TL -import Data.Time (UTCTime) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.Traversable (for) -import Data.Version (Version) -import Data.Word (Word16, Word32, Word64) -import GHC.Exts (IsList) -import GHC.Generics (Generic) -import Language.Marlowe.Analysis.Safety.Types (SafetyError) -import qualified Language.Marlowe.Core.V1.Semantics as V1 -import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics -import Language.Marlowe.Object.Types (Label (..)) -import Language.Marlowe.Runtime.Web.Orphans () -import Network.URI (parseURI) -import Servant -import Servant.Pagination (HasPagination (..)) - --- | A newtype for Base16 decoding and encoding ByteStrings -newtype Base16 = Base16 {unBase16 :: ByteString} - deriving (Eq, Ord) - -instance Show Base16 where - show = T.unpack . encodeBase16 . unBase16 - -instance IsString Base16 where - fromString = either (error . T.unpack) Base16 . decodeBase16 . encodeUtf8 . T.pack - -instance ToJSON Base16 where - toJSON = String . toUrlPiece - -instance ToJSONKey Base16 where - toJSONKey = toJSONKeyText toUrlPiece - -instance FromJSON Base16 where - parseJSON = - withText "Base16" $ either (parseFail . T.unpack) pure . parseUrlPiece - -instance FromJSONKey Base16 where - fromJSONKey = FromJSONKeyTextParser $ either (parseFail . T.unpack) pure . parseUrlPiece - -instance ToHttpApiData Base16 where - toUrlPiece = encodeBase16 . unBase16 - -instance FromHttpApiData Base16 where - parseUrlPiece = fmap Base16 . decodeBase16 . encodeUtf8 - -instance ToSchema Base16 where - declareNamedSchema _ = NamedSchema Nothing <$> declareSchema (Proxy @String) - -data Assets = Assets - { lovelace :: Integer - , tokens :: Tokens - } - deriving (Eq, Show, Ord, Generic) - deriving anyclass (ToJSON, FromJSON, ToSchema) - -newtype Tokens = Tokens {unTokens :: Map PolicyId (Map Text Integer)} - deriving (Eq, Show, Ord, Generic) - deriving newtype (ToJSON, FromJSON, ToSchema) - -newtype ContractSourceId = ContractSourceId {unContractSourceId :: ByteString} - deriving (Eq, Ord, Generic) - deriving (Show, ToHttpApiData, ToJSON) via Base16 - -instance FromHttpApiData ContractSourceId where - parseUrlPiece = fmap ContractSourceId . (hasLength 32 . unBase16 <=< parseUrlPiece) - -instance FromJSON ContractSourceId where - parseJSON = - withText "ContractSourceId" $ either (parseFail . T.unpack) pure . parseUrlPiece - -instance ToSchema ContractSourceId where - declareNamedSchema = pure . NamedSchema (Just "ContractSourceId") . toParamSchema - -instance ToParamSchema ContractSourceId where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "The hex-encoded identifier of a Marlowe contract source" - & pattern ?~ "^[a-fA-F0-9]{64}$" - -newtype TxId = TxId {unTxId :: ByteString} - deriving (Eq, Ord, Generic) - deriving (Show, ToHttpApiData, ToJSON) via Base16 - -instance FromHttpApiData TxId where - parseUrlPiece = fmap TxId . (hasLength 32 . unBase16 <=< parseUrlPiece) - -instance FromJSON TxId where - parseJSON = - withText "TxId" $ either (parseFail . T.unpack) pure . parseUrlPiece - -hasLength :: Int -> ByteString -> Either T.Text ByteString -hasLength l bytes - | BS.length bytes == l = pure bytes - | otherwise = Left $ "Expected " <> T.pack (show l) <> " bytes" - -instance ToSchema TxId where - declareNamedSchema = pure . NamedSchema (Just "TxId") . toParamSchema - -instance ToParamSchema TxId where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "The hex-encoded identifier of a Cardano transaction" - & pattern ?~ "^[a-fA-F0-9]{64}$" - -newtype Address = Address {unAddress :: T.Text} - deriving (Eq, Ord, Generic) - deriving newtype (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON) - -instance ToSchema Address where - declareNamedSchema = pure . NamedSchema (Just "Address") . toParamSchema - -instance ToParamSchema Address where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "A cardano address, in Bech32 format" - & example ?~ "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf" - -newtype StakeAddress = StakeAddress {unStakeAddress :: T.Text} - deriving (Eq, Ord, Generic) - deriving newtype (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON) - -instance ToSchema StakeAddress where - declareNamedSchema = pure . NamedSchema (Just "StakeAddress") . toParamSchema - -instance ToParamSchema StakeAddress where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "A cardano stake address, in Bech32 format" - & example ?~ "stake1ux7lyy9nhecm033qsmel9awnr22up6jadlzkrxufr78w82gsfsn0d" - -newtype CommaList a = CommaList {unCommaList :: [a]} - deriving (Eq, Ord, Generic, Functor) - deriving newtype (Show, ToJSON, FromJSON, IsList) - -instance ToParamSchema (CommaList a) where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "A comma-separated list of values" - -instance (ToSchema a) => ToSchema (CommaList a) - -instance (ToHttpApiData a) => ToHttpApiData (CommaList a) where - toUrlPiece = T.intercalate "," . fmap toUrlPiece . unCommaList - toQueryParam = T.intercalate "," . fmap toQueryParam . unCommaList - -instance (FromHttpApiData a) => FromHttpApiData (CommaList a) where - parseUrlPiece = - fmap CommaList - . traverse (parseUrlPiece . T.dropWhileEnd isSpace . T.dropWhile isSpace) - . splitOnNonEmpty "," - parseQueryParam = - fmap CommaList - . traverse (parseQueryParam . T.dropWhileEnd isSpace . T.dropWhile isSpace) - . splitOnNonEmpty "," - -splitOnNonEmpty :: Text -> Text -> [Text] -splitOnNonEmpty sep t - | T.null t = [] - | otherwise = T.splitOn sep t - -newtype PolicyId = PolicyId {unPolicyId :: ByteString} - deriving (Eq, Ord, Generic) - deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, ToJSONKey, FromJSON, FromJSONKey) via Base16 - -instance ToSchema PolicyId where - declareNamedSchema proxy = pure $ NamedSchema (Just "PolicyId") $ toParamSchema proxy - -instance ToParamSchema PolicyId where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "The hex-encoded minting policy ID for a native Cardano token" - & pattern ?~ "^[a-fA-F0-9]*$" - -data AssetId = AssetId - { policyId :: PolicyId - , assetName :: Text - } - deriving (Show, Eq, Ord, Generic) - -instance ToSchema AssetId -instance FromJSON AssetId -instance ToJSON AssetId - -instance ToParamSchema AssetId where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description - ?~ "A minting policy ID and a token name identifying a specific asset type. Encoded as policyId.tokenName." - & pattern ?~ "^[a-fA-F0-9]*\\..*$" - -instance FromHttpApiData AssetId where - parseUrlPiece piece = case T.breakOn "." piece of - (_, "") -> Left "Expected ^[a-fA-F0-9]*(\\.).*$" - (policyId, tokenNameStartingWitPeriodCharacter) -> AssetId <$> parseUrlPiece policyId <*> parseUrlPiece (T.drop 1 tokenNameStartingWitPeriodCharacter) - -instance ToHttpApiData AssetId where - toUrlPiece AssetId{..} = toUrlPiece policyId <> "." <> toUrlPiece assetName - -newtype ScriptHash = ScriptHash {unScriptHash :: ByteString} - deriving (Eq, Ord, Generic) - deriving (Show, ToHttpApiData, ToJSON, FromJSON) via Base16 - -instance ToSchema ScriptHash where - declareNamedSchema proxy = pure $ NamedSchema (Just "ScriptHash") $ toParamSchema proxy - -instance ToParamSchema ScriptHash where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "The hex-encoded hash of a Plutus script" - & pattern ?~ "^[a-fA-F0-9]*$" - -newtype Party = Party {unParty :: T.Text} - deriving (Eq, Ord, Generic) - deriving newtype (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, FromJSONKey, ToJSONKey) - -instance ToSchema Party where - declareNamedSchema proxy = pure $ NamedSchema (Just "Party") $ toParamSchema proxy - -instance ToParamSchema Party where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "Party (A role name or an Address)" - -data TxOutRef = TxOutRef - { txId :: TxId - , txIx :: Word16 - } - deriving (Show, Eq, Ord, Generic) - -instance FromHttpApiData TxOutRef where - parseUrlPiece t = case splitOn "#" t of - [idText, ixText] -> TxOutRef <$> parseUrlPiece idText <*> parseUrlPiece ixText - _ -> case parseUrlPiece @TxId t of - Right _ -> Left "Expected [a-fA-F0-9]{64}#[0-9]+ (hint: do you need to URL-encode the '#' as \"%23\"?)" - _ -> Left "Expected [a-fA-F0-9]{64}#[0-9]+" - -instance ToHttpApiData TxOutRef where - toUrlPiece TxOutRef{..} = toUrlPiece txId <> "#" <> toUrlPiece txIx - -instance FromJSON TxOutRef where - parseJSON = - withText "TxOutRef" $ either (parseFail . T.unpack) pure . parseUrlPiece - -instance FromJSONKey TxOutRef where - fromJSONKey = FromJSONKeyTextParser $ either (parseFail . T.unpack) pure . parseUrlPiece - -instance ToSchema TxOutRef where - declareNamedSchema _ = - pure $ - NamedSchema (Just "TxOutRef") $ - mempty - & type_ ?~ OpenApiString - & OpenApi.description - ?~ "A reference to a transaction output with a transaction ID and index." - & pattern ?~ "^[a-fA-F0-9]{64}#[0-9]+$" - & example ?~ "98d601c9307dd43307cf68a03aad0086d4e07a789b66919ccf9f7f7676577eb7#1" - -instance ToParamSchema TxOutRef where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & OpenApi.description - ?~ "A reference to a transaction output with a transaction ID and index. The value must be URL encoded by replacing the '#' character with %23." - & pattern ?~ "^[a-fA-F0-9]{64}%23[0-9]+$" - & example ?~ "98d601c9307dd43307cf68a03aad0086d4e07a789b66919ccf9f7f7676577eb7%231" - -instance ToJSON TxOutRef where - toJSON = String . toUrlPiece - -instance ToJSONKey TxOutRef where - toJSONKey = toJSONKeyText toUrlPiece - -data MarloweVersion = V1 - deriving (Show, Eq, Ord) - -instance ToJSON MarloweVersion where - toJSON V1 = String "v1" - -instance FromJSON MarloweVersion where - parseJSON = - withText "MarloweVersion" $ either (parseFail . T.unpack) pure . parseUrlPiece - -instance ToHttpApiData MarloweVersion where - toUrlPiece V1 = "v1" - -instance FromHttpApiData MarloweVersion where - parseUrlPiece "v1" = Right V1 - parseUrlPiece _ = - Left $ - fold @[] - [ "expected one of " - , intercalate "; " ["v1"] - ] - -instance ToSchema MarloweVersion where - declareNamedSchema _ = - pure $ - NamedSchema (Just "MarloweVersion") $ - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "A version of the Marlowe language." - & enum_ ?~ ["v1"] - -data Payout = Payout - { payoutId :: TxOutRef - , role :: Text - , assets :: Assets - } - deriving (FromJSON, ToJSON, ToSchema, Show, Eq, Generic) - -data ContractState = ContractState - { contractId :: TxOutRef - , roleTokenMintingPolicyId :: PolicyId - , version :: MarloweVersion - , tags :: Map Text Metadata - , metadata :: Map Word64 Metadata - , status :: TxStatus - , block :: Maybe BlockHeader - , initialContract :: Semantics.Contract - , initialState :: Semantics.State - , currentContract :: Maybe Semantics.Contract - , state :: Maybe Semantics.State - , utxo :: Maybe TxOutRef - , assets :: Assets - , txBody :: Maybe TextEnvelope - , unclaimedPayouts :: [Payout] - } - deriving (Show, Eq, Generic) - -instance ToJSON ContractState -instance FromJSON ContractState -instance ToSchema ContractState - -data ContractHeader = ContractHeader - { contractId :: TxOutRef - , roleTokenMintingPolicyId :: PolicyId - , version :: MarloweVersion - , tags :: Map Text Metadata - , metadata :: Map Word64 Metadata - , status :: TxStatus - , block :: Maybe BlockHeader - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON ContractHeader -instance FromJSON ContractHeader -instance ToSchema ContractHeader - -data WithdrawalHeader = WithdrawalHeader - { withdrawalId :: TxId - , status :: TxStatus - , block :: Maybe BlockHeader - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON WithdrawalHeader -instance FromJSON WithdrawalHeader -instance ToSchema WithdrawalHeader - -instance HasPagination WithdrawalHeader "withdrawalId" where - type RangeType WithdrawalHeader "withdrawalId" = TxId - getFieldValue _ WithdrawalHeader{..} = withdrawalId - -data PayoutStatus - = Available - | Withdrawn - deriving (Show, Eq, Ord, Generic) - -instance ToJSON PayoutStatus where - toJSON = - String . \case - Available -> "available" - Withdrawn -> "withdrawn" - -instance FromJSON PayoutStatus where - parseJSON = - withText - "PayoutStatus" - ( \str -> case T.toLower str of - "available" -> pure Available - "withdrawn" -> pure Withdrawn - _ -> fail "expected \"available\" or \"withdrawn\"" - ) - -instance ToHttpApiData PayoutStatus where - toQueryParam = \case - Available -> "available" - Withdrawn -> "withdrawn" - -instance FromHttpApiData PayoutStatus where - parseQueryParam str = case T.toLower str of - "available" -> pure Available - "withdrawn" -> pure Withdrawn - _ -> Left "expected \"available\" or \"withdrawn\"" - -instance ToSchema PayoutStatus where - declareNamedSchema = pure . NamedSchema (Just "PayoutStatus") . toParamSchema - -instance ToParamSchema PayoutStatus where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & enum_ ?~ ["available", "withdrawn"] - & OpenApi.description - ?~ "The status of a payout. Either it is available to be withdrawn, or it has already been withdrawn." - -data PayoutHeader = PayoutHeader - { payoutId :: TxOutRef - , contractId :: TxOutRef - , withdrawalId :: Maybe TxId - , role :: AssetId - , status :: PayoutStatus - } - deriving (Show, Eq, Ord, Generic) - -instance HasPagination PayoutHeader "payoutId" where - type RangeType PayoutHeader "payoutId" = TxOutRef - getFieldValue _ PayoutHeader{..} = payoutId - -instance ToJSON PayoutHeader -instance FromJSON PayoutHeader -instance ToSchema PayoutHeader - -data PayoutState = PayoutState - { payoutId :: TxOutRef - , contractId :: TxOutRef - , withdrawalId :: Maybe TxId - , role :: AssetId - , payoutValidatorAddress :: Address - , status :: PayoutStatus - , assets :: Assets - } - deriving (FromJSON, ToJSON, ToSchema, Show, Eq, Generic) - -data Withdrawal = Withdrawal - { payouts :: Set PayoutHeader - , withdrawalId :: TxId - , status :: TxStatus - , block :: Maybe BlockHeader - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON Withdrawal -instance FromJSON Withdrawal -instance ToSchema Withdrawal - -instance HasPagination ContractHeader "contractId" where - type RangeType ContractHeader "contractId" = TxOutRef - getFieldValue _ ContractHeader{..} = contractId - -newtype Metadata = Metadata {unMetadata :: Value} - deriving (Show, Eq, Ord) - deriving newtype (ToJSON, FromJSON) - -instance ToSchema Metadata where - declareNamedSchema _ = do - integerSchema <- declareSchemaRef $ Proxy @Integer - let metadataSchema = Ref $ Reference "Metadata" - binaryTextSchema = - mempty - & OpenApi.description ?~ "Hex-encoded binary data of up to 64 bytes" - & OpenApi.type_ ?~ OpenApiString - & OpenApi.pattern ?~ "0x[A-Fa-f0-9]{0,128}" - plainTextSchema = - mempty - & OpenApi.description ?~ "Text data of up to 64 characters" - & OpenApi.type_ ?~ OpenApiString - metadataArraySchema = - mempty - & OpenApi.description ?~ "Array of metadata values" - & OpenApi.type_ ?~ OpenApiArray - & OpenApi.items ?~ OpenApiItemsObject metadataSchema - metadataObjectSchema = - mempty - & OpenApi.description ?~ "Object of metadata values" - & OpenApi.type_ ?~ OpenApiObject - & OpenApi.additionalProperties ?~ AdditionalPropertiesSchema metadataSchema - pure $ - NamedSchema (Just "Metadata") $ - mempty - & OpenApi.description ?~ "Arbitrary JSON-encoded transaction metadata" - & oneOf - ?~ [ integerSchema - , Inline binaryTextSchema - , Inline plainTextSchema - , Inline metadataArraySchema - , Inline metadataObjectSchema - ] - -data TxHeader = TxHeader - { contractId :: TxOutRef - , transactionId :: TxId - , tags :: Map Text Metadata - , metadata :: Map Word64 Metadata - , status :: TxStatus - , block :: Maybe BlockHeader - , utxo :: Maybe TxOutRef - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON TxHeader -instance FromJSON TxHeader -instance ToSchema TxHeader - -data Tx = Tx - { contractId :: TxOutRef - , transactionId :: TxId - , tags :: Map Text Metadata - , metadata :: Map Word64 Metadata - , status :: TxStatus - , block :: Maybe BlockHeader - , inputUtxo :: TxOutRef - , inputContract :: Semantics.Contract - , inputState :: Semantics.State - , inputs :: [Semantics.Input] - , outputUtxo :: Maybe TxOutRef - , outputContract :: Maybe Semantics.Contract - , outputState :: Maybe Semantics.State - , assets :: Assets - , payouts :: [Payout] - , consumingTx :: Maybe TxId - , invalidBefore :: UTCTime - , invalidHereafter :: UTCTime - , reconstructedSemanticInput :: V1.TransactionInput - , reconstructedSemanticOutput :: V1.TransactionOutput - , txBody :: Maybe TextEnvelope - } - deriving (Show, Eq, Generic) - -instance ToJSON Tx -instance FromJSON Tx -instance ToSchema Tx - -instance HasPagination TxHeader "transactionId" where - type RangeType TxHeader "transactionId" = TxId - getFieldValue _ TxHeader{..} = transactionId - -data TxStatus - = Unsigned - | Submitted - | Confirmed - deriving (Show, Eq, Ord) - -instance ToJSON TxStatus where - toJSON Unsigned = String "unsigned" - toJSON Submitted = String "submitted" - toJSON Confirmed = String "confirmed" - -instance FromJSON TxStatus where - parseJSON (String "unsigned") = pure Unsigned - parseJSON (String "submitted") = pure Submitted - parseJSON (String "confirmed") = pure Confirmed - parseJSON _ = parseFail "invalid status" - -instance ToSchema TxStatus where - declareNamedSchema _ = - pure $ - NamedSchema (Just "TxStatus") $ - mempty - & type_ ?~ OpenApiString - & enum_ ?~ ["unsigned", "submitted", "confirmed"] - & OpenApi.description ?~ "The status of a transaction on the local node." - -data BlockHeader = BlockHeader - { slotNo :: Word64 - , blockNo :: Word64 - , blockHeaderHash :: Base16 - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON BlockHeader -instance FromJSON BlockHeader -instance ToSchema BlockHeader - -data CardanoTx -data CardanoTxBody - -data WithdrawTxEnvelope tx = WithdrawTxEnvelope - { withdrawalId :: TxId - , txEnvelope :: TextEnvelope - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON (WithdrawTxEnvelope CardanoTx) where - toJSON WithdrawTxEnvelope{..} = - object - [ ("withdrawalId", toJSON withdrawalId) - , ("tx", toJSON txEnvelope) - ] -instance ToJSON (WithdrawTxEnvelope CardanoTxBody) where - toJSON WithdrawTxEnvelope{..} = - object - [ ("withdrawalId", toJSON withdrawalId) - , ("txBody", toJSON txEnvelope) - ] - -instance FromJSON (WithdrawTxEnvelope CardanoTx) where - parseJSON = - withObject - "WithdrawTxEnvelope" - ( \obj -> - WithdrawTxEnvelope - <$> obj .: "withdrawalId" - <*> obj .: "tx" - ) - -instance FromJSON (WithdrawTxEnvelope CardanoTxBody) where - parseJSON = - withObject - "WithdrawTxEnvelope" - ( \obj -> - WithdrawTxEnvelope - <$> obj .: "withdrawalId" - <*> obj .: "txBody" - ) - -instance ToSchema (WithdrawTxEnvelope CardanoTx) where - declareNamedSchema _ = do - withdrawalIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) - txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) - return $ - NamedSchema (Just "WithdrawTxEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" - & properties - .~ [ ("withdrawalId", withdrawalIdSchema) - , ("tx", txEnvelopeSchema) - ] - & required .~ ["withdrawalId", "tx"] - -instance ToSchema (WithdrawTxEnvelope CardanoTxBody) where - declareNamedSchema _ = do - withdrawalIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) - txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) - return $ - NamedSchema (Just "WithdrawTxBodyEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" - & properties - .~ [ ("withdrawalId", withdrawalIdSchema) - , ("txBody", txEnvelopeSchema) - ] - & required .~ ["withdrawalId", "txBody"] - -data CreateTxEnvelope tx = CreateTxEnvelope - { contractId :: TxOutRef - , txEnvelope :: TextEnvelope - , safetyErrors :: [SafetyError] - } - deriving (Show, Eq, Generic) - -instance ToJSON (CreateTxEnvelope CardanoTx) where - toJSON CreateTxEnvelope{..} = - object - [ ("contractId", toJSON contractId) - , ("tx", toJSON txEnvelope) - , ("safetyErrors", toJSON safetyErrors) - ] -instance ToJSON (CreateTxEnvelope CardanoTxBody) where - toJSON CreateTxEnvelope{..} = - object - [ ("contractId", toJSON contractId) - , ("txBody", toJSON txEnvelope) - , ("safetyErrors", toJSON safetyErrors) - ] - -instance FromJSON (CreateTxEnvelope CardanoTx) where - parseJSON = - withObject - "CreateTxEnvelope" - ( \obj -> - CreateTxEnvelope - <$> obj .: "contractId" - <*> obj .: "tx" - <*> obj .: "safetyErrors" - ) - -instance FromJSON (CreateTxEnvelope CardanoTxBody) where - parseJSON = - withObject - "CreateTxEnvelope" - ( \obj -> - CreateTxEnvelope - <$> obj .: "contractId" - <*> obj .: "txBody" - <*> obj .: "safetyErrors" - ) - -instance ToSchema (CreateTxEnvelope CardanoTx) where - declareNamedSchema _ = do - contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) - txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) - safetyErrorsSchema <- declareSchemaRef (Proxy :: Proxy [SafetyError]) - return $ - NamedSchema (Just "CreateTxEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" - & properties - .~ [ ("contractId", contractIdSchema) - , ("tx", txEnvelopeSchema) - , ("safetyErrors", safetyErrorsSchema) - ] - & required .~ ["contractId", "tx"] - -instance ToSchema (CreateTxEnvelope CardanoTxBody) where - declareNamedSchema _ = do - contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) - txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) - safetyErrorsSchema <- declareSchemaRef (Proxy :: Proxy [SafetyError]) - return $ - NamedSchema (Just "CreateTxBodyEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" - & properties - .~ [ ("contractId", contractIdSchema) - , ("txBody", txEnvelopeSchema) - , ("safetyErrors", safetyErrorsSchema) - ] - & required .~ ["contractId", "txBody"] - -data TextEnvelope = TextEnvelope - { teType :: Text - , teDescription :: Text - , teCborHex :: Base16 - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON TextEnvelope where - toJSON TextEnvelope{..} = - object - [ ("type", toJSON teType) - , ("description", toJSON teDescription) - , ("cborHex", toJSON teCborHex) - ] - -instance FromJSON TextEnvelope where - parseJSON = - withObject - "TextEnvelope" - ( \obj -> - TextEnvelope - <$> obj .: "type" - <*> obj .: "description" - <*> obj .: "cborHex" - ) - -instance ToSchema TextEnvelope where - declareNamedSchema _ = do - textSchema <- declareSchemaRef (Proxy @Text) - let typeSchema = - mempty - & type_ ?~ OpenApiString - & OpenApi.description - ?~ "What type of data is encoded in the CBOR Hex. Valid values include \"Tx \", \"TxBody \", and \"ShelleyTxWitness \" where is one of \"BabbageEra\", \"ConwayEra\"." - pure $ - NamedSchema (Just "TextEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & required .~ ["type", "description", "cborHex"] - & properties - .~ [ ("type", Inline typeSchema) - , ("description", textSchema) - , ("cborHex", textSchema) - ] - -data PostContractSourceResponse = PostContractSourceResponse - { contractSourceId :: ContractSourceId - , intermediateIds :: Map Label ContractSourceId - } - deriving (Show, Eq, Ord, Generic) - -instance FromJSON PostContractSourceResponse -instance ToJSON PostContractSourceResponse -instance ToSchema PostContractSourceResponse - -newtype PostWithdrawalsRequest = PostWithdrawalsRequest - { payouts :: Set TxOutRef - } - deriving (Show, Eq, Ord, Generic) - -instance FromJSON PostWithdrawalsRequest -instance ToJSON PostWithdrawalsRequest -instance ToSchema PostWithdrawalsRequest - -data PostContractsRequest = PostContractsRequest - { tags :: Map Text Metadata - , metadata :: Map Word64 Metadata - , version :: MarloweVersion - , roles :: Maybe RolesConfig - , threadTokenName :: Maybe Text - , contract :: ContractOrSourceId - , accounts :: Map Party Assets - , minUTxODeposit :: Maybe Word64 - } - deriving (Show, Eq, Generic) - -instance FromJSON PostContractsRequest -instance ToJSON PostContractsRequest -instance ToSchema PostContractsRequest - -newtype ContractOrSourceId = ContractOrSourceId (Either Semantics.Contract ContractSourceId) - deriving (Show, Eq, Ord, Generic) - -instance FromJSON ContractOrSourceId where - parseJSON = - fmap ContractOrSourceId . \case - String "close" -> pure $ Left Semantics.Close - String s -> Right <$> parseJSON (String s) - j -> Left <$> parseJSON j - -instance ToJSON ContractOrSourceId where - toJSON = \case - ContractOrSourceId (Left contract) -> toJSON contract - ContractOrSourceId (Right hash) -> toJSON hash - -instance ToSchema ContractOrSourceId where - declareNamedSchema _ = do - contractSchema <- declareSchemaRef $ Proxy @Semantics.Contract - contractSourceIdSchema <- declareSchemaRef $ Proxy @ContractSourceId - pure $ - NamedSchema Nothing $ - mempty - & oneOf ?~ [contractSchema, contractSourceIdSchema] - -data RolesConfig - = UsePolicy PolicyId - | UsePolicyWithOpenRoles PolicyId [Text] - | Mint (Map Text RoleTokenConfig) - deriving (Show, Eq, Ord, Generic) - -instance FromJSON RolesConfig where - parseJSON (String s) = UsePolicy <$> parseJSON (String s) - parseJSON value = - withObject - "RolesConfig" - ( \obj -> - let parseMint = Mint <$> parseJSON value - parseOpen = - do - script <- obj .: "script" - unless (script == ("OpenRole" :: String)) $ fail "AllowedValues: \"OpenRole\"" - UsePolicyWithOpenRoles <$> obj .: "policyId" <*> obj .: "openRoleNames" - in parseOpen <|> parseMint - ) - value - -instance ToJSON RolesConfig where - toJSON (UsePolicy policy) = toJSON policy - toJSON (UsePolicyWithOpenRoles policy openRoleNames) = - object - [ "script" .= ("OpenRole" :: String) - , "policyId" .= policy - , "openRoleNames" .= openRoleNames - ] - toJSON (Mint configs) = toJSON configs - -instance ToSchema RolesConfig where - declareNamedSchema _ = do - policySchema <- declareSchemaRef (Proxy @PolicyId) - mintSchema <- declareSchemaRef (Proxy @(Map Text RoleTokenConfig)) - pure $ - NamedSchema (Just "RolesConfig") $ - mempty - & oneOf ?~ [policySchema, mintSchema] - -data RoleTokenConfig = RoleTokenConfig - { recipients :: RoleTokenRecipients - , metadata :: Maybe TokenMetadata - } - deriving (Show, Eq, Ord, Generic) - -type RoleTokenRecipients = Map RoleTokenRecipient Word64 - -data RoleTokenRecipient - = ClosedRole Address - | OpenRole - deriving (Show, Eq, Ord, Generic) - -roleTokenRecipientToText :: RoleTokenRecipient -> Text -roleTokenRecipientToText = \case - ClosedRole addr -> unAddress addr - OpenRole -> "OpenRole" - -roleTokenRecipientFromText :: Text -> RoleTokenRecipient -roleTokenRecipientFromText = \case - "OpenRole" -> OpenRole - addr -> ClosedRole $ Address addr - -instance ToJSON RoleTokenRecipient where - toJSON = String . roleTokenRecipientToText - -instance ToJSONKey RoleTokenRecipient where - toJSONKey = toJSONKeyText roleTokenRecipientToText - -instance FromJSON RoleTokenRecipient where - parseJSON = withText "RoleTokenRecipient" $ pure . roleTokenRecipientFromText - -instance FromJSONKey RoleTokenRecipient where - fromJSONKey = FromJSONKeyText roleTokenRecipientFromText - -instance FromJSON RoleTokenConfig where - parseJSON (String "OpenRole") = - pure - . flip RoleTokenConfig Nothing - $ Map.singleton OpenRole 1 - parseJSON (String s) = - pure - . flip RoleTokenConfig Nothing - . flip Map.singleton 1 - . ClosedRole - $ Address s - parseJSON value = - withObject - "RoleTokenConfig" - ( \obj -> do - mRecipients <- obj .:? "recipients" - mAddress <- obj .:? "address" - mScriptRole <- do - mScript :: Maybe String <- obj .:? "script" - for - mScript - ( \case - "OpenRole" -> pure OpenRole - _ -> fail "Expected \'OpenRole\"" - ) - metadata <- obj .:? "metadata" - recipients <- case (mRecipients, mAddress, mScriptRole) of - (Just recipients, _, _) -> pure recipients - (_, Just address, _) -> pure $ Map.singleton (ClosedRole address) 1 - (_, _, Just scriptRole) -> pure $ Map.singleton scriptRole 1 - _ -> fail "one of recipients, address, or script required" - pure RoleTokenConfig{..} - ) - value - -instance ToJSON RoleTokenConfig where - toJSON (RoleTokenConfig recipients metadata) = - object - [ "recipients" .= recipients - , "metadata" .= metadata - ] - -instance ToSchema RoleTokenConfig where - declareNamedSchema _ = do - simpleSchema <- declareSchemaRef (Proxy @Address) - metadataSchema <- declareSchemaRef (Proxy @TokenMetadata) - quantitySchema <- declareSchemaRef (Proxy @Word64) - let multiSchema = - mempty - & type_ ?~ OpenApiObject - & required .~ ["recipients"] - & properties - .~ [ - ( "recipients" - , Inline $ - mempty - & type_ ?~ OpenApiObject - & additionalProperties ?~ AdditionalPropertiesSchema quantitySchema - ) - , ("metadata", metadataSchema) - ] - advancedSchema = - mempty - & type_ ?~ OpenApiObject - & required .~ ["address"] - & properties - .~ [ ("address", simpleSchema) - , ("metadata", metadataSchema) - ] - scriptSchema = - mempty - & type_ ?~ OpenApiString - & OpenApi.description ?~ "The type of script receiving the role token." - & enum_ ?~ ["OpenRole"] - openSchema = - mempty - & type_ ?~ OpenApiObject - & required .~ ["script"] - & properties - .~ [ ("script", Inline scriptSchema) - , ("metadata", metadataSchema) - ] - pure $ - NamedSchema (Just "RoleTokenConfig") $ - mempty - & oneOf ?~ [Inline multiSchema, simpleSchema, Inline advancedSchema, Inline openSchema] - -data TokenMetadata = TokenMetadata - { name :: Text - , image :: URI - , mediaType :: Maybe Text - , description :: Maybe Text - , files :: Maybe [TokenMetadataFile] - , additionalProps :: Aeson.Object - } - deriving (Show, Eq, Ord, Generic) - -instance FromJSON TokenMetadata where - parseJSON = - withObject - "TokenMetadata" - ( \obj -> do - imageJSON <- obj .: "image" - let additionalProps = - AMap.delete "name" - . AMap.delete "image" - . AMap.delete "mediaType" - . AMap.delete "description" - . AMap.delete "files" - $ obj - TokenMetadata - <$> obj .: "name" - <*> uriFromJSON imageJSON - <*> obj .:? "mediaType" - <*> obj .:? "description" - <*> obj .:? "files" - <*> pure additionalProps - ) - -instance ToJSON TokenMetadata where - toJSON TokenMetadata{..} = - object $ - [ "name" .= name - , "image" .= uriToJSON image - , "mediaType" .= mediaType - , "description" .= description - , "files" .= files - ] - <> AMap.toList additionalProps - -instance ToSchema TokenMetadata where - declareNamedSchema _ = do - stringSchema <- declareSchemaRef (Proxy @Text) - filesSchema <- declareSchemaRef (Proxy @[TokenMetadataFile]) - metadataSchema <- declareSchemaRef (Proxy @Metadata) - pure $ - NamedSchema (Just "TokenMetadata") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Metadata for an NFT, as described by https://cips.cardano.org/cips/cip25/" - & required .~ ["name", "image"] - & properties - .~ [ ("name", stringSchema) - , ("image", stringSchema) - , ("mediaType", stringSchema) - , ("description", stringSchema) - , ("files", filesSchema) - ] - & additionalProperties ?~ AdditionalPropertiesSchema metadataSchema - -data TokenMetadataFile = TokenMetadataFile - { name :: Text - , src :: URI - , mediaType :: Text - , additionalProps :: Aeson.Object - } - deriving (Show, Eq, Ord, Generic) - -instance FromJSON TokenMetadataFile where - parseJSON = - withObject - "TokenMetadataFile" - ( \obj -> do - srcJSON <- obj .: "src" - let additionalProps = - AMap.delete "name" - . AMap.delete "mediaType" - . AMap.delete "src" - $ obj - TokenMetadataFile - <$> obj .: "name" - <*> uriFromJSON srcJSON - <*> obj .: "mediaType" - <*> pure additionalProps - ) - -instance ToJSON TokenMetadataFile where - toJSON TokenMetadataFile{..} = - object $ - [ ("name", toJSON name) - , ("src", uriToJSON src) - , ("mediaType", toJSON mediaType) - ] - <> AMap.toList additionalProps - -instance ToSchema TokenMetadataFile where - declareNamedSchema _ = do - stringSchema <- declareSchemaRef (Proxy @Text) - metadataSchema <- declareSchemaRef (Proxy @Metadata) - pure $ - NamedSchema (Just "TokenMetadataFile") $ - mempty - & type_ ?~ OpenApiObject - & required .~ ["name", "src", "mediaType"] - & properties - .~ [ ("name", stringSchema) - , ("src", stringSchema) - , ("mediaType", stringSchema) - ] - & additionalProperties ?~ AdditionalPropertiesSchema metadataSchema - -uriFromJSON :: Value -> Parser URI -uriFromJSON = withText "URI" $ maybe (parseFail "invalid URI") pure . parseURI . T.unpack - -uriToJSON :: URI -> Value -uriToJSON = String . T.pack . show - -data PostTransactionsRequest = PostTransactionsRequest - { version :: MarloweVersion - , tags :: Map Text Metadata - , metadata :: Map Word64 Metadata - , invalidBefore :: Maybe UTCTime - , invalidHereafter :: Maybe UTCTime - , inputs :: [Semantics.Input] - } - deriving (Show, Eq, Generic) - -instance FromJSON PostTransactionsRequest -instance ToJSON PostTransactionsRequest -instance ToSchema PostTransactionsRequest - -data ApplyInputsTxEnvelope tx = ApplyInputsTxEnvelope - { contractId :: TxOutRef - , transactionId :: TxId - , txEnvelope :: TextEnvelope - } - deriving (Show, Eq, Ord, Generic) - -instance ToJSON (ApplyInputsTxEnvelope CardanoTx) where - toJSON ApplyInputsTxEnvelope{..} = - object - [ ("contractId", toJSON contractId) - , ("transactionId", toJSON transactionId) - , ("tx", toJSON txEnvelope) - ] -instance ToJSON (ApplyInputsTxEnvelope CardanoTxBody) where - toJSON ApplyInputsTxEnvelope{..} = - object - [ ("contractId", toJSON contractId) - , ("transactionId", toJSON transactionId) - , ("txBody", toJSON txEnvelope) - ] - -instance FromJSON (ApplyInputsTxEnvelope CardanoTx) where - parseJSON = - withObject - "ApplyInputsTxEnvelope" - ( \obj -> do - contractId <- obj .: "contractId" - transactionId <- obj .: "transactionId" - txEnvelope <- obj .: "tx" - pure ApplyInputsTxEnvelope{..} - ) - -instance FromJSON (ApplyInputsTxEnvelope CardanoTxBody) where - parseJSON = - withObject - "ApplyInputsTxEnvelope" - ( \obj -> do - contractId <- obj .: "contractId" - transactionId <- obj .: "transactionId" - txEnvelope <- obj .: "txBody" - pure ApplyInputsTxEnvelope{..} - ) - -instance ToSchema (ApplyInputsTxEnvelope CardanoTx) where - declareNamedSchema _ = do - contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) - transactionIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) - txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) - return $ - NamedSchema (Just "ApplyInputsTxEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" - & properties - .~ [ ("contractId", contractIdSchema) - , ("transactionId", transactionIdSchema) - , ("tx", txEnvelopeSchema) - ] - & required .~ ["contractId", "transactionId", "tx"] - -instance ToSchema (ApplyInputsTxEnvelope CardanoTxBody) where - declareNamedSchema _ = do - contractIdSchema <- declareSchemaRef (Proxy :: Proxy TxOutRef) - transactionIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) - txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) - return $ - NamedSchema (Just "ApplyInputsTxEnvelope") $ - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" - & properties - .~ [ ("contractId", contractIdSchema) - , ("transactionId", transactionIdSchema) - , ("txBody", txEnvelopeSchema) - ] - & required .~ ["contractId", "transactionId", "txBody"] - -data NetworkId - = Mainnet - | Testnet Word32 - deriving (Show, Eq, Ord) - -instance ToSchema NetworkId where - declareNamedSchema _ = do - let mainnetSchema = - mempty - & type_ ?~ OpenApiString - & enum_ ?~ ["mainnet"] - testnetSchema <- declareSchemaRef (Proxy @Word32) - pure $ - NamedSchema (Just "NetworkId") $ - mempty - & oneOf ?~ [Inline mainnetSchema, testnetSchema] - -data ChainTip - = ChainTipGenesis UTCTime - | ChainTip BlockHeader UTCTime - deriving (Show, Eq, Ord) - -data RuntimeStatus = RuntimeStatus - { nodeTip :: ChainTip - , runtimeChainTip :: ChainTip - , runtimeTip :: ChainTip - , networkId :: NetworkId - , runtimeVersion :: Version - } - deriving (Show, Eq, Ord) - -instance ToJSON ChainTip where - toJSON = \case - ChainTipGenesis time -> object ["genesisTimeUTC" .= iso8601Show time] - ChainTip blockHeader time -> - object - [ "blockHeader" .= blockHeader - , "slotTimeUTC" .= iso8601Show time - ] - -instance FromJSON ChainTip where - parseJSON = - withObject - "ChainTip" - ( \obj -> do - genesisTimeUTC <- obj .:? "genesisTimeUTC" - blockHeader <- obj .:? "blockHeader" - slotTimeUTC <- obj .:? "slotTimeUTC" - case (genesisTimeUTC, blockHeader, slotTimeUTC) of - (Nothing, Just blockHeader', Just slotTimeUTC') -> pure $ ChainTip blockHeader' slotTimeUTC' - (Just genesisTimeUTC', Nothing, Nothing) -> pure $ ChainTipGenesis genesisTimeUTC' - _ -> parseFail "Invalid keys, expecting ([\"genesisTimeUTC\"] | [\"blockHeader\", \"slotTimeUTC\"])" - ) - -instance ToHttpApiData ChainTip where - toUrlPiece = TL.toStrict . encodeToLazyText - -instance FromHttpApiData ChainTip where - parseUrlPiece = first T.pack . eitherDecodeStrict . encodeUtf8 - -instance ToHttpApiData NetworkId where - toUrlPiece = \case - Mainnet -> "mainnet" - Testnet n -> toUrlPiece n - -instance ToHttpApiData Label where - toUrlPiece = unLabel - -instance FromHttpApiData Label where - parseUrlPiece = pure . Label - -instance FromHttpApiData NetworkId where - parseUrlPiece = \case - "mainnet" -> pure Mainnet - n -> Testnet <$> parseUrlPiece n - -instance ToParamSchema ChainTip where - toParamSchema _ = - mempty - & oneOf ?~ [Inline genesisSchema, Inline tipSchema] - & OpenApi.description ?~ "The latest known point in the chain on a peer." - where - genesisSchema = - mempty - & type_ ?~ OpenApiObject - & properties - .~ [ ("genesisTimeUTC", Inline $ toParamSchema $ Proxy @UTCTime) - ] - & required .~ ["genesisTimeUTC"] - - tipSchema = - mempty - & type_ ?~ OpenApiObject - & properties - .~ [ ("blockHeader", Ref $ Reference "BlockHeader") - , ("slotTimeUTC", Inline $ toParamSchema $ Proxy @UTCTime) - ] - & required .~ ["blockHeader", "slotTimeUTC"] - -instance ToParamSchema NetworkId where - toParamSchema _ = - mempty - & oneOf ?~ [Inline (mempty & type_ ?~ OpenApiString), Inline (mempty & type_ ?~ OpenApiInteger)] - & OpenApi.description ?~ "The latest known point in the chain on a peer." - -data RoleTokenFilter - = RoleTokenAnd RoleTokenFilter RoleTokenFilter - | RoleTokenOr RoleTokenFilter RoleTokenFilter - | RoleTokenNot RoleTokenFilter - | RoleTokenFilterNone - | RoleTokenFilterByContracts (Set TxOutRef) - | RoleTokenFilterByPolicies (Set PolicyId) - | RoleTokenFilterByTokens (Set AssetId) - | RoleTokenFilterAny - deriving stock (Show, Eq, Ord, Generic) - -instance ToJSON RoleTokenFilter where - toJSON = \case - RoleTokenAnd a b -> object ["and" .= (a, b)] - RoleTokenOr a b -> object ["or" .= (a, b)] - RoleTokenNot a -> object ["not" .= a] - RoleTokenFilterNone -> toJSON False - RoleTokenFilterByContracts contracts -> object ["contract_id" .= contracts] - RoleTokenFilterByPolicies policies -> object ["roles_currency" .= policies] - RoleTokenFilterByTokens tokens -> object ["role_tokens" .= tokens] - RoleTokenFilterAny -> toJSON True - -instance FromJSON RoleTokenFilter where - parseJSON = - prependFailure "Parsing RoleTokenFilter failed" . \case - Object o -> case KeyMap.toList o of - [(k, v)] -> case k of - "and" -> uncurry RoleTokenAnd <$> parseJSON v Key "and" - "or" -> uncurry RoleTokenOr <$> parseJSON v Key "or" - "not" -> RoleTokenNot <$> parseJSON v Key "not" - "contract_id" -> RoleTokenFilterByContracts <$> parseSetOrSingle v Key "contract_id" - "roles_currency" -> RoleTokenFilterByPolicies <$> parseSetOrSingle v Key "roles_currency" - "role_tokens" -> RoleTokenFilterByTokens <$> parseSetOrSingle v Key "role_tokens" - _ -> fail $ "Unexpected key: " <> show k - _ -> fail "Unexpected number of keys, expected exactly 1." - Bool True -> pure RoleTokenFilterAny - Bool False -> pure RoleTokenFilterNone - v -> typeMismatch "object|boolean" v - -parseSetOrSingle :: (FromJSON a, Ord a) => Value -> Parser (Set a) -parseSetOrSingle = \case - Array arr -> parseJSON $ Array arr - v -> Set.singleton <$> parseJSON v - -instance ToSchema RoleTokenFilter where - declareNamedSchema _ = do - roleTokenFilterSchema <- declareSchemaRef $ Proxy @RoleTokenFilter - roleTokenFilterPairSchema <- declareSchemaRef $ Proxy @(RoleTokenFilter, RoleTokenFilter) - let setOrSingleSchema - :: forall a - . (ToSchema a) - => Proxy a - -> Declare (Definitions Schema) (Referenced Schema) - setOrSingleSchema p = do - singleSchema <- declareSchemaRef p - setSchema <- declareSchemaRef $ Proxy @(Set a) - pure $ Inline $ mempty & oneOf ?~ [singleSchema, setSchema] - txOutRefSchema <- setOrSingleSchema $ Proxy @TxOutRef - policyIdSchema <- setOrSingleSchema $ Proxy @PolicyId - assetIdSchema <- setOrSingleSchema $ Proxy @AssetId - let andSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens matched by both sub-filters." - & required .~ ["and"] - & properties .~ [("and", roleTokenFilterPairSchema)] - orSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens matched by either sub-filter." - & required .~ ["or"] - & properties .~ [("or", roleTokenFilterPairSchema)] - notSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens not matched by the sub-filter." - & required .~ ["not"] - & properties .~ [("not", roleTokenFilterSchema)] - anySchema = - mempty - & type_ ?~ OpenApiBoolean - & OpenApi.description ?~ "Matches any role token." - & enum_ ?~ [Bool True] - noneSchema = - mempty - & type_ ?~ OpenApiBoolean - & OpenApi.description ?~ "Matches no role token." - & enum_ ?~ [Bool False] - contractsSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens used by the given contract(s)." - & required .~ ["contract_id"] - & properties .~ [("contract_id", txOutRefSchema)] - policiesSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens with the given currency symbol(s)." - & required .~ ["roles_currency"] - & properties .~ [("roles_currency", policyIdSchema)] - tokensSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches only the given role token(s)." - & required .~ ["role_tokens"] - & properties .~ [("role_tokens", assetIdSchema)] - pure $ - NamedSchema (Just "RoleTokenFilter") $ - mempty - & OpenApi.description ?~ "A filter that selects role tokens for burning." - & oneOf - ?~ fmap - Inline - [ andSchema - , orSchema - , notSchema - , anySchema - , noneSchema - , contractsSchema - , policiesSchema - , tokensSchema - ] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/API.hs new file mode 100644 index 0000000000..4f7b847734 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/API.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Language.Marlowe.Runtime.Web.Withdrawal.API ( + WithdrawalHeader (..), + Withdrawal (..), + WithdrawalsAPI, + GetWithdrawalsResponse, + PostWithdrawalsRequest (..), + PostWithdrawalsResponse, + WithdrawalAPI, + GetWithdrawalAPI, + PostTransactionsRequest (..), +) where + +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink) +import Language.Marlowe.Runtime.Web.Adapter.Pagination (PaginatedGet) +import Language.Marlowe.Runtime.Web.Adapter.Servant ( + OperationId, + RenameResponseSchema, + ) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () +import Language.Marlowe.Runtime.Web.Core.Asset (PolicyId) + +import Language.Marlowe.Runtime.Web.Core.BlockHeader ( + BlockHeader, + ) +import Servant ( + Capture, + Description, + Get, + JSON, + PostCreated, + QueryParams, + ReqBody, + Summary, + type (:<|>), + type (:>), + ) + +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.OpenApi ( + ToSchema, + ) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Word (Word64) +import GHC.Generics (Generic) +import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics +import Language.Marlowe.Runtime.Web.Core.MarloweVersion (MarloweVersion) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Servant.Pagination (HasPagination (..)) + +import Language.Marlowe.Runtime.Web.Core.Metadata (Metadata) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TxId, + TxOutRef, + TxStatus, + ) +import Language.Marlowe.Runtime.Web.Payout.API (PayoutHeader) +import Language.Marlowe.Runtime.Web.Tx.API ( + CardanoTx, + CardanoTxBody, + PostTxAPI, + PutSignedTxAPI, + TxJSON, + WithdrawTx, + WithdrawTxEnvelope, + ) + +-- | /withdrawals sub-API +type WithdrawalsAPI = + GetWithdrawalsAPI + :<|> PostWithdrawalsAPI + :<|> Capture "withdrawalId" TxId :> WithdrawalAPI + +-- | /contracts/:contractId/withdrawals/:withdrawalId sub-API +type WithdrawalAPI = + GetWithdrawalAPI + :<|> Summary "Submit payout withdrawal" + :> Description + "Submit a signed (Cardano) transaction that withdraws available payouts from a role payout validator. \ + \The transaction must have originally been created by the POST /withdrawals endpoint. \ + \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ + \it will not wait for the transaction to be published in a block. \ + \Use the GET /withdrawals/{withdrawalId} endpoint to poll the on-chain status." + :> OperationId "submitWithdrawal" + :> PutSignedTxAPI + +-- | GET /contracts/:contractId/withdrawals/:withdrawalId sub-API +type GetWithdrawalAPI = + Summary "Get withdrawal by ID" + :> OperationId "getWithdrawalById" + :> Get '[JSON] Withdrawal + +-- | POST /contracts sub-API +type PostWithdrawalsAPI = + Summary "Withdraw payouts" + :> Description + "Build an unsigned (Cardano) transaction body which withdraws available payouts from a role payout validator. \ + \This unsigned transaction must be signed by a wallet (such as a CIP-30 or CIP-45 wallet) before being submitted. \ + \To submit the signed transaction, use the PUT /withdrawals/{withdrawalId} endpoint." + :> OperationId "withdrawPayouts" + :> RenameResponseSchema "WithdrawPayoutsResponse" + :> ( ReqBody '[JSON] PostWithdrawalsRequest :> PostTxAPI (PostCreated '[JSON] (PostWithdrawalsResponse CardanoTxBody)) + :<|> ReqBody '[JSON] PostWithdrawalsRequest + :> PostTxAPI (PostCreated '[TxJSON WithdrawTx] (PostWithdrawalsResponse CardanoTx)) + ) + +type PostWithdrawalsResponse tx = WithLink "withdrawal" (WithdrawTxEnvelope tx) + +-- | GET /contracts/:contractId/withdrawals sub-API +type GetWithdrawalsAPI = + Summary "Get withdrawals" + :> Description + "Get published withdrawal transactions. \ + \Results are returned in pages, with paging being specified by request headers." + :> OperationId "getWithdrawals" + :> QueryParams "roleCurrency" PolicyId + :> RenameResponseSchema "GetWithdrawalsResponse" + :> PaginatedGet '["withdrawalId"] GetWithdrawalsResponse + +type GetWithdrawalsResponse = WithLink "withdrawal" WithdrawalHeader + +data WithdrawalHeader = WithdrawalHeader + { withdrawalId :: TxId + , status :: TxStatus + , block :: Maybe BlockHeader + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) + +instance HasPagination WithdrawalHeader "withdrawalId" where + type RangeType WithdrawalHeader "withdrawalId" = TxId + getFieldValue _ WithdrawalHeader{..} = withdrawalId + +data Withdrawal = Withdrawal + { payouts :: Set PayoutHeader + , withdrawalId :: TxId + , status :: TxStatus + , block :: Maybe BlockHeader + } + deriving (Show, Eq, Ord, Generic, ToJSON, FromJSON, ToSchema) + +newtype PostWithdrawalsRequest = PostWithdrawalsRequest + { payouts :: Set TxOutRef + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON PostWithdrawalsRequest +instance ToJSON PostWithdrawalsRequest +instance ToSchema PostWithdrawalsRequest + +data PostTransactionsRequest = PostTransactionsRequest + { version :: MarloweVersion + , tags :: Map Text Metadata + , metadata :: Map Word64 Metadata + , invalidBefore :: Maybe UTCTime + , invalidHereafter :: Maybe UTCTime + , inputs :: [Semantics.Input] + } + deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema) diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Withdrawals.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs similarity index 80% rename from marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Withdrawals.hs rename to marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs index ed87769f72..4c0f4536d5 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Withdrawals.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} -- | This module defines a server for the /withdrawals REST API. -module Language.Marlowe.Runtime.Web.Server.REST.Withdrawals where +module Language.Marlowe.Runtime.Web.Withdrawal.Server where import Cardano.Api ( BabbageEra, @@ -25,21 +26,68 @@ import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Core.Api (MarloweVersion (..)) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..), WithdrawTx (..), WithdrawTxInEra (..)) -import Language.Marlowe.Runtime.Web hiding (Unsigned) -import Language.Marlowe.Runtime.Web.Server.DTO -import Language.Marlowe.Runtime.Web.Server.Monad (ServerM, loadWithdrawal, loadWithdrawals, submitWithdrawal, withdraw) -import Language.Marlowe.Runtime.Web.Server.REST.ApiError ( +import Language.Marlowe.Runtime.Web.Adapter.Links (WithLink (..)) +import Language.Marlowe.Runtime.Web.Adapter.Pagination ( + PaginatedResponse, + ) +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError ( ApiError (ApiError), badRequest', notFound', rangeNotSatisfiable', throwDTOError, ) -import qualified Language.Marlowe.Runtime.Web.Server.REST.ApiError as ApiError -import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx (..), TempTxStatus (..)) -import Language.Marlowe.Runtime.Web.Server.Util -import Servant -import Servant.Pagination +import qualified Language.Marlowe.Runtime.Web.Adapter.Server.ApiError as ApiError +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO ( + FromDTO (fromDTO), + ShelleyTxWitness (..), + ToDTO (toDTO), + fromDTOThrow, + fromPaginationRange, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + ServerM, + loadWithdrawal, + loadWithdrawals, + submitWithdrawal, + withdraw, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (..), TempTxStatus (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.Util ( + makeSignedTxWithWitnessKeys, + ) + +import Language.Marlowe.Runtime.Web.Adapter.CommaList (CommaList (..)) +import Language.Marlowe.Runtime.Web.Core.Address (Address) +import Language.Marlowe.Runtime.Web.Core.Asset (PolicyId) + +import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope (..), TxId, TxOutRef) +import Language.Marlowe.Runtime.Web.Tx.API (CardanoTx, CardanoTxBody, WithdrawTxEnvelope (..)) +import Language.Marlowe.Runtime.Web.Withdrawal.API ( + GetWithdrawalsResponse, + PostWithdrawalsRequest (..), + PostWithdrawalsResponse, + Withdrawal (..), + WithdrawalAPI, + WithdrawalHeader (..), + WithdrawalsAPI, + ) +import Servant ( + HasServer (ServerT), + NoContent (..), + Proxy (Proxy), + addHeader, + throwError, + type (:<|>) ((:<|>)), + ) +import Servant.Pagination ( + ExtractRange (extractRange), + HasPagination (getDefaultRange), + Range, + Ranges, + returnRange, + ) server :: ServerT WithdrawalsAPI ServerM server = diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 49f0316cde..8c41627456 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -18,8 +18,20 @@ import Data.Coerce (coerce) import Data.Data (Typeable) import qualified Data.HashMap.Strict.InsOrd as IOHM import Data.Kind (Type) -import Data.OpenApi hiding (version) -import Data.Proxy +import Data.OpenApi ( + HasDescription (description), + HasOneOf (oneOf), + HasProperties (properties), + HasRequired (required), + HasType (type_), + OpenApiType (OpenApiBoolean, OpenApiInteger, OpenApiString), + Pattern, + Reference (Reference), + Referenced (Inline, Ref), + Schema, + ToSchema, + ) +import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Internal.Builder as TB @@ -29,9 +41,24 @@ import qualified Language.Marlowe.Core.V1.Semantics.Types as Semantics (Input (. import qualified Language.Marlowe.Core.V1.Semantics.Types as V1 import Language.Marlowe.Object.Gen () import Language.Marlowe.Runtime.Transaction.Gen () -import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), WithRuntimeStatus) -import qualified Language.Marlowe.Runtime.Web as Web -import Language.Marlowe.Runtime.Web.Server.OpenAPI ( +import qualified Language.Marlowe.Runtime.Web.API as Web ( + RuntimeAPI, + ) +import qualified Language.Marlowe.Runtime.Web.Adapter.Links as Web +import Language.Marlowe.Runtime.Web.Adapter.Servant (WithRuntimeStatus) +import qualified Language.Marlowe.Runtime.Web.Adapter.Servant as Web +import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..)) +import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import qualified Language.Marlowe.Runtime.Web.Core.Address as Web +import qualified Language.Marlowe.Runtime.Web.Core.Asset as Web +import qualified Language.Marlowe.Runtime.Web.Core.Base16 as Web +import qualified Language.Marlowe.Runtime.Web.Core.BlockHeader as Web +import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web +import qualified Language.Marlowe.Runtime.Web.Core.Metadata as Web +import qualified Language.Marlowe.Runtime.Web.Core.Party as Web +import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web +import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import Language.Marlowe.Runtime.Web.OpenAPIServer ( OpenApiLintEnvironment (..), OpenApiLintIssue (..), OpenApiWithEmptySecurity (..), @@ -41,8 +68,18 @@ import Language.Marlowe.Runtime.Web.Server.OpenAPI ( openApi, schemaRule1Check, ) -import Servant.API -import Servant.OpenApi +import qualified Language.Marlowe.Runtime.Web.Payout.API as Web + +import qualified Language.Marlowe.Runtime.Web.Tx.API as Web +import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web +import Servant.API ( + Headers, + ReqBody', + Verb, + type (:<|>), + type (:>), + ) +import Servant.OpenApi (validateEveryToJSONWithPatternChecker) import Spec.Marlowe.Semantics.Arbitrary () import Spec.Marlowe.Semantics.Next.Arbitrary () import Test.Hspec (Spec, describe, hspec, it, shouldBe) @@ -342,7 +379,7 @@ openAPISpec = do ] actual `shouldBe` expected - validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.API))) + validateEveryToJSONWithPatternChecker patternChecker (Proxy @(WrapContractBodies (RetractRuntimeStatus Web.RuntimeAPI))) it "Should match the golden test" do defaultGolden "OpenApi" $ TL.unpack $ diff --git a/marlowe-runtime/.golden/Job MarloweTxCommand/golden b/marlowe-runtime/.golden/Job MarloweTxCommand/golden index 6eb10de42b..4edf39fbc1 100644 --- a/marlowe-runtime/.golden/Job MarloweTxCommand/golden +++ b/marlowe-runtime/.golden/Job MarloweTxCommand/golden @@ -10,6 +10,10 @@ Show: MsgAttachFailed Binary: 09 Show: MsgAttachFailed Binary: 09 +Show: MsgAttachFailed +Binary: 09 +Show: MsgAttached +Binary: 08 Show: MsgAttached Binary: 08 Show: MsgAttached @@ -32,6 +36,8 @@ Show: MsgDetach Binary: 07 Show: MsgDetach Binary: 07 +Show: MsgDetach +Binary: 07 Show: MsgExec (ApplyInputs MarloweV1 (WalletAddresses {changeAddress = "", extraAddresses = fromList [""], collateralUtxos = fromList []}) (ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}) (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing Nothing []) Binary: 01020000000100000000000000000000000000000001000000000000000000000000000000000000000000000000000100000000000000000000020000000000000000 Show: MsgExec (ApplyInputs MarloweV1 (WalletAddresses {changeAddress = "", extraAddresses = fromList ["61"], collateralUtxos = fromList []}) (ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}) (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing Nothing []) @@ -918,6 +924,46 @@ Show: MsgExec (ApplyInputs MarloweV1 (WalletAddresses {changeAddress = "", extra Binary: 010200000001000000000000000000000000000000000000000000000000000000000000000161000100000000000000000000020000000000000000 Show: MsgExec (ApplyInputs MarloweV1 (WalletAddresses {changeAddress = "61", extraAddresses = fromList [], collateralUtxos = fromList []}) (ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}) (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing Nothing []) Binary: 010200000001000000000000000161000000000000000000000000000000000000000000000000000100000000000000000000020000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [""], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 01050000000000000000000000000000000100000000000000000000000000000000000404 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList ["61"], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 0105000000000000000000000000000000010000000000000001610000000000000000000404 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList [TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}]}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 010500000000000000000000000000000000000000000000000100000000000000000001000404 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList [TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}]}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 01050000000000000000000000000000000000000000000000010000000000000001610001000404 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList [ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}]))) +Binary: 010500000000000000000000000000000000000000000000000005000000000000000100000000000000000001 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList [ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}]))) +Binary: 01050000000000000000000000000000000000000000000000000500000000000000010000000000000001610001 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList []))) +Binary: 0105000000000000000000000000000000000000000000000000050000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList [""]))) +Binary: 01050000000000000000000000000000000000000000000000000600000000000000010000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList ["61"]))) +Binary: 0105000000000000000000000000000000000000000000000000060000000000000001000000000000000161 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList []))) +Binary: 0105000000000000000000000000000000000000000000000000060000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "", tokenName = ""}]))) +Binary: 010500000000000000000000000000000000000000000000000007000000000000000100000000000000000000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "", tokenName = "a"}]))) +Binary: 01050000000000000000000000000000000000000000000000000700000000000000010000000000000000000000000000000161 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "61", tokenName = ""}]))) +Binary: 01050000000000000000000000000000000000000000000000000700000000000000010000000000000001610000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList []))) +Binary: 0105000000000000000000000000000000000000000000000000070000000000000000 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensAnd RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 0105000000000000000000000000000000000000000000000000010404 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensNot RoleTokenFilterNone)) +Binary: 01050000000000000000000000000000000000000000000000000204 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 0105000000000000000000000000000000000000000000000000000404 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) RoleTokenFilterAny) +Binary: 010500000000000000000000000000000000000000000000000003 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) RoleTokenFilterNone) +Binary: 010500000000000000000000000000000000000000000000000004 +Show: MsgExec (Burn (WalletAddresses {changeAddress = "61", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 010500000000000000016100000000000000000000000000000000000404 Show: MsgExec (Create (Just (StakeKeyCredential "")) MarloweV1 (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) Nothing RoleTokensNone (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing (fromList []) (Left Close)) Binary: 01010000000101000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 Show: MsgExec (Create (Just (StakeKeyCredential "61")) MarloweV1 (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) Nothing RoleTokensNone (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing (fromList []) (Left Close)) @@ -2032,6 +2078,140 @@ Show: MsgFail (ApplyInputsLoadMarloweContextFailed LoadMarloweContextErrorNotFou Binary: 0302000000010300 Show: MsgFail (ApplyInputsLoadMarloweContextFailed LoadMarloweContextToCardanoError) Binary: 0302000000010302 +Show: MsgFail (BurnConstraintError (BalancingError "")) +Binary: 0305050a0000000000000000 +Show: MsgFail (BurnConstraintError (BalancingError "a")) +Binary: 0305050a000000000000000161 +Show: MsgFail (BurnConstraintError (CalculateMinUtxoFailed "")) +Binary: 030505080000000000000000 +Show: MsgFail (BurnConstraintError (CalculateMinUtxoFailed "a")) +Binary: 03050508000000000000000161 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientLovelace {required = 1, available = 1}))) +Binary: 030505090100000000010000000001 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = ""},Quantity {unQuantity = 1})]})))) +Binary: 03050509020000000000000001000000000000000000000000000000000000000000000001 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = "a"},Quantity {unQuantity = 1})]})))) +Binary: 0305050902000000000000000100000000000000000000000000000001610000000000000001 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList [(AssetId {policyId = "61", tokenName = ""},Quantity {unQuantity = 1})]})))) +Binary: 0305050902000000000000000100000000000000016100000000000000000000000000000001 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList []})))) +Binary: 03050509020000000000000000 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (NoCollateralFound (fromList [TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}])))) +Binary: 0305050900000000000000000100000000000000000001 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (NoCollateralFound (fromList [TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}])))) +Binary: 030505090000000000000000010000000000000001610001 +Show: MsgFail (BurnConstraintError (CoinSelectionFailed (NoCollateralFound (fromList [])))) +Binary: 03050509000000000000000000 +Show: MsgFail (BurnConstraintError (HelperScriptNotFound "")) +Binary: 030505100000000000000000 +Show: MsgFail (BurnConstraintError (HelperScriptNotFound "a")) +Binary: 03050510000000000000000161 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "")))) +Binary: 030505060000000000000000000101040000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "a")))) +Binary: 03050506000000000000000000010104000000000000000161 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [Constr 1 []])))) +Binary: 03050506000000000000000000010100000000000100000000000000010000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [])))) +Binary: 0305050600000000000000000001010000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (I 1)))) +Binary: 030505060000000000000000000101030000000001 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [Constr 1 []])))) +Binary: 0305050600000000000000000001010200000000000000010000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [])))) +Binary: 030505060000000000000000000101020000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [(Constr 1 [],Constr 1 [])])))) +Binary: 03050506000000000000000000010101000000000000000100000000000100000000000000000000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [])))) +Binary: 030505060000000000000000000101010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) Nothing)) +Binary: 030505060000000000000000000100 +Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}) Nothing)) +Binary: 03050506000000000000000161000100 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "")))) +Binary: 030505050000000000000000000101040000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "a")))) +Binary: 03050505000000000000000000010104000000000000000161 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [Constr 1 []])))) +Binary: 03050505000000000000000000010100000000000100000000000000010000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [])))) +Binary: 0305050500000000000000000001010000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (I 1)))) +Binary: 030505050000000000000000000101030000000001 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [Constr 1 []])))) +Binary: 0305050500000000000000000001010200000000000000010000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [])))) +Binary: 030505050000000000000000000101020000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [(Constr 1 [],Constr 1 [])])))) +Binary: 03050505000000000000000000010101000000000000000100000000000100000000000000000000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [])))) +Binary: 030505050000000000000000000101010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) Nothing)) +Binary: 030505050000000000000000000100 +Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}) Nothing)) +Binary: 03050505000000000000000161000100 +Show: MsgFail (BurnConstraintError (InvalidPayoutScriptAddress (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) "")) +Binary: 03050507000000000000000000010000000000000000 +Show: MsgFail (BurnConstraintError (InvalidPayoutScriptAddress (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) "61")) +Binary: 0305050700000000000000000001000000000000000161 +Show: MsgFail (BurnConstraintError (InvalidPayoutScriptAddress (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}) "")) +Binary: 0305050700000000000000016100010000000000000000 +Show: MsgFail (BurnConstraintError (MintingUtxoNotFound (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}))) +Binary: 0305050000000000000000000001 +Show: MsgFail (BurnConstraintError (MintingUtxoNotFound (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}))) +Binary: 030505000000000000000001610001 +Show: MsgFail (BurnConstraintError (PayoutNotFound (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}))) +Binary: 0305050400000000000000000001 +Show: MsgFail (BurnConstraintError (PayoutNotFound (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}))) +Binary: 030505040000000000000001610001 +Show: MsgFail (BurnConstraintError (RoleTokenNotFound (AssetId {policyId = "", tokenName = ""}))) +Binary: 0305050100000000000000000000000000000000 +Show: MsgFail (BurnConstraintError (RoleTokenNotFound (AssetId {policyId = "", tokenName = "a"}))) +Binary: 030505010000000000000000000000000000000161 +Show: MsgFail (BurnConstraintError (RoleTokenNotFound (AssetId {policyId = "61", tokenName = ""}))) +Binary: 030505010000000000000001610000000000000000 +Show: MsgFail (BurnConstraintError (UnknownPayoutScript "")) +Binary: 0305050f0000000000000000 +Show: MsgFail (BurnConstraintError (UnknownPayoutScript "61")) +Binary: 0305050f000000000000000161 +Show: MsgFail (BurnConstraintError MarloweInputInWithdraw) +Binary: 0305050b +Show: MsgFail (BurnConstraintError MarloweOutputInWithdraw) +Binary: 0305050c +Show: MsgFail (BurnConstraintError MissingMarloweInput) +Binary: 03050503 +Show: MsgFail (BurnConstraintError PayoutInputInCreateOrApply) +Binary: 0305050e +Show: MsgFail (BurnConstraintError PayoutOutputInWithdraw) +Binary: 0305050d +Show: MsgFail (BurnConstraintError ToCardanoError) +Binary: 03050502 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra AllegraEra)) +Binary: 03050002 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra AlonzoEra)) +Binary: 03050004 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra BabbageEra)) +Binary: 03050005 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra ByronEra)) +Binary: 03050000 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra ConwayEra)) +Binary: 03050006 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra MaryEra)) +Binary: 03050003 +Show: MsgFail (BurnEraUnsupported (AnyCardanoEra ShelleyEra)) +Binary: 03050001 +Show: MsgFail (BurnInvalidPolicyId (fromList [""])) +Binary: 03050200000000000000010000000000000000 +Show: MsgFail (BurnInvalidPolicyId (fromList ["61"])) +Binary: 0305020000000000000001000000000000000161 +Show: MsgFail (BurnInvalidPolicyId (fromList [])) +Binary: 0305020000000000000000 +Show: MsgFail (BurnRolesActive (fromList [""])) +Binary: 03050100000000000000010000000000000000 +Show: MsgFail (BurnRolesActive (fromList ["61"])) +Binary: 0305010000000000000001000000000000000161 +Show: MsgFail (BurnRolesActive (fromList [])) +Binary: 0305010000000000000000 Show: MsgFail (CreateBuildupFailed (AddressDecodingFailed "")) Binary: 03010000000104010000000000000000 Show: MsgFail (CreateBuildupFailed (AddressDecodingFailed "61")) @@ -12956,6 +13136,10 @@ Show: MsgFail (WithdrawLoadHelpersContextFailed (LoadHelpersContextTxOutRefNotFo Binary: 03030000000103050000000000000001610001 Show: MsgFail (WithdrawLoadHelpersContextFailed RollForwardToGenesisError) Binary: 0303000000010304 +Show: MsgFail BurnFromCardanoError +Binary: 030504 +Show: MsgFail BurnNoTokens +Binary: 030503 Show: MsgFail CreateContractNotFound Binary: 03010000000108 Show: MsgFail CreateToCardanoError @@ -12978,10 +13162,20 @@ Show: MsgPoll Binary: 06 Show: MsgPoll Binary: 06 +Show: MsgPoll +Binary: 06 Show: MsgSucceed (BlockHeader {slotNo = SlotNo {unSlotNo = 1}, headerHash = "", blockNo = BlockNo {unBlockNo = 1}}) Binary: 0404000000000000000100000000000000000000000000000001 Show: MsgSucceed (BlockHeader {slotNo = SlotNo {unSlotNo = 1}, headerHash = "61", blockNo = BlockNo {unBlockNo = 1}}) Binary: 040400000000000000010000000000000001610000000000000001 +Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = ""},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 0405000000000000000001000000000000000000000000000000000000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = "a"},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 040500000000000000000100000000000000000000000000000001610000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "61", tokenName = ""},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 040500000000000000000100000000000000016100000000000000000000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList []}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 0405000000000000000000000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 Show: MsgSucceed (ContractCreated BabbageEraOnwardsBabbage(ContractCreatedInEra {contractId = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, rolesCurrency = "", metadata = MarloweTransactionMetadata {marloweMetadata = Just (MarloweMetadata {tags = fromList [("",Just (MetadataBytes ""))], continuations = Nothing}), transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}, marloweScriptHash = "", marloweScriptAddress = "", payoutScriptHash = "", payoutScriptAddress = "", version = MarloweV1, datum = MarloweData {marloweParams = MarloweParams {rolesCurrency = }, marloweState = State {accounts = Map {unMap = []}, choices = Map {unMap = []}, boundValues = Map {unMap = []}, minTime = POSIXTime {getPOSIXTime = 1}}, marloweContract = Close}, assets = Assets {ada = Lovelace {unLovelace = 1}, tokens = Tokens {unTokens = fromList []}}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone, safetyErrors = []})) Binary: 040100000001000000000000000000000100000000000000000000000000000001000000000000061c0100000000000000020200000000020100000000000000010100000000000000020400000000000000000300000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000300000000000000000000000000010400000000000000000000000000000000000000000004010000000000000000010000000000000000010000000000000000030000000001000000000000000000000000000000000000000000010000000000000000000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f60000000000000000 Show: MsgSucceed (ContractCreated BabbageEraOnwardsBabbage(ContractCreatedInEra {contractId = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, rolesCurrency = "", metadata = MarloweTransactionMetadata {marloweMetadata = Just (MarloweMetadata {tags = fromList [("",Just (MetadataBytes "a"))], continuations = Nothing}), transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}, marloweScriptHash = "", marloweScriptAddress = "", payoutScriptHash = "", payoutScriptAddress = "", version = MarloweV1, datum = MarloweData {marloweParams = MarloweParams {rolesCurrency = }, marloweState = State {accounts = Map {unMap = []}, choices = Map {unMap = []}, boundValues = Map {unMap = []}, minTime = POSIXTime {getPOSIXTime = 1}}, marloweContract = Close}, assets = Assets {ada = Lovelace {unLovelace = 1}, tokens = Tokens {unTokens = fromList []}}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone, safetyErrors = []})) From acfa8832bb01a40e847be277ed9fe885f04671c8 Mon Sep 17 00:00:00 2001 From: zeme Date: Tue, 26 Mar 2024 14:06:28 +0100 Subject: [PATCH 16/18] add libpq to static build and postgres to build tools --- nix/outputs.nix | 6 ++---- nix/project.nix | 12 +++++++++++- nix/shell.nix | 1 + 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/nix/outputs.nix b/nix/outputs.nix index 4caa993bc7..00ef3e6ab0 100644 --- a/nix/outputs.nix +++ b/nix/outputs.nix @@ -9,10 +9,8 @@ let static = - staticPkgs.marlowe-apps.components.exes - // - staticPkgs.marlowe-cli.components.exes - ; + staticPkgs.marlowe-apps.components.exes // + staticPkgs.marlowe-cli.components.exes; allStatic = pkgs.runCommand "all-statics" { } '' diff --git a/nix/project.nix b/nix/project.nix index 3a8c2111df..c0b8e70520 100644 --- a/nix/project.nix +++ b/nix/project.nix @@ -82,11 +82,19 @@ let marlowe.ghcOptions = [ "-Werror" ]; marlowe-actus.ghcOptions = [ "-Werror" ]; marlowe-contracts.ghcOptions = [ "-Werror" ]; - marlowe-cli.ghcOptions = [ "-Werror" ] ++ lib.optional pkgs.stdenv.hostPlatform.isMusl "-L${static-bzip2.out}/lib"; + + # NOTE this is important or the static builds will fail with: + # Error: pg_config not found + postgresql-libpq.flags."use-pkg-config" = pkgs.stdenv.hostPlatform.isMusl; + # We need to be a bit more careful with setting the static-bzip2 flag here. # We do not want it to end up in the library component of marlowe-apps. marlowe-apps.ghcOptions = [ "-Werror" ] ++ lib.optional pkgs.stdenv.hostPlatform.isMusl "-L${static-bzip2.out}/lib"; marlowe-apps.components.library.ghcOptions = [ "-Werror" ]; + + marlowe-cli.ghcOptions = [ "-Werror" ] ++ + lib.optional pkgs.stdenv.hostPlatform.isMusl "-L${static-bzip2.out}/lib"; + marlowe-chain-sync.ghcOptions = [ "-Werror" ]; marlowe-client.ghcOptions = [ "-Werror" ]; marlowe-integration.ghcOptions = [ "-Werror" ]; @@ -108,3 +116,5 @@ let in project + + diff --git a/nix/shell.nix b/nix/shell.nix index 1e9c343cfc..d6b97f2f39 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -22,6 +22,7 @@ in inputs.marlowe-plutus.packages.marlowe-minting-validator inputs.n2c.packages.skopeo-nix2container + pkgs.z3 pkgs.sqitchPg pkgs.postgresql From e838f7e5dab8d526bb06a2611bf09b7115701e01 Mon Sep 17 00:00:00 2001 From: Nicolas Henin Date: Thu, 28 Mar 2024 15:15:33 +0100 Subject: [PATCH 17/18] fixed integration tests --- .../marlowe-integration-tests.cabal | 6 +- .../Runtime/Integration/ApplyInputs.hs | 32 ++++++- .../Marlowe/Runtime/Integration/Contract.hs | 37 ++++++-- .../Marlowe/Runtime/Integration/Create.hs | 36 ++++++- .../{ => Integration}/IntegrationSpec.hs | 4 +- .../Runtime/Integration/Intersections.hs | 44 ++++++++- .../Runtime/Integration/MarloweQuery.hs | 4 +- .../Marlowe/Runtime/Integration/OpenRoles.hs | 2 +- .../Integration/{Basic.hs => Scenario.hs} | 95 ++++++++++++++++--- .../Runtime/Integration/StandardContract.hs | 19 +++- .../Marlowe/Runtime/Integration/Withdraw.hs | 29 +++++- .../Runtime/Web/Contracts/Contract/Post.hs | 9 +- .../Marlowe/Runtime/{ => Web}/WebSpec.hs | 2 +- .../Marlowe/Runtime/Transaction/Api.hs | 27 ++++-- 14 files changed, 292 insertions(+), 54 deletions(-) rename marlowe-integration-tests/test/Language/Marlowe/Runtime/{ => Integration}/IntegrationSpec.hs (84%) rename marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/{Basic.hs => Scenario.hs} (88%) rename marlowe-integration-tests/test/Language/Marlowe/Runtime/{ => Web}/WebSpec.hs (96%) diff --git a/marlowe-integration-tests/marlowe-integration-tests.cabal b/marlowe-integration-tests/marlowe-integration-tests.cabal index f0373954ab..41125fcb3d 100644 --- a/marlowe-integration-tests/marlowe-integration-tests.cabal +++ b/marlowe-integration-tests/marlowe-integration-tests.cabal @@ -62,16 +62,16 @@ executable marlowe-integration-tests main-is: Spec.hs other-modules: Language.Marlowe.Runtime.Integration.ApplyInputs - Language.Marlowe.Runtime.Integration.Basic Language.Marlowe.Runtime.Integration.Common Language.Marlowe.Runtime.Integration.Contract Language.Marlowe.Runtime.Integration.Create + Language.Marlowe.Runtime.Integration.IntegrationSpec Language.Marlowe.Runtime.Integration.Intersections Language.Marlowe.Runtime.Integration.MarloweQuery Language.Marlowe.Runtime.Integration.OpenRoles + Language.Marlowe.Runtime.Integration.Scenario Language.Marlowe.Runtime.Integration.StandardContract Language.Marlowe.Runtime.Integration.Withdraw - Language.Marlowe.Runtime.IntegrationSpec Language.Marlowe.Runtime.Web.Common Language.Marlowe.Runtime.Web.Contracts.Contract.Get Language.Marlowe.Runtime.Web.Contracts.Contract.Next.Get @@ -83,9 +83,9 @@ executable marlowe-integration-tests Language.Marlowe.Runtime.Web.Contracts.Transactions.Transaction.Post Language.Marlowe.Runtime.Web.Contracts.Transactions.Transaction.Put Language.Marlowe.Runtime.Web.StandardContract + Language.Marlowe.Runtime.Web.WebSpec Language.Marlowe.Runtime.Web.Withdrawal.Post Language.Marlowe.Runtime.Web.Withdrawal.Put - Language.Marlowe.Runtime.WebSpec build-depends: , aeson diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/ApplyInputs.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/ApplyInputs.hs index b6596a3f52..8384bf3012 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/ApplyInputs.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/ApplyInputs.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -module Language.Marlowe.Runtime.Integration.ApplyInputs where +module Language.Marlowe.Runtime.Integration.ApplyInputs (spec, utcTimeToPOSIXTime) where import Cardano.Api ( BabbageEraOnwards (BabbageEraOnwardsBabbage), @@ -25,7 +25,19 @@ import Data.Time (UTCTime, addUTCTime, getCurrentTime, secondsToNominalDiffTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Language.Marlowe.Core.V1.Semantics (MarloweData (..)) import qualified Language.Marlowe.Core.V1.Semantics as Semantics -import Language.Marlowe.Core.V1.Semantics.Types hiding (TokenName) +import Language.Marlowe.Core.V1.Semantics.Types ( + Action (Choice, Deposit, Notify), + Bound (Bound), + Case (Case, MerkleizedCase), + ChoiceId (ChoiceId), + Contract (Close, If, Pay, When), + Input (MerkleizedInput, NormalInput), + InputContent (IChoice, IDeposit, INotify), + Observation (FalseObs, TrueObs), + Party (Address, Role), + Payee (Account, Party), + Value (Constant), + ) import qualified Language.Marlowe.Core.V1.Semantics.Types as Types import qualified Language.Marlowe.Core.V1.Semantics.Types.Address as Address import Language.Marlowe.Extended.V1 (ada) @@ -36,7 +48,21 @@ import Language.Marlowe.Runtime.Cardano.Api ( ) import Language.Marlowe.Runtime.ChainSync.Api (AssetId (AssetId), Assets (Assets), TokenName, TxOutRef (..)) import Language.Marlowe.Runtime.Client (applyInputs, createContract) -import Language.Marlowe.Runtime.Core.Api hiding (Contract) +import Language.Marlowe.Runtime.Core.Api ( + ContractId, + MarloweVersion (MarloweV1), + MarloweVersionTag (V1), + Payout (Payout), + TransactionOutput (payouts, scriptOutput), + TransactionScriptOutput ( + TransactionScriptOutput, + address, + assets, + datum, + utxo + ), + emptyMarloweTransactionMetadata, + ) import Language.Marlowe.Runtime.Integration.Common ( Integration, Wallet (..), diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Contract.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Contract.hs index 6e6dae342d..c3c20c4b83 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Contract.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Contract.hs @@ -4,13 +4,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Language.Marlowe.Runtime.Integration.Contract where +module Language.Marlowe.Runtime.Integration.Contract (spec) where import Cardano.Api (ScriptData (ScriptDataBytes), hashScriptDataBytes, unsafeHashableScriptData) import Colog (HasLog (..), LogAction, Message) import Control.Applicative (Applicative (..)) import Control.Arrow (Arrow (..), returnA) -import Control.Concurrent.Component +import Control.Concurrent.Component (Component (unComponent)) import Control.Monad (foldM, unless) import Control.Monad.Event.Class (Inject (..), NoopEventT (runNoopEventT)) import Control.Monad.Reader (ReaderT, ask, runReaderT) @@ -25,7 +25,16 @@ import qualified Data.Set as Set import Language.Marlowe.Core.V1.Merkle (deepMerkleize) import Language.Marlowe.Core.V1.Plate (extractAll) import Language.Marlowe.Core.V1.Semantics (TransactionInput (..), TransactionOutput (..), computeTransaction) -import Language.Marlowe.Core.V1.Semantics.Types +import Language.Marlowe.Core.V1.Semantics.Types ( + Action (Notify), + Case (..), + Contract (Close, When), + Environment (Environment), + Input (NormalInput), + Observation (FalseObs), + State (..), + TimeInterval, + ) import Language.Marlowe.Object.Gen () import Language.Marlowe.Object.Link (LinkedObject (LinkedContract), linkBundle', unlink) import Language.Marlowe.Object.Types ( @@ -36,7 +45,18 @@ import Language.Marlowe.Object.Types ( fromCoreContract, ) import Language.Marlowe.Protocol.BulkSync.Client (serveMarloweBulkSyncClient) -import Language.Marlowe.Protocol.BulkSync.Server +import Language.Marlowe.Protocol.BulkSync.Server ( + MarloweBulkSyncServer (MarloweBulkSyncServer), + ServerStIdle ( + ServerStIdle, + recvMsgDone, + recvMsgIntersect, + recvMsgRequestNext + ), + ServerStIntersect (SendMsgIntersectNotFound), + ServerStNext (SendMsgWait), + ServerStPoll (ServerStPoll, recvMsgCancel, recvMsgPoll), + ) import Language.Marlowe.Protocol.Load.Client (MarloweLoadClient, pushContract, serveMarloweLoadClient) import Language.Marlowe.Protocol.Transfer.Client ( MarloweTransferClient (..), @@ -62,7 +82,12 @@ import qualified Language.Marlowe.Runtime.Contract as Contract import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency (adjacency), merkleizeInputs) import qualified Language.Marlowe.Runtime.Contract.Api as Api import Language.Marlowe.Runtime.Contract.Store.File (ContractStoreOptions (..), createContractStore) -import Network.Protocol.Connection +import Network.Protocol.Connection ( + Connector, + ServerSource (ServerSource), + directConnector, + runConnector, + ) import Network.Protocol.Driver.Trace (HasSpanContext (..)) import Network.Protocol.Peer.Trace (defaultSpanContext) import Network.Protocol.Query.Client (QueryClient, serveQueryClient) @@ -74,7 +99,7 @@ import qualified Pipes.Prelude as P import qualified PlutusLedgerApi.V2 as PV2 import Spec.Marlowe.Semantics.Arbitrary (arbitraryNonnegativeInteger) import Spec.Marlowe.Semantics.Path (genContractPath, getContract, getInputs) -import Test.Hspec +import Test.Hspec (Spec, describe, it, parallel, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.Integration.Marlowe (createWorkspace, resolveWorkspacePath) import Test.QuickCheck (Gen, chooseInt, counterexample, forAll) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Create.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Create.hs index 320f76e162..a2e887087b 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Create.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Create.hs @@ -54,7 +54,13 @@ import Language.Marlowe.Runtime.ChainSync.Api ( stakeReference, ) import Language.Marlowe.Runtime.Client (runMarloweTxClient) -import Language.Marlowe.Runtime.Core.Api +import Language.Marlowe.Runtime.Core.Api ( + MarloweMetadata (..), + MarloweTransactionMetadata (..), + MarloweVersion (MarloweV1), + MarloweVersionTag (V1), + encodeMarloweMetadata, + ) import Language.Marlowe.Runtime.Integration.Common ( Wallet (..), allocateWallet, @@ -63,11 +69,35 @@ import Language.Marlowe.Runtime.Integration.Common ( runIntegrationTest, submitBuilder, ) -import Language.Marlowe.Runtime.Transaction.Api +import Language.Marlowe.Runtime.Transaction.Api ( + ContractCreated (..), + ContractCreatedInEra (..), + CreateError, + Destination (ToAddress), + MarloweTxCommand (Create), + RoleTokenMetadata (..), + RoleTokensConfig (..), + WalletAddresses (changeAddress, collateralUtxos), + encodeRoleTokenMetadata, + mkMint, + ) import Network.Protocol.Codec.Spec (varyAp) import Network.Protocol.Job.Client (liftCommand) import Network.URI (parseURI) -import Test.Hspec +import Test.Hspec ( + ActionWith, + Spec, + SpecWith, + aroundAll, + aroundAllWith, + describe, + expectationFailure, + it, + parallel, + pending, + shouldBe, + shouldContain, + ) import Test.Integration.Marlowe (MarloweRuntime (..), withLocalMarloweRuntime) spec :: Spec diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/IntegrationSpec.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/IntegrationSpec.hs similarity index 84% rename from marlowe-integration-tests/test/Language/Marlowe/Runtime/IntegrationSpec.hs rename to marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/IntegrationSpec.hs index 1828692c92..1b3624979a 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/IntegrationSpec.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/IntegrationSpec.hs @@ -1,12 +1,12 @@ -module Language.Marlowe.Runtime.IntegrationSpec where +module Language.Marlowe.Runtime.Integration.IntegrationSpec (spec) where import qualified Language.Marlowe.Runtime.Integration.ApplyInputs as Apply -import qualified Language.Marlowe.Runtime.Integration.Basic as Basic import qualified Language.Marlowe.Runtime.Integration.Contract as Contract import qualified Language.Marlowe.Runtime.Integration.Create as Create import qualified Language.Marlowe.Runtime.Integration.Intersections as Integrations import qualified Language.Marlowe.Runtime.Integration.MarloweQuery as MarloweQuery import qualified Language.Marlowe.Runtime.Integration.OpenRoles as OpenRoles +import qualified Language.Marlowe.Runtime.Integration.Scenario as Basic import qualified Language.Marlowe.Runtime.Integration.Withdraw as Withdraw import Test.Hspec (Spec, describe) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs index f9e27d2788..627d355c64 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs @@ -9,8 +9,48 @@ import Cardano.Api (getTxId) import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, TxId, TxOutRef (..)) import Language.Marlowe.Runtime.Core.Api (ContractId (..)) -import Language.Marlowe.Runtime.Integration.Common -import Language.Marlowe.Runtime.Integration.StandardContract +import Language.Marlowe.Runtime.Integration.Common ( + Integration, + getGenesisWallet, + getTip, + headerSyncIntersectExpectFound, + headerSyncIntersectExpectNotFound, + marloweSyncIntersectExpectFound, + marloweSyncIntersectExpectNotFound, + runIntegrationTest, + ) +import Language.Marlowe.Runtime.Integration.StandardContract ( + StandardContractChoiceMade ( + StandardContractChoiceMade, + choiceBlock, + gimmeTheMoneyChosen, + sendNotify + ), + StandardContractClosed ( + StandardContractClosed, + burnPartyARoleTokenByAny, + burnPartyARoleTokenByContractId, + burnPartyARoleTokenByPolicyId, + returnDepositBlock, + returnDeposited, + rolesCurrency, + withdrawPartyAFunds + ), + StandardContractFundsDeposited ( + StandardContractFundsDeposited, + chooseGimmeTheMoney, + initialDepositBlock, + initialFundsDeposited + ), + StandardContractInit (..), + StandardContractNotified ( + StandardContractNotified, + makeReturnDeposit, + notified, + notifiedBlock + ), + createStandardContract, + ) import Language.Marlowe.Runtime.Transaction.Api ( ContractCreated (..), ContractCreatedInEra (..), diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs index 4ccf8f9288..4cfe3a229b 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs @@ -55,13 +55,13 @@ import Language.Marlowe.Runtime.Core.Api ( import qualified Language.Marlowe.Runtime.Core.Api as Core import Language.Marlowe.Runtime.Discovery.Api (ContractHeader) import Language.Marlowe.Runtime.History.Api (MarloweBlock (..), MarloweWithdrawTransaction (..)) -import Language.Marlowe.Runtime.Integration.Basic ( +import Language.Marlowe.Runtime.Integration.Common +import Language.Marlowe.Runtime.Integration.Scenario ( contractCreatedToMarloweCreateTransaction, contractCreatedToUnspentContractOutput, inputsAppliedToMarloweApplyInputsTransaction, inputsAppliedToUnspentContractOutput, ) -import Language.Marlowe.Runtime.Integration.Common import Language.Marlowe.Runtime.Integration.StandardContract import Language.Marlowe.Runtime.Transaction.Api ( ContractCreated (..), diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/OpenRoles.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/OpenRoles.hs index c4be3cefea..a6548769ce 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/OpenRoles.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/OpenRoles.hs @@ -1,7 +1,7 @@ module Language.Marlowe.Runtime.Integration.OpenRoles where import Language.Marlowe.Runtime.Core.ScriptRegistry (HelperScript (OpenRoleScript)) -import Language.Marlowe.Runtime.Integration.Basic (basicScenarioWithCreator) +import Language.Marlowe.Runtime.Integration.Scenario (basicScenarioWithCreator) import Language.Marlowe.Runtime.Integration.StandardContract (createStandardContractWithRolesConfig) import Language.Marlowe.Runtime.Transaction.Api ( Destination (..), diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs similarity index 88% rename from marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs rename to marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs index a272070ab9..a7f555fb7f 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Basic.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs @@ -4,11 +4,19 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RankNTypes #-} -module Language.Marlowe.Runtime.Integration.Basic where +module Language.Marlowe.Runtime.Integration.Scenario ( + spec, + basicScenarioWithCreator, + contractCreatedToMarloweCreateTransaction, + contractCreatedToUnspentContractOutput, + inputsAppliedToMarloweApplyInputsTransaction, + inputsAppliedToUnspentContractOutput, +) where import Cardano.Api (getTxId) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Functor (void) +import Data.Map (keys) import qualified Data.Map as Map import Data.Maybe (fromJust) import Data.Time (addUTCTime, getCurrentTime, secondsToNominalDiffTime) @@ -55,8 +63,49 @@ import Language.Marlowe.Runtime.History.Api ( UnspentContractOutput (..), ) import Language.Marlowe.Runtime.Integration.ApplyInputs (utcTimeToPOSIXTime) -import Language.Marlowe.Runtime.Integration.Common -import Language.Marlowe.Runtime.Integration.StandardContract +import Language.Marlowe.Runtime.Integration.Common ( + Integration, + Wallet (addresses), + bulkSyncPollExpectRollForward, + bulkSyncPollExpectWait, + bulkSyncRequestNextExpectWait, + bulkSyncRequestNextNExpectRollForward, + choose, + contractCreatedToContractHeader, + contractCreatedToCreateStep, + expectJust, + expectRight, + getGenesisWallet, + headerSyncExpectWait, + headerSyncPollExpectNewHeaders, + headerSyncRequestNextExpectWait, + inputsAppliedToTransaction, + marloweSyncExpectContractFound, + marloweSyncPollExpectRollForward, + marloweSyncPollExpectWait, + marloweSyncRequestNextExpectRollForward, + marloweSyncRequestNextExpectWait, + runIntegrationTest, + submit, + ) +import Language.Marlowe.Runtime.Integration.StandardContract ( + StandardContractChoiceMade ( + StandardContractChoiceMade, + choiceBlock, + gimmeTheMoneyChosen, + sendNotify + ), + StandardContractClosed (..), + StandardContractFundsDeposited (..), + StandardContractInit (..), + StandardContractNotified ( + StandardContractNotified, + makeReturnDeposit, + notified, + notifiedBlock + ), + createStandardContract, + ) import Language.Marlowe.Runtime.Transaction.Api ( BurnTx (..), BurnTxInEra (..), @@ -72,7 +121,7 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) spec :: Spec -spec = describe "Basic scenarios" do +spec = describe "Scenarios" do basicScenarioWithCreator createStandardContract it "Basic e2e scenario - bulk sync" $ withLocalMarloweRuntime $ runIntegrationTest do partyAWallet <- getGenesisWallet 0 @@ -131,6 +180,27 @@ spec = describe "Basic scenarios" do -- 9. Poll -- 10. Expect roll forward bulkSyncPollExpectRollForward [expectedBlock] $ + -- i1. Request next + -- 12. Expect wait, poll, expect wait + + -- i1. Request next + -- 12. Expect wait, poll, expect wait + + -- i1. Request next + -- 12. Expect wait, poll, expect wait + + -- i1. Request next + -- 12. Expect wait, poll, expect wait + + -- i1. Request next + -- 12. Expect wait, poll, expect wait + + -- i1. Request next + -- 12. Expect wait, poll, expect wait + + -- i1. Request next + -- 12. Expect wait, poll, expect wait + -- i1. Request next -- 12. Expect wait, poll, expect wait pure $ @@ -257,7 +327,7 @@ spec = describe "Basic scenarios" do applied.inputs `shouldBe` [NormalInput $ IChoice (ChoiceId "Option A" $ Role "") 1] basicScenarioWithCreator :: (Wallet -> Wallet -> Integration (StandardContractInit 'V1)) -> Spec -basicScenarioWithCreator createStandardContractArg = do +basicScenarioWithCreator createStandardContractArg = it "Basic e2e scenario" $ withLocalMarloweRuntime $ runIntegrationTest do partyAWallet <- getGenesisWallet 0 partyBWallet <- getGenesisWallet 1 @@ -355,15 +425,12 @@ basicScenarioWithCreator createStandardContractArg = do pure $ marloweSyncRequestNextExpectWait $ pure $ MarloweSync.SendMsgCancel $ MarloweSync.SendMsgDone closed StandardContractClosed{..} <- startDiscoveryClient - -- 37. Burn role tokens - BurnTx era BurnTxInEra{burnedTokens = burnedByToken, txBody} <- burnPartyARoleTokenByToken - BurnTx _ BurnTxInEra{burnedTokens = burnedByContractId} <- burnPartyARoleTokenByContractId - BurnTx _ BurnTxInEra{burnedTokens = burnedByPolicyId} <- burnPartyARoleTokenByPolicyId - BurnTx _ BurnTxInEra{burnedTokens = burnedByAny} <- burnPartyARoleTokenByAny - liftIO $ burnedByToken `shouldBe` Tokens (Map.singleton (AssetId rolesCurrency "Party A") 1) - liftIO $ burnedByToken `shouldBe` burnedByContractId - liftIO $ burnedByContractId `shouldBe` burnedByPolicyId - liftIO $ burnedByPolicyId `shouldBe` burnedByAny + -- 37. Burn only role token Party A (Could have a Thread token as well) + BurnTx era BurnTxInEra{burnedTokens = Tokens burnedByAssetIdPartyA, txBody} <- burnPartyARoleTokenByAssetIdPartyA + + let onlyPartyARoleToken = [AssetId rolesCurrency "Party A"] + liftIO $ keys burnedByAssetIdPartyA `shouldBe` onlyPartyARoleToken + void $ submit partyAWallet era txBody inputsAppliedToUnspentContractOutput :: ContractCreated 'V1 -> InputsApplied 'V1 -> UnspentContractOutput diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs index 55f22c471d..ae0ea3014b 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs @@ -11,7 +11,17 @@ import qualified Data.Set as Set import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime, secondsToNominalDiffTime) import Data.Time.Clock (nominalDiffTimeToSeconds) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Language.Marlowe.Core.V1.Semantics.Types +import Language.Marlowe.Core.V1.Semantics.Types ( + Action (Choice, Deposit, Notify), + Bound (Bound), + Case (Case), + ChoiceId (ChoiceId), + Contract (Close, Pay, When), + Observation (TrueObs), + Party (..), + Payee (Party), + Value (AvailableMoney, Constant), + ) import Language.Marlowe.Extended.V1 (ada) import Language.Marlowe.Protocol.Load.Client (pushContract) import Language.Marlowe.Protocol.Query.Types (PayoutHeader (..)) @@ -112,7 +122,7 @@ data StandardContractNotified v = StandardContractNotified data StandardContractClosed v = StandardContractClosed { withdrawPartyAFunds :: Integration (WithdrawTx v, BlockHeader) , rolesCurrency :: PolicyId - , burnPartyARoleTokenByToken :: Integration BurnTx + , burnPartyARoleTokenByAssetIdPartyA :: Integration BurnTx , burnPartyARoleTokenByContractId :: Integration BurnTx , burnPartyARoleTokenByPolicyId :: Integration BurnTx , burnPartyARoleTokenByAny :: Integration BurnTx @@ -140,7 +150,8 @@ createStandardContractWithRolesConfig -> Wallet -> Wallet -> Integration (StandardContractInit 'V1) -createStandardContractWithRolesConfig threadName rolesConfig = createStandardContractWithTagsAndRolesConfig threadName rolesConfig mempty +createStandardContractWithRolesConfig threadName rolesConfig = + createStandardContractWithTagsAndRolesConfig threadName rolesConfig mempty createStandardContractWithTagsAndRolesConfig :: Maybe Chain.TokenName @@ -243,7 +254,7 @@ createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAW withdrawTx@(WithdrawTx era5 WithdrawTxInEra{txBody = withdrawTxBody}) <- withdraw partyAWallet $ Map.keysSet $ payouts output (withdrawTx,) <$> submit partyAWallet era5 withdrawTxBody - , burnPartyARoleTokenByToken = + , burnPartyARoleTokenByAssetIdPartyA = mkBurn $ RoleTokenFilterByTokens $ Set.singleton $ AssetId rolesCurrency "Party A" , burnPartyARoleTokenByContractId = mkBurn $ RoleTokenFilterByContracts $ Set.singleton contractId diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs index ba7dd998f5..820b29336a 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -module Language.Marlowe.Runtime.Integration.Withdraw where +module Language.Marlowe.Runtime.Integration.Withdraw (spec) where import Cardano.Api (BabbageEraOnwards (..), getTxId) import Control.Arrow ((&&&)) @@ -28,7 +28,23 @@ import Language.Marlowe.Runtime.Integration.Common ( getGenesisWallet, runIntegrationTest, ) -import Language.Marlowe.Runtime.Integration.StandardContract +import Language.Marlowe.Runtime.Integration.StandardContract ( + StandardContractChoiceMade (sendNotify), + StandardContractClosed ( + StandardContractClosed, + returnDeposited, + withdrawPartyAFunds + ), + StandardContractFundsDeposited (chooseGimmeTheMoney), + StandardContractInit ( + StandardContractInit, + contractCreated, + createdBlock, + makeInitialDeposit + ), + StandardContractNotified (makeReturnDeposit), + createStandardContract, + ) import Language.Marlowe.Runtime.Transaction.Api ( ConstraintError (..), ContractCreated (..), @@ -40,7 +56,14 @@ import Language.Marlowe.Runtime.Transaction.Api ( WithdrawTx (WithdrawTx), WithdrawTxInEra (..), ) -import Test.Hspec +import Test.Hspec ( + ActionWith, + Spec, + aroundAll, + describe, + it, + shouldBe, + ) import Test.Integration.Marlowe.Local (MarloweRuntime, withLocalMarloweRuntime) spec :: Spec diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs index ba0f49f34c..ca6924e2d5 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs @@ -45,7 +45,14 @@ import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..)) import qualified Language.Marlowe.Runtime.Web.Contract.API as Web import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web -import Language.Marlowe.Runtime.Web.Tx.API +import Language.Marlowe.Runtime.Web.Tx.API ( + CreateTxEnvelope ( + CreateTxEnvelope, + contractId, + safetyErrors, + txEnvelope + ), + ) import Network.URI (parseURI) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/WebSpec.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs similarity index 96% rename from marlowe-integration-tests/test/Language/Marlowe/Runtime/WebSpec.hs rename to marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs index c6f1052c2d..ac96f00f30 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/WebSpec.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs @@ -1,4 +1,4 @@ -module Language.Marlowe.Runtime.WebSpec where +module Language.Marlowe.Runtime.Web.WebSpec where import qualified Language.Marlowe.Runtime.Web.Contracts.Get as Contracts.Get diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index 49558a6d5a..0f425e5a7a 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -854,15 +854,24 @@ data BurnError deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary, ToJSON, Variations) -data RoleTokenFilter' c p t - = RoleTokensOr (RoleTokenFilter' c p t) (RoleTokenFilter' c p t) - | RoleTokensAnd (RoleTokenFilter' c p t) (RoleTokenFilter' c p t) - | RoleTokensNot (RoleTokenFilter' c p t) - | RoleTokenFilterAny - | RoleTokenFilterNone - | RoleTokenFilterByContracts (Set c) - | RoleTokenFilterByPolicyIds (Set p) - | RoleTokenFilterByTokens (Set t) +-- | Represents different filters for role tokens. +data RoleTokenFilter' contract policyId token + = -- | Represents a filter that matches if either of the two sub-filters match. + RoleTokensOr (RoleTokenFilter' contract policyId token) (RoleTokenFilter' contract policyId token) + | -- | Represents a filter that matches if both of the two sub-filters match. + RoleTokensAnd (RoleTokenFilter' contract policyId token) (RoleTokenFilter' contract policyId token) + | -- | Represents a filter that matches if the sub-filter does not match. + RoleTokensNot (RoleTokenFilter' contract policyId token) + | -- | Represents a filter that matches any role token. + RoleTokenFilterAny + | -- | Represents a filter that matches no role tokens. + RoleTokenFilterNone + | -- | Represents a filter that matches role tokens based on a set of contracts. + RoleTokenFilterByContracts (Set contract) + | -- | Represents a filter that matches role tokens based on a set of policy IDs. + RoleTokenFilterByPolicyIds (Set policyId) + | -- | Represents a filter that matches role tokens based on a set of tokens. + RoleTokenFilterByTokens (Set token) deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary) From 9df612d7ecacf6d4b4ce5b5eb98f8c1f764e0762 Mon Sep 17 00:00:00 2001 From: Nicolas Henin Date: Wed, 3 Apr 2024 15:50:25 +0200 Subject: [PATCH 18/18] added Role Web API/Server/Client + integration tests --- .../src/Control/Monad/Trans/Marlowe/Class.hs | 46 +- .../src/Language/Marlowe/Runtime/Client.hs | 2 +- .../Marlowe/Runtime/Client/Transfer.hs | 33 +- .../Marlowe/Runtime/Integration/Common.hs | 81 ++- .../Runtime/Integration/Intersections.hs | 6 +- .../Runtime/Integration/MarloweQuery.hs | 16 +- .../Marlowe/Runtime/Integration/Scenario.hs | 23 +- .../Runtime/Integration/StandardContract.hs | 56 +- .../Marlowe/Runtime/Integration/Withdraw.hs | 10 +- .../Language/Marlowe/Runtime/Web/Common.hs | 31 +- .../Runtime/Web/Contracts/Transactions/Get.hs | 9 +- .../Contracts/Transactions/Transaction/Get.hs | 7 +- .../Transactions/Transaction/Post.hs | 3 +- .../Contracts/Transactions/Transaction/Put.hs | 6 +- .../Marlowe/Runtime/Web/StandardContract.hs | 117 +++- .../Language/Marlowe/Runtime/Web/WebSpec.hs | 1 - .../Marlowe/Runtime/Web/Withdrawal/Post.hs | 4 +- .../Marlowe/Runtime/Web/Withdrawal/Put.hs | 36 +- marlowe-runtime-web/.golden/OpenApi/golden | 517 ++++++++++++++++++ marlowe-runtime-web/marlowe-runtime-web.cabal | 6 +- .../Marlowe/Runtime/Web/RuntimeServer.hs | 61 ++- .../src/Language/Marlowe/Runtime/Web/API.hs | 28 +- .../Runtime/Web/Adapter/Server/Monad.hs | 89 ++- .../Runtime/Web/Adapter/Server/SyncClient.hs | 39 +- .../Runtime/Web/Adapter/Server/TxClient.hs | 59 +- .../Language/Marlowe/Runtime/Web/Burn/API.hs | 42 -- .../Language/Marlowe/Runtime/Web/Client.hs | 165 +----- .../Marlowe/Runtime/Web/Contract/API.hs | 10 +- .../Marlowe/Runtime/Web/Contract/Server.hs | 2 +- .../Runtime/Web/Contract/Transaction/API.hs | 3 +- .../Web/Contract/Transaction/Client.hs | 221 ++++++++ .../Web/Contract/Transaction/Server.hs | 102 ++-- .../Marlowe/Runtime/Web/Core/Roles.hs | 137 +---- .../Language/Marlowe/Runtime/Web/Core/Tx.hs | 5 + .../Language/Marlowe/Runtime/Web/Role/API.hs | 181 ++++++ .../Marlowe/Runtime/Web/Role/Client.hs | 162 ++++++ .../Marlowe/Runtime/Web/Role/Server.hs | 174 ++++++ .../Marlowe/Runtime/Web/Role/TokenFilter.hs | 206 +++++++ .../Language/Marlowe/Runtime/Web/Server.hs | 8 +- .../Language/Marlowe/Runtime/Web/Tx/API.hs | 2 - .../Marlowe/Runtime/Web/Withdrawal/Server.hs | 15 +- marlowe-runtime-web/test/Spec.hs | 21 + .../.golden/Job MarloweTxCommand/golden | 234 ++++---- .../Marlowe/Runtime/Transaction/Gen.hs | 65 +-- .../Marlowe/Runtime/Transaction/Api.hs | 216 ++++---- .../Language/Marlowe/Runtime/Transaction.hs | 44 +- .../Marlowe/Runtime/Transaction/Burn.hs | 12 +- .../Marlowe/Runtime/Transaction/Server.hs | 22 +- nix/marlowe-cardano/compose.nix | 2 +- 49 files changed, 2479 insertions(+), 858 deletions(-) delete mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Client.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/API.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Client.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Server.hs create mode 100644 marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/TokenFilter.hs diff --git a/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs b/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs index fb0a97bde1..2458d08b81 100644 --- a/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs +++ b/marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs @@ -2,13 +2,37 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -module Control.Monad.Trans.Marlowe.Class where +module Control.Monad.Trans.Marlowe.Class ( + MonadMarlowe (..), + runClientStreaming, + runMarloweSyncClient, + runMarloweHeaderSyncClient, + runMarloweBulkSyncClient, + runMarloweQueryClient, + runContractQueryClient, + runMarloweLoadClient, + runMarloweTransferClient, + runMarloweTxClient, + loadContract, + createContract, + applyInputs, + applyInputs', + withdraw, + buildBurnRoleTokensTx, + submitAndWait, + submitAndDetach, + submit, + attachSubmit, +) where import Cardano.Api (BabbageEraOnwards, Tx) import Control.Concurrent (threadDelay) import Control.Monad (join) import Control.Monad.Identity (IdentityT (..)) -import Control.Monad.Trans.Marlowe +import Control.Monad.Trans.Marlowe ( + MarloweT (MarloweT), + runMarloweT, + ) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.Resource.Internal (ResourceT (..)) import Data.Coerce (coerce) @@ -48,8 +72,8 @@ import Language.Marlowe.Runtime.Core.Api ( import Language.Marlowe.Runtime.Transaction.Api ( Account, ApplyInputsError, - BurnError, - BurnTx, + BurnRoleTokensError, + BurnRoleTokensTx, ContractCreated, CreateError, InputsApplied, @@ -310,16 +334,18 @@ withdraw withdraw version wallet payouts = runMarloweTxClient $ liftCommand $ Withdraw version wallet payouts --- | Withdraw funds that have been paid out to a role in a contract. -burn +-- | Burn role tokens. +buildBurnRoleTokensTx :: (MonadMarlowe m) - => WalletAddresses + => MarloweVersion v + -- ^ The Marlowe version to use + -> WalletAddresses -- ^ The wallet addresses to use when constructing the transaction. -> RoleTokenFilter -- ^ A filter that identifies which role tokens to burn. - -> m (Either BurnError BurnTx) -burn wallet tFilter = - runMarloweTxClient $ liftCommand $ Burn wallet tFilter + -> m (Either BurnRoleTokensError (BurnRoleTokensTx v)) +buildBurnRoleTokensTx version wallet tFilter = + runMarloweTxClient $ liftCommand $ BurnRoleTokens version wallet tFilter -- | Submit a signed transaction via the Marlowe Runtime. Waits for completion -- with exponential back-off in the polling. diff --git a/marlowe-client/src/Language/Marlowe/Runtime/Client.hs b/marlowe-client/src/Language/Marlowe/Runtime/Client.hs index 6a890b1f59..07fc9abc8e 100644 --- a/marlowe-client/src/Language/Marlowe/Runtime/Client.hs +++ b/marlowe-client/src/Language/Marlowe/Runtime/Client.hs @@ -9,7 +9,7 @@ module Language.Marlowe.Runtime.Client ( connectToMarloweRuntimeTraced, ) where -import Control.Monad.Event.Class +import Control.Monad.Event.Class (MonadEvent) import Control.Monad.Trans.Marlowe import Control.Monad.Trans.Marlowe.Class import Language.Marlowe.Protocol.Client (marloweRuntimeClientPeer) diff --git a/marlowe-client/src/Language/Marlowe/Runtime/Client/Transfer.hs b/marlowe-client/src/Language/Marlowe/Runtime/Client/Transfer.hs index 6cabb96595..144eed5afa 100644 --- a/marlowe-client/src/Language/Marlowe/Runtime/Client/Transfer.hs +++ b/marlowe-client/src/Language/Marlowe/Runtime/Client/Transfer.hs @@ -8,9 +8,36 @@ module Language.Marlowe.Runtime.Client.Transfer ( ) where import Data.Map (Map) -import Language.Marlowe.Object.Types -import Language.Marlowe.Protocol.Transfer.Client -import Language.Marlowe.Protocol.Transfer.Types +import Language.Marlowe.Object.Types ( + Label, + ObjectBundle (ObjectBundle), + ) +import Language.Marlowe.Protocol.Transfer.Client ( + ClientStCanDownload (SendMsgDownload), + ClientStCanUpload (SendMsgImported, SendMsgUpload), + ClientStDownload ( + ClientStDownload, + recvMsgDownloaded, + recvMsgExported + ), + ClientStExport ( + ClientStExport, + recvMsgContractNotFound, + recvMsgStartExport + ), + ClientStIdle ( + SendMsgDone, + SendMsgRequestExport, + SendMsgStartImport + ), + ClientStUpload ( + ClientStUpload, + recvMsgUploadFailed, + recvMsgUploaded + ), + MarloweTransferClient (MarloweTransferClient), + ) +import Language.Marlowe.Protocol.Transfer.Types (ImportError) import Language.Marlowe.Runtime.ChainSync.Api (DatumHash) import Numeric.Natural (Natural) import Pipes (Pipe, Producer, await, yield) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs index 627ba41382..c0d988d0f9 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs @@ -4,7 +4,59 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} -module Language.Marlowe.Runtime.Integration.Common where +module Language.Marlowe.Runtime.Integration.Common ( + allocateWallet, + contractCreatedToContractHeader, + marloweSyncRequestNextExpectWait, + contractCreatedToCreateStep, + expectLeft, + expectJust, + expectRight, + getGenesisWallet, + getStakeCredential, + getTip, + getUTxO, + inputsAppliedToTransaction, + retryDelayMicroSeconds, + runIntegrationTest, + submitBuilder, + submit', + testnet, + timeout, + Wallet (..), + withCurrentEra, + withdraw, + notify, + buildBurnRoleTokensTx, + choose, + deposit, + submit, + bulkSyncRequestNextNExpectRollForward, + bulkSyncRequestNextExpectRollForward, + bulkSyncPollExpectWait, + bulkSyncRequestNextExpectWait, + headerSyncRequestNextExpectWait, + headerSyncPollExpectNewHeaders, + headerSyncRequestNextExpectNewHeaders, + headerSyncPollExpectWait, + headerSyncExpectWait, + Integration, + bulkSyncPollExpectRollForward, + marloweSyncExpectContractFound, + marloweSyncExpectRollForward, + headerSyncIntersectExpectNotFound, + headerSyncIntersectExpectFound, + marloweSyncIntersectExpectNotFound, + marloweSyncIntersectExpectFound, + marloweSyncPollExpectRollForward, + marloweSyncPollExpectWait, + marloweSyncRequestNextExpectRollForward, + prepareCliArgs, + execMarlowe, + execMarlowe_, + execMarlowe', + runWebClient, +) where import Cardano.Api ( AddressAny (AddressShelley), @@ -40,6 +92,13 @@ import qualified Control.Monad.Reader as Reader import Control.Monad.Reader.Class (asks) import Control.Monad.State (StateT, runStateT, state) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Marlowe (MarloweT, runMarloweT) +import Control.Monad.Trans.Marlowe.Class ( + applyInputs, + runMarloweHeaderSyncClient, + runMarloweSyncClient, + runMarloweTxClient, + ) import Data.Aeson (FromJSON (..), Value (..), decodeFileStrict, eitherDecodeStrict) import Data.Aeson.Types (parseFail) import Data.ByteString (ByteString) @@ -83,14 +142,6 @@ import Language.Marlowe.Runtime.ChainSync.Api ( fromBech32, ) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain -import Language.Marlowe.Runtime.Client ( - MarloweT, - applyInputs, - runMarloweHeaderSyncClient, - runMarloweSyncClient, - runMarloweT, - runMarloweTxClient, - ) import qualified Language.Marlowe.Runtime.Client as Client import Language.Marlowe.Runtime.Core.Api ( ContractId (..), @@ -104,7 +155,7 @@ import Language.Marlowe.Runtime.Core.Api ( import Language.Marlowe.Runtime.Discovery.Api (ContractHeader (..)) import Language.Marlowe.Runtime.History.Api (ContractStep, CreateStep (..), MarloweBlock) import Language.Marlowe.Runtime.Transaction.Api ( - BurnTx, + BurnRoleTokensTx, ContractCreated (..), ContractCreatedInEra (..), InputsApplied (..), @@ -424,13 +475,13 @@ withdraw Wallet{..} payouts = do result <- Client.withdraw MarloweV1 addresses payouts expectRight "Failed to create withdraw transaction" result -burn +buildBurnRoleTokensTx :: Wallet -> RoleTokenFilter - -> Integration BurnTx -burn Wallet{..} tokenFilter = do - result <- Client.burn addresses tokenFilter - expectRight "Failed to create burn transaction" result + -> Integration (BurnRoleTokensTx 'V1) +buildBurnRoleTokensTx Wallet{..} tokenFilter = do + result <- Client.buildBurnRoleTokensTx MarloweV1 addresses tokenFilter + expectRight "Failed to create burn Role Tokens transaction" result timeout :: NominalDiffTime timeout = secondsToNominalDiffTime 2 diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs index 627d355c64..2e13311d35 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Intersections.hs @@ -42,7 +42,7 @@ import Language.Marlowe.Runtime.Integration.StandardContract ( initialDepositBlock, initialFundsDeposited ), - StandardContractInit (..), + StandardContractLifecycleInit (..), StandardContractNotified ( StandardContractNotified, makeReturnDeposit, @@ -112,8 +112,8 @@ spec = it "Intersections" $ withLocalMarloweRuntime $ runIntegrationTest do marloweSyncIntersectExpectNotFound (ContractId $ TxOutRef txIdA1 1) [pA1, pA2, pA3, pA4, pA5] completeContract - :: StandardContractInit v -> Integration (BlockHeader, TxId, BlockHeader, BlockHeader, BlockHeader, BlockHeader) -completeContract StandardContractInit{..} = do + :: StandardContractLifecycleInit v -> Integration (BlockHeader, TxId, BlockHeader, BlockHeader, BlockHeader, BlockHeader) +completeContract StandardContractLifecycleInit{..} = do StandardContractFundsDeposited{..} <- makeInitialDeposit StandardContractChoiceMade{..} <- chooseGimmeTheMoney StandardContractNotified{..} <- sendNotify diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs index 4cfe3a229b..3a2fe66a10 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/MarloweQuery.hs @@ -330,8 +330,8 @@ payoutContract = \case Payout2 -> Contract2 Payout3 -> Contract3 -standardContractRoleCurrency :: StandardContractInit 'V1 -> PolicyId -standardContractRoleCurrency StandardContractInit{..} = case contractCreated of +standardContractRoleCurrency :: StandardContractLifecycleInit 'V1 -> PolicyId +standardContractRoleCurrency StandardContractLifecycleInit{..} = case contractCreated of ContractCreated _ ContractCreatedInEra{..} -> rolesCurrency data PartyAddress = Wallet1 | Wallet2 @@ -498,7 +498,7 @@ evalTestRoleCurrencyFilter MarloweQueryTestData{..} = go , (Known Contract4, standardContractRoleCurrency' contract4 True) ] -standardContractRoleCurrency' :: StandardContractInit 'V1 -> Bool -> RoleCurrency +standardContractRoleCurrency' :: StandardContractLifecycleInit 'V1 -> Bool -> RoleCurrency standardContractRoleCurrency' contract active = RoleCurrency { rolePolicyId = standardContractRoleCurrency contract @@ -560,24 +560,24 @@ data MarloweQueryTestData = MarloweQueryTestData { runtime :: MarloweRuntime , wallet1 :: Wallet , wallet2 :: Wallet - , contract1 :: StandardContractInit 'V1 + , contract1 :: StandardContractLifecycleInit 'V1 , contract1Step1 :: StandardContractFundsDeposited 'V1 , contract1Step2 :: StandardContractChoiceMade 'V1 , contract1Step3 :: StandardContractNotified 'V1 , contract1Step4 :: StandardContractClosed 'V1 , contract1Step5 :: (WithdrawTx 'V1, BlockHeader) - , contract2 :: StandardContractInit 'V1 + , contract2 :: StandardContractLifecycleInit 'V1 , contract2Step1 :: StandardContractFundsDeposited 'V1 , contract2Step2 :: StandardContractChoiceMade 'V1 , contract2Step3 :: StandardContractNotified 'V1 , contract2Step4 :: StandardContractClosed 'V1 , contract2Step5 :: (WithdrawTx 'V1, BlockHeader) - , contract3 :: StandardContractInit 'V1 + , contract3 :: StandardContractLifecycleInit 'V1 , contract3Step1 :: StandardContractFundsDeposited 'V1 , contract3Step2 :: StandardContractChoiceMade 'V1 , contract3Step3 :: StandardContractNotified 'V1 , contract3Step4 :: StandardContractClosed 'V1 - , contract4 :: StandardContractInit 'V1 + , contract4 :: StandardContractLifecycleInit 'V1 } data TxNo @@ -856,7 +856,7 @@ txNoToTxId testData = inputsAppliedTxId . txNoToInputsApplied testData inputsAppliedTxId :: InputsApplied v -> TxId inputsAppliedTxId (InputsApplied _ InputsAppliedInEra{..}) = fromCardanoTxId $ getTxId txBody -contractNoToStandardContract :: MarloweQueryTestData -> RefSym GetHeaders -> StandardContractInit 'V1 +contractNoToStandardContract :: MarloweQueryTestData -> RefSym GetHeaders -> StandardContractLifecycleInit 'V1 contractNoToStandardContract MarloweQueryTestData{..} = \case Contract1 -> contract1 Contract2 -> contract2 diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs index a7f555fb7f..4f5c5b7232 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Scenario.hs @@ -97,7 +97,7 @@ import Language.Marlowe.Runtime.Integration.StandardContract ( ), StandardContractClosed (..), StandardContractFundsDeposited (..), - StandardContractInit (..), + StandardContractLifecycleInit (..), StandardContractNotified ( StandardContractNotified, makeReturnDeposit, @@ -107,8 +107,8 @@ import Language.Marlowe.Runtime.Integration.StandardContract ( createStandardContract, ) import Language.Marlowe.Runtime.Transaction.Api ( - BurnTx (..), - BurnTxInEra (..), + BurnRoleTokensTx (..), + BurnRoleTokensTxInEra (..), ContractCreated (..), ContractCreatedInEra (..), InputsApplied (..), @@ -135,7 +135,7 @@ spec = describe "Scenarios" do $ bulkSyncRequestNextExpectWait do -- 3. Create standard contract - contract@StandardContractInit{..} <- createStandardContract partyAWallet partyBWallet + contract@StandardContractLifecycleInit{..} <- createStandardContract partyAWallet partyBWallet let expectedBlock = MarloweBlock { blockHeader = createdBlock @@ -160,10 +160,10 @@ spec = describe "Scenarios" do -- pure $ HeaderSync.SendMsgPoll $ headerSyncExpectWait $ pure $ HeaderSync.SendMsgCancel $ HeaderSync.SendMsgDone txOutRef afterDeposit - :: StandardContractInit 'V1 + :: StandardContractLifecycleInit 'V1 -> StandardContractFundsDeposited 'V1 -> Integration (BulkSync.ClientStPoll Integration ()) - afterDeposit StandardContractInit{..} StandardContractFundsDeposited{..} = do + afterDeposit StandardContractLifecycleInit{..} StandardContractFundsDeposited{..} = do ContractCreated _ ContractCreatedInEra{contractId} <- pure contractCreated let expectedBlock = MarloweBlock @@ -326,7 +326,7 @@ spec = describe "Scenarios" do applied.output.scriptOutput `shouldBe` Nothing applied.inputs `shouldBe` [NormalInput $ IChoice (ChoiceId "Option A" $ Role "") 1] -basicScenarioWithCreator :: (Wallet -> Wallet -> Integration (StandardContractInit 'V1)) -> Spec +basicScenarioWithCreator :: (Wallet -> Wallet -> Integration (StandardContractLifecycleInit 'V1)) -> Spec basicScenarioWithCreator createStandardContractArg = it "Basic e2e scenario" $ withLocalMarloweRuntime $ runIntegrationTest do partyAWallet <- getGenesisWallet 0 @@ -340,7 +340,7 @@ basicScenarioWithCreator createStandardContractArg = $ headerSyncRequestNextExpectWait do -- 3. Create standard contract - contract@StandardContractInit{..} <- createStandardContractArg partyAWallet partyBWallet + contract@StandardContractLifecycleInit{..} <- createStandardContractArg partyAWallet partyBWallet -- 4. Poll -- 5. Expect new headers headerSyncPollExpectNewHeaders createdBlock [contractCreatedToContractHeader createdBlock contractCreated] $ @@ -360,10 +360,10 @@ basicScenarioWithCreator createStandardContractArg = -- 9. Start MarloweSyncClient (follow contract) marloweSyncClient - :: StandardContractInit 'V1 + :: StandardContractLifecycleInit 'V1 -> StandardContractFundsDeposited 'V1 -> MarloweSync.MarloweSyncClient Integration (StandardContractClosed 'V1) - marloweSyncClient StandardContractInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do + marloweSyncClient StandardContractLifecycleInit{..} StandardContractFundsDeposited{..} = MarloweSync.MarloweSyncClient do let ContractCreated _ ContractCreatedInEra{contractId} = contractCreated pure $ MarloweSync.SendMsgFollowContract contractId @@ -426,7 +426,8 @@ basicScenarioWithCreator createStandardContractArg = StandardContractClosed{..} <- startDiscoveryClient -- 37. Burn only role token Party A (Could have a Thread token as well) - BurnTx era BurnTxInEra{burnedTokens = Tokens burnedByAssetIdPartyA, txBody} <- burnPartyARoleTokenByAssetIdPartyA + BurnRoleTokensTx era BurnRoleTokensTxInEra{burnedTokens = Tokens burnedByAssetIdPartyA, txBody} <- + burnPartyARoleTokenByAssetIdPartyA let onlyPartyARoleToken = [AssetId rolesCurrency "Party A"] liftIO $ keys burnedByAssetIdPartyA `shouldBe` onlyPartyARoleToken diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs index ae0ea3014b..0b45948255 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/StandardContract.hs @@ -45,7 +45,7 @@ import Language.Marlowe.Runtime.Discovery.Api (ContractHeader) import Language.Marlowe.Runtime.Integration.Common ( Integration, Wallet (..), - burn, + buildBurnRoleTokensTx, choose, contractCreatedToContractHeader, deposit, @@ -57,7 +57,7 @@ import Language.Marlowe.Runtime.Integration.Common ( ) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api ( - BurnTx, + BurnRoleTokensTx, ContractCreated (..), ContractCreatedInEra (..), Destination (ToAddress), @@ -72,20 +72,20 @@ import Language.Marlowe.Runtime.Transaction.Api ( ) import qualified PlutusLedgerApi.V2 as PV2 -data StandardContractInit v = StandardContractInit +data StandardContractLifecycleInit v = StandardContractLifecycleInit { makeInitialDeposit :: Integration (StandardContractFundsDeposited v) , contractCreated :: ContractCreated v , createdBlock :: BlockHeader } -standardContractHeader :: StandardContractInit v -> ContractHeader -standardContractHeader StandardContractInit{..} = contractCreatedToContractHeader createdBlock contractCreated +standardContractHeader :: StandardContractLifecycleInit v -> ContractHeader +standardContractHeader StandardContractLifecycleInit{..} = contractCreatedToContractHeader createdBlock contractCreated -standardContractId :: StandardContractInit v -> ContractId -standardContractId StandardContractInit{contractCreated = ContractCreated _ ContractCreatedInEra{..}} = contractId +standardContractId :: StandardContractLifecycleInit v -> ContractId +standardContractId StandardContractLifecycleInit{contractCreated = ContractCreated _ ContractCreatedInEra{..}} = contractId -standardContractDatum :: StandardContractInit v -> Datum v -standardContractDatum StandardContractInit{contractCreated = ContractCreated _ ContractCreatedInEra{..}} = datum +standardContractDatum :: StandardContractLifecycleInit v -> Datum v +standardContractDatum StandardContractLifecycleInit{contractCreated = ContractCreated _ ContractCreatedInEra{..}} = datum standardContractPayout :: StandardContractClosed 'V1 -> Maybe (WithdrawTx 'V1) -> PayoutHeader standardContractPayout StandardContractClosed{returnDeposited = InputsApplied _ InputsAppliedInEra{..}} mWithdraw = @@ -122,18 +122,19 @@ data StandardContractNotified v = StandardContractNotified data StandardContractClosed v = StandardContractClosed { withdrawPartyAFunds :: Integration (WithdrawTx v, BlockHeader) , rolesCurrency :: PolicyId - , burnPartyARoleTokenByAssetIdPartyA :: Integration BurnTx - , burnPartyARoleTokenByContractId :: Integration BurnTx - , burnPartyARoleTokenByPolicyId :: Integration BurnTx - , burnPartyARoleTokenByAny :: Integration BurnTx + , burnPartyARoleTokenByAssetIdPartyA :: Integration (BurnRoleTokensTx v) + , burnPartyARoleTokenByContractId :: Integration (BurnRoleTokensTx v) + , burnPartyARoleTokenByPolicyId :: Integration (BurnRoleTokensTx v) + , burnPartyARoleTokenByAny :: Integration (BurnRoleTokensTx v) , returnDeposited :: InputsApplied v , returnDepositBlock :: BlockHeader } -createStandardContract :: Wallet -> Wallet -> Integration (StandardContractInit 'V1) +createStandardContract :: Wallet -> Wallet -> Integration (StandardContractLifecycleInit 'V1) createStandardContract = createStandardContractWithTags mempty -createStandardContractWithTags :: Set MarloweMetadataTag -> Wallet -> Wallet -> Integration (StandardContractInit 'V1) +createStandardContractWithTags + :: Set MarloweMetadataTag -> Wallet -> Wallet -> Integration (StandardContractLifecycleInit 'V1) createStandardContractWithTags tags partyAWallet = createStandardContractWithTagsAndRolesConfig Nothing @@ -149,7 +150,7 @@ createStandardContractWithRolesConfig -> RoleTokensConfig -> Wallet -> Wallet - -> Integration (StandardContractInit 'V1) + -> Integration (StandardContractLifecycleInit 'V1) createStandardContractWithRolesConfig threadName rolesConfig = createStandardContractWithTagsAndRolesConfig threadName rolesConfig mempty @@ -159,7 +160,7 @@ createStandardContractWithTagsAndRolesConfig -> Set MarloweMetadataTag -> Wallet -> Wallet - -> Integration (StandardContractInit 'V1) + -> Integration (StandardContractLifecycleInit 'V1) createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAWallet partyBWallet = do partyBAddress <- expectJust "Failed to convert party B address" $ toPlutusAddress $ changeAddress $ addresses partyBWallet @@ -193,7 +194,7 @@ createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAW createdBlock <- submit partyAWallet era0 createTxBody pure - StandardContractInit + StandardContractLifecycleInit { createdBlock , contractCreated , makeInitialDeposit = do @@ -244,7 +245,7 @@ createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAW 100_000_000 returnDepositBlock <- submit partyBWallet era4 returnTxBody - let mkBurn = burn partyAWallet + let buildBurnRoleTokensByPartyATx = buildBurnRoleTokensTx partyAWallet pure StandardContractClosed { rolesCurrency @@ -255,18 +256,27 @@ createStandardContractWithTagsAndRolesConfig threadName rolesConfig tags partyAW withdraw partyAWallet $ Map.keysSet $ payouts output (withdrawTx,) <$> submit partyAWallet era5 withdrawTxBody , burnPartyARoleTokenByAssetIdPartyA = - mkBurn $ RoleTokenFilterByTokens $ Set.singleton $ AssetId rolesCurrency "Party A" + buildBurnRoleTokensByPartyATx $ RoleTokenFilterByTokens $ Set.singleton $ AssetId rolesCurrency "Party A" , burnPartyARoleTokenByContractId = - mkBurn $ RoleTokenFilterByContracts $ Set.singleton contractId + buildBurnRoleTokensByPartyATx $ RoleTokenFilterByContracts $ Set.singleton contractId , burnPartyARoleTokenByPolicyId = - mkBurn $ RoleTokenFilterByPolicyIds $ Set.singleton rolesCurrency - , burnPartyARoleTokenByAny = mkBurn RoleTokenFilterAny + buildBurnRoleTokensByPartyATx $ RoleTokenFilterByPolicyIds $ Set.singleton rolesCurrency + , burnPartyARoleTokenByAny = buildBurnRoleTokensByPartyATx RoleTokenFilterAny } } } } } +-- | A standard contract that can be used for testing. +-- | The contract is a simple escrow contract where Party A deposits 100 ADA and Party B can claim the funds by choosing a choice. +-- | The contract is parameterized by the address of Party B, the start time, and the timeout length. +-- | The contract is structured as follows: +-- | 1. Party A deposits 100 ADA. +-- | 2. Party B can choose to claim the funds by choosing the choice "Gimme the money". +-- | 3. If Party B chooses the choice, Party A must deposit 100 ADA to Party B within the timeout length. +-- | 4. If Party B does not choose the choice within the timeout length, the contract closes. +-- | 5. A Payout is only available for Party B when the contract closes. standardContract :: PV2.Address -> UTCTime diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs index 820b29336a..15012b1884 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Withdraw.hs @@ -36,8 +36,8 @@ import Language.Marlowe.Runtime.Integration.StandardContract ( withdrawPartyAFunds ), StandardContractFundsDeposited (chooseGimmeTheMoney), - StandardContractInit ( - StandardContractInit, + StandardContractLifecycleInit ( + StandardContractLifecycleInit, contractCreated, createdBlock, makeInitialDeposit @@ -183,7 +183,7 @@ setup runTests = withLocalMarloweRuntime $ runIntegrationTest do wallet2 <- getGenesisWallet 2 (wallet1AvailablePayout1, wallet1AvailablePayout2, wallet1WithdrawnPayout) <- setupPayments wallet1 wallet2 wallet2AvailablePayout <- createAndExecuteStandardContractWithoutWithdrawing wallet2 wallet1 - StandardContractInit{contractCreated = randomCreation} <- createStandardContract wallet1 wallet2 + StandardContractLifecycleInit{contractCreated = randomCreation} <- createStandardContract wallet1 wallet2 liftIO $ runTests TestData{..} setupPayments :: Wallet -> Wallet -> Integration (PayoutState 'V1, PayoutState 'V1, PayoutState 'V1) @@ -195,7 +195,7 @@ setupPayments partyA partyB = do createAndExecuteStandardContractWithoutWithdrawing :: Wallet -> Wallet -> Integration (PayoutState 'V1) createAndExecuteStandardContractWithoutWithdrawing partyA partyB = do - StandardContractInit{..} <- createStandardContract partyA partyB + StandardContractLifecycleInit{..} <- createStandardContract partyA partyB ContractCreated _ ContractCreatedInEra{..} <- pure contractCreated step2 <- makeInitialDeposit step3 <- chooseGimmeTheMoney step2 @@ -214,7 +214,7 @@ createAndExecuteStandardContractWithoutWithdrawing partyA partyB = do createAndExecuteStandardContract :: Wallet -> Wallet -> Integration (PayoutState 'V1) createAndExecuteStandardContract partyA partyB = do - StandardContractInit{..} <- createStandardContract partyA partyB + StandardContractLifecycleInit{..} <- createStandardContract partyA partyB ContractCreated _ ContractCreatedInEra{contractId} <- pure contractCreated step2 <- makeInitialDeposit step3 <- chooseGimmeTheMoney step2 diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs index 9b70ec0f58..449e103fd0 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Eta reduce" #-} module Language.Marlowe.Runtime.Web.Common ( applyCloseTransaction, applyInputs, @@ -11,6 +14,8 @@ module Language.Marlowe.Runtime.Web.Common ( submitWithdrawal, waitUntilConfirmed, withdraw, + buildBurnRoleTokenTx, + submitBurnRoleTokensTx, ) where import Cardano.Api ( @@ -44,21 +49,27 @@ import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client ( getContract, - getTransaction, getWithdrawal, postContract, - postTransaction, postWithdrawal, putContract, - putTransaction, putWithdrawal, ) import Language.Marlowe.Runtime.Web.Contract.API (ContractOrSourceId (..)) import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import Language.Marlowe.Runtime.Web.Contract.Transaction.Client ( + getTransaction, + postTransaction, + putTransaction, + ) import qualified Language.Marlowe.Runtime.Web.Core.Base16 as Web import qualified Language.Marlowe.Runtime.Web.Core.BlockHeader as Web import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web +import qualified Language.Marlowe.Runtime.Web.Role.API as Web +import Language.Marlowe.Runtime.Web.Role.Client (toWalletHeader) +import qualified Language.Marlowe.Runtime.Web.Role.Client as Web +import qualified Language.Marlowe.Runtime.Web.Role.TokenFilter as Web import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import qualified PlutusLedgerApi.V2 as PV2 @@ -151,6 +162,14 @@ submitWithdrawal Wallet{..} Web.WithdrawTxEnvelope{withdrawalId, txEnvelope} = d Web.Withdrawal{block} <- waitUntilConfirmed (\Web.Withdrawal{status} -> status) $ getWithdrawal withdrawalId liftIO $ expectJust "Expected a block header" block +submitBurnRoleTokensTx + :: Wallet + -> Web.BurnRoleTokensTxEnvelope Web.CardanoTxBody + -> ClientM () +submitBurnRoleTokensTx Wallet{..} Web.BurnRoleTokensTxEnvelope{txId, txEnvelope} = do + signedBurnTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys + Web.submitBurnTokenTx txId signedBurnTx + deposit :: Wallet -> Web.TxOutRef @@ -220,6 +239,12 @@ applyInputs Wallet{..} contractId inputs = do , tags = mempty } +buildBurnRoleTokenTx + :: Wallet + -> Web.RoleTokenFilter + -> ClientM (Web.BurnRoleTokensTxEnvelope Web.CardanoTxBody) +buildBurnRoleTokenTx Wallet{..} roleFilter = Web.buildBurnTokenTxBody (toWalletHeader addresses) roleFilter + signShelleyTransaction' :: Web.TextEnvelope -> [ShelleyWitnessSigningKey] -> IO Web.TextEnvelope signShelleyTransaction' Web.TextEnvelope{..} wits = do let te = diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs index ce452a0811..bfb9f0a02d 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Get.hs @@ -9,10 +9,11 @@ import Data.Proxy (Proxy (Proxy)) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (Wallet, getGenesisWallet, runIntegrationTest, runWebClient) import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) -import Language.Marlowe.Runtime.Web.Client (Page (..), getTransactions) +import Language.Marlowe.Runtime.Web.Client (Page (..)) import Language.Marlowe.Runtime.Web.Common (applyCloseTransaction, createCloseContract) +import Language.Marlowe.Runtime.Web.Contract.Transaction.Client import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web -import Language.Marlowe.Runtime.Web.StandardContract (createFullyExecutedStandardContract) +import Language.Marlowe.Runtime.Web.StandardContract (executeCompleteStandardContractLifecycle) import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) @@ -157,7 +158,7 @@ singleContractMultipleTransactionsValidSpec = it "returns a list with multiple t multipleContractsMultipleTransactionsValidSpec :: SpecWith MarloweWebTestData multipleContractsMultipleTransactionsValidSpec = it "returns a list with multiple transaction when multiple contracts are on chain" \MarloweWebTestData{..} -> flip runIntegrationTest runtime do either throw pure =<< runWebClient do - (createContractId, testTransactionIds) <- createFullyExecutedStandardContract wallet1 wallet2 + (createContractId, testTransactionIds) <- executeCompleteStandardContractLifecycle wallet1 wallet2 Page{..} <- getTransactions createContractId Nothing @@ -204,7 +205,7 @@ setup runSpec = withLocalMarloweRuntime $ runIntegrationTest do wallet1 <- getGenesisWallet 0 wallet2 <- getGenesisWallet 1 either throw pure =<< runWebClient do - (expectedContractId, expectedTransactionIds) <- createFullyExecutedStandardContract wallet1 wallet2 + (expectedContractId, expectedTransactionIds) <- executeCompleteStandardContractLifecycle wallet1 wallet2 liftIO $ runSpec MarloweWebTestData{..} data MarloweWebTestData = MarloweWebTestData diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs index 5e4768871f..a5fdd52707 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Get.hs @@ -8,12 +8,13 @@ import Data.Functor (void) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain import Language.Marlowe.Runtime.Integration.Common (getGenesisWallet, runIntegrationTest, runWebClient) import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) -import Language.Marlowe.Runtime.Web.Client (getTransaction) + import qualified Language.Marlowe.Runtime.Web.Core.Asset as Web import qualified Language.Marlowe.Runtime.Web.Core.Tx as Web import qualified Language.Marlowe.Runtime.Web.Payout.API as Web -import Language.Marlowe.Runtime.Web.StandardContract (createFullyExecutedStandardContract) +import Language.Marlowe.Runtime.Web.StandardContract (executeCompleteStandardContractLifecycle) +import Language.Marlowe.Runtime.Web.Contract.Transaction.Client (getTransaction) import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Network.HTTP.Types (Status (..)) import Servant.Client (ClientError (FailureResponse)) @@ -110,7 +111,7 @@ setup runSpec = withLocalMarloweRuntime $ runIntegrationTest do wallet1 <- getGenesisWallet 0 wallet2 <- getGenesisWallet 1 either throw pure =<< runWebClient do - (contractId, transactionIds) <- createFullyExecutedStandardContract wallet1 wallet2 + (contractId, transactionIds) <- executeCompleteStandardContractLifecycle wallet1 wallet2 liftIO $ runSpec MarloweWebTestData{..} data MarloweWebTestData = MarloweWebTestData diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs index f1cafa277c..766a78c2fc 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Post.hs @@ -18,7 +18,7 @@ import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) -import Language.Marlowe.Runtime.Web.Client (postContract, postTransaction) +import Language.Marlowe.Runtime.Web.Client (postContract) import Language.Marlowe.Runtime.Web.Common (submitContract) import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web @@ -30,6 +30,7 @@ import Language.Marlowe.Runtime.Web.Core.Roles ( ) import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web +import Language.Marlowe.Runtime.Web.Contract.Transaction.Client import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Test.Hspec (Spec, describe, it) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs index 0f1a1d2586..dfa35b0a31 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs @@ -17,7 +17,7 @@ import Language.Marlowe.Runtime.Integration.StandardContract (standardContract) import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress) import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) -import Language.Marlowe.Runtime.Web.Client (postContract, postTransaction, putTransaction) +import Language.Marlowe.Runtime.Web.Client (postContract) import Language.Marlowe.Runtime.Web.Common (signShelleyTransaction', submitContract) import qualified Language.Marlowe.Runtime.Web.Core.MarloweVersion as Web @@ -35,6 +35,10 @@ import Language.Marlowe.Runtime.Web.Contract.API ( ), ) import qualified Language.Marlowe.Runtime.Web.Contract.API as Web +import Language.Marlowe.Runtime.Web.Contract.Transaction.Client ( + postTransaction, + putTransaction, + ) import Language.Marlowe.Runtime.Web.Core.Roles ( RoleTokenConfig (RoleTokenConfig), RoleTokenRecipient (ClosedRole), diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs index cf7525e7cc..3dd6ce47b3 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs @@ -1,6 +1,19 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} -module Language.Marlowe.Runtime.Web.StandardContract where +module Language.Marlowe.Runtime.Web.StandardContract ( + createStandardContract, + createStandardContractWithTags, + executeCompleteStandardContractLifecycle, + StandardContractLifecycleInit (..), + StandardContractFundsDeposited (..), + StandardContractChoiceMade (..), + StandardContractNotified (..), + StandardContractClosed (..), + StandardContractPayoutsPartyAWithdrawn (..), + StandardContractLifecycleEnded (..), +) where import Control.Monad.RWS.Strict (MonadIO (liftIO)) import Data.Map (Map) @@ -23,9 +36,11 @@ import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) import Language.Marlowe.Runtime.Web.Client (Page (..), getPayouts, postContract, postContractSource) import Language.Marlowe.Runtime.Web.Common ( + buildBurnRoleTokenTx, choose, deposit, notify, + submitBurnRoleTokensTx, submitContract, submitTransaction, submitWithdrawal, @@ -43,6 +58,11 @@ import Language.Marlowe.Runtime.Web.Core.BlockHeader ( import qualified Language.Marlowe.Runtime.Web.Core.Metadata as Web import Language.Marlowe.Runtime.Web.Core.Roles (RoleTokenConfig (..), RoleTokenRecipient (..)) import qualified Language.Marlowe.Runtime.Web.Core.Roles as Web +import Language.Marlowe.Runtime.Web.Role.API ( + BurnRoleTokensTxEnvelope, + ) + +import qualified Language.Marlowe.Runtime.Web.Role.TokenFilter as Web import Language.Marlowe.Runtime.Web.Tx.API ( ApplyInputsTxEnvelope (transactionId), CardanoTxBody, @@ -53,7 +73,7 @@ import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import Pipes (yield) import Servant.Client.Streaming (ClientM) -data StandardContractInit = StandardContractInit +data StandardContractLifecycleInit = StandardContractLifecycleInit { makeInitialDeposit :: ClientM StandardContractFundsDeposited , contractCreated :: CreateTxEnvelope CardanoTxBody , createdBlock :: BlockHeader @@ -78,15 +98,28 @@ data StandardContractNotified = StandardContractNotified } data StandardContractClosed = StandardContractClosed - { withdrawPartyAFunds :: ClientM (WithdrawTxEnvelope CardanoTxBody, BlockHeader) + { withdrawPartyAPayout :: ClientM StandardContractPayoutsPartyAWithdrawn , returnDeposited :: ApplyInputsTxEnvelope CardanoTxBody , returnDepositBlock :: BlockHeader } -createStandardContract :: Wallet -> Wallet -> ClientM StandardContractInit +data StandardContractPayoutsPartyAWithdrawn = StandardContractPayoutsPartyAWithdrawn + { burnRoleTokens :: ClientM StandardContractLifecycleEnded + , tx :: WithdrawTxEnvelope CardanoTxBody + , block :: BlockHeader + } + +data StandardContractLifecycleEnded where + StandardContractLifecycleEnded + :: { tx + :: BurnRoleTokensTxEnvelope CardanoTxBody + } + -> StandardContractLifecycleEnded + +createStandardContract :: Wallet -> Wallet -> ClientM StandardContractLifecycleInit createStandardContract = createStandardContractWithTags mempty -createStandardContractWithTags :: Map Text Web.Metadata -> Wallet -> Wallet -> ClientM StandardContractInit +createStandardContractWithTags :: Map Text Web.Metadata -> Wallet -> Wallet -> ClientM StandardContractLifecycleInit createStandardContractWithTags tags partyAWallet partyBWallet = do let partyAWalletAddresses = addresses partyAWallet let partyAWebChangeAddress = toDTO $ changeAddress partyAWalletAddresses @@ -127,7 +160,7 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do createdBlock <- submitContract partyAWallet contractCreated pure - StandardContractInit + StandardContractLifecycleInit { createdBlock , contractCreated , makeInitialDeposit = do @@ -182,34 +215,60 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do StandardContractClosed { returnDepositBlock , returnDeposited - , withdrawPartyAFunds = do + , withdrawPartyAPayout = do Page{..} <- getPayouts (Just $ Set.singleton contractId) Nothing (Just Available) Nothing let payouts = Set.fromList $ payoutId <$> items - withdrawTxBody <- withdraw partyAWallet payouts - (withdrawTxBody,) <$> submitWithdrawal partyAWallet withdrawTxBody + withdrawPartyATxBody <- withdraw partyAWallet payouts + blockPartyA <- submitWithdrawal partyAWallet withdrawPartyATxBody + pure + StandardContractPayoutsPartyAWithdrawn + { tx = withdrawPartyATxBody + , block = blockPartyA + , burnRoleTokens = do + let roleFilter = Web.RoleTokenFilterByContracts $ Set.singleton contractId + txSubmittedPartyA <- buildBurnRoleTokenTx partyAWallet roleFilter + submitBurnRoleTokensTx partyAWallet txSubmittedPartyA + pure + StandardContractLifecycleEnded + { tx = txSubmittedPartyA + } + } } } } } } -createFullyExecutedStandardContract :: Wallet -> Wallet -> ClientM (Web.TxOutRef, [Web.TxId]) -createFullyExecutedStandardContract partyAWallet partyBWallet = do - StandardContractInit{contractCreated, makeInitialDeposit} <- createStandardContract partyAWallet partyBWallet - StandardContractFundsDeposited{initialFundsDeposited, chooseGimmeTheMoney} <- makeInitialDeposit - StandardContractChoiceMade{gimmeTheMoneyChosen, sendNotify} <- chooseGimmeTheMoney - StandardContractNotified{notified, makeReturnDeposit} <- sendNotify - StandardContractClosed{returnDeposited, withdrawPartyAFunds} <- makeReturnDeposit - (_, _) <- withdrawPartyAFunds - createContractId <- case contractCreated of - Web.CreateTxEnvelope{contractId} -> pure contractId - transactionId1 <- case initialFundsDeposited of - Web.ApplyInputsTxEnvelope{transactionId} -> pure transactionId - transactionId2 <- case gimmeTheMoneyChosen of - Web.ApplyInputsTxEnvelope{transactionId} -> pure transactionId - transactionId3 <- case notified of - Web.ApplyInputsTxEnvelope{transactionId} -> pure transactionId - transactionId4 <- case returnDeposited of - Web.ApplyInputsTxEnvelope{transactionId} -> pure transactionId - let transactionIds = [transactionId1, transactionId2, transactionId3, transactionId4] - pure (createContractId, transactionIds) +executeCompleteStandardContractLifecycle :: Wallet -> Wallet -> ClientM (Web.TxOutRef, [Web.TxId]) +executeCompleteStandardContractLifecycle partyAWallet partyBWallet = do + StandardContractLifecycleInit{contractCreated = Web.CreateTxEnvelope{contractId}, makeInitialDeposit} <- + createStandardContract partyAWallet partyBWallet + StandardContractFundsDeposited + { initialFundsDeposited = Web.ApplyInputsTxEnvelope{transactionId = initialFundsDepositedTxId} + , chooseGimmeTheMoney + } <- + makeInitialDeposit + StandardContractChoiceMade + { gimmeTheMoneyChosen = Web.ApplyInputsTxEnvelope{transactionId = gimmeTheMoneyChosenTxId} + , sendNotify + } <- + chooseGimmeTheMoney + StandardContractNotified{notified = Web.ApplyInputsTxEnvelope{transactionId = notifiedTx}, makeReturnDeposit} <- + sendNotify + StandardContractClosed + { returnDeposited = Web.ApplyInputsTxEnvelope{transactionId = returnDepositedTx} + , withdrawPartyAPayout + } <- + makeReturnDeposit + StandardContractPayoutsPartyAWithdrawn{burnRoleTokens} <- withdrawPartyAPayout + _ <- burnRoleTokens + + pure + ( contractId + , + [ initialFundsDepositedTxId + , gimmeTheMoneyChosenTxId + , notifiedTx + , returnDepositedTx + ] + ) diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs index ac96f00f30..4e2f9f3c71 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/WebSpec.hs @@ -16,7 +16,6 @@ import qualified Language.Marlowe.Runtime.Web.Contracts.Transactions.Transaction import qualified Language.Marlowe.Runtime.Web.Withdrawal.Post as Withdrawal.Post import qualified Language.Marlowe.Runtime.Web.Withdrawal.Put as Withdrawal.Put - import Test.Hspec (Spec, describe) spec :: Spec diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs index 69ae9eb445..6058e25390 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Post.hs @@ -18,7 +18,7 @@ import Language.Marlowe.Runtime.Web.StandardContract ( StandardContractChoiceMade (..), StandardContractClosed (..), StandardContractFundsDeposited (..), - StandardContractInit (..), + StandardContractLifecycleInit (..), StandardContractNotified (..), createStandardContract, ) @@ -40,7 +40,7 @@ spec = describe "POST /contracts/{contractId}/withdrawal" do let webExtraAddresses = Set.map toDTO extraAddresses let webCollateralUtxos = Set.map toDTO collateralUtxos - StandardContractInit{contractCreated, makeInitialDeposit} <- createStandardContract partyAWallet partyBWallet + StandardContractLifecycleInit{contractCreated, makeInitialDeposit} <- createStandardContract partyAWallet partyBWallet StandardContractFundsDeposited{chooseGimmeTheMoney} <- makeInitialDeposit StandardContractChoiceMade{sendNotify} <- chooseGimmeTheMoney StandardContractNotified{makeReturnDeposit} <- sendNotify diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs index f2a2a2441d..7ba5e1239f 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs @@ -1,61 +1,37 @@ module Language.Marlowe.Runtime.Web.Withdrawal.Put where -import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.Set as Set import Language.Marlowe.Runtime.Integration.Common ( - Wallet (Wallet, addresses, signingKeys), getGenesisWallet, runIntegrationTest, runWebClient, ) -import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) -import Language.Marlowe.Runtime.Web.Client (Page (..), getPayouts, postWithdrawal, putWithdrawal) -import Language.Marlowe.Runtime.Web.Common (signShelleyTransaction') - -import Language.Marlowe.Runtime.Web.Adapter.Server.DTO (ToDTO (toDTO)) -import Language.Marlowe.Runtime.Web.Payout.API (PayoutHeader (..), PayoutStatus (..)) import Language.Marlowe.Runtime.Web.StandardContract ( StandardContractChoiceMade (..), StandardContractClosed (..), StandardContractFundsDeposited (..), - StandardContractInit (..), + StandardContractLifecycleInit (..), StandardContractNotified (..), createStandardContract, ) -import qualified Language.Marlowe.Runtime.Web.Tx.API as Web -import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Test.Hspec (Spec, describe, it) import Test.Integration.Marlowe.Local (withLocalMarloweRuntime) spec :: Spec spec = describe "PUT /contracts/{contractId}/withdrawals/{withdrawalId}" do it "successfully submits a withdrawal" $ withLocalMarloweRuntime $ runIntegrationTest do - partyAWallet@Wallet{signingKeys} <- getGenesisWallet 0 + partyAWallet <- getGenesisWallet 0 partyBWallet <- getGenesisWallet 1 result <- runWebClient do - let WalletAddresses{..} = addresses partyAWallet - let webChangeAddress = toDTO changeAddress - let webExtraAddresses = Set.map toDTO extraAddresses - let webCollateralUtxos = Set.map toDTO collateralUtxos - StandardContractInit{contractCreated, makeInitialDeposit} <- createStandardContract partyAWallet partyBWallet + StandardContractLifecycleInit{makeInitialDeposit} <- createStandardContract partyAWallet partyBWallet StandardContractFundsDeposited{chooseGimmeTheMoney} <- makeInitialDeposit StandardContractChoiceMade{sendNotify} <- chooseGimmeTheMoney StandardContractNotified{makeReturnDeposit} <- sendNotify - StandardContractClosed{} <- makeReturnDeposit - - contractId <- case contractCreated of - Web.CreateTxEnvelope{contractId} -> pure contractId - - Page{..} <- getPayouts (Just $ Set.singleton contractId) Nothing (Just Available) Nothing - let payouts = Set.fromList $ payoutId <$> items - - Web.WithdrawTxEnvelope{withdrawalId, txEnvelope} <- - postWithdrawal webChangeAddress (Just webExtraAddresses) (Just webCollateralUtxos) Web.PostWithdrawalsRequest{..} - signedWithdrawalTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys - putWithdrawal withdrawalId signedWithdrawalTx + StandardContractClosed{withdrawPartyAPayout} <- makeReturnDeposit + _ <- withdrawPartyAPayout + return () case result of Left _ -> fail $ "Expected 200 response code - got " <> show result diff --git a/marlowe-runtime-web/.golden/OpenApi/golden b/marlowe-runtime-web/.golden/OpenApi/golden index 2535175879..c767008055 100644 --- a/marlowe-runtime-web/.golden/OpenApi/golden +++ b/marlowe-runtime-web/.golden/OpenApi/golden @@ -273,6 +273,22 @@ ], "type": "object" }, + "BurnRoleTokensResponse": { + "description": "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"", + "properties": { + "tx": { + "$ref": "#/components/schemas/TextEnvelope" + }, + "txId": { + "$ref": "#/components/schemas/TxId" + } + }, + "required": [ + "txId", + "tx" + ], + "type": "object" + }, "CanChoose": { "description": "Choice Inputs that can be applied for a given contract", "properties": { @@ -2279,6 +2295,150 @@ } ] }, + "RoleTokenFilter": { + "description": "A filter that selects role tokens for burning.", + "oneOf": [ + { + "description": "Matches any role tokens matched by both sub-filters.", + "properties": { + "and": { + "items": [ + { + "$ref": "#/components/schemas/RoleTokenFilter" + }, + { + "$ref": "#/components/schemas/RoleTokenFilter" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + } + }, + "required": [ + "and" + ], + "type": "object" + }, + { + "description": "Matches any role tokens matched by either sub-filter.", + "properties": { + "or": { + "items": [ + { + "$ref": "#/components/schemas/RoleTokenFilter" + }, + { + "$ref": "#/components/schemas/RoleTokenFilter" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + } + }, + "required": [ + "or" + ], + "type": "object" + }, + { + "description": "Matches any role tokens not matched by the sub-filter.", + "properties": { + "not": { + "$ref": "#/components/schemas/RoleTokenFilter" + } + }, + "required": [ + "not" + ], + "type": "object" + }, + { + "description": "Matches any role token.", + "enum": [ + true + ], + "type": "boolean" + }, + { + "description": "Matches no role token.", + "enum": [ + false + ], + "type": "boolean" + }, + { + "description": "Matches any role tokens used by the given contract(s).", + "properties": { + "contract_id": { + "oneOf": [ + { + "$ref": "#/components/schemas/TxOutRef" + }, + { + "items": { + "$ref": "#/components/schemas/TxOutRef" + }, + "type": "array", + "uniqueItems": true + } + ] + } + }, + "required": [ + "contract_id" + ], + "type": "object" + }, + { + "description": "Matches any role tokens with the given currency symbol(s).", + "properties": { + "roles_currency": { + "oneOf": [ + { + "$ref": "#/components/schemas/PolicyId" + }, + { + "items": { + "$ref": "#/components/schemas/PolicyId" + }, + "type": "array", + "uniqueItems": true + } + ] + } + }, + "required": [ + "roles_currency" + ], + "type": "object" + }, + { + "description": "Matches only the given role token(s).", + "properties": { + "role_tokens": { + "oneOf": [ + { + "$ref": "#/components/schemas/AssetId" + }, + { + "items": { + "$ref": "#/components/schemas/AssetId" + }, + "type": "array", + "uniqueItems": true + } + ] + } + }, + "required": [ + "role_tokens" + ], + "type": "object" + } + ] + }, "RolesConfig": { "oneOf": [ { @@ -6195,6 +6355,363 @@ "summary": "Get payout by ID" } }, + "/role-tokens/burnTxs": { + "post": { + "description": "Build an unsigned (Cardano) transaction body which burns role tokens matching a filter. Role tokens used by active contracts will not be burned and the request will fail if active role tokens are included. To submit the signed transaction, use the PUT /roles/burnTokensTxs/submit endpoint.", + "operationId": "buildBurnRoleTokensTx", + "parameters": [ + { + "in": "header", + "name": "X-Change-Address", + "required": true, + "schema": { + "description": "A cardano address, in Bech32 format", + "example": "addr1w94f8ywk4fg672xasahtk4t9k6w3aql943uxz5rt62d4dvq8evxaf", + "type": "string" + } + }, + { + "in": "header", + "name": "X-Address", + "required": false, + "schema": { + "description": "A comma-separated list of values", + "type": "string" + } + }, + { + "in": "header", + "name": "X-Collateral-UTxO", + "required": false, + "schema": { + "description": "A comma-separated list of values", + "type": "string" + } + } + ], + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/RoleTokenFilter" + } + } + } + }, + "responses": { + "201": { + "content": { + "application/vendor.iog.marlowe-runtime.burn-role-tokens-tx-json": { + "schema": { + "$ref": "#/components/schemas/BurnRoleTokensResponse" + } + } + }, + "description": "", + "headers": { + "X-Network-Id": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "type": "string" + }, + { + "type": "integer" + } + ] + } + }, + "X-Node-Tip": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "properties": { + "genesisTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "genesisTimeUTC" + ], + "type": "object" + }, + { + "properties": { + "blockHeader": { + "$ref": "#/components/schemas/BlockHeader" + }, + "slotTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "blockHeader", + "slotTimeUTC" + ], + "type": "object" + } + ] + } + }, + "X-Runtime-Chain-Tip": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "properties": { + "genesisTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "genesisTimeUTC" + ], + "type": "object" + }, + { + "properties": { + "blockHeader": { + "$ref": "#/components/schemas/BlockHeader" + }, + "slotTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "blockHeader", + "slotTimeUTC" + ], + "type": "object" + } + ] + } + }, + "X-Runtime-Tip": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "properties": { + "genesisTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "genesisTimeUTC" + ], + "type": "object" + }, + { + "properties": { + "blockHeader": { + "$ref": "#/components/schemas/BlockHeader" + }, + "slotTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "blockHeader", + "slotTimeUTC" + ], + "type": "object" + } + ] + } + }, + "X-Runtime-Version": { + "schema": { + "pattern": "^\\d+(\\.\\d+)*$", + "type": "string" + } + } + } + }, + "400": { + "description": "Invalid `X-Collateral-UTxO` or `X-Address` or `X-Change-Address` or `body`" + } + }, + "security": [], + "summary": "Build a Burn role tokens Transation" + } + }, + "/role-tokens/burnTxs/{TxId}": { + "put": { + "description": "Submit a signed (Cardano) transaction that burns role tokens. The transaction must have originally been created by the POST /roles/burnTokensTxs/build endpoint. This endpoint will respond when the transaction is submitted successfully to the local node, which means it will not wait for the transaction to be published in a block. Use the GET /roles/burn/{burnId} endpoint to poll the on-chain status.", + "operationId": "submitBurnRoleTokensTx", + "parameters": [ + { + "in": "path", + "name": "TxId", + "required": true, + "schema": { + "description": "The hex-encoded identifier of a Cardano transaction", + "pattern": "^[a-fA-F0-9]{64}$", + "type": "string" + } + } + ], + "requestBody": { + "content": { + "application/json;charset=utf-8": { + "schema": { + "$ref": "#/components/schemas/TextEnvelope" + } + } + } + }, + "responses": { + "202": { + "content": { + "application/json;charset=utf-8": {} + }, + "description": "", + "headers": { + "X-Network-Id": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "type": "string" + }, + { + "type": "integer" + } + ] + } + }, + "X-Node-Tip": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "properties": { + "genesisTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "genesisTimeUTC" + ], + "type": "object" + }, + { + "properties": { + "blockHeader": { + "$ref": "#/components/schemas/BlockHeader" + }, + "slotTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "blockHeader", + "slotTimeUTC" + ], + "type": "object" + } + ] + } + }, + "X-Runtime-Chain-Tip": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "properties": { + "genesisTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "genesisTimeUTC" + ], + "type": "object" + }, + { + "properties": { + "blockHeader": { + "$ref": "#/components/schemas/BlockHeader" + }, + "slotTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "blockHeader", + "slotTimeUTC" + ], + "type": "object" + } + ] + } + }, + "X-Runtime-Tip": { + "schema": { + "description": "The latest known point in the chain on a peer.", + "oneOf": [ + { + "properties": { + "genesisTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "genesisTimeUTC" + ], + "type": "object" + }, + { + "properties": { + "blockHeader": { + "$ref": "#/components/schemas/BlockHeader" + }, + "slotTimeUTC": { + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + }, + "required": [ + "blockHeader", + "slotTimeUTC" + ], + "type": "object" + } + ] + } + }, + "X-Runtime-Version": { + "schema": { + "pattern": "^\\d+(\\.\\d+)*$", + "type": "string" + } + } + } + }, + "400": { + "description": "Invalid `body`" + }, + "404": { + "description": "`TxId` not found" + } + }, + "security": [], + "summary": "Submit a Burn Role Token Transaction" + } + }, "/withdrawals": { "get": { "description": "Get published withdrawal transactions. Results are returned in pages, with paging being specified by request headers.", diff --git a/marlowe-runtime-web/marlowe-runtime-web.cabal b/marlowe-runtime-web/marlowe-runtime-web.cabal index 211ecf66d3..80b7addd35 100644 --- a/marlowe-runtime-web/marlowe-runtime-web.cabal +++ b/marlowe-runtime-web/marlowe-runtime-web.cabal @@ -68,7 +68,6 @@ library Language.Marlowe.Runtime.Web.Adapter.Server.Util Language.Marlowe.Runtime.Web.Adapter.URI Language.Marlowe.Runtime.Web.API - Language.Marlowe.Runtime.Web.Burn.API Language.Marlowe.Runtime.Web.Client Language.Marlowe.Runtime.Web.Contract.API Language.Marlowe.Runtime.Web.Contract.Next.API @@ -78,6 +77,7 @@ library Language.Marlowe.Runtime.Web.Contract.Server Language.Marlowe.Runtime.Web.Contract.Source.Server Language.Marlowe.Runtime.Web.Contract.Transaction.API + Language.Marlowe.Runtime.Web.Contract.Transaction.Client Language.Marlowe.Runtime.Web.Contract.Transaction.Server Language.Marlowe.Runtime.Web.Core.Address Language.Marlowe.Runtime.Web.Core.Asset @@ -95,6 +95,10 @@ library Language.Marlowe.Runtime.Web.Core.Tx Language.Marlowe.Runtime.Web.Payout.API Language.Marlowe.Runtime.Web.Payout.Server + Language.Marlowe.Runtime.Web.Role.API + Language.Marlowe.Runtime.Web.Role.Client + Language.Marlowe.Runtime.Web.Role.Server + Language.Marlowe.Runtime.Web.Role.TokenFilter Language.Marlowe.Runtime.Web.Server Language.Marlowe.Runtime.Web.Status Language.Marlowe.Runtime.Web.Tx.API diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs index 9fb03ea36a..3f05e1e562 100644 --- a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs +++ b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/RuntimeServer.hs @@ -60,6 +60,7 @@ import Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient ( LoadContractHeaders, LoadPayout, LoadPayouts, + LoadTempBurnRoleTokensTx, LoadTransaction, LoadTransactions, LoadWithdrawal, @@ -70,6 +71,7 @@ import Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient ( ) import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient ( ApplyInputs, + BurnRoleTokens, CreateContract, Submit, TxClient (..), @@ -221,6 +223,7 @@ runtimeServer = proc deps@ServerDependencies{connector} -> do , lookupTempContract , lookupTempTransaction , lookupTempWithdrawal + , lookupTempBurnRoleTokensTx } ContractClient{..} <- contractClient @@ -232,46 +235,64 @@ runtimeServer = proc deps@ServerDependencies{connector} -> do -< case deps of ServerDependencies{connector = _, ..} -> WebServerDependencies - { _loadContractHeaders = loadContractHeaders + { -- \| contract creation. + _createContract = createContract + , _loadContractHeaders = loadContractHeaders , _loadContract = loadContract + , _getContract = getContract + , _submitContract = submitContract + , -- \| Apply Inputs + _applyInputs = applyInputs + , _submitTransaction = submitTransaction , _loadTransactions = loadTransactions - , _importBundle = importBundle , _loadTransaction = loadTransaction , _loadWithdrawals = loadWithdrawals , _loadWithdrawal = loadWithdrawal , _loadPayouts = loadPayouts , _loadPayout = loadPayout - , _createContract = createContract - , _getContract = getContract - , _applyInputs = applyInputs - , _withdraw = withdraw - , _submitContract = submitContract - , _submitTransaction = submitTransaction + , -- \| Withdrawals + _withdraw = withdraw , _submitWithdrawal = submitWithdrawal - , openAPIEnabled + , -- \| Burn Role Tokens + _burnRoleTokens = burnRoleTokens + , _submitBurnRoleTokens = submitBurnRoleTokens + , _loadTempBurnRoleTokensTx = loadTempBurnRoleTokensTx + , -- \| Merkleization and Marlowe Object + _importBundle = importBundle + , -- \| Infrastructure + openAPIEnabled , accessControlAllowOriginAll , runApplication , connector } data WebServerDependencies r s = WebServerDependencies - { _loadContractHeaders :: LoadContractHeaders (AppM r s) + { _createContract :: CreateContract (AppM r s) + -- ^ contract creation. + , _loadContractHeaders :: LoadContractHeaders (AppM r s) , _loadContract :: LoadContract (AppM r s) - , _importBundle :: ImportBundle (AppM r s) - , _loadWithdrawals :: LoadWithdrawals (AppM r s) - , _loadWithdrawal :: LoadWithdrawal (AppM r s) - , _loadPayouts :: LoadPayouts (AppM r s) - , _loadPayout :: LoadPayout (AppM r s) - , _loadTransactions :: LoadTransactions (AppM r s) - , _loadTransaction :: LoadTransaction (AppM r s) - , _createContract :: CreateContract (AppM r s) , _getContract :: GetContract (AppM r s) - , _withdraw :: Withdraw (AppM r s) - , _applyInputs :: ApplyInputs (AppM r s) , _submitContract :: ContractId -> Submit r (AppM r s) + , _applyInputs :: ApplyInputs (AppM r s) + -- ^ Apply Inputs , _submitTransaction :: ContractId -> TxId -> Submit r (AppM r s) + , _loadTransactions :: LoadTransactions (AppM r s) + , _loadTransaction :: LoadTransaction (AppM r s) + , _loadPayouts :: LoadPayouts (AppM r s) + , _loadPayout :: LoadPayout (AppM r s) + , _withdraw :: Withdraw (AppM r s) + -- ^ Withdrawals , _submitWithdrawal :: TxId -> Submit r (AppM r s) + , _loadWithdrawal :: LoadWithdrawal (AppM r s) + , _loadWithdrawals :: LoadWithdrawals (AppM r s) + , _burnRoleTokens :: BurnRoleTokens (AppM r s) + -- ^ Burn Role Tokens + , _submitBurnRoleTokens :: TxId -> Submit r (AppM r s) + , _loadTempBurnRoleTokensTx :: LoadTempBurnRoleTokensTx (AppM r s) + , _importBundle :: ImportBundle (AppM r s) + -- ^ Merkleization and Marlowe Object , openAPIEnabled :: Bool + -- ^ Infrastructure , accessControlAllowOriginAll :: Bool , runApplication :: Application -> IO () , connector :: Connector MarloweRuntimeClient (AppM r s) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs index d7029e47b9..7191b7777e 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs @@ -72,11 +72,27 @@ import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( import Language.Marlowe.Runtime.Web.Payout.API (GetPayoutAPI, PayoutHeader (..), PayoutState (..), PayoutsAPI) -import Language.Marlowe.Runtime.Web.Core.NetworkId -import Language.Marlowe.Runtime.Web.Core.Tip -import Language.Marlowe.Runtime.Web.Core.Tx -import Language.Marlowe.Runtime.Web.Status -import Language.Marlowe.Runtime.Web.Tx.API +import Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId) +import Language.Marlowe.Runtime.Web.Core.Tip (ChainTip) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TxId (TxId), + TxOutRef (TxOutRef, txId), + TxStatus (Confirmed), + ) +import Language.Marlowe.Runtime.Web.Role.API (RoleAPI) +import Language.Marlowe.Runtime.Web.Status (RuntimeStatus (..)) +import Language.Marlowe.Runtime.Web.Tx.API ( + ApplyInputsTx, + ApplyInputsTxEnvelope (..), + CardanoTx, + ContractTx, + CreateTxEnvelope (..), + Tx (..), + TxHeader (..), + TxJSON, + WithdrawTx, + WithdrawTxEnvelope (..), + ) import Language.Marlowe.Runtime.Web.Withdrawal.API ( GetWithdrawalAPI, PostWithdrawalsResponse, @@ -135,7 +151,7 @@ type RuntimeAPI = ( "contracts" :> ContractsAPI :<|> "withdrawals" :> WithdrawalsAPI :<|> "payouts" :> PayoutsAPI - -- :<|> "role-tokens" :> "burn" :> BurnsAPI + :<|> RoleAPI :<|> "healthcheck" :> ( Summary "Test server status" :> Description "Check if the server is running and ready to respond to requests." diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs index a7f9888356..d3767b0a84 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/Monad.hs @@ -7,7 +7,30 @@ {-# LANGUAGE UndecidableInstances #-} -- | Defines a custom Monad for the web server's handler functions to run in. -module Language.Marlowe.Runtime.Web.Adapter.Server.Monad where +module Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + AppEnv (..), + ServerM (..), + importBundle, + loadContractHeaders, + loadContract, + loadWithdrawals, + loadWithdrawal, + loadPayouts, + loadPayout, + loadTransactions, + loadTransaction, + createContract, + applyInputs, + burnRoleTokens, + withdraw, + getContract, + submitContract, + submitTransaction, + submitBurnRoleTokensTx, + submitWithdrawal, + loadTmpBurnRoleTokensTx, + liftBackendM, +) where import Colog (LogAction, Message, hoistLogAction) import Control.Concurrent.Component.Run (AppM, unAppM) @@ -26,15 +49,24 @@ import Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient ( LoadContractHeaders, LoadPayout, LoadPayouts, + LoadTempBurnRoleTokensTx, LoadTransaction, LoadTransactions, LoadWithdrawal, LoadWithdrawals, ) -import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (ApplyInputs, CreateContract, Submit, Submit', Withdraw) + +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient ( + ApplyInputs, + BurnRoleTokens, + CreateContract, + Submit, + Submit', + Withdraw, + ) import Observe.Event (EventBackend) import Pipes (MFunctor (..)) -import Servant +import Servant (Handler, ServerError) newtype ServerM a = ServerM {runServerM :: ReaderT AppEnv Handler a} deriving newtype @@ -54,23 +86,35 @@ newtype ServerM a = ServerM {runServerM :: ReaderT AppEnv Handler a} data AppEnv = forall r s. AppEnv - { _loadContractHeaders :: LoadContractHeaders (AppM r s) + { _createContract :: CreateContract (AppM r s) + -- ^ contract creation + , _submitContract :: ContractId -> Submit r (AppM r s) + , _getContract :: GetContract (AppM r s) + , _loadContractHeaders :: LoadContractHeaders (AppM r s) , _loadContract :: LoadContract (AppM r s) - , _loadWithdrawals :: LoadWithdrawals (AppM r s) - , _loadWithdrawal :: LoadWithdrawal (AppM r s) - , _loadPayouts :: LoadPayouts (AppM r s) - , _loadPayout :: LoadPayout (AppM r s) + , _applyInputs :: ApplyInputs (AppM r s) + -- ^ Apply inputs to a contract + , _submitTransaction :: ContractId -> TxId -> Submit r (AppM r s) , _loadTransactions :: LoadTransactions (AppM r s) , _loadTransaction :: LoadTransaction (AppM r s) - , _importBundle :: ImportBundle (AppM r s) - , _createContract :: CreateContract (AppM r s) - , _getContract :: GetContract (AppM r s) + , _loadPayouts :: LoadPayouts (AppM r s) + , _loadPayout :: LoadPayout (AppM r s) , _withdraw :: Withdraw (AppM r s) - , _applyInputs :: ApplyInputs (AppM r s) - , _submitContract :: ContractId -> Submit r (AppM r s) - , _submitTransaction :: ContractId -> TxId -> Submit r (AppM r s) + -- ^ Withdrawals , _submitWithdrawal :: TxId -> Submit r (AppM r s) + , _loadWithdrawal :: LoadWithdrawal (AppM r s) + , _loadWithdrawals :: LoadWithdrawals (AppM r s) + , _burnRoleTokens :: BurnRoleTokens (AppM r s) + -- ^ Burn role tokens + , _submitBurnRoleTokens :: TxId -> Submit r (AppM r s) + , _loadTempBurnRoleTokensTx :: LoadTempBurnRoleTokensTx (AppM r s) + -- ^ Look up a burn role tokens temporary transaction (Either Unsigned or Submitted) + -- N.B : Confirmation Status is not available for this transaction, Please use a + -- waitConfirmation TxId on your wallet. + -- | Merkleization and Marlowe Object + , _importBundle :: ImportBundle (AppM r s) , _eventBackend :: EventBackend (AppM r s) r s + -- ^ Infrastructure , _requestParent :: r , _logAction :: LogAction IO Message } @@ -135,6 +179,12 @@ loadTransaction contractId txId = do AppEnv{_eventBackend = backend, _loadTransaction = load} <- ask liftBackendM backend $ load contractId txId +-- | Look up a burn role tokens transaction. +loadTmpBurnRoleTokensTx :: LoadTempBurnRoleTokensTx ServerM +loadTmpBurnRoleTokensTx txId = do + AppEnv{_eventBackend = backend, _loadTempBurnRoleTokensTx = load} <- ask + liftBackendM backend $ load txId + -- | Create a contract. createContract :: CreateContract ServerM createContract stakeCredential version addresses threadName roles metadata minUTxODeposit state contract = do @@ -147,6 +197,17 @@ applyInputs version addresses contractId metadata invalidBefore invalidHereafter AppEnv{_eventBackend = backend, _applyInputs = apply} <- ask liftBackendM backend $ apply version addresses contractId metadata invalidBefore invalidHereafter inputs +-- | Burn role tokens. +burnRoleTokens :: BurnRoleTokens ServerM +burnRoleTokens version addresses roleTokenFilter = do + AppEnv{_eventBackend = backend, _burnRoleTokens = burn} <- ask + liftBackendM backend $ burn version addresses roleTokenFilter + +submitBurnRoleTokensTx :: TxId -> Submit' ServerM +submitBurnRoleTokensTx txId era tx = do + AppEnv{_eventBackend = backend, _requestParent, _submitBurnRoleTokens = submit} <- ask + liftBackendM backend $ submit txId _requestParent era tx + -- | Withdraw funds from a role. withdraw :: Withdraw ServerM withdraw version addresses payouts = do diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs index beeef244c9..db1f0e9007 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/SyncClient.hs @@ -2,10 +2,24 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -module Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient where +module Language.Marlowe.Runtime.Web.Adapter.Server.SyncClient ( + SyncClientDependencies (..), + SyncClient (..), + syncClient, + LoadContractHeaders, + LoadWithdrawals, + LoadPayouts, + LoadPayout, + LoadContract, + LoadWithdrawal, + LoadTransactions, + LoadTransaction, + LoadTempBurnRoleTokensTx, + LoadTxError (..), +) where import Control.Arrow (arr) -import Control.Concurrent.Component +import Control.Concurrent.Component (Component) import Control.Concurrent.STM (STM, atomically) import Control.Error (note) import Control.Monad (guard, mfilter) @@ -43,17 +57,23 @@ import Language.Marlowe.Runtime.Core.Api ( Transaction (..), ) import Language.Marlowe.Runtime.Discovery.Api (ContractHeader) -import Language.Marlowe.Runtime.Transaction.Api (ContractCreatedInEra, InputsAppliedInEra (..), WithdrawTxInEra (..)) +import Language.Marlowe.Runtime.Transaction.Api ( + BurnRoleTokensTxInEra, + ContractCreatedInEra, + InputsAppliedInEra (..), + WithdrawTxInEra (..), + ) import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (..)) import Language.Marlowe.Runtime.Web.Adapter.Server.Util (applyRangeToAscList) import Network.Protocol.Connection (Connector, runConnector) -import Servant.Pagination +import Servant.Pagination (RangeOrder (RangeAsc, RangeDesc)) data SyncClientDependencies m = SyncClientDependencies { connector :: Connector MarloweRuntimeClient m , lookupTempContract :: ContractId -> STM (Maybe (TempTx ContractCreatedInEra)) , lookupTempTransaction :: ContractId -> TxId -> STM (Maybe (TempTx InputsAppliedInEra)) , lookupTempWithdrawal :: TxId -> STM (Maybe (TempTx WithdrawTxInEra)) + , lookupTempBurnRoleTokensTx :: TxId -> STM (Maybe (TempTx BurnRoleTokensTxInEra)) } -- | Signature for a delegate that loads a list of contract headers. @@ -89,13 +109,20 @@ type LoadContract m = -> m (Maybe (Either (TempTx ContractCreatedInEra) SomeContractState)) -- ^ Nothing if the ID is not found --- | Signature for a delegate that loads the state of a single contract. +-- | Signature for a delegate that loads the state of a single withdrawal. type LoadWithdrawal m = TxId -- ^ ID of the contract to load -> m (Maybe (Either (TempTx WithdrawTxInEra) Withdrawal)) -- ^ Nothing if the ID is not found +-- | Signature for a delegate that looks a burn role token transaction up. +type LoadTempBurnRoleTokensTx m = + TxId + -- ^ ID of the burn role token Tx to load + -> m (Maybe (TempTx BurnRoleTokensTxInEra)) + -- ^ Nothing if the ID is not found + data LoadTxError = ContractNotFound | TxNotFound @@ -126,6 +153,7 @@ data SyncClient m = SyncClient , loadWithdrawal :: LoadWithdrawal m , loadPayouts :: LoadPayouts m , loadPayout :: LoadPayout m + , loadTempBurnRoleTokensTx :: LoadTempBurnRoleTokensTx m } syncClient :: (MonadUnliftIO m) => Component m (SyncClientDependencies m) (SyncClient m) @@ -173,4 +201,5 @@ syncClient = arr \SyncClientDependencies{..} -> Just contract -> pure $ Just $ Right contract , loadPayouts = fmap (runConnector connector . RunMarloweQueryClient) . getPayouts , loadPayout = runConnector connector . RunMarloweQueryClient . getPayout + , loadTempBurnRoleTokensTx = liftIO . atomically . lookupTempBurnRoleTokensTx } diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs index 0c6ca0e921..57195fd5c8 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Adapter/Server/TxClient.hs @@ -55,12 +55,16 @@ import Language.Marlowe.Runtime.Core.Api ( import Language.Marlowe.Runtime.Transaction.Api ( Account, ApplyInputsError, + BurnRoleTokensError, + BurnRoleTokensTx (..), + BurnRoleTokensTxInEra (BurnRoleTokensTxInEra), ContractCreated (..), ContractCreatedInEra (..), CreateError, InputsApplied (..), InputsAppliedInEra (..), MarloweTxCommand (..), + RoleTokenFilter, RoleTokensConfig, SubmitError, SubmitStatus (..), @@ -150,6 +154,13 @@ type Withdraw m = -> Set TxOutRef -> m (Either WithdrawError (WithdrawTx v)) +type BurnRoleTokens m = + forall v + . MarloweVersion v + -> WalletAddresses + -> RoleTokenFilter + -> m (Either BurnRoleTokensError (BurnRoleTokensTx v)) + data TempTxStatus = Unsigned | Submitted type Submit r m = r -> Submit' m @@ -163,17 +174,25 @@ data TempTx (tx :: Type -> MarloweVersionTag -> Type) where -- | Public API of the TxClient data TxClient r m = TxClient { createContract :: CreateContract m - , applyInputs :: ApplyInputs m - , withdraw :: Withdraw m + -- ^ Create a contract , submitContract :: ContractId -> Submit r m - , submitTransaction :: ContractId -> TxId -> Submit r m - , submitWithdrawal :: TxId -> Submit r m , lookupTempContract :: ContractId -> STM (Maybe (TempTx ContractCreatedInEra)) , getTempContracts :: STM [TempTx ContractCreatedInEra] - , lookupTempTransaction :: ContractId -> TxId -> STM (Maybe (TempTx InputsAppliedInEra)) + , applyInputs :: ApplyInputs m + -- ^ Apply inputs to a contract + , submitTransaction :: ContractId -> TxId -> Submit r m , getTempTransactions :: ContractId -> STM [TempTx InputsAppliedInEra] + , lookupTempTransaction :: ContractId -> TxId -> STM (Maybe (TempTx InputsAppliedInEra)) + , withdraw :: Withdraw m + -- ^ Withdraw + , submitWithdrawal :: TxId -> Submit r m , lookupTempWithdrawal :: TxId -> STM (Maybe (TempTx WithdrawTxInEra)) , getTempWithdrawals :: STM [TempTx WithdrawTxInEra] + , burnRoleTokens :: BurnRoleTokens m + -- ^ Burn Role Tokens + , submitBurnRoleTokens :: TxId -> Submit r m + , lookupTempBurnRoleTokensTx :: TxId -> STM (Maybe (TempTx BurnRoleTokensTxInEra)) + , getTempBurnRoleTokens :: STM [TempTx BurnRoleTokensTxInEra] } -- Basically a lens to the actual map of temp txs to modify within a structure. @@ -204,6 +223,7 @@ txClient = component "web-tx-client" \TxClientDependencies{..} -> do tempContracts <- newTVar mempty tempTransactions <- newTVar mempty tempWithdrawals <- newTVar mempty + tempRoleTokensBurn <- newTVar mempty submitQueue <- newTQueue let runSubmitGeneric @@ -265,11 +285,8 @@ txClient = component "web-tx-client" \TxClientDependencies{..} -> do ( runTxClient , TxClient { createContract = \stakeCredential version addresses threadName roles metadata minUTxODeposit accounts contract -> do - response <- - runConnector connector $ - RunTxClient $ - liftCommand $ - Create stakeCredential version addresses threadName roles metadata minUTxODeposit accounts contract + let command = Create stakeCredential version addresses threadName roles metadata minUTxODeposit accounts contract + response <- runConnector connector $ RunTxClient $ liftCommand command liftIO $ for_ response \(ContractCreated era creation@ContractCreatedInEra{contractId}) -> atomically $ modifyTVar tempContracts $ @@ -277,11 +294,8 @@ txClient = component "web-tx-client" \TxClientDependencies{..} -> do TempTx era version Unsigned creation pure response , applyInputs = \version addresses contractId metadata invalidBefore invalidHereafter inputs -> do - response <- - runConnector connector $ - RunTxClient $ - liftCommand $ - ApplyInputs version addresses contractId metadata invalidBefore invalidHereafter inputs + let command = ApplyInputs version addresses contractId metadata invalidBefore invalidHereafter inputs + response <- runConnector connector $ RunTxClient $ liftCommand command liftIO $ for_ response \(InputsApplied era application@InputsAppliedInEra{txBody}) -> do let txId = fromCardanoTxId $ getTxId txBody let tempTx = TempTx era version Unsigned application @@ -290,22 +304,35 @@ txClient = component "web-tx-client" \TxClientDependencies{..} -> do Map.alter (Just . maybe (Map.singleton txId tempTx) (Map.insert txId tempTx)) contractId pure response , withdraw = \version addresses payouts -> do - response <- runConnector connector $ RunTxClient $ liftCommand $ Withdraw version addresses payouts + let command = Withdraw version addresses payouts + response <- runConnector connector $ RunTxClient $ liftCommand command liftIO $ for_ response \(WithdrawTx era withdrawal@WithdrawTxInEra{txBody}) -> atomically $ modifyTVar tempWithdrawals $ Map.insert (fromCardanoTxId $ getTxId txBody) $ TempTx era version Unsigned withdrawal pure response + , burnRoleTokens = \version addresses roleTokenFilter -> do + let command = BurnRoleTokens version addresses roleTokenFilter + response <- runConnector connector $ RunTxClient $ liftCommand command + liftIO $ for_ response \(BurnRoleTokensTx era burnedTokensTx@BurnRoleTokensTxInEra{txBody}) -> + atomically $ + modifyTVar tempRoleTokensBurn $ + Map.insert (fromCardanoTxId $ getTxId txBody) $ + TempTx era version Unsigned burnedTokensTx + pure response , submitContract = \contractId -> genericSubmit $ SomeTVarWithMapUpdate tempContracts ($ contractId) , submitTransaction = \contractId txId -> genericSubmit $ SomeTVarWithMapUpdate tempTransactions \update -> Map.update (Just . update txId) contractId , submitWithdrawal = \txId -> genericSubmit $ SomeTVarWithMapUpdate tempWithdrawals ($ txId) + , submitBurnRoleTokens = \txId -> genericSubmit $ SomeTVarWithMapUpdate tempRoleTokensBurn ($ txId) , lookupTempContract = \contractId -> Map.lookup contractId <$> readTVar tempContracts , getTempContracts = fmap snd . Map.toAscList <$> readTVar tempContracts , lookupTempTransaction = \contractId txId -> (Map.lookup txId <=< Map.lookup contractId) <$> readTVar tempTransactions , getTempTransactions = \contractId -> fmap snd . foldMap Map.toList . Map.lookup contractId <$> readTVar tempTransactions , lookupTempWithdrawal = \txId -> Map.lookup txId <$> readTVar tempWithdrawals , getTempWithdrawals = fmap snd . Map.toAscList <$> readTVar tempWithdrawals + , lookupTempBurnRoleTokensTx = \txId -> Map.lookup txId <$> readTVar tempRoleTokensBurn + , getTempBurnRoleTokens = fmap snd . Map.toAscList <$> readTVar tempRoleTokensBurn } ) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs deleted file mode 100644 index 6e0176fbbc..0000000000 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Burn/API.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- | This module specifies the Marlowe Runtime Web API as a Servant API type. -module Language.Marlowe.Runtime.Web.Burn.API (BurnsAPI) where - -import Language.Marlowe.Runtime.Web.Contract.Next.Schema () - -import Language.Marlowe.Runtime.Web.Adapter.Servant (OperationId, RenameResponseSchema) -import Servant ( - Description, - Summary, - type (:>), - ) - -type BurnsAPI = PostBurnsAPI - --- :<|> Capture "burnId" TxId :> BurnAPI - --- | POST /role-token-burns sub-API -type PostBurnsAPI = - Summary "Burn role tokens" - :> Description - "Build an unsigned (Cardano) transaction body which burns role tokens matching a filter. \ - \Role tokens used by active contracts will not be burned and the request will fail if active role tokens are included. \ - \To submit the signed transaction, use the PUT /role-token-burns/{burnId} endpoint." - :> OperationId "burnRoleTokens" - :> RenameResponseSchema "BurnRoleTokensResponse" - --- :> ( ReqBody '[JSON] PostBurnRequest :> PostTxAPI (PostCreated '[JSON] (PostBurnResponse CardanoTxBody)) --- :<|> ReqBody '[JSON] PostBurnRequest :> PostTxAPI (PostCreated '[TxJSON BurnTx] (PostBurnResponse CardanoTx)) --- ) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs index e91d0e2996..7a1fd5cc25 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs @@ -20,10 +20,6 @@ module Language.Marlowe.Runtime.Web.Client ( getPayoutStatus, getPayouts, getPayoutsStatus, - getTransaction, - getTransactionStatus, - getTransactions, - getTransactionsStatus, getWithdrawal, getWithdrawalStatus, getWithdrawals, @@ -35,18 +31,12 @@ module Language.Marlowe.Runtime.Web.Client ( postContractSource, postContractSourceStatus, postContractStatus, - postTransaction, - postTransactionCreateTx, - postTransactionCreateTxStatus, - postTransactionStatus, postWithdrawal, postWithdrawalCreateTx, postWithdrawalCreateTxStatus, postWithdrawalStatus, putContract, putContractStatus, - putTransaction, - putTransactionStatus, putWithdrawal, putWithdrawalStatus, ) where @@ -78,9 +68,6 @@ import Language.Marlowe.Runtime.Web.Contract.API ( PostContractSourceResponse, PostContractsRequest, ) -import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( - GetTransactionsResponse, - ) import Language.Marlowe.Runtime.Web.Core.Address ( Address, StakeAddress, @@ -108,17 +95,13 @@ import Language.Marlowe.Runtime.Web.Status ( RuntimeStatus (RuntimeStatus), ) import Language.Marlowe.Runtime.Web.Tx.API ( - ApplyInputsTxEnvelope, CardanoTx, CardanoTxBody, CreateTxEnvelope, - Tx, - TxHeader, WithdrawTxEnvelope, ) import Language.Marlowe.Runtime.Web.Withdrawal.API ( GetWithdrawalsResponse, - PostTransactionsRequest, PostWithdrawalsRequest, Withdrawal, WithdrawalHeader, @@ -134,8 +117,8 @@ import Servant.Pipes () import Language.Marlowe.Runtime.Web.Core.Object.Schema () -client :: Client ClientM RuntimeAPI -client = ServantStreaming.client runtimeApi +runtimeClient :: Client ClientM RuntimeAPI +runtimeClient = ServantStreaming.client runtimeApi data Page field resource = Page { totalCount :: Int @@ -146,7 +129,7 @@ data Page field resource = Page healthcheck :: ClientM Bool healthcheck = do - let _ :<|> _ :<|> _ :<|> healthcheck' = client + let _ :<|> _ :<|> _ :<|> _ :<|> healthcheck' = runtimeClient (True <$ healthcheck') `catchError` const (pure False) extractStatus @@ -174,7 +157,7 @@ getContractsStatus -> Maybe (Range "contractId" TxOutRef) -> ClientM (RuntimeStatus, Page "contractId" ContractHeader) getContractsStatus roleCurrencies tags partyAddresses partyRoles range = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let getContracts' :<|> _ = contractsClient response <- getContracts' @@ -214,7 +197,7 @@ postContractStatus -> PostContractsRequest -> ClientM (RuntimeStatus, CreateTxEnvelope CardanoTxBody) postContractStatus stakeAddress changeAddress otherAddresses collateralUtxos request = do - let (_ :<|> getPost :<|> _) :<|> _ = client + let (_ :<|> getPost :<|> _) :<|> _ = runtimeClient let (postContractCreateTxBody' :<|> _) = getPost stakeAddress response <- postContractCreateTxBody' @@ -242,7 +225,7 @@ postContractCreateTxStatus -> PostContractsRequest -> ClientM (RuntimeStatus, CreateTxEnvelope CardanoTx) postContractCreateTxStatus stakeAddress changeAddress otherAddresses collateralUtxos request = do - let (_ :<|> getPost :<|> _) :<|> _ = client + let (_ :<|> getPost :<|> _) :<|> _ = runtimeClient let (_ :<|> postContractCreateTx') = getPost stakeAddress response <- postContractCreateTx' @@ -267,7 +250,7 @@ postContractSourceStatus -> Producer ObjectBundle IO () -> ClientM (RuntimeStatus, PostContractSourceResponse) postContractSourceStatus main bundles = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient let postContractSource' :<|> _ = contractSourcesClient response <- postContractSource' main bundles @@ -282,7 +265,7 @@ postContractSource = (fmap . fmap) snd . postContractSourceStatus getContractSourceStatus :: ContractSourceId -> Bool -> ClientM (RuntimeStatus, Contract) getContractSourceStatus contractSourceId expand = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient let _ :<|> contractSourceClient = contractSourcesClient let getContractSource' :<|> _ = contractSourceClient contractSourceId @@ -295,7 +278,7 @@ getContractSource = (fmap . fmap) snd . getContractSourceStatus getContractSourceAdjacencyStatus :: ContractSourceId -> ClientM (RuntimeStatus, Set ContractSourceId) getContractSourceAdjacencyStatus contractSourceId = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient let _ :<|> contractSourceClient = contractSourcesClient let _ :<|> getContractSourceAdjacency' :<|> _ = contractSourceClient contractSourceId @@ -308,7 +291,7 @@ getContractSourceAdjacency = fmap snd . getContractSourceAdjacencyStatus getContractSourceClosureStatus :: ContractSourceId -> ClientM (RuntimeStatus, Set ContractSourceId) getContractSourceClosureStatus contractSourceId = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient let _ :<|> contractSourceClient = contractSourcesClient let _ :<|> _ :<|> getContractSourceClosure' = contractSourceClient contractSourceId @@ -321,7 +304,7 @@ getContractSourceClosure = fmap snd . getContractSourceClosureStatus getContractStatus :: TxOutRef -> ClientM (RuntimeStatus, ContractState) getContractStatus contractId = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let _ :<|> _ :<|> contractApi :<|> _ = contractsClient let getContract' :<|> _ = contractApi contractId response <- getContract' @@ -333,7 +316,7 @@ getContract = fmap snd . getContractStatus putContractStatus :: TxOutRef -> TextEnvelope -> ClientM RuntimeStatus putContractStatus contractId tx = do - let contractsClient :<|> _ = client + let contractsClient :<|> _ = runtimeClient let _ :<|> _ :<|> contractApi :<|> _ = contractsClient let _ :<|> putContract' :<|> _ = contractApi contractId response <- putContract' tx @@ -347,7 +330,7 @@ getWithdrawalsStatus -> Maybe (Range "withdrawalId" TxId) -> ClientM (RuntimeStatus, Page "withdrawalId" WithdrawalHeader) getWithdrawalsStatus roleCurrencies range = do - let _ :<|> withdrawalsClient :<|> _ = client + let _ :<|> withdrawalsClient :<|> _ = runtimeClient let getWithdrawals' :<|> _ = withdrawalsClient response <- getWithdrawals' (foldMap Set.toList roleCurrencies) $ putRange <$> range totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response @@ -376,7 +359,7 @@ postWithdrawalStatus -> PostWithdrawalsRequest -> ClientM (RuntimeStatus, WithdrawTxEnvelope CardanoTxBody) postWithdrawalStatus changeAddress otherAddresses collateralUtxos request = do - let _ :<|> withdrawalsClient :<|> _ = client + let _ :<|> withdrawalsClient :<|> _ = runtimeClient let _ :<|> (postWithdrawal' :<|> _) :<|> _ = withdrawalsClient response <- postWithdrawal' @@ -402,7 +385,7 @@ postWithdrawalCreateTxStatus -> PostWithdrawalsRequest -> ClientM (RuntimeStatus, WithdrawTxEnvelope CardanoTx) postWithdrawalCreateTxStatus changeAddress otherAddresses collateralUtxos request = do - let _ :<|> withdrawalsClient :<|> _ = client + let _ :<|> withdrawalsClient :<|> _ = runtimeClient let _ :<|> (_ :<|> postWithdrawalCreateTx') :<|> _ = withdrawalsClient response <- postWithdrawalCreateTx' @@ -423,7 +406,7 @@ postWithdrawalCreateTx = (fmap . fmap . fmap . fmap) snd . postWithdrawalCreateT getWithdrawalStatus :: TxId -> ClientM (RuntimeStatus, Withdrawal) getWithdrawalStatus withdrawalId = do - let _ :<|> withdrawalsClient :<|> _ = client + let _ :<|> withdrawalsClient :<|> _ = runtimeClient let _ :<|> _ :<|> contractApi = withdrawalsClient let getWithdrawal' :<|> _ = contractApi withdrawalId response <- getWithdrawal' @@ -435,7 +418,7 @@ getWithdrawal = fmap snd . getWithdrawalStatus putWithdrawalStatus :: TxId -> TextEnvelope -> ClientM RuntimeStatus putWithdrawalStatus withdrawalId tx = do - let _ :<|> withdrawalsClient :<|> _ = client + let _ :<|> withdrawalsClient :<|> _ = runtimeClient let _ :<|> _ :<|> contractApi = withdrawalsClient let _ :<|> putWithdrawal' = contractApi withdrawalId response <- putWithdrawal' tx @@ -451,7 +434,7 @@ getPayoutsStatus -> Maybe (Range "payoutId" TxOutRef) -> ClientM (RuntimeStatus, Page "payoutId" PayoutHeader) getPayoutsStatus contractIds roleTokens unclaimed range = do - let _ :<|> _ :<|> payoutsClient :<|> _ = client + let _ :<|> _ :<|> payoutsClient :<|> _ = runtimeClient let getPayouts' :<|> _ = payoutsClient response <- getPayouts' (foldMap Set.toList contractIds) (foldMap Set.toList roleTokens) unclaimed $ @@ -481,7 +464,7 @@ getPayoutStatus :: TxOutRef -> ClientM (RuntimeStatus, PayoutState) getPayoutStatus payoutId = do - let _ :<|> _ :<|> payoutsClient :<|> _ = client + let _ :<|> _ :<|> payoutsClient :<|> _ = runtimeClient let _ :<|> getPayout' = payoutsClient response <- getPayout' payoutId status <- extractStatus response @@ -495,116 +478,6 @@ getPayout -> ClientM PayoutState getPayout = fmap snd . getPayoutStatus -getTransactionsStatus - :: TxOutRef - -> Maybe (Range "transactionId" TxId) - -> ClientM (RuntimeStatus, Page "transactionId" TxHeader) -getTransactionsStatus contractId range = do - let contractsClient :<|> _ = client - let _ :<|> _ :<|> contractApi :<|> _ = contractsClient - let _ :<|> _ :<|> _ :<|> getTransactions' :<|> _ = contractApi contractId - response <- getTransactions' $ putRange <$> range - totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response - nextRanges <- headerValue $ lookupResponseHeader @"Next-Range" response - let ListObject items = getResponse response - status <- extractStatus response - pure - ( status - , Page - { totalCount - , nextRange = extractRangeSingleton @GetTransactionsResponse <$> nextRanges - , items = retractLink <$> items - } - ) - -getTransactions - :: TxOutRef - -> Maybe (Range "transactionId" TxId) - -> ClientM (Page "transactionId" TxHeader) -getTransactions = (fmap . fmap) snd . getTransactionsStatus - -postTransactionStatus - :: Address - -> Maybe (Set Address) - -> Maybe (Set TxOutRef) - -> TxOutRef - -> PostTransactionsRequest - -> ClientM (RuntimeStatus, ApplyInputsTxEnvelope CardanoTxBody) -postTransactionStatus changeAddress otherAddresses collateralUtxos contractId request = do - let contractsClient :<|> _ = client - let _ :<|> _ :<|> contractApi :<|> _ = contractsClient - let _ :<|> _ :<|> _ :<|> _ :<|> (postTransaction' :<|> _) :<|> _ = contractApi contractId - response <- - postTransaction' - request - changeAddress - (setToCommaList <$> otherAddresses) - (setToCommaList <$> collateralUtxos) - status <- extractStatus response - pure (status, retractLink $ getResponse response) - -postTransaction - :: Address - -> Maybe (Set Address) - -> Maybe (Set TxOutRef) - -> TxOutRef - -> PostTransactionsRequest - -> ClientM (ApplyInputsTxEnvelope CardanoTxBody) -postTransaction = (fmap . fmap . fmap . fmap . fmap) snd . postTransactionStatus - -postTransactionCreateTxStatus - :: Address - -> Maybe (Set Address) - -> Maybe (Set TxOutRef) - -> TxOutRef - -> PostTransactionsRequest - -> ClientM (RuntimeStatus, ApplyInputsTxEnvelope CardanoTx) -postTransactionCreateTxStatus changeAddress otherAddresses collateralUtxos contractId request = do - let (_ :<|> _ :<|> contractApi :<|> _) :<|> _ = client - let _ :<|> _ :<|> _ :<|> _ :<|> (_ :<|> postTransactionCreateTx') :<|> _ = contractApi contractId - response <- - postTransactionCreateTx' - request - changeAddress - (setToCommaList <$> otherAddresses) - (setToCommaList <$> collateralUtxos) - status <- extractStatus response - pure (status, retractLink $ getResponse response) - -postTransactionCreateTx - :: Address - -> Maybe (Set Address) - -> Maybe (Set TxOutRef) - -> TxOutRef - -> PostTransactionsRequest - -> ClientM (ApplyInputsTxEnvelope CardanoTx) -postTransactionCreateTx = (fmap . fmap . fmap . fmap . fmap) snd . postTransactionCreateTxStatus - -getTransactionStatus :: TxOutRef -> TxId -> ClientM (RuntimeStatus, Tx) -getTransactionStatus contractId transactionId = do - let contractsClient :<|> _ = client - let _ :<|> _ :<|> contractApi :<|> _ = contractsClient - let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> transactionApi = contractApi contractId - let getTransaction' :<|> _ = transactionApi transactionId - response <- getTransaction' - status <- extractStatus response - pure (status, retractLink $ retractLink $ getResponse response) - -getTransaction :: TxOutRef -> TxId -> ClientM Tx -getTransaction = (fmap . fmap) snd . getTransactionStatus - -putTransactionStatus :: TxOutRef -> TxId -> TextEnvelope -> ClientM RuntimeStatus -putTransactionStatus contractId transactionId tx = do - let contractsClient :<|> _ = client - let _ :<|> _ :<|> contractApi :<|> _ = contractsClient - let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> transactionApi = contractApi contractId - let _ :<|> putTransaction' = transactionApi transactionId - response <- putTransaction' tx - extractStatus response - -putTransaction :: TxOutRef -> TxId -> TextEnvelope -> ClientM () -putTransaction = (fmap . fmap) void . putTransactionStatus - setToCommaList :: Set a -> CommaList a setToCommaList = CommaList . Set.toList diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs index 83f2a0198e..d975779672 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/API.hs @@ -123,7 +123,15 @@ import qualified Data.OpenApi as OpenApi import qualified Data.Text as T import Language.Marlowe.Runtime.Web.Adapter.ByteString (hasLength) import Language.Marlowe.Runtime.Web.Core.Base16 (Base16 (..)) -import Language.Marlowe.Runtime.Web.Tx.API +import Language.Marlowe.Runtime.Web.Tx.API ( + CardanoTx, + CardanoTxBody, + ContractTx, + CreateTxEnvelope, + PostTxAPI, + PutSignedTxAPI, + TxJSON, + ) type ContractsAPI = GetContractsAPI diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs index 27bc335511..0f30a6e8e4 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Server.hs @@ -81,9 +81,9 @@ import Language.Marlowe.Runtime.Web.Core.Asset ( ) import Language.Marlowe.Runtime.Web.Core.Tx ( TextEnvelope (..), + TxBodyInAnyEra (..), TxOutRef, ) -import Language.Marlowe.Runtime.Web.Withdrawal.Server (TxBodyInAnyEra (..)) import Language.Marlowe.Runtime.Web.Tx.API ( CardanoTx, diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs index 80fd3ece3d..4be14f9890 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/API.hs @@ -15,6 +15,7 @@ module Language.Marlowe.Runtime.Web.Contract.Transaction.API ( TransactionsAPI, GetTransactionsAPI, + PostTransactionsAPI, GetTransactionsResponse, TransactionAPI, GetTransactionAPI, @@ -31,7 +32,7 @@ import Language.Marlowe.Runtime.Web.Adapter.Servant ( RenameResponseSchema, ) import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () -import Language.Marlowe.Runtime.Web.Core.Tx +import Language.Marlowe.Runtime.Web.Core.Tx (TxId) import Language.Marlowe.Runtime.Web.Tx.API ( ApplyInputsTx, ApplyInputsTxEnvelope, diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Client.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Client.hs new file mode 100644 index 0000000000..9fdeb62e32 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Client.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module Language.Marlowe.Runtime.Web.Contract.Transaction.Client ( + getTransaction, + getTransactionStatus, + getTransactions, + getTransactionsStatus, + postTransaction, + postTransactionCreateTx, + postTransactionCreateTxStatus, + postTransactionStatus, + putTransaction, + putTransactionStatus, +) where + +import Control.Monad.IO.Class (liftIO) +import Data.Functor (void) +import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Version (Version) +import GHC.TypeLits (KnownSymbol, symbolVal) + +import Language.Marlowe.Runtime.Web.API (RuntimeAPI, runtimeApi) +import Language.Marlowe.Runtime.Web.Adapter.CommaList ( + CommaList (CommaList), + ) +import Language.Marlowe.Runtime.Web.Adapter.Links (retractLink) +import Language.Marlowe.Runtime.Web.Adapter.Servant (ListObject (..)) +import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( + GetTransactionsResponse, + ) +import Language.Marlowe.Runtime.Web.Core.Address ( + Address, + ) + +import Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId) +import Language.Marlowe.Runtime.Web.Core.Tip (ChainTip) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope, + TxId, + TxOutRef, + ) +import Language.Marlowe.Runtime.Web.Status ( + RuntimeStatus (RuntimeStatus), + ) +import Language.Marlowe.Runtime.Web.Tx.API ( + ApplyInputsTxEnvelope, + CardanoTx, + CardanoTxBody, + Tx, + TxHeader, + ) +import Language.Marlowe.Runtime.Web.Withdrawal.API ( + PostTransactionsRequest, + ) +import Servant (HasResponseHeader, ResponseHeader (..), getResponse, lookupResponseHeader, type (:<|>) ((:<|>))) +import Servant.API (Headers) +import Servant.Client (Client) +import Servant.Client.Streaming (ClientM) +import qualified Servant.Client.Streaming as ServantStreaming +import Servant.Pagination (ExtractRange (extractRange), HasPagination (..), PutRange (..), Range, Ranges) +import Servant.Pipes () + +import Language.Marlowe.Runtime.Web.Client (Page (..)) +import Language.Marlowe.Runtime.Web.Core.Object.Schema () + +runtimeClient :: Client ClientM RuntimeAPI +runtimeClient = ServantStreaming.client runtimeApi + +extractStatus + :: ( HasResponseHeader "X-Node-Tip" ChainTip hs + , HasResponseHeader "X-Runtime-Chain-Tip" ChainTip hs + , HasResponseHeader "X-Runtime-Tip" ChainTip hs + , HasResponseHeader "X-Network-Id" NetworkId hs + , HasResponseHeader "X-Runtime-Version" Version hs + ) + => Headers hs a + -> ClientM RuntimeStatus +extractStatus response = + RuntimeStatus + <$> (reqHeaderValue $ lookupResponseHeader @"X-Node-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Chain-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Network-Id" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Version" response) + +getTransactionsStatus + :: TxOutRef + -> Maybe (Range "transactionId" TxId) + -> ClientM (RuntimeStatus, Page "transactionId" TxHeader) +getTransactionsStatus contractId range = do + let contractsClient :<|> _ = runtimeClient + let _ :<|> _ :<|> contractApi :<|> _ = contractsClient + let _ :<|> _ :<|> _ :<|> getTransactions' :<|> _ = contractApi contractId + response <- getTransactions' $ putRange <$> range + totalCount <- reqHeaderValue $ lookupResponseHeader @"Total-Count" response + nextRanges <- headerValue $ lookupResponseHeader @"Next-Range" response + let ListObject items = getResponse response + status <- extractStatus response + pure + ( status + , Page + { totalCount + , nextRange = extractRangeSingleton @GetTransactionsResponse <$> nextRanges + , items = retractLink <$> items + } + ) + +getTransactions + :: TxOutRef + -> Maybe (Range "transactionId" TxId) + -> ClientM (Page "transactionId" TxHeader) +getTransactions = (fmap . fmap) snd . getTransactionsStatus + +postTransactionStatus + :: Address + -> Maybe (Set Address) + -> Maybe (Set TxOutRef) + -> TxOutRef + -> PostTransactionsRequest + -> ClientM (RuntimeStatus, ApplyInputsTxEnvelope CardanoTxBody) +postTransactionStatus changeAddress otherAddresses collateralUtxos contractId request = do + let contractsClient :<|> _ = runtimeClient + let _ :<|> _ :<|> contractApi :<|> _ = contractsClient + let _ :<|> _ :<|> _ :<|> _ :<|> (postTransaction' :<|> _) :<|> _ = contractApi contractId + response <- + postTransaction' + request + changeAddress + (setToCommaList <$> otherAddresses) + (setToCommaList <$> collateralUtxos) + status <- extractStatus response + pure (status, retractLink $ getResponse response) + +postTransaction + :: Address + -> Maybe (Set Address) + -> Maybe (Set TxOutRef) + -> TxOutRef + -> PostTransactionsRequest + -> ClientM (ApplyInputsTxEnvelope CardanoTxBody) +postTransaction = (fmap . fmap . fmap . fmap . fmap) snd . postTransactionStatus + +postTransactionCreateTxStatus + :: Address + -> Maybe (Set Address) + -> Maybe (Set TxOutRef) + -> TxOutRef + -> PostTransactionsRequest + -> ClientM (RuntimeStatus, ApplyInputsTxEnvelope CardanoTx) +postTransactionCreateTxStatus changeAddress otherAddresses collateralUtxos contractId request = do + let (_ :<|> _ :<|> contractApi :<|> _) :<|> _ = runtimeClient + let _ :<|> _ :<|> _ :<|> _ :<|> (_ :<|> postTransactionCreateTx') :<|> _ = contractApi contractId + response <- + postTransactionCreateTx' + request + changeAddress + (setToCommaList <$> otherAddresses) + (setToCommaList <$> collateralUtxos) + status <- extractStatus response + pure (status, retractLink $ getResponse response) + +postTransactionCreateTx + :: Address + -> Maybe (Set Address) + -> Maybe (Set TxOutRef) + -> TxOutRef + -> PostTransactionsRequest + -> ClientM (ApplyInputsTxEnvelope CardanoTx) +postTransactionCreateTx = (fmap . fmap . fmap . fmap . fmap) snd . postTransactionCreateTxStatus + +getTransactionStatus :: TxOutRef -> TxId -> ClientM (RuntimeStatus, Tx) +getTransactionStatus contractId transactionId = do + let contractsClient :<|> _ = runtimeClient + let _ :<|> _ :<|> contractApi :<|> _ = contractsClient + let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> transactionApi = contractApi contractId + let getTransaction' :<|> _ = transactionApi transactionId + response <- getTransaction' + status <- extractStatus response + pure (status, retractLink $ retractLink $ getResponse response) + +getTransaction :: TxOutRef -> TxId -> ClientM Tx +getTransaction = (fmap . fmap) snd . getTransactionStatus + +putTransactionStatus :: TxOutRef -> TxId -> TextEnvelope -> ClientM RuntimeStatus +putTransactionStatus contractId transactionId tx = do + let contractsClient :<|> _ = runtimeClient + let _ :<|> _ :<|> contractApi :<|> _ = contractsClient + let _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> transactionApi = contractApi contractId + let _ :<|> putTransaction' = transactionApi transactionId + response <- putTransaction' tx + extractStatus response + +putTransaction :: TxOutRef -> TxId -> TextEnvelope -> ClientM () +putTransaction = (fmap . fmap) void . putTransactionStatus + +setToCommaList :: Set a -> CommaList a +setToCommaList = CommaList . Set.toList + +reqHeaderValue :: forall name a. (KnownSymbol name) => ResponseHeader name a -> ClientM a +reqHeaderValue = \case + Header a -> pure a + UndecodableHeader _ -> liftIO $ fail $ "Unable to decode header " <> symbolVal (Proxy @name) + MissingHeader -> liftIO $ fail $ "Required header missing " <> symbolVal (Proxy @name) + +headerValue :: forall name a. (KnownSymbol name) => ResponseHeader name a -> ClientM (Maybe a) +headerValue = \case + Header a -> pure $ Just a + UndecodableHeader _ -> liftIO $ fail $ "Unable to decode header " <> symbolVal (Proxy @name) + MissingHeader -> pure Nothing + +extractRangeSingleton + :: (HasPagination resource field) + => Ranges '[field] resource + -> Range field (RangeType resource field) +extractRangeSingleton = fromJust . extractRange diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs index 03c3a11282..3225f07563 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Contract/Transaction/Server.hs @@ -57,14 +57,15 @@ import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (TempTx), Te import Language.Marlowe.Runtime.Web.Adapter.Server.Util (makeSignedTxWithWitnessKeys) import Language.Marlowe.Runtime.Web.Contract.Transaction.API ( GetTransactionResponse, + GetTransactionsAPI, GetTransactionsResponse, + PostTransactionsAPI, PostTransactionsResponse, TransactionAPI, TransactionsAPI, ) import Language.Marlowe.Runtime.Web.Core.Address (Address) -import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope (..), TxId, TxOutRef) -import Language.Marlowe.Runtime.Web.Withdrawal.Server (TxBodyInAnyEra (..)) +import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope (..), TxBodyInAnyEra (..), TxId, TxOutRef) import Language.Marlowe.Runtime.Web.Tx.API ( ApplyInputsTxEnvelope (ApplyInputsTxEnvelope), @@ -93,15 +94,24 @@ import Servant.Pagination ( server :: TxOutRef -> ServerT TransactionsAPI ServerM server contractId = - get contractId - :<|> (postCreateTxBodyResponse contractId :<|> postCreateTxResponse contractId) - :<|> transactionServer contractId + getTransactionsAPI contractId + :<|> postTransactionsAPI + :<|> transactionAPI contractId + where + getTransactionsAPI :: TxOutRef -> ServerT GetTransactionsAPI ServerM + getTransactionsAPI = getTransactionsByContractId + + postTransactionsAPI :: ServerT PostTransactionsAPI ServerM + postTransactionsAPI = buildCreateContractTxBody contractId :<|> buildCreateContractTx contractId -get + transactionAPI :: TxOutRef -> TxId -> ServerT TransactionAPI ServerM + transactionAPI contractId' txId = getTransaction contractId' txId :<|> submitCreateContractTx contractId txId + +getTransactionsByContractId :: TxOutRef -> Maybe (Ranges '["transactionId"] GetTransactionsResponse) -> ServerM (PaginatedResponse '["transactionId"] GetTransactionsResponse) -get contractId ranges = do +getTransactionsByContractId contractId ranges = do let range :: Range "transactionId" TxId range = fromMaybe (getDefaultRange (Proxy @TxHeader)) $ extractRange =<< ranges contractId' <- fromDTOThrow (badRequest' "Invalid contract id value") contractId @@ -113,14 +123,46 @@ get contractId ranges = do let headers' = toDTO items addHeader totalCount . fmap ListObject <$> returnRange range (IncludeLink (Proxy @"transaction") <$> headers') -postCreateTxBody +buildCreateContractTxBody + :: TxOutRef + -> PostTransactionsRequest + -> Address + -> Maybe (CommaList Address) + -> Maybe (CommaList TxOutRef) + -> ServerM (PostTransactionsResponse CardanoTxBody) +buildCreateContractTxBody contractId req changeAddressDTO mAddresses mCollateralUtxos = do + TxBodyInAnyEra txBody <- buildCreateContractTxBody' contractId req changeAddressDTO mAddresses mCollateralUtxos + pure $ + IncludeLink (Proxy @"transaction") $ + ApplyInputsTxEnvelope + contractId + (toDTO $ fromCardanoTxId $ getTxId txBody) + (toDTO txBody) + +buildCreateContractTx + :: TxOutRef + -> PostTransactionsRequest + -> Address + -> Maybe (CommaList Address) + -> Maybe (CommaList TxOutRef) + -> ServerM (PostTransactionsResponse CardanoTx) +buildCreateContractTx contractId req changeAddressDTO mAddresses mCollateralUtxos = do + TxBodyInAnyEra txBody <- buildCreateContractTxBody' contractId req changeAddressDTO mAddresses mCollateralUtxos + pure $ + IncludeLink (Proxy @"transaction") $ + ApplyInputsTxEnvelope + contractId + (toDTO $ fromCardanoTxId $ getTxId txBody) + (toDTO $ makeSignedTransaction [] txBody) + +buildCreateContractTxBody' :: TxOutRef -> PostTransactionsRequest -> Address -> Maybe (CommaList Address) -> Maybe (CommaList TxOutRef) -> ServerM TxBodyInAnyEra -postCreateTxBody contractId PostTransactionsRequest{..} changeAddressDTO mAddresses mCollateralUtxos = do +buildCreateContractTxBody' contractId PostTransactionsRequest{..} changeAddressDTO mAddresses mCollateralUtxos = do SomeMarloweVersion v@MarloweV1 <- fromDTOThrow (badRequest' "Invalid Marlowe version") version changeAddress <- fromDTOThrow (badRequest' "Invalid change address") changeAddressDTO extraAddresses <- @@ -139,42 +181,8 @@ postCreateTxBody contractId PostTransactionsRequest{..} changeAddressDTO mAddres Right (InputsApplied BabbageEraOnwardsBabbage InputsAppliedInEra{txBody}) -> pure $ TxBodyInAnyEra txBody Right (InputsApplied BabbageEraOnwardsConway InputsAppliedInEra{txBody}) -> pure $ TxBodyInAnyEra txBody -postCreateTxBodyResponse - :: TxOutRef - -> PostTransactionsRequest - -> Address - -> Maybe (CommaList Address) - -> Maybe (CommaList TxOutRef) - -> ServerM (PostTransactionsResponse CardanoTxBody) -postCreateTxBodyResponse contractId req changeAddressDTO mAddresses mCollateralUtxos = do - TxBodyInAnyEra txBody <- postCreateTxBody contractId req changeAddressDTO mAddresses mCollateralUtxos - let txBody' = toDTO txBody - let txId = toDTO $ fromCardanoTxId $ getTxId txBody - let body = ApplyInputsTxEnvelope contractId txId txBody' - pure $ IncludeLink (Proxy @"transaction") body - -postCreateTxResponse - :: TxOutRef - -> PostTransactionsRequest - -> Address - -> Maybe (CommaList Address) - -> Maybe (CommaList TxOutRef) - -> ServerM (PostTransactionsResponse CardanoTx) -postCreateTxResponse contractId req changeAddressDTO mAddresses mCollateralUtxos = do - TxBodyInAnyEra txBody <- postCreateTxBody contractId req changeAddressDTO mAddresses mCollateralUtxos - let txId = toDTO $ fromCardanoTxId $ getTxId txBody - let tx = makeSignedTransaction [] txBody - let tx' = toDTO tx - let body = ApplyInputsTxEnvelope contractId txId tx' - pure $ IncludeLink (Proxy @"transaction") body - -transactionServer :: TxOutRef -> TxId -> ServerT TransactionAPI ServerM -transactionServer contractId txId = - getOne contractId txId - :<|> put contractId txId - -getOne :: TxOutRef -> TxId -> ServerM GetTransactionResponse -getOne contractId txId = do +getTransaction :: TxOutRef -> TxId -> ServerM GetTransactionResponse +getTransaction contractId txId = do contractId' <- fromDTOThrow (badRequest' "Invalid contract id value") contractId txId' <- fromDTOThrow (badRequest' "Invalid transaction id value") txId loadTransaction contractId' txId' >>= \case @@ -185,8 +193,8 @@ getOne contractId txId = do IncludeLink (Proxy @"previous") $ IncludeLink (Proxy @"next") contractState -put :: TxOutRef -> TxId -> TextEnvelope -> ServerM NoContent -put contractId txId body = do +submitCreateContractTx :: TxOutRef -> TxId -> TextEnvelope -> ServerM NoContent +submitCreateContractTx contractId txId body = do contractId' <- fromDTOThrow (badRequest' "Invalid contract id value") contractId txId' <- fromDTOThrow (badRequest' "Invalid transaction id value") txId loadTransaction contractId' txId' >>= \case diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs index 8092923ffa..2249e85f17 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Roles.hs @@ -16,7 +16,6 @@ module Language.Marlowe.Runtime.Web.Core.Roles ( RoleTokenRecipient (..), TokenMetadata (..), TokenMetadataFile (..), - RoleTokenFilter (..), ) where import Control.Applicative ((<|>)) @@ -29,29 +28,25 @@ import Data.Aeson ( KeyValue ((.=)), ToJSON (toJSON), ToJSONKey (toJSONKey), - Value (Array, Bool, Object, String), + Value (String), object, withObject, withText, (.:), (.:?), - (), ) import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as AMap -import qualified Data.Aeson.KeyMap as KeyMap -import Data.Aeson.Types (JSONPathElement (..), Parser, prependFailure, toJSONKeyText, typeMismatch) +import Data.Aeson.Types (toJSONKeyText) import Data.Map (Map) import qualified Data.Map as Map import Data.OpenApi ( AdditionalProperties (..), - Definitions, HasAdditionalProperties (..), HasType (..), NamedSchema (..), OpenApiType (..), Referenced (..), - Schema, ToSchema, declareSchemaRef, enum_, @@ -60,10 +55,7 @@ import Data.OpenApi ( required, ) import qualified Data.OpenApi as OpenApi -import Data.OpenApi.Declare (Declare) import Data.OpenApi.Schema (ToSchema (..)) -import Data.Set (Set) -import qualified Data.Set as Set import Data.Text (Text) import Data.Traversable (for) import Data.Word (Word64) @@ -74,12 +66,10 @@ import Language.Marlowe.Runtime.Web.Adapter.URI ( ) import Language.Marlowe.Runtime.Web.Core.Address (Address (..)) import Language.Marlowe.Runtime.Web.Core.Asset ( - AssetId, PolicyId, ) import Language.Marlowe.Runtime.Web.Core.Metadata (Metadata) import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () -import Language.Marlowe.Runtime.Web.Core.Tx (TxOutRef) import Servant ( Proxy (..), URI, @@ -367,126 +357,3 @@ instance ToSchema TokenMetadataFile where , ("mediaType", stringSchema) ] & additionalProperties ?~ AdditionalPropertiesSchema metadataSchema - -data RoleTokenFilter - = RoleTokenAnd RoleTokenFilter RoleTokenFilter - | RoleTokenOr RoleTokenFilter RoleTokenFilter - | RoleTokenNot RoleTokenFilter - | RoleTokenFilterNone - | RoleTokenFilterByContracts (Set TxOutRef) - | RoleTokenFilterByPolicies (Set PolicyId) - | RoleTokenFilterByTokens (Set AssetId) - | RoleTokenFilterAny - deriving stock (Show, Eq, Ord, Generic) - -instance ToJSON RoleTokenFilter where - toJSON = \case - RoleTokenAnd a b -> object ["and" .= (a, b)] - RoleTokenOr a b -> object ["or" .= (a, b)] - RoleTokenNot a -> object ["not" .= a] - RoleTokenFilterNone -> toJSON False - RoleTokenFilterByContracts contracts -> object ["contract_id" .= contracts] - RoleTokenFilterByPolicies policies -> object ["roles_currency" .= policies] - RoleTokenFilterByTokens tokens -> object ["role_tokens" .= tokens] - RoleTokenFilterAny -> toJSON True - -instance FromJSON RoleTokenFilter where - parseJSON = - prependFailure "Parsing RoleTokenFilter failed" . \case - Object o -> case KeyMap.toList o of - [(k, v)] -> case k of - "and" -> uncurry RoleTokenAnd <$> parseJSON v Key "and" - "or" -> uncurry RoleTokenOr <$> parseJSON v Key "or" - "not" -> RoleTokenNot <$> parseJSON v Key "not" - "contract_id" -> RoleTokenFilterByContracts <$> parseSetOrSingle v Key "contract_id" - "roles_currency" -> RoleTokenFilterByPolicies <$> parseSetOrSingle v Key "roles_currency" - "role_tokens" -> RoleTokenFilterByTokens <$> parseSetOrSingle v Key "role_tokens" - _ -> fail $ "Unexpected key: " <> show k - _ -> fail "Unexpected number of keys, expected exactly 1." - Bool True -> pure RoleTokenFilterAny - Bool False -> pure RoleTokenFilterNone - v -> typeMismatch "object|boolean" v - -parseSetOrSingle :: (FromJSON a, Ord a) => Value -> Parser (Set a) -parseSetOrSingle = \case - Array arr -> parseJSON $ Array arr - v -> Set.singleton <$> parseJSON v - -instance ToSchema RoleTokenFilter where - declareNamedSchema _ = do - roleTokenFilterSchema <- declareSchemaRef $ Proxy @RoleTokenFilter - roleTokenFilterPairSchema <- declareSchemaRef $ Proxy @(RoleTokenFilter, RoleTokenFilter) - let setOrSingleSchema - :: forall a - . (ToSchema a) - => Proxy a - -> Declare (Definitions Schema) (Referenced Schema) - setOrSingleSchema p = do - singleSchema <- declareSchemaRef p - setSchema <- declareSchemaRef $ Proxy @(Set a) - pure $ Inline $ mempty & oneOf ?~ [singleSchema, setSchema] - txOutRefSchema <- setOrSingleSchema $ Proxy @TxOutRef - policyIdSchema <- setOrSingleSchema $ Proxy @PolicyId - assetIdSchema <- setOrSingleSchema $ Proxy @AssetId - let andSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens matched by both sub-filters." - & required .~ ["and"] - & properties .~ [("and", roleTokenFilterPairSchema)] - orSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens matched by either sub-filter." - & required .~ ["or"] - & properties .~ [("or", roleTokenFilterPairSchema)] - notSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens not matched by the sub-filter." - & required .~ ["not"] - & properties .~ [("not", roleTokenFilterSchema)] - anySchema = - mempty - & type_ ?~ OpenApiBoolean - & OpenApi.description ?~ "Matches any role token." - & enum_ ?~ [Bool True] - noneSchema = - mempty - & type_ ?~ OpenApiBoolean - & OpenApi.description ?~ "Matches no role token." - & enum_ ?~ [Bool False] - contractsSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens used by the given contract(s)." - & required .~ ["contract_id"] - & properties .~ [("contract_id", txOutRefSchema)] - policiesSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches any role tokens with the given currency symbol(s)." - & required .~ ["roles_currency"] - & properties .~ [("roles_currency", policyIdSchema)] - tokensSchema = - mempty - & type_ ?~ OpenApiObject - & OpenApi.description ?~ "Matches only the given role token(s)." - & required .~ ["role_tokens"] - & properties .~ [("role_tokens", assetIdSchema)] - pure $ - NamedSchema (Just "RoleTokenFilter") $ - mempty - & OpenApi.description ?~ "A filter that selects role tokens for burning." - & oneOf - ?~ fmap - Inline - [ andSchema - , orSchema - , notSchema - , anySchema - , noneSchema - , contractsSchema - , policiesSchema - , tokensSchema - ] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs index d8128427c1..bc483a7e55 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Core/Tx.hs @@ -14,6 +14,7 @@ {-# LANGUAGE UndecidableSuperClasses #-} module Language.Marlowe.Runtime.Web.Core.Tx ( + TxBodyInAnyEra (..), TxOutRef (..), TxId (..), TextEnvelope (..), @@ -44,6 +45,7 @@ import Servant ( ToHttpApiData (toUrlPiece), ) +import Cardano.Api (IsShelleyBasedEra, TxBody) import Data.OpenApi ( HasEnum (enum_), HasType (..), @@ -67,6 +69,9 @@ import Data.Word (Word16) import Language.Marlowe.Runtime.Web.Adapter.ByteString (hasLength) import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +data TxBodyInAnyEra where + TxBodyInAnyEra :: (IsShelleyBasedEra era) => TxBody era -> TxBodyInAnyEra + newtype TxId = TxId {unTxId :: ByteString} deriving (Eq, Ord, Generic) deriving (Show, ToHttpApiData, ToJSON) via Base16 diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/API.hs new file mode 100644 index 0000000000..2b61a5b672 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/API.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | This module specifies the Marlowe Runtime Web API as a Servant API type. +module Language.Marlowe.Runtime.Web.Role.API ( + BurnRoleTokensTxEnvelope (..), + BurnTokensTx, + SubmitBurnTokensTxAPI, + RoleAPI, +) where + +import Language.Marlowe.Runtime.Web.Adapter.Servant (OperationId, RenameResponseSchema) +import Language.Marlowe.Runtime.Web.Contract.Next.Schema () +import Servant ( + Accept (contentType), + JSON, + MimeRender (mimeRender), + MimeUnrender (mimeUnrender), + Proxy (..), + ReqBody, + type (:>), + ) + +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson ( + FromJSON (parseJSON), + ToJSON (toJSON), + eitherDecode, + encode, + object, + withObject, + (.:), + ) +import Data.OpenApi ( + HasProperties (properties), + HasRequired (required), + HasType (type_), + NamedSchema (NamedSchema), + OpenApiType (OpenApiObject), + ToSchema (..), + declareSchemaRef, + ) +import qualified Data.OpenApi as OpenApi +import GHC.Generics (Generic) + +import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope, TxId) +import Language.Marlowe.Runtime.Web.Role.TokenFilter (RoleTokenFilter) +import Language.Marlowe.Runtime.Web.Tx.API ( + CardanoTx, + CardanoTxBody, + PostTxAPI, + PutSignedTxAPI, + TxJSON, + ) +import Network.HTTP.Media ((//)) +import Servant.API ( + Capture, + Description, + PostCreated, + Summary, + type (:<|>), + ) + +type RoleAPI = + "role-tokens" :> "burnTxs" :> (BuildBurnTokensTxAPI :<|> Capture "TxId" TxId :> SubmitBurnTokensTxAPI) + +data BurnTokensTx + +instance Accept (TxJSON BurnTokensTx) where + contentType _ = "application" // "vendor.iog.marlowe-runtime.burn-role-tokens-tx-json" + +instance MimeRender (TxJSON BurnTokensTx) (BurnRoleTokensTxEnvelope CardanoTx) where + mimeRender _ = encode . toJSON + +instance MimeUnrender (TxJSON BurnTokensTx) (BurnRoleTokensTxEnvelope CardanoTx) where + mimeUnrender _ = eitherDecode + +type BuildBurnTokensTxAPI = + Summary "Build a Burn role tokens Transation" + :> Description + "Build an unsigned (Cardano) transaction body which burns role tokens matching a filter. \ + \Role tokens used by active contracts will not be burned and the request will fail if active role tokens are included. \ + \To submit the signed transaction, use the PUT /roles/burnTokensTxs/submit endpoint." + :> OperationId "buildBurnRoleTokensTx" + :> RenameResponseSchema "BurnRoleTokensResponse" + :> ( ReqBody '[JSON] RoleTokenFilter :> PostTxAPI (PostCreated '[JSON] (BurnRoleTokensTxEnvelope CardanoTxBody)) + :<|> ReqBody '[JSON] RoleTokenFilter :> PostTxAPI (PostCreated '[TxJSON BurnTokensTx] (BurnRoleTokensTxEnvelope CardanoTx)) + ) + +type SubmitBurnTokensTxAPI = + Summary "Submit a Burn Role Token Transaction" + :> Description + "Submit a signed (Cardano) transaction that burns role tokens. \ + \The transaction must have originally been created by the POST /roles/burnTokensTxs/build endpoint. \ + \This endpoint will respond when the transaction is submitted successfully to the local node, which means \ + \it will not wait for the transaction to be published in a block. \ + \Use the GET /roles/burn/{burnId} endpoint to poll the on-chain status." + :> OperationId "submitBurnRoleTokensTx" + :> PutSignedTxAPI + +data BurnRoleTokensTxEnvelope tx = BurnRoleTokensTxEnvelope + { txId :: TxId + , txEnvelope :: TextEnvelope + } + deriving (Show, Eq, Ord, Generic) + +instance ToJSON (BurnRoleTokensTxEnvelope CardanoTx) where + toJSON BurnRoleTokensTxEnvelope{..} = + object + [ ("txId", toJSON txId) + , ("tx", toJSON txEnvelope) + ] +instance ToJSON (BurnRoleTokensTxEnvelope CardanoTxBody) where + toJSON BurnRoleTokensTxEnvelope{..} = + object + [ ("txId", toJSON txId) + , ("txBody", toJSON txEnvelope) + ] + +instance FromJSON (BurnRoleTokensTxEnvelope CardanoTx) where + parseJSON = + withObject + "BurnRoleTokensTxEnvelope" + ( \obj -> + BurnRoleTokensTxEnvelope + <$> obj .: "txId" + <*> obj .: "tx" + ) + +instance FromJSON (BurnRoleTokensTxEnvelope CardanoTxBody) where + parseJSON = + withObject + "BurnRoleTokensTxEnvelope" + ( \obj -> + BurnRoleTokensTxEnvelope + <$> obj .: "txId" + <*> obj .: "txBody" + ) + +instance ToSchema (BurnRoleTokensTxEnvelope CardanoTx) where + declareNamedSchema _ = do + txIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + return $ + NamedSchema (Just "BurnRoleTokensTxEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"tx\" must be \"Tx BabbageEra\" or \"Tx ConwayEra\"" + & properties + .~ [ ("txId", txIdSchema) + , ("tx", txEnvelopeSchema) + ] + & required .~ ["txId", "tx"] + +instance ToSchema (BurnRoleTokensTxEnvelope CardanoTxBody) where + declareNamedSchema _ = do + txIdSchema <- declareSchemaRef (Proxy :: Proxy TxId) + txEnvelopeSchema <- declareSchemaRef (Proxy :: Proxy TextEnvelope) + return $ + NamedSchema (Just "BurnRoleTokensTxEnvelope") $ + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "The \"type\" property of \"txBody\" must be \"TxBody BabbageEra\" or \"TxBody ConwayEra\"" + & properties + .~ [ ("txId", txIdSchema) + , ("txBody", txEnvelopeSchema) + ] + & required .~ ["txId", "txBody"] diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Client.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Client.hs new file mode 100644 index 0000000000..be8ff1ed27 --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Client.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module Language.Marlowe.Runtime.Web.Role.Client ( + WalletHeader (..), + toWalletHeader, + buildBurnTokenTxBody, + buildBurnTokenTxBodyWithStatus, + buildBurnTokenTx, + buildBurnTokenTxWithStatus, + submitBurnTokenTx, + submitBurnTokenTxWithRuntimeStatus, +) where + +import Control.Monad.IO.Class (liftIO) +import Data.Functor (void) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Version (Version) +import GHC.TypeLits (KnownSymbol, symbolVal) + +import Language.Marlowe.Runtime.Web.API (RuntimeAPI, runtimeApi) +import Language.Marlowe.Runtime.Web.Adapter.CommaList ( + CommaList (CommaList), + ) +import Language.Marlowe.Runtime.Web.Core.Address ( + Address, + ) + +import Language.Marlowe.Runtime.Web.Core.NetworkId (NetworkId) +import Language.Marlowe.Runtime.Web.Core.Tip (ChainTip) +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope, + TxId, + TxOutRef, + ) +import Language.Marlowe.Runtime.Web.Status ( + RuntimeStatus (RuntimeStatus), + ) +import Language.Marlowe.Runtime.Web.Tx.API ( + CardanoTx, + CardanoTxBody, + ) +import Servant (HasResponseHeader, ResponseHeader (..), getResponse, lookupResponseHeader, type (:<|>) ((:<|>))) +import Servant.API (Headers) +import Servant.Client (Client) +import Servant.Client.Streaming (ClientM) +import qualified Servant.Client.Streaming as ServantStreaming +import Servant.Pipes () + +import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO ( + ToDTO (toDTO), + ) +import Language.Marlowe.Runtime.Web.Core.Object.Schema () +import Language.Marlowe.Runtime.Web.Role.API ( + BurnRoleTokensTxEnvelope, + ) +import Language.Marlowe.Runtime.Web.Role.TokenFilter ( + RoleTokenFilter, + ) + +runtimeClient :: Client ClientM RuntimeAPI +runtimeClient = ServantStreaming.client runtimeApi + +data WalletHeader = Wallet + { changeAddress :: Address + , usedAddresses :: Maybe (Set Address) + , collaterals :: Maybe (Set TxOutRef) + } + deriving (Eq, Show) + +toWalletHeader :: WalletAddresses -> WalletHeader +toWalletHeader WalletAddresses{..} = + Wallet + { changeAddress = toDTO changeAddress + , usedAddresses = Just $ Set.map toDTO extraAddresses + , collaterals = Just $ Set.map toDTO collateralUtxos + } + +extractStatus + :: ( HasResponseHeader "X-Node-Tip" ChainTip hs + , HasResponseHeader "X-Runtime-Chain-Tip" ChainTip hs + , HasResponseHeader "X-Runtime-Tip" ChainTip hs + , HasResponseHeader "X-Network-Id" NetworkId hs + , HasResponseHeader "X-Runtime-Version" Version hs + ) + => Headers hs a + -> ClientM RuntimeStatus +extractStatus response = + RuntimeStatus + <$> (reqHeaderValue $ lookupResponseHeader @"X-Node-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Chain-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Tip" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Network-Id" response) + <*> (reqHeaderValue $ lookupResponseHeader @"X-Runtime-Version" response) + +buildBurnTokenTxBodyWithStatus + :: WalletHeader + -> RoleTokenFilter + -> ClientM (RuntimeStatus, BurnRoleTokensTxEnvelope CardanoTxBody) +buildBurnTokenTxBodyWithStatus Wallet{..} roleFilter = do + let _ :<|> _ :<|> _ :<|> roleClient :<|> _ = runtimeClient + let (buildBurnTokenTxBody' :<|> _) :<|> _ = roleClient + response <- + buildBurnTokenTxBody' + roleFilter + changeAddress + (setToCommaList <$> usedAddresses) + (setToCommaList <$> collaterals) + status <- extractStatus response + pure (status, getResponse response) + +buildBurnTokenTxBody + :: WalletHeader + -> RoleTokenFilter + -> ClientM (BurnRoleTokensTxEnvelope CardanoTxBody) +buildBurnTokenTxBody = (fmap . fmap) snd . buildBurnTokenTxBodyWithStatus + +buildBurnTokenTxWithStatus + :: WalletHeader + -> RoleTokenFilter + -> ClientM (RuntimeStatus, BurnRoleTokensTxEnvelope CardanoTx) +buildBurnTokenTxWithStatus Wallet{..} roleFilter = do + let _ :<|> _ :<|> _ :<|> roleClient :<|> _ = runtimeClient + let (_ :<|> buildBurnTokenTx') :<|> _ = roleClient + response <- + buildBurnTokenTx' + roleFilter + changeAddress + (setToCommaList <$> usedAddresses) + (setToCommaList <$> collaterals) + status <- extractStatus response + pure (status, getResponse response) + +buildBurnTokenTx + :: WalletHeader + -> RoleTokenFilter + -> ClientM (BurnRoleTokensTxEnvelope CardanoTx) +buildBurnTokenTx = (fmap . fmap) snd . buildBurnTokenTxWithStatus + +submitBurnTokenTxWithRuntimeStatus :: TxId -> TextEnvelope -> ClientM RuntimeStatus +submitBurnTokenTxWithRuntimeStatus txId textEnvelope = do + let _ :<|> _ :<|> _ :<|> roleClient :<|> _ = runtimeClient + let _ :<|> submitBurnTokenTx' = roleClient + response <- submitBurnTokenTx' txId textEnvelope + extractStatus response + +submitBurnTokenTx :: TxId -> TextEnvelope -> ClientM () +submitBurnTokenTx txId = void . submitBurnTokenTxWithRuntimeStatus txId + +setToCommaList :: Set a -> CommaList a +setToCommaList = CommaList . Set.toList + +reqHeaderValue :: forall name a. (KnownSymbol name) => ResponseHeader name a -> ClientM a +reqHeaderValue = \case + Header a -> pure a + UndecodableHeader _ -> liftIO $ fail $ "Unable to decode header " <> symbolVal (Proxy @name) + MissingHeader -> liftIO $ fail $ "Required header missing " <> symbolVal (Proxy @name) diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Server.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Server.hs new file mode 100644 index 0000000000..7204ffa45c --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/Server.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Marlowe.Runtime.Web.Role.Server ( + server, +) where + +import Control.Monad.Except (MonadError (throwError)) +import qualified Data.Set as Set +import Language.Marlowe.Runtime.Web.Adapter.CommaList (CommaList (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.ApiError ( + ApiError (..), + badRequest', + constraintErrorToApiError, + throwDTOError, + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO ( + FromDTO (..), + HasDTO (..), + ShelleyTxWitness (..), + ToDTO (..), + fromDTOThrow, + ) +import Language.Marlowe.Runtime.Web.Core.Address (Address) + +import Language.Marlowe.Runtime.Web.Core.Tx ( + TextEnvelope (..), + TxId, + TxOutRef, + ) +import Language.Marlowe.Runtime.Web.Role.API (BurnRoleTokensTxEnvelope (..), RoleAPI) +import Language.Marlowe.Runtime.Web.Tx.API ( + CardanoTx, + CardanoTxBody, + ) +import Servant ( + NoContent (..), + type (:<|>) ((:<|>)), + ) + +import Cardano.Api (BabbageEra, BabbageEraOnwards (..), ConwayEra, TxBody, getTxId, makeSignedTransaction) +import Data.Aeson (ToJSON (toJSON), Value (Null)) +import Language.Marlowe.Runtime.Cardano.Api (fromCardanoTxId) +import Language.Marlowe.Runtime.Core.Api (MarloweVersion (..)) +import Language.Marlowe.Runtime.Transaction.Api ( + BurnRoleTokensError (..), + BurnRoleTokensTx (BurnRoleTokensTx), + BurnRoleTokensTxInEra (..), + WalletAddresses (..), + ) +import Language.Marlowe.Runtime.Web.Adapter.Server.Monad ( + ServerM, + burnRoleTokens, + loadTmpBurnRoleTokensTx, + submitBurnRoleTokensTx, + ) +import Language.Marlowe.Runtime.Web.Role.TokenFilter (RoleTokenFilter) +import Servant.Server (HasServer (ServerT)) + +import qualified Cardano.Api as Cardano +import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..)) +import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain +import qualified Language.Marlowe.Runtime.Web.Adapter.Server.ApiError as ApiError +import Language.Marlowe.Runtime.Web.Adapter.Server.TxClient (TempTx (..), TempTxStatus (..)) +import Language.Marlowe.Runtime.Web.Adapter.Server.Util (makeSignedTxWithWitnessKeys) + +server :: ServerT Language.Marlowe.Runtime.Web.Role.API.RoleAPI ServerM +server = (buildTxBody :<|> buildTx) :<|> submitTx + +buildTx + :: RoleTokenFilter + -> Address + -> Maybe (CommaList Address) + -> Maybe (CommaList TxOutRef) + -> ServerM (BurnRoleTokensTxEnvelope CardanoTx) +buildTx roleTokenFilterDTO changeAddressDTO usedAddressesDTO collateralsDTO = do + walletAddresses <- toWalletAddress (changeAddressDTO, usedAddressesDTO, collateralsDTO) + roleTokenFilter <- fromDTOThrow (badRequest' "Invalid Role Token Filter") roleTokenFilterDTO + burnRoleTokens MarloweV1 walletAddresses roleTokenFilter >>= \case + Left err -> throwDTOError err + Right (BurnRoleTokensTx BabbageEraOnwardsBabbage BurnRoleTokensTxInEra{txBody}) -> do + let (txId, txBody') = toDTO (fromCardanoTxId $ getTxId txBody, makeSignedTransaction [] txBody) + let body = Language.Marlowe.Runtime.Web.Role.API.BurnRoleTokensTxEnvelope txId txBody' + pure body + Right (BurnRoleTokensTx BabbageEraOnwardsConway BurnRoleTokensTxInEra{txBody}) -> do + let (txId, txBody') = toDTO (fromCardanoTxId $ getTxId txBody, makeSignedTransaction [] txBody) + let body = Language.Marlowe.Runtime.Web.Role.API.BurnRoleTokensTxEnvelope txId txBody' + pure body + +buildTxBody + :: RoleTokenFilter + -> Address + -> Maybe (CommaList Address) + -> Maybe (CommaList TxOutRef) + -> ServerM (BurnRoleTokensTxEnvelope CardanoTxBody) +buildTxBody roleTokenFilterDTO changeAddressDTO usedAddressesDTO collateralsDTO = do + walletAddresses <- toWalletAddress (changeAddressDTO, usedAddressesDTO, collateralsDTO) + roleTokenFilter <- fromDTOThrow (badRequest' "Invalid Role Token Filter") roleTokenFilterDTO + burnRoleTokens MarloweV1 walletAddresses roleTokenFilter >>= \case + Left err -> throwDTOError err + Right (BurnRoleTokensTx BabbageEraOnwardsBabbage BurnRoleTokensTxInEra{txBody}) -> do + let (txId, txBody') = toDTO (fromCardanoTxId $ getTxId txBody, txBody) + let body = BurnRoleTokensTxEnvelope txId txBody' + pure body + Right (BurnRoleTokensTx BabbageEraOnwardsConway BurnRoleTokensTxInEra{txBody}) -> do + let (txId, txBody') = toDTO (fromCardanoTxId $ getTxId txBody, txBody) + let body = BurnRoleTokensTxEnvelope txId txBody' + pure body + +submitTx :: TxId -> TextEnvelope -> ServerM NoContent +submitTx txIdTDO body = do + txId <- fromDTOThrow (badRequest' "Invalid transaction id value") txIdTDO + loadTmpBurnRoleTokensTx txId >>= \case + Nothing -> throwError $ badRequest' "Transaction not found" + Just ((TempTx _ _ Submitted _)) -> + throwError $ ApiError.toServerError $ ApiError "Tx already submitted" "TxAlreadySubmitted" Null 409 + Just ((TempTx era _ Unsigned BurnRoleTokensTxInEra{txBody})) -> submitTx' txId era txBody + where + submitTx' :: Chain.TxId -> BabbageEraOnwards era -> TxBody era -> ServerM NoContent + submitTx' txId' BabbageEraOnwardsBabbage txBody = do + (req :: Maybe (Either (Cardano.Tx BabbageEra) (ShelleyTxWitness BabbageEra))) <- case teType body of + "Tx BabbageEra" -> pure $ Left <$> fromDTO body + "ShelleyTxWitness BabbageEra" -> pure $ Right <$> fromDTO body + _ -> + throwError $ badRequest' "Unknown envelope type - allowed types are: \"Tx BabbageEra\", \"ShelleyTxWitness BabbageEra\"" + + tx <- case req of + Nothing -> throwError $ badRequest' "Invalid text envelope cbor value" + Just (Left tx) -> pure tx + Just (Right (ShelleyTxWitness (AlonzoTxWits wtKeys _ _ _ _))) -> pure $ makeSignedTxWithWitnessKeys txBody wtKeys + submitBurnRoleTokensTx txId' BabbageEraOnwardsBabbage tx >>= \case + Nothing -> pure NoContent + Just err -> throwError $ ApiError.toServerError $ ApiError (show err) "SubmissionError" Null 403 + submitTx' txId' BabbageEraOnwardsConway txBody = do + (req :: Maybe (Either (Cardano.Tx ConwayEra) (ShelleyTxWitness ConwayEra))) <- case teType body of + "Tx ConwayEra" -> pure $ Left <$> fromDTO body + "ShelleyTxWitness ConwayEra" -> pure $ Right <$> fromDTO body + _ -> + throwError $ badRequest' "Unknown envelope type - allowed types are: \"Tx ConwayEra\", \"ShelleyTxWitness ConwayEra\"" + + tx <- case req of + Nothing -> throwError $ badRequest' "Invalid text envelope cbor value" + Just (Left tx) -> pure tx + Just (Right (ShelleyTxWitness (AlonzoTxWits wtKeys _ _ _ _))) -> pure $ makeSignedTxWithWitnessKeys txBody wtKeys + submitBurnRoleTokensTx txId' BabbageEraOnwardsConway tx >>= \case + Nothing -> pure NoContent + Just err -> throwError $ ApiError.toServerError $ ApiError (show err) "SubmissionError" Null 403 + +type WalletAddressesDTO = (Address, Maybe (CommaList Address), Maybe (CommaList TxOutRef)) + +toWalletAddress :: WalletAddressesDTO -> ServerM WalletAddresses +toWalletAddress (changeAddressDTO, usedAddressesDTO, collateralsDTO) = do + changeAddress <- fromDTOThrow (badRequest' "Invalid change address") changeAddressDTO + extraAddresses <- + Set.fromList <$> fromDTOThrow (badRequest' "Invalid addresses header value") (maybe [] unCommaList usedAddressesDTO) + collateralUtxos <- + Set.fromList <$> fromDTOThrow (badRequest' "Invalid collateral header UTxO value") (maybe [] unCommaList collateralsDTO) + pure WalletAddresses{..} + +instance HasDTO BurnRoleTokensError where + type DTO BurnRoleTokensError = ApiError + +instance ToDTO BurnRoleTokensError where + toDTO = \case + BurnEraUnsupported era -> ApiError ("Current network era not supported: " <> show era) "BurnEraUnsupported" Null 503 + BurnRolesActive roles -> ApiError "Active roles detected, refusing to burn" "BurnRolesActive" (toJSON roles) 400 + BurnInvalidPolicyId policyIds -> ApiError "Invalid policies" "BurnInvalidPolicyId" (toJSON policyIds) 400 + BurnNoTokens -> ApiError "No tokens to burn" "BurnNoTokensToBurn" Null 400 + BurnFromCardanoError -> ApiError "Internal error" "BurnFromCardanoError" Null 400 + BurnConstraintError err -> constraintErrorToApiError err diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/TokenFilter.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/TokenFilter.hs new file mode 100644 index 0000000000..5ed94f4eea --- /dev/null +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Role/TokenFilter.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module defines the request and response types in the Marlowe Runtime +-- | Web API. +module Language.Marlowe.Runtime.Web.Role.TokenFilter ( + RoleTokenFilter (..), +) where + +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson ( + FromJSON (parseJSON), + KeyValue ((.=)), + ToJSON (toJSON), + Value (Array, Bool, Object), + object, + (), + ) +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (JSONPathElement (..), Parser, prependFailure, typeMismatch) +import Data.OpenApi ( + Definitions, + HasType (..), + NamedSchema (..), + OpenApiType (..), + Referenced (..), + Schema, + ToSchema, + declareSchemaRef, + enum_, + oneOf, + properties, + required, + ) +import qualified Data.OpenApi as OpenApi +import Data.OpenApi.Declare (Declare) +import Data.OpenApi.Schema (ToSchema (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import qualified Language.Marlowe.Runtime.Transaction.Api as Chain +import Language.Marlowe.Runtime.Web.Adapter.Server.DTO +import Language.Marlowe.Runtime.Web.Core.Asset ( + AssetId, + PolicyId, + ) +import Language.Marlowe.Runtime.Web.Core.Semantics.Schema () +import Language.Marlowe.Runtime.Web.Core.Tx (TxOutRef) +import Servant ( + Proxy (..), + ) + +data RoleTokenFilter + = RoleTokensAnd RoleTokenFilter RoleTokenFilter + | RoleTokensOr RoleTokenFilter RoleTokenFilter + | RoleTokenNot RoleTokenFilter + | RoleTokenFilterNone + | RoleTokenFilterByContracts (Set TxOutRef) + | RoleTokenFilterByPolicyIds (Set PolicyId) + | RoleTokenFilterByTokens (Set AssetId) + | RoleTokenFilterAny + deriving stock (Show, Eq, Ord, Generic) + +instance ToJSON RoleTokenFilter where + toJSON = \case + RoleTokensAnd a b -> object ["and" .= (a, b)] + RoleTokensOr a b -> object ["or" .= (a, b)] + RoleTokenNot a -> object ["not" .= a] + RoleTokenFilterNone -> toJSON False + RoleTokenFilterByContracts contracts -> object ["contract_id" .= contracts] + RoleTokenFilterByPolicyIds policies -> object ["roles_currency" .= policies] + RoleTokenFilterByTokens tokens -> object ["role_tokens" .= tokens] + RoleTokenFilterAny -> toJSON True + +instance FromJSON RoleTokenFilter where + parseJSON = + prependFailure "Parsing RoleTokenFilter failed" . \case + Object o -> case KeyMap.toList o of + [(k, v)] -> case k of + "and" -> uncurry RoleTokensAnd <$> parseJSON v Key "and" + "or" -> uncurry RoleTokensOr <$> parseJSON v Key "or" + "not" -> RoleTokenNot <$> parseJSON v Key "not" + "contract_id" -> RoleTokenFilterByContracts <$> parseSetOrSingle v Key "contract_id" + "roles_currency" -> RoleTokenFilterByPolicyIds <$> parseSetOrSingle v Key "roles_currency" + "role_tokens" -> RoleTokenFilterByTokens <$> parseSetOrSingle v Key "role_tokens" + _ -> fail $ "Unexpected key: " <> show k + _ -> fail "Unexpected number of keys, expected exactly 1." + Bool True -> pure RoleTokenFilterAny + Bool False -> pure RoleTokenFilterNone + v -> typeMismatch "object|boolean" v + +parseSetOrSingle :: (FromJSON a, Ord a) => Value -> Parser (Set a) +parseSetOrSingle = \case + Array arr -> parseJSON $ Array arr + v -> Set.singleton <$> parseJSON v + +instance ToSchema RoleTokenFilter where + declareNamedSchema _ = do + roleTokenFilterSchema <- declareSchemaRef $ Proxy @RoleTokenFilter + roleTokenFilterPairSchema <- declareSchemaRef $ Proxy @(RoleTokenFilter, RoleTokenFilter) + let setOrSingleSchema + :: forall a + . (ToSchema a) + => Proxy a + -> Declare (Definitions Schema) (Referenced Schema) + setOrSingleSchema p = do + singleSchema <- declareSchemaRef p + setSchema <- declareSchemaRef $ Proxy @(Set a) + pure $ Inline $ mempty & oneOf ?~ [singleSchema, setSchema] + txOutRefSchema <- setOrSingleSchema $ Proxy @TxOutRef + policyIdSchema <- setOrSingleSchema $ Proxy @PolicyId + assetIdSchema <- setOrSingleSchema $ Proxy @AssetId + let andSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens matched by both sub-filters." + & required .~ ["and"] + & properties .~ [("and", roleTokenFilterPairSchema)] + orSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens matched by either sub-filter." + & required .~ ["or"] + & properties .~ [("or", roleTokenFilterPairSchema)] + notSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens not matched by the sub-filter." + & required .~ ["not"] + & properties .~ [("not", roleTokenFilterSchema)] + anySchema = + mempty + & type_ ?~ OpenApiBoolean + & OpenApi.description ?~ "Matches any role token." + & enum_ ?~ [Bool True] + noneSchema = + mempty + & type_ ?~ OpenApiBoolean + & OpenApi.description ?~ "Matches no role token." + & enum_ ?~ [Bool False] + contractsSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens used by the given contract(s)." + & required .~ ["contract_id"] + & properties .~ [("contract_id", txOutRefSchema)] + policiesSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches any role tokens with the given currency symbol(s)." + & required .~ ["roles_currency"] + & properties .~ [("roles_currency", policyIdSchema)] + tokensSchema = + mempty + & type_ ?~ OpenApiObject + & OpenApi.description ?~ "Matches only the given role token(s)." + & required .~ ["role_tokens"] + & properties .~ [("role_tokens", assetIdSchema)] + pure $ + NamedSchema (Just "RoleTokenFilter") $ + mempty + & OpenApi.description ?~ "A filter that selects role tokens for burning." + & oneOf + ?~ fmap + Inline + [ andSchema + , orSchema + , notSchema + , anySchema + , noneSchema + , contractsSchema + , policiesSchema + , tokensSchema + ] + +instance HasDTO Chain.RoleTokenFilter where + type DTO Chain.RoleTokenFilter = RoleTokenFilter + +instance ToDTO Chain.RoleTokenFilter where + toDTO = \case + Chain.RoleTokensAnd a b -> RoleTokensAnd (toDTO a) (toDTO b) + Chain.RoleTokensOr a b -> RoleTokensOr (toDTO a) (toDTO b) + Chain.RoleTokensNot a -> RoleTokenNot (toDTO a) + Chain.RoleTokenFilterNone -> RoleTokenFilterNone + Chain.RoleTokenFilterByContracts contracts -> RoleTokenFilterByContracts (toDTO contracts) + Chain.RoleTokenFilterByPolicyIds policies -> RoleTokenFilterByPolicyIds (toDTO policies) + Chain.RoleTokenFilterByTokens tokens -> RoleTokenFilterByTokens (toDTO tokens) + Chain.RoleTokenFilterAny -> RoleTokenFilterAny + +instance FromDTO Chain.RoleTokenFilter where + fromDTO = \case + RoleTokensAnd a b -> Chain.RoleTokensAnd <$> fromDTO a <*> fromDTO b + RoleTokensOr a b -> Chain.RoleTokensOr <$> fromDTO a <*> fromDTO b + RoleTokenNot a -> Chain.RoleTokensNot <$> fromDTO a + RoleTokenFilterNone -> pure Chain.RoleTokenFilterNone + RoleTokenFilterByContracts contracts -> Chain.RoleTokenFilterByContracts <$> fromDTO contracts + RoleTokenFilterByPolicyIds policies -> Chain.RoleTokenFilterByPolicyIds <$> fromDTO policies + RoleTokenFilterByTokens tokens -> Chain.RoleTokenFilterByTokens <$> fromDTO tokens + RoleTokenFilterAny -> pure Chain.RoleTokenFilterAny diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs index a74997789f..451f5e9ae2 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Server.hs @@ -10,6 +10,7 @@ import Language.Marlowe.Runtime.Web.API (RuntimeAPI) import Language.Marlowe.Runtime.Web.Adapter.Server.Monad (ServerM) import qualified Language.Marlowe.Runtime.Web.Contract.Server as Contracts import qualified Language.Marlowe.Runtime.Web.Payout.Server as Payouts +import qualified Language.Marlowe.Runtime.Web.Role.Server as Roles import qualified Language.Marlowe.Runtime.Web.Withdrawal.Server as Withdrawals import Servant ( HasServer (ServerT), @@ -18,7 +19,12 @@ import Servant ( ) server :: ServerT RuntimeAPI ServerM -server = Contracts.server :<|> Withdrawals.server :<|> Payouts.server :<|> healthcheckServer +server = + Contracts.server + :<|> Withdrawals.server + :<|> Payouts.server + :<|> Roles.server + :<|> healthcheckServer healthcheckServer :: ServerM NoContent healthcheckServer = pure NoContent diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs index 54df033aad..bd52915276 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Tx/API.hs @@ -25,7 +25,6 @@ module Language.Marlowe.Runtime.Web.Tx.API ( ApplyInputsTxEnvelope (..), WithdrawTx, WithdrawTxEnvelope (..), - BurnTx, PostTxAPI, PutSignedTxAPI, TxJSON, @@ -139,7 +138,6 @@ data CardanoTxBody data ContractTx data ApplyInputsTx data WithdrawTx -data BurnTx type PutSignedTxAPI = ReqBody '[JSON] TextEnvelope :> PutAccepted '[JSON] NoContent diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs index 4c0f4536d5..3f54a2b4c4 100644 --- a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs +++ b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Withdrawal/Server.hs @@ -4,14 +4,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} --- | This module defines a server for the /withdrawals REST API. -module Language.Marlowe.Runtime.Web.Withdrawal.Server where +module Language.Marlowe.Runtime.Web.Withdrawal.Server (server) where import Cardano.Api ( BabbageEra, BabbageEraOnwards (..), ConwayEra, - IsShelleyBasedEra, TxBody, getTxId, makeSignedTransaction, @@ -62,7 +60,7 @@ import Language.Marlowe.Runtime.Web.Adapter.CommaList (CommaList (..)) import Language.Marlowe.Runtime.Web.Core.Address (Address) import Language.Marlowe.Runtime.Web.Core.Asset (PolicyId) -import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope (..), TxId, TxOutRef) +import Language.Marlowe.Runtime.Web.Core.Tx (TextEnvelope (..), TxBodyInAnyEra (..), TxId, TxOutRef) import Language.Marlowe.Runtime.Web.Tx.API (CardanoTx, CardanoTxBody, WithdrawTxEnvelope (..)) import Language.Marlowe.Runtime.Web.Withdrawal.API ( GetWithdrawalsResponse, @@ -95,9 +93,6 @@ server = :<|> (postCreateTxBodyResponse :<|> postCreateTxResponse) :<|> withdrawalServer -data TxBodyInAnyEra where - TxBodyInAnyEra :: (IsShelleyBasedEra era) => TxBody era -> TxBodyInAnyEra - postCreateTxBody :: PostWithdrawalsRequest -> Address @@ -166,7 +161,7 @@ toWithdrawalHeader :: Withdrawal -> WithdrawalHeader toWithdrawalHeader Withdrawal{..} = WithdrawalHeader{..} withdrawalServer :: TxId -> ServerT WithdrawalAPI ServerM -withdrawalServer withdrawalId = getOne withdrawalId :<|> put withdrawalId +withdrawalServer withdrawalId = getOne withdrawalId :<|> submitWithdrawalTx withdrawalId getOne :: TxId -> ServerM Withdrawal getOne withdrawalId = do @@ -175,8 +170,8 @@ getOne withdrawalId = do Nothing -> throwError $ notFound' "Withdrawal not found" Just result -> pure $ either toDTO toDTO result -put :: TxId -> TextEnvelope -> ServerM NoContent -put withdrawalId body = do +submitWithdrawalTx :: TxId -> TextEnvelope -> ServerM NoContent +submitWithdrawalTx withdrawalId body = do withdrawalId' <- fromDTOThrow (badRequest' "Invalid withdrawal id value") withdrawalId loadWithdrawal withdrawalId' >>= \case Nothing -> throwError $ notFound' "Withdrawal not found" diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs index 8c41627456..dc8a39f544 100644 --- a/marlowe-runtime-web/test/Spec.hs +++ b/marlowe-runtime-web/test/Spec.hs @@ -70,6 +70,8 @@ import Language.Marlowe.Runtime.Web.OpenAPIServer ( ) import qualified Language.Marlowe.Runtime.Web.Payout.API as Web +import qualified Language.Marlowe.Runtime.Web.Role.API as Web +import qualified Language.Marlowe.Runtime.Web.Role.TokenFilter as Web import qualified Language.Marlowe.Runtime.Web.Tx.API as Web import qualified Language.Marlowe.Runtime.Web.Withdrawal.API as Web import Servant.API ( @@ -517,6 +519,21 @@ instance Arbitrary Web.Withdrawal where <*> arbitrary shrink = genericShrink +instance Arbitrary Web.RoleTokenFilter where + arbitrary = + oneof + [ Web.RoleTokensAnd <$> arbitrary <*> arbitrary + , Web.RoleTokensOr <$> arbitrary <*> arbitrary + , Web.RoleTokenNot <$> arbitrary + , Web.RoleTokenNot <$> arbitrary + , pure Web.RoleTokenFilterNone + , Web.RoleTokenFilterByContracts <$> arbitrary + , Web.RoleTokenFilterByPolicyIds <$> arbitrary + , Web.RoleTokenFilterByTokens <$> arbitrary + , pure Web.RoleTokenFilterAny + ] + shrink = genericShrink + instance Arbitrary Web.Tx where arbitrary = do -- size of 6 will result in a 1-layer deep contract being generated (this is @@ -593,6 +610,10 @@ instance Arbitrary (Web.ApplyInputsTxEnvelope tx) where arbitrary = Web.ApplyInputsTxEnvelope <$> arbitrary <*> arbitrary <*> arbitrary shrink = genericShrink +instance Arbitrary (Web.BurnRoleTokensTxEnvelope tx) where + arbitrary = Web.BurnRoleTokensTxEnvelope <$> arbitrary <*> arbitrary + shrink = genericShrink + instance Arbitrary Web.MarloweVersion where arbitrary = pure Web.V1 diff --git a/marlowe-runtime/.golden/Job MarloweTxCommand/golden b/marlowe-runtime/.golden/Job MarloweTxCommand/golden index 4edf39fbc1..eea7cb498e 100644 --- a/marlowe-runtime/.golden/Job MarloweTxCommand/golden +++ b/marlowe-runtime/.golden/Job MarloweTxCommand/golden @@ -924,46 +924,46 @@ Show: MsgExec (ApplyInputs MarloweV1 (WalletAddresses {changeAddress = "", extra Binary: 010200000001000000000000000000000000000000000000000000000000000000000000000161000100000000000000000000020000000000000000 Show: MsgExec (ApplyInputs MarloweV1 (WalletAddresses {changeAddress = "61", extraAddresses = fromList [], collateralUtxos = fromList []}) (ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}) (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing Nothing []) Binary: 010200000001000000000000000161000000000000000000000000000000000000000000000000000100000000000000000000020000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [""], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 01050000000000000000000000000000000100000000000000000000000000000000000404 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList ["61"], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 0105000000000000000000000000000000010000000000000001610000000000000000000404 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList [TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}]}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 010500000000000000000000000000000000000000000000000100000000000000000001000404 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList [TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}]}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 01050000000000000000000000000000000000000000000000010000000000000001610001000404 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList [ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}]))) -Binary: 010500000000000000000000000000000000000000000000000005000000000000000100000000000000000001 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList [ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}]))) -Binary: 01050000000000000000000000000000000000000000000000000500000000000000010000000000000001610001 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList []))) -Binary: 0105000000000000000000000000000000000000000000000000050000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList [""]))) -Binary: 01050000000000000000000000000000000000000000000000000600000000000000010000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList ["61"]))) -Binary: 0105000000000000000000000000000000000000000000000000060000000000000001000000000000000161 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList []))) -Binary: 0105000000000000000000000000000000000000000000000000060000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "", tokenName = ""}]))) -Binary: 010500000000000000000000000000000000000000000000000007000000000000000100000000000000000000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "", tokenName = "a"}]))) -Binary: 01050000000000000000000000000000000000000000000000000700000000000000010000000000000000000000000000000161 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "61", tokenName = ""}]))) -Binary: 01050000000000000000000000000000000000000000000000000700000000000000010000000000000001610000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList []))) -Binary: 0105000000000000000000000000000000000000000000000000070000000000000000 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensAnd RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 0105000000000000000000000000000000000000000000000000010404 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensNot RoleTokenFilterNone)) -Binary: 01050000000000000000000000000000000000000000000000000204 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 0105000000000000000000000000000000000000000000000000000404 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) RoleTokenFilterAny) -Binary: 010500000000000000000000000000000000000000000000000003 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) RoleTokenFilterNone) -Binary: 010500000000000000000000000000000000000000000000000004 -Show: MsgExec (Burn (WalletAddresses {changeAddress = "61", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) -Binary: 010500000000000000016100000000000000000000000000000000000404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [""], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 0105000000010000000000000000000000000000000100000000000000000000000000000000000404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList ["61"], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 010500000001000000000000000000000000000000010000000000000001610000000000000000000404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList [TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}]}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 01050000000100000000000000000000000000000000000000000000000100000000000000000001000404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList [TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}]}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 0105000000010000000000000000000000000000000000000000000000010000000000000001610001000404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList [ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}]))) +Binary: 01050000000100000000000000000000000000000000000000000000000005000000000000000100000000000000000001 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList [ContractId {unContractId = TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}}]))) +Binary: 0105000000010000000000000000000000000000000000000000000000000500000000000000010000000000000001610001 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByContracts (fromList []))) +Binary: 010500000001000000000000000000000000000000000000000000000000050000000000000000 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList [""]))) +Binary: 0105000000010000000000000000000000000000000000000000000000000600000000000000010000000000000000 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList ["61"]))) +Binary: 010500000001000000000000000000000000000000000000000000000000060000000000000001000000000000000161 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByPolicyIds (fromList []))) +Binary: 010500000001000000000000000000000000000000000000000000000000060000000000000000 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "", tokenName = ""}]))) +Binary: 01050000000100000000000000000000000000000000000000000000000007000000000000000100000000000000000000000000000000 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "", tokenName = "a"}]))) +Binary: 0105000000010000000000000000000000000000000000000000000000000700000000000000010000000000000000000000000000000161 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList [AssetId {policyId = "61", tokenName = ""}]))) +Binary: 0105000000010000000000000000000000000000000000000000000000000700000000000000010000000000000001610000000000000000 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokenFilterByTokens (fromList []))) +Binary: 010500000001000000000000000000000000000000000000000000000000070000000000000000 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensAnd RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 010500000001000000000000000000000000000000000000000000000000010404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensNot RoleTokenFilterNone)) +Binary: 0105000000010000000000000000000000000000000000000000000000000204 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 010500000001000000000000000000000000000000000000000000000000000404 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) RoleTokenFilterAny) +Binary: 01050000000100000000000000000000000000000000000000000000000003 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) RoleTokenFilterNone) +Binary: 01050000000100000000000000000000000000000000000000000000000004 +Show: MsgExec (BurnRoleTokens (WalletAddresses {changeAddress = "61", extraAddresses = fromList [], collateralUtxos = fromList []}) (RoleTokensOr RoleTokenFilterNone RoleTokenFilterNone)) +Binary: 01050000000100000000000000016100000000000000000000000000000000000404 Show: MsgExec (Create (Just (StakeKeyCredential "")) MarloweV1 (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) Nothing RoleTokensNone (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing (fromList []) (Left Close)) Binary: 01010000000101000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 Show: MsgExec (Create (Just (StakeKeyCredential "61")) MarloweV1 (WalletAddresses {changeAddress = "", extraAddresses = fromList [], collateralUtxos = fromList []}) Nothing RoleTokensNone (MarloweTransactionMetadata {marloweMetadata = Nothing, transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}) Nothing (fromList []) (Left Close)) @@ -2079,139 +2079,139 @@ Binary: 0302000000010300 Show: MsgFail (ApplyInputsLoadMarloweContextFailed LoadMarloweContextToCardanoError) Binary: 0302000000010302 Show: MsgFail (BurnConstraintError (BalancingError "")) -Binary: 0305050a0000000000000000 +Binary: 030500000001050a0000000000000000 Show: MsgFail (BurnConstraintError (BalancingError "a")) -Binary: 0305050a000000000000000161 +Binary: 030500000001050a000000000000000161 Show: MsgFail (BurnConstraintError (CalculateMinUtxoFailed "")) -Binary: 030505080000000000000000 +Binary: 03050000000105080000000000000000 Show: MsgFail (BurnConstraintError (CalculateMinUtxoFailed "a")) -Binary: 03050508000000000000000161 +Binary: 0305000000010508000000000000000161 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientLovelace {required = 1, available = 1}))) -Binary: 030505090100000000010000000001 +Binary: 03050000000105090100000000010000000001 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = ""},Quantity {unQuantity = 1})]})))) -Binary: 03050509020000000000000001000000000000000000000000000000000000000000000001 +Binary: 0305000000010509020000000000000001000000000000000000000000000000000000000000000001 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = "a"},Quantity {unQuantity = 1})]})))) -Binary: 0305050902000000000000000100000000000000000000000000000001610000000000000001 +Binary: 030500000001050902000000000000000100000000000000000000000000000001610000000000000001 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList [(AssetId {policyId = "61", tokenName = ""},Quantity {unQuantity = 1})]})))) -Binary: 0305050902000000000000000100000000000000016100000000000000000000000000000001 +Binary: 030500000001050902000000000000000100000000000000016100000000000000000000000000000001 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (InsufficientTokens (Tokens {unTokens = fromList []})))) -Binary: 03050509020000000000000000 +Binary: 0305000000010509020000000000000000 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (NoCollateralFound (fromList [TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}])))) -Binary: 0305050900000000000000000100000000000000000001 +Binary: 030500000001050900000000000000000100000000000000000001 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (NoCollateralFound (fromList [TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}])))) -Binary: 030505090000000000000000010000000000000001610001 +Binary: 03050000000105090000000000000000010000000000000001610001 Show: MsgFail (BurnConstraintError (CoinSelectionFailed (NoCollateralFound (fromList [])))) -Binary: 03050509000000000000000000 +Binary: 0305000000010509000000000000000000 Show: MsgFail (BurnConstraintError (HelperScriptNotFound "")) -Binary: 030505100000000000000000 +Binary: 03050000000105100000000000000000 Show: MsgFail (BurnConstraintError (HelperScriptNotFound "a")) -Binary: 03050510000000000000000161 +Binary: 0305000000010510000000000000000161 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "")))) -Binary: 030505060000000000000000000101040000000000000000 +Binary: 03050000000105060000000000000000000101040000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "a")))) -Binary: 03050506000000000000000000010104000000000000000161 +Binary: 0305000000010506000000000000000000010104000000000000000161 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [Constr 1 []])))) -Binary: 03050506000000000000000000010100000000000100000000000000010000000000010000000000000000 +Binary: 0305000000010506000000000000000000010100000000000100000000000000010000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [])))) -Binary: 0305050600000000000000000001010000000000010000000000000000 +Binary: 030500000001050600000000000000000001010000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (I 1)))) -Binary: 030505060000000000000000000101030000000001 +Binary: 03050000000105060000000000000000000101030000000001 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [Constr 1 []])))) -Binary: 0305050600000000000000000001010200000000000000010000000000010000000000000000 +Binary: 030500000001050600000000000000000001010200000000000000010000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [])))) -Binary: 030505060000000000000000000101020000000000000000 +Binary: 03050000000105060000000000000000000101020000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [(Constr 1 [],Constr 1 [])])))) -Binary: 03050506000000000000000000010101000000000000000100000000000100000000000000000000000000010000000000000000 +Binary: 0305000000010506000000000000000000010101000000000000000100000000000100000000000000000000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [])))) -Binary: 030505060000000000000000000101010000000000000000 +Binary: 03050000000105060000000000000000000101010000000000000000 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) Nothing)) -Binary: 030505060000000000000000000100 +Binary: 03050000000105060000000000000000000100 Show: MsgFail (BurnConstraintError (InvalidHelperDatum (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}) Nothing)) -Binary: 03050506000000000000000161000100 +Binary: 0305000000010506000000000000000161000100 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "")))) -Binary: 030505050000000000000000000101040000000000000000 +Binary: 03050000000105050000000000000000000101040000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (B "a")))) -Binary: 03050505000000000000000000010104000000000000000161 +Binary: 0305000000010505000000000000000000010104000000000000000161 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [Constr 1 []])))) -Binary: 03050505000000000000000000010100000000000100000000000000010000000000010000000000000000 +Binary: 0305000000010505000000000000000000010100000000000100000000000000010000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Constr 1 [])))) -Binary: 0305050500000000000000000001010000000000010000000000000000 +Binary: 030500000001050500000000000000000001010000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (I 1)))) -Binary: 030505050000000000000000000101030000000001 +Binary: 03050000000105050000000000000000000101030000000001 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [Constr 1 []])))) -Binary: 0305050500000000000000000001010200000000000000010000000000010000000000000000 +Binary: 030500000001050500000000000000000001010200000000000000010000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (List [])))) -Binary: 030505050000000000000000000101020000000000000000 +Binary: 03050000000105050000000000000000000101020000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [(Constr 1 [],Constr 1 [])])))) -Binary: 03050505000000000000000000010101000000000000000100000000000100000000000000000000000000010000000000000000 +Binary: 0305000000010505000000000000000000010101000000000000000100000000000100000000000000000000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) (Just (Map [])))) -Binary: 030505050000000000000000000101010000000000000000 +Binary: 03050000000105050000000000000000000101010000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) Nothing)) -Binary: 030505050000000000000000000100 +Binary: 03050000000105050000000000000000000100 Show: MsgFail (BurnConstraintError (InvalidPayoutDatum (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}) Nothing)) -Binary: 03050505000000000000000161000100 +Binary: 0305000000010505000000000000000161000100 Show: MsgFail (BurnConstraintError (InvalidPayoutScriptAddress (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) "")) -Binary: 03050507000000000000000000010000000000000000 +Binary: 0305000000010507000000000000000000010000000000000000 Show: MsgFail (BurnConstraintError (InvalidPayoutScriptAddress (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}) "61")) -Binary: 0305050700000000000000000001000000000000000161 +Binary: 030500000001050700000000000000000001000000000000000161 Show: MsgFail (BurnConstraintError (InvalidPayoutScriptAddress (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}) "")) -Binary: 0305050700000000000000016100010000000000000000 +Binary: 030500000001050700000000000000016100010000000000000000 Show: MsgFail (BurnConstraintError (MintingUtxoNotFound (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}))) -Binary: 0305050000000000000000000001 +Binary: 030500000001050000000000000000000001 Show: MsgFail (BurnConstraintError (MintingUtxoNotFound (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}))) -Binary: 030505000000000000000001610001 +Binary: 03050000000105000000000000000001610001 Show: MsgFail (BurnConstraintError (PayoutNotFound (TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}))) -Binary: 0305050400000000000000000001 +Binary: 030500000001050400000000000000000001 Show: MsgFail (BurnConstraintError (PayoutNotFound (TxOutRef {txId = "61", txIx = TxIx {unTxIx = 1}}))) -Binary: 030505040000000000000001610001 +Binary: 03050000000105040000000000000001610001 Show: MsgFail (BurnConstraintError (RoleTokenNotFound (AssetId {policyId = "", tokenName = ""}))) -Binary: 0305050100000000000000000000000000000000 +Binary: 030500000001050100000000000000000000000000000000 Show: MsgFail (BurnConstraintError (RoleTokenNotFound (AssetId {policyId = "", tokenName = "a"}))) -Binary: 030505010000000000000000000000000000000161 +Binary: 03050000000105010000000000000000000000000000000161 Show: MsgFail (BurnConstraintError (RoleTokenNotFound (AssetId {policyId = "61", tokenName = ""}))) -Binary: 030505010000000000000001610000000000000000 +Binary: 03050000000105010000000000000001610000000000000000 Show: MsgFail (BurnConstraintError (UnknownPayoutScript "")) -Binary: 0305050f0000000000000000 +Binary: 030500000001050f0000000000000000 Show: MsgFail (BurnConstraintError (UnknownPayoutScript "61")) -Binary: 0305050f000000000000000161 +Binary: 030500000001050f000000000000000161 Show: MsgFail (BurnConstraintError MarloweInputInWithdraw) -Binary: 0305050b +Binary: 030500000001050b Show: MsgFail (BurnConstraintError MarloweOutputInWithdraw) -Binary: 0305050c +Binary: 030500000001050c Show: MsgFail (BurnConstraintError MissingMarloweInput) -Binary: 03050503 +Binary: 0305000000010503 Show: MsgFail (BurnConstraintError PayoutInputInCreateOrApply) -Binary: 0305050e +Binary: 030500000001050e Show: MsgFail (BurnConstraintError PayoutOutputInWithdraw) -Binary: 0305050d +Binary: 030500000001050d Show: MsgFail (BurnConstraintError ToCardanoError) -Binary: 03050502 +Binary: 0305000000010502 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra AllegraEra)) -Binary: 03050002 +Binary: 0305000000010002 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra AlonzoEra)) -Binary: 03050004 +Binary: 0305000000010004 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra BabbageEra)) -Binary: 03050005 +Binary: 0305000000010005 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra ByronEra)) -Binary: 03050000 +Binary: 0305000000010000 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra ConwayEra)) -Binary: 03050006 +Binary: 0305000000010006 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra MaryEra)) -Binary: 03050003 +Binary: 0305000000010003 Show: MsgFail (BurnEraUnsupported (AnyCardanoEra ShelleyEra)) -Binary: 03050001 +Binary: 0305000000010001 Show: MsgFail (BurnInvalidPolicyId (fromList [""])) -Binary: 03050200000000000000010000000000000000 +Binary: 0305000000010200000000000000010000000000000000 Show: MsgFail (BurnInvalidPolicyId (fromList ["61"])) -Binary: 0305020000000000000001000000000000000161 +Binary: 030500000001020000000000000001000000000000000161 Show: MsgFail (BurnInvalidPolicyId (fromList [])) -Binary: 0305020000000000000000 +Binary: 030500000001020000000000000000 Show: MsgFail (BurnRolesActive (fromList [""])) -Binary: 03050100000000000000010000000000000000 +Binary: 0305000000010100000000000000010000000000000000 Show: MsgFail (BurnRolesActive (fromList ["61"])) -Binary: 0305010000000000000001000000000000000161 +Binary: 030500000001010000000000000001000000000000000161 Show: MsgFail (BurnRolesActive (fromList [])) -Binary: 0305010000000000000000 +Binary: 030500000001010000000000000000 Show: MsgFail (CreateBuildupFailed (AddressDecodingFailed "")) Binary: 03010000000104010000000000000000 Show: MsgFail (CreateBuildupFailed (AddressDecodingFailed "61")) @@ -13137,9 +13137,9 @@ Binary: 03030000000103050000000000000001610001 Show: MsgFail (WithdrawLoadHelpersContextFailed RollForwardToGenesisError) Binary: 0303000000010304 Show: MsgFail BurnFromCardanoError -Binary: 030504 +Binary: 03050000000104 Show: MsgFail BurnNoTokens -Binary: 030503 +Binary: 03050000000103 Show: MsgFail CreateContractNotFound Binary: 03010000000108 Show: MsgFail CreateToCardanoError @@ -13168,14 +13168,14 @@ Show: MsgSucceed (BlockHeader {slotNo = SlotNo {unSlotNo = 1}, headerHash = "", Binary: 0404000000000000000100000000000000000000000000000001 Show: MsgSucceed (BlockHeader {slotNo = SlotNo {unSlotNo = 1}, headerHash = "61", blockNo = BlockNo {unBlockNo = 1}}) Binary: 040400000000000000010000000000000001610000000000000001 -Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = ""},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) -Binary: 0405000000000000000001000000000000000000000000000000000000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 -Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = "a"},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) -Binary: 040500000000000000000100000000000000000000000000000001610000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 -Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "61", tokenName = ""},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) -Binary: 040500000000000000000100000000000000016100000000000000000000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 -Show: MsgSucceed (BurnTx BabbageEraOnwardsBabbage(BurnTxInEra {burnedTokens = Tokens {unTokens = fromList []}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) -Binary: 0405000000000000000000000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnRoleTokensTx BabbageEraOnwardsBabbage(BurnRoleTokensTxInEra {version = MarloweV1, burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = ""},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 040500000001000000000000000001000000000000000000000000000000000000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnRoleTokensTx BabbageEraOnwardsBabbage(BurnRoleTokensTxInEra {version = MarloweV1, burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "", tokenName = "a"},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 04050000000100000000000000000100000000000000000000000000000001610000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnRoleTokensTx BabbageEraOnwardsBabbage(BurnRoleTokensTxInEra {version = MarloweV1, burnedTokens = Tokens {unTokens = fromList [(AssetId {policyId = "61", tokenName = ""},Quantity {unQuantity = 1})]}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 04050000000100000000000000000100000000000000016100000000000000000000000000000001000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 +Show: MsgSucceed (BurnRoleTokensTx BabbageEraOnwardsBabbage(BurnRoleTokensTxInEra {version = MarloweV1, burnedTokens = Tokens {unTokens = fromList []}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone})) +Binary: 040500000001000000000000000000000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f6 Show: MsgSucceed (ContractCreated BabbageEraOnwardsBabbage(ContractCreatedInEra {contractId = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, rolesCurrency = "", metadata = MarloweTransactionMetadata {marloweMetadata = Just (MarloweMetadata {tags = fromList [("",Just (MetadataBytes ""))], continuations = Nothing}), transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}, marloweScriptHash = "", marloweScriptAddress = "", payoutScriptHash = "", payoutScriptAddress = "", version = MarloweV1, datum = MarloweData {marloweParams = MarloweParams {rolesCurrency = }, marloweState = State {accounts = Map {unMap = []}, choices = Map {unMap = []}, boundValues = Map {unMap = []}, minTime = POSIXTime {getPOSIXTime = 1}}, marloweContract = Close}, assets = Assets {ada = Lovelace {unLovelace = 1}, tokens = Tokens {unTokens = fromList []}}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone, safetyErrors = []})) Binary: 040100000001000000000000000000000100000000000000000000000000000001000000000000061c0100000000000000020200000000020100000000000000010100000000000000020400000000000000000300000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000300000000000000000000000000010400000000000000000000000000000000000000000004010000000000000000010000000000000000010000000000000000030000000001000000000000000000000000000000000000000000010000000000000000000000000000005084a30081825820000000000000000000000000000000000000000000000000000000000000000000018182581d610a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07010200a0f5f60000000000000000 Show: MsgSucceed (ContractCreated BabbageEraOnwardsBabbage(ContractCreatedInEra {contractId = ContractId {unContractId = TxOutRef {txId = "", txIx = TxIx {unTxIx = 1}}}, rolesCurrency = "", metadata = MarloweTransactionMetadata {marloweMetadata = Just (MarloweMetadata {tags = fromList [("",Just (MetadataBytes "a"))], continuations = Nothing}), transactionMetadata = TransactionMetadata {unTransactionMetadata = fromList []}}, marloweScriptHash = "", marloweScriptAddress = "", payoutScriptHash = "", payoutScriptAddress = "", version = MarloweV1, datum = MarloweData {marloweParams = MarloweParams {rolesCurrency = }, marloweState = State {accounts = Map {unMap = []}, choices = Map {unMap = []}, boundValues = Map {unMap = []}, minTime = POSIXTime {getPOSIXTime = 1}}, marloweContract = Close}, assets = Assets {ada = Lovelace {unLovelace = 1}, tokens = Tokens {unTokens = fromList []}}, txBody = ShelleyTxBody ShelleyBasedEraBabbage (TxBodyConstr BabbageTxBodyRaw {btbrSpendInputs = fromList [TxIn (TxId {unTxId = SafeHash "0000000000000000000000000000000000000000000000000000000000000000"}) (TxIx 0)], btbrCollateralInputs = fromList [], btbrReferenceInputs = fromList [], btbrOutputs = StrictSeq {fromStrict = fromList [Sized {sizedValue = (Addr Mainnet (KeyHashObj (KeyHash "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07")) StakeRefNull,MaryValue (Coin 1) (MultiAsset (fromList [])),NoDatum,SNothing), sizedSize = 33}]}, btbrCollateralReturn = SNothing, btbrTotalCollateral = SNothing, btbrCerts = StrictSeq {fromStrict = fromList []}, btbrWithdrawals = Withdrawals {unWithdrawals = fromList []}, btbrTxFee = Coin 0, btbrValidityInterval = ValidityInterval {invalidBefore = SNothing, invalidHereafter = SNothing}, btbrUpdate = SNothing, btbrReqSignerHashes = fromList [], btbrMint = MultiAsset (fromList []), btbrScriptIntegrityHash = SNothing, btbrAuxDataHash = SNothing, btbrTxNetworkId = SNothing} (blake2b_256: SafeHash "b6e78b5ddb51de9be8e70ae8d07ed0a75db5e11e703d3c825bcb8eb6b2954634")) [] (TxBodyScriptData AlonzoEraOnwardsBabbage (TxDatsConstr TxDatsRaw {unTxDatsRaw = fromList []} (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0")) (RedeemersConstr fromList [] (blake2b_256: SafeHash "45b0cfc220ceec5b7c1c62c4d4193d38e4eba48e8815729ce75f9c0ab0e4c1c0"))) Nothing TxScriptValidityNone, safetyErrors = []})) diff --git a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs index 78a522b357..d5e78bedaa 100644 --- a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs +++ b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs @@ -342,21 +342,24 @@ instance (ArbitraryMarloweVersion v, IsShelleyBasedEra era) => Arbitrary (Withdr <*> hedgehog (genTxBody shelleyBasedEra) shrink WithdrawTxInEra{..} = [WithdrawTxInEra{..}{WithdrawTxInEra.inputs = inputs'} | inputs' <- shrink inputs] -instance Arbitrary BurnTx where +instance (ArbitraryMarloweVersion v) => Arbitrary (BurnRoleTokensTx v) where arbitrary = oneof - [ BurnTx BabbageEraOnwardsBabbage <$> arbitrary - , BurnTx BabbageEraOnwardsConway <$> arbitrary + [ BurnRoleTokensTx BabbageEraOnwardsBabbage <$> arbitrary + , BurnRoleTokensTx BabbageEraOnwardsConway <$> arbitrary ] - shrink (BurnTx BabbageEraOnwardsBabbage created) = - BurnTx BabbageEraOnwardsBabbage <$> shrink created - shrink (BurnTx BabbageEraOnwardsConway created) = - BurnTx BabbageEraOnwardsConway <$> shrink created + shrink (BurnRoleTokensTx BabbageEraOnwardsBabbage created) = + BurnRoleTokensTx BabbageEraOnwardsBabbage <$> shrink created + shrink (BurnRoleTokensTx BabbageEraOnwardsConway created) = + BurnRoleTokensTx BabbageEraOnwardsConway <$> shrink created -instance (IsShelleyBasedEra era) => Arbitrary (BurnTxInEra era) where - arbitrary = BurnTxInEra <$> arbitrary <*> hedgehog (genTxBody shelleyBasedEra) - shrink BurnTxInEra{..} = - [BurnTxInEra{..}{burnedTokens = burnedTokens'} | burnedTokens' <- shrink burnedTokens] +instance (ArbitraryMarloweVersion v, IsShelleyBasedEra era) => Arbitrary (BurnRoleTokensTxInEra era v) where + arbitrary = + BurnRoleTokensTxInEra Core.marloweVersion + <$> arbitrary + <*> hedgehog (genTxBody shelleyBasedEra) + shrink BurnRoleTokensTxInEra{..} = + [BurnRoleTokensTxInEra{..}{burnedTokens = burnedTokens'} | burnedTokens' <- shrink burnedTokens] instance Arbitrary Account where arbitrary = @@ -385,7 +388,7 @@ instance (Arbitrary c, Ord c, Arbitrary p, Ord p, Arbitrary t, Ord t) => Arbitra ] shrink = genericShrink -instance Arbitrary BurnError where +instance Arbitrary BurnRoleTokensError where arbitrary = frequency [ (5, BurnRolesActive <$> arbitrary) @@ -403,7 +406,7 @@ instance ArbitraryCommand MarloweTxCommand where [ SomeTag $ TagCreate Core.MarloweV1 , SomeTag $ TagApplyInputs Core.MarloweV1 , SomeTag $ TagWithdraw Core.MarloweV1 - , SomeTag TagBurn + , SomeTag $ TagBurnRoleTokens Core.MarloweV1 , SomeTag TagSubmit ] arbitraryCmd = \case @@ -430,7 +433,7 @@ instance ArbitraryCommand MarloweTxCommand where Withdraw Core.MarloweV1 <$> arbitrary <*> arbitrary - TagBurn -> Burn <$> arbitrary <*> arbitrary + TagBurnRoleTokens Core.MarloweV1 -> BurnRoleTokens Core.MarloweV1 <$> arbitrary <*> arbitrary TagSubmit -> oneof [ Submit BabbageEraOnwardsBabbage <$> hedgehog (genTx ShelleyBasedEraBabbage) @@ -440,25 +443,25 @@ instance ArbitraryCommand MarloweTxCommand where TagCreate Core.MarloweV1 -> Nothing TagApplyInputs Core.MarloweV1 -> Nothing TagWithdraw Core.MarloweV1 -> Nothing - TagBurn -> Nothing + TagBurnRoleTokens Core.MarloweV1 -> Nothing TagSubmit -> Just $ JobIdSubmit <$> arbitrary arbitraryStatus = \case TagCreate Core.MarloweV1 -> Nothing TagApplyInputs Core.MarloweV1 -> Nothing TagWithdraw Core.MarloweV1 -> Nothing - TagBurn -> Nothing + TagBurnRoleTokens Core.MarloweV1 -> Nothing TagSubmit -> Just arbitrary arbitraryErr = \case TagCreate Core.MarloweV1 -> Just arbitrary TagApplyInputs Core.MarloweV1 -> Just arbitrary TagWithdraw Core.MarloweV1 -> Just arbitrary - TagBurn -> Just arbitrary + TagBurnRoleTokens Core.MarloweV1 -> Just arbitrary TagSubmit -> Just arbitrary arbitraryResult = \case TagCreate Core.MarloweV1 -> arbitrary TagApplyInputs Core.MarloweV1 -> arbitrary TagWithdraw Core.MarloweV1 -> arbitrary - TagBurn -> arbitrary + TagBurnRoleTokens Core.MarloweV1 -> arbitrary TagSubmit -> arbitrary shrinkCommand = \case Create staking Core.MarloweV1 wallet thread roleConfig meta minAda state contract -> @@ -542,9 +545,9 @@ instance ArbitraryCommand MarloweTxCommand where Withdraw Core.MarloweV1 wallet payouts -> (Withdraw Core.MarloweV1 <$> shrink wallet <*> pure payouts) <> (Withdraw Core.MarloweV1 wallet <$> shrink payouts) - Burn wallet tokenFilter -> - (Burn <$> shrink wallet <*> pure tokenFilter) - <> (Burn wallet <$> shrink tokenFilter) + BurnRoleTokens Core.MarloweV1 wallet tokenFilter -> + (BurnRoleTokens Core.MarloweV1 <$> shrink wallet <*> pure tokenFilter) + <> (BurnRoleTokens Core.MarloweV1 wallet <$> shrink tokenFilter) Submit _ _ -> [] shrinkJobId = \case JobIdSubmit txId -> JobIdSubmit <$> shrink txId @@ -552,19 +555,19 @@ instance ArbitraryCommand MarloweTxCommand where TagCreate Core.MarloweV1 -> shrink TagApplyInputs Core.MarloweV1 -> shrink TagWithdraw Core.MarloweV1 -> shrink - TagBurn -> shrink + TagBurnRoleTokens Core.MarloweV1 -> shrink TagSubmit -> shrink shrinkResult = \case TagCreate Core.MarloweV1 -> shrink TagApplyInputs Core.MarloweV1 -> shrink TagWithdraw Core.MarloweV1 -> shrink - TagBurn -> shrink + TagBurnRoleTokens Core.MarloweV1 -> shrink TagSubmit -> shrink shrinkStatus = \case TagCreate Core.MarloweV1 -> \case {} TagApplyInputs Core.MarloweV1 -> \case {} TagWithdraw Core.MarloweV1 -> \case {} - TagBurn -> \case {} + TagBurnRoleTokens Core.MarloweV1 -> \case {} TagSubmit -> shrink instance CommandVariations MarloweTxCommand where @@ -574,7 +577,7 @@ instance CommandVariations MarloweTxCommand where , SomeTag $ TagApplyInputs Core.MarloweV1 , SomeTag $ TagWithdraw Core.MarloweV1 , SomeTag TagSubmit - , SomeTag TagBurn + , SomeTag $ TagBurnRoleTokens Core.MarloweV1 ] cmdVariations = \case TagCreate Core.MarloweV1 -> @@ -598,8 +601,8 @@ instance CommandVariations MarloweTxCommand where `varyAp` variations TagWithdraw Core.MarloweV1 -> Withdraw Core.MarloweV1 <$> variations `varyAp` variations - TagBurn -> - Burn <$> variations `varyAp` variations + TagBurnRoleTokens Core.MarloweV1 -> + BurnRoleTokens Core.MarloweV1 <$> variations `varyAp` variations TagSubmit -> sconcat $ NE.fromList @@ -610,23 +613,23 @@ instance CommandVariations MarloweTxCommand where TagCreate Core.MarloweV1 -> [] TagApplyInputs Core.MarloweV1 -> [] TagWithdraw Core.MarloweV1 -> [] - TagBurn -> [] + TagBurnRoleTokens Core.MarloweV1 -> [] TagSubmit -> NE.toList $ JobIdSubmit <$> variations statusVariations = \case TagCreate Core.MarloweV1 -> [] TagApplyInputs Core.MarloweV1 -> [] TagWithdraw Core.MarloweV1 -> [] - TagBurn -> [] + TagBurnRoleTokens Core.MarloweV1 -> [] TagSubmit -> NE.toList variations errVariations = \case TagCreate Core.MarloweV1 -> NE.toList variations TagApplyInputs Core.MarloweV1 -> NE.toList variations TagWithdraw Core.MarloweV1 -> NE.toList variations - TagBurn -> NE.toList variations + TagBurnRoleTokens Core.MarloweV1 -> NE.toList variations TagSubmit -> NE.toList variations resultVariations = \case TagCreate Core.MarloweV1 -> variations TagApplyInputs Core.MarloweV1 -> variations TagWithdraw Core.MarloweV1 -> variations - TagBurn -> variations + TagBurnRoleTokens Core.MarloweV1 -> variations TagSubmit -> variations diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs index 0f425e5a7a..b5a858bcd2 100644 --- a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs +++ b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs @@ -12,49 +12,55 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Language.Marlowe.Runtime.Transaction.Api ( - Account (..), - ApplyInputsConstraintsBuildupError (..), - ApplyInputsError (..), - BurnError (..), - BurnTx (..), - BurnTxInEra (..), - CoinSelectionError (..), - ConstraintError (..), + -- | Contract Creation API ContractCreated (..), ContractCreatedInEra (..), CreateBuildupError (..), CreateError (..), - Destination (..), - InputsApplied (..), - InputsAppliedInEra (..), - IsToken (..), - JobId (..), - LoadHelpersContextError (..), - LoadMarloweContextError (..), - MarloweTxCommand (..), Mint (..), MintRole (..), NFTMetadataFile (..), - RoleTokenFilter' (..), - RoleTokenFilter, + decodeRoleTokenMetadata, + encodeRoleTokenMetadata, RoleTokenMetadata (..), RoleTokensConfig (RoleTokensNone, RoleTokensUsePolicy, RoleTokensMint), - SubmitError (..), - SubmitStatus (..), - Tag (..), - WalletAddresses (..), + -- | Apply Inputs API + ApplyInputsConstraintsBuildupError (..), + ApplyInputsError (..), + InputsApplied (..), + InputsAppliedInEra (..), + -- | Withdraw API WithdrawError (..), WithdrawTx (..), WithdrawTxInEra (..), - decodeRoleTokenMetadata, - encodeRoleTokenMetadata, + -- | Burn Role Tokens API + BurnRoleTokensError (..), + BurnRoleTokensTx (..), + BurnRoleTokensTxInEra (..), + RoleTokenFilter' (..), + RoleTokenFilter, + roleTokenFilterToRoleCurrencyFilter, evalRoleTokenFilter, - getTokenQuantities, - hasRecipient, - mkMint, optimizeRoleTokenFilter, rewriteRoleTokenFilter, - roleTokenFilterToRoleCurrencyFilter, + -- | Submit API + SubmitError (..), + SubmitStatus (..), + -- | Remaining To Classify API + Account (..), + CoinSelectionError (..), + ConstraintError (..), + Destination (..), + IsToken (..), + JobId (..), + LoadHelpersContextError (..), + LoadMarloweContextError (..), + MarloweTxCommand (..), + WalletAddresses (..), + Tag (..), + hasRecipient, + getTokenQuantities, + mkMint, ) where import Cardano.Api ( @@ -135,7 +141,21 @@ import Language.Marlowe.Runtime.ChainSync.Api ( parseMetadataText, ) import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain -import Language.Marlowe.Runtime.Core.Api +import Language.Marlowe.Runtime.Core.Api ( + ContractId, + IsMarloweVersion (Contract, Datum, Inputs), + MarloweTransactionMetadata, + MarloweVersion (..), + MarloweVersionTag (V1), + Payout, + SomeMarloweVersion (..), + TransactionOutput, + TransactionScriptOutput, + getDatum, + getInputs, + putDatum, + putInputs, + ) import Language.Marlowe.Runtime.Core.ScriptRegistry (HelperScript) import Language.Marlowe.Runtime.History.Api (ExtractCreationError, ExtractMarloweTransactionError) import Network.HTTP.Media (MediaType) @@ -157,7 +177,13 @@ import qualified Data.Set as Set import Language.Marlowe.Protocol.Query.Types (RoleCurrencyFilter (..)) import Network.Protocol.Codec.Spec (Variations (..), varyAp) import Network.Protocol.Handshake.Types (HasSignature (..)) -import Network.Protocol.Job.Types +import Network.Protocol.Job.Types ( + Command (..), + CommandEq (..), + OTelCommand (..), + ShowCommand (..), + SomeTag (SomeTag), + ) import qualified Network.URI as Network import PlutusCore.Evaluation.Machine.ExBudget (ExBudget) import PlutusCore.Evaluation.Machine.ExMemory (ExCPU, ExMemory) @@ -770,70 +796,72 @@ instance (IsShelleyBasedEra era) => ToJSON (InputsAppliedInEra era 'V1) where , "tx-body" .= serialiseToTextEnvelope Nothing txBody ] -data BurnTx where - BurnTx - :: BabbageEraOnwards era -> BurnTxInEra era -> BurnTx +data BurnRoleTokensTx v where + BurnRoleTokensTx + :: BabbageEraOnwards era -> BurnRoleTokensTxInEra era v -> BurnRoleTokensTx v -instance Variations BurnTx where - variations = BurnTx BabbageEraOnwardsBabbage <$> variations +instance Variations (BurnRoleTokensTx 'V1) where + variations = BurnRoleTokensTx BabbageEraOnwardsBabbage <$> variations -instance Show BurnTx where - showsPrec p (BurnTx BabbageEraOnwardsBabbage created) = +instance Show (BurnRoleTokensTx 'V1) where + showsPrec p (BurnRoleTokensTx BabbageEraOnwardsBabbage created) = showParen (p > 10) $ - showString "BurnTx" + showString "BurnRoleTokensTx" . showSpace . showString "BabbageEraOnwardsBabbage" . showsPrec 11 created - showsPrec p (BurnTx BabbageEraOnwardsConway created) = + showsPrec p (BurnRoleTokensTx BabbageEraOnwardsConway created) = showParen (p > 10) $ - showString "BurnTx" + showString "BurnRoleTokensTx" . showSpace . showString "BabbageEraOnwardsConway" . showsPrec 11 created -instance Eq BurnTx where - BurnTx BabbageEraOnwardsBabbage a == BurnTx BabbageEraOnwardsBabbage b = +instance Eq (BurnRoleTokensTx 'V1) where + BurnRoleTokensTx BabbageEraOnwardsBabbage a == BurnRoleTokensTx BabbageEraOnwardsBabbage b = a == b - BurnTx BabbageEraOnwardsBabbage _ == _ = False - BurnTx BabbageEraOnwardsConway a == BurnTx BabbageEraOnwardsConway b = + BurnRoleTokensTx BabbageEraOnwardsBabbage _ == _ = False + BurnRoleTokensTx BabbageEraOnwardsConway a == BurnRoleTokensTx BabbageEraOnwardsConway b = a == b - BurnTx BabbageEraOnwardsConway _ == _ = False + BurnRoleTokensTx BabbageEraOnwardsConway _ == _ = False -instance Binary BurnTx where - put (BurnTx BabbageEraOnwardsBabbage created) = do +instance Binary (BurnRoleTokensTx 'V1) where + put (BurnRoleTokensTx BabbageEraOnwardsBabbage created) = do putWord8 0 put created - put (BurnTx BabbageEraOnwardsConway created) = do + put (BurnRoleTokensTx BabbageEraOnwardsConway created) = do putWord8 1 put created get = do eraTag <- getWord8 case eraTag of - 0 -> BurnTx BabbageEraOnwardsBabbage <$> get - 1 -> BurnTx BabbageEraOnwardsConway <$> get + 0 -> BurnRoleTokensTx BabbageEraOnwardsBabbage <$> get + 1 -> BurnRoleTokensTx BabbageEraOnwardsConway <$> get _ -> fail $ "Invalid era tag value: " <> show eraTag -data BurnTxInEra era = BurnTxInEra - { burnedTokens :: Chain.Tokens +data BurnRoleTokensTxInEra era v = BurnRoleTokensTxInEra + { version :: MarloweVersion v + , burnedTokens :: Chain.Tokens , txBody :: TxBody era } -deriving instance Show (BurnTxInEra BabbageEra) -deriving instance Eq (BurnTxInEra BabbageEra) -deriving instance Show (BurnTxInEra ConwayEra) -deriving instance Eq (BurnTxInEra ConwayEra) +deriving instance Show (BurnRoleTokensTxInEra BabbageEra 'V1) +deriving instance Eq (BurnRoleTokensTxInEra BabbageEra 'V1) +deriving instance Show (BurnRoleTokensTxInEra ConwayEra 'V1) +deriving instance Eq (BurnRoleTokensTxInEra ConwayEra 'V1) -instance (IsShelleyBasedEra era) => Variations (BurnTxInEra era) where - variations = BurnTxInEra <$> variations `varyAp` variations +instance (IsShelleyBasedEra era) => Variations (BurnRoleTokensTxInEra era 'V1) where + variations = BurnRoleTokensTxInEra MarloweV1 <$> variations `varyAp` variations -instance (IsShelleyBasedEra era) => Binary (BurnTxInEra era) where - put BurnTxInEra{..} = do +instance (IsShelleyBasedEra era) => Binary (BurnRoleTokensTxInEra era 'V1) where + put BurnRoleTokensTxInEra{..} = do put burnedTokens putTxBody txBody get = do + let version = MarloweV1 burnedTokens <- get txBody <- getTxBody - pure BurnTxInEra{..} + pure BurnRoleTokensTxInEra{..} data Account = RoleAccount TokenName @@ -841,7 +869,7 @@ data Account deriving stock (Show, Eq, Ord, Generic) deriving anyclass (Binary, ToJSON, Variations) -data BurnError +data BurnRoleTokensError = BurnEraUnsupported AnyCardanoEra | BurnRolesActive (Set PolicyId) | BurnInvalidPolicyId (Set PolicyId) @@ -1110,12 +1138,14 @@ data MarloweTxCommand status err result where ) -- | Construct a transaction that burns all role tokens in a wallet which match -- the given filter. - Burn - :: WalletAddresses + BurnRoleTokens + :: MarloweVersion v + -- ^ The Marlowe version to use + -> WalletAddresses -- ^ The wallet addresses to use when constructing the transaction -> RoleTokenFilter -- ^ Which role tokens to burn - -> MarloweTxCommand Void BurnError BurnTx + -> MarloweTxCommand Void BurnRoleTokensError (BurnRoleTokensTx v) -- | Submits a signed transaction to the attached Cardano node. Submit :: BabbageEraOnwards era @@ -1135,7 +1165,7 @@ instance OTelCommand MarloweTxCommand where TagCreate _ -> "create" TagApplyInputs _ -> "apply_inputs" TagWithdraw _ -> "withdraw" - TagBurn -> "burn" + TagBurnRoleTokens _ -> "burn_role_tokens" TagSubmit -> "submit" instance Command MarloweTxCommand where @@ -1143,7 +1173,7 @@ instance Command MarloweTxCommand where TagCreate :: MarloweVersion v -> Tag MarloweTxCommand Void CreateError (ContractCreated v) TagApplyInputs :: MarloweVersion v -> Tag MarloweTxCommand Void ApplyInputsError (InputsApplied v) TagWithdraw :: MarloweVersion v -> Tag MarloweTxCommand Void WithdrawError (WithdrawTx v) - TagBurn :: Tag MarloweTxCommand Void BurnError BurnTx + TagBurnRoleTokens :: MarloweVersion v -> Tag MarloweTxCommand Void BurnRoleTokensError (BurnRoleTokensTx v) TagSubmit :: Tag MarloweTxCommand SubmitStatus SubmitError BlockHeader data JobId MarloweTxCommand stats err result where @@ -1153,7 +1183,7 @@ instance Command MarloweTxCommand where Create _ version _ _ _ _ _ _ _ -> TagCreate version ApplyInputs version _ _ _ _ _ _ -> TagApplyInputs version Withdraw version _ _ -> TagWithdraw version - Burn _ _ -> TagBurn + BurnRoleTokens version _ _ -> TagBurnRoleTokens version Submit _ _ -> TagSubmit tagFromJobId = \case @@ -1166,8 +1196,8 @@ instance Command MarloweTxCommand where (TagApplyInputs _, _) -> Nothing (TagWithdraw MarloweV1, TagWithdraw MarloweV1) -> pure (Refl, Refl, Refl) (TagWithdraw _, _) -> Nothing - (TagBurn, TagBurn) -> pure (Refl, Refl, Refl) - (TagBurn, _) -> Nothing + (TagBurnRoleTokens MarloweV1, TagBurnRoleTokens MarloweV1) -> pure (Refl, Refl, Refl) + (TagBurnRoleTokens MarloweV1, _) -> Nothing (TagSubmit, TagSubmit) -> pure (Refl, Refl, Refl) (TagSubmit, _) -> Nothing @@ -1176,7 +1206,7 @@ instance Command MarloweTxCommand where TagApplyInputs version -> putWord8 0x02 *> put (SomeMarloweVersion version) TagWithdraw version -> putWord8 0x03 *> put (SomeMarloweVersion version) TagSubmit -> putWord8 0x04 - TagBurn -> putWord8 0x05 + TagBurnRoleTokens version -> putWord8 0x05 *> put (SomeMarloweVersion version) getTag = do tag <- getWord8 @@ -1191,7 +1221,9 @@ instance Command MarloweTxCommand where SomeMarloweVersion version <- get pure $ SomeTag $ TagWithdraw version 0x04 -> pure $ SomeTag TagSubmit - 0x05 -> pure $ SomeTag TagBurn + 0x05 -> do + SomeMarloweVersion version <- get + pure $ SomeTag $ TagBurnRoleTokens version _ -> fail $ "Invalid command tag: " <> show tag putJobId = \case @@ -1201,7 +1233,7 @@ instance Command MarloweTxCommand where TagCreate _ -> fail "create has no job ID" TagApplyInputs _ -> fail "apply inputs has no job ID" TagWithdraw _ -> fail "withdraw has no job ID" - TagBurn -> fail "burn has no job ID" + TagBurnRoleTokens _ -> fail "burn role tokens has no job ID" TagSubmit -> JobIdSubmit <$> get putCommand = \case @@ -1224,7 +1256,7 @@ instance Command MarloweTxCommand where Withdraw _ walletAddresses payoutIds -> do put walletAddresses put payoutIds - Burn walletAddresses tokenFilter -> do + BurnRoleTokens _ walletAddresses tokenFilter -> do put walletAddresses put tokenFilter Submit era tx -> case era of @@ -1257,7 +1289,7 @@ instance Command MarloweTxCommand where TagWithdraw version -> do walletAddresses <- get Withdraw version walletAddresses <$> get - TagBurn -> Burn <$> get <*> get + TagBurnRoleTokens version -> BurnRoleTokens version <$> get <*> get TagSubmit -> do eraTag <- getWord8 case eraTag of @@ -1277,42 +1309,42 @@ instance Command MarloweTxCommand where TagCreate _ -> absurd TagApplyInputs _ -> absurd TagWithdraw _ -> absurd - TagBurn -> absurd + TagBurnRoleTokens _ -> absurd TagSubmit -> put getStatus = \case TagCreate _ -> fail "create has no status" TagApplyInputs _ -> fail "apply inputs has no status" TagWithdraw _ -> fail "withdraw has no status" - TagBurn -> fail "burn has no status" + TagBurnRoleTokens _ -> fail "burn role tokens has no status" TagSubmit -> get putErr = \case TagCreate MarloweV1 -> put TagApplyInputs MarloweV1 -> put TagWithdraw MarloweV1 -> put - TagBurn -> put + TagBurnRoleTokens _ -> put TagSubmit -> put getErr = \case TagCreate MarloweV1 -> get TagApplyInputs MarloweV1 -> get TagWithdraw MarloweV1 -> get - TagBurn -> get + TagBurnRoleTokens _ -> get TagSubmit -> get putResult = \case TagCreate MarloweV1 -> put TagApplyInputs MarloweV1 -> put TagWithdraw MarloweV1 -> put - TagBurn -> put + TagBurnRoleTokens MarloweV1 -> put TagSubmit -> put getResult = \case TagCreate MarloweV1 -> get TagApplyInputs MarloweV1 -> get TagWithdraw MarloweV1 -> get - TagBurn -> get + TagBurnRoleTokens MarloweV1 -> get TagSubmit -> get putTxBody :: (IsShelleyBasedEra era) => TxBody era -> Put @@ -1491,8 +1523,8 @@ instance CommandEq MarloweTxCommand where Withdraw MarloweV1 wallet' payoutIds' -> wallet == wallet' && payoutIds == payoutIds' - Burn wallet tokenFilter -> \case - Burn wallet' tokenFilter' -> + BurnRoleTokens MarloweV1 wallet tokenFilter -> \case + BurnRoleTokens MarloweV1 wallet' tokenFilter' -> wallet == wallet' && tokenFilter == tokenFilter' Submit BabbageEraOnwardsBabbage tx -> \case @@ -1510,21 +1542,21 @@ instance CommandEq MarloweTxCommand where TagCreate MarloweV1 -> (==) TagApplyInputs MarloweV1 -> (==) TagWithdraw MarloweV1 -> (==) - TagBurn -> (==) + TagBurnRoleTokens MarloweV1 -> (==) TagSubmit -> (==) errEq = \case TagCreate MarloweV1 -> (==) TagApplyInputs MarloweV1 -> (==) TagWithdraw MarloweV1 -> (==) - TagBurn -> (==) + TagBurnRoleTokens MarloweV1 -> (==) TagSubmit -> (==) resultEq = \case TagCreate MarloweV1 -> (==) TagApplyInputs MarloweV1 -> (==) TagWithdraw MarloweV1 -> (==) - TagBurn -> (==) + TagBurnRoleTokens MarloweV1 -> (==) TagSubmit -> (==) instance ShowCommand MarloweTxCommand where @@ -1550,7 +1582,7 @@ instance ShowCommand MarloweTxCommand where . showSpace . showString "MarloweV1" ) - TagBurn -> showString "TagBurn" + TagBurnRoleTokens MarloweV1 -> showString "TagBurnRoleTokens" TagSubmit -> showString "TagSubmit" showsPrecCommand p = @@ -1602,8 +1634,8 @@ instance ShowCommand MarloweTxCommand where . showSpace . showsPrec 11 payoutIds ) - Burn wallet tokenFilter -> - ( showString "Burn" + BurnRoleTokens MarloweV1 wallet tokenFilter -> + ( showString "BurnRoleTokens" . showSpace . showsPrec 11 wallet . showSpace @@ -1637,21 +1669,21 @@ instance ShowCommand MarloweTxCommand where TagCreate MarloweV1 -> showsPrec p TagApplyInputs MarloweV1 -> showsPrec p TagWithdraw MarloweV1 -> showsPrec p - TagBurn -> showsPrec p + TagBurnRoleTokens MarloweV1 -> showsPrec p TagSubmit -> showsPrec p showsPrecErr p = \case TagCreate MarloweV1 -> showsPrec p TagApplyInputs MarloweV1 -> showsPrec p TagWithdraw MarloweV1 -> showsPrec p - TagBurn -> showsPrec p + TagBurnRoleTokens MarloweV1 -> showsPrec p TagSubmit -> showsPrec p showsPrecResult p = \case TagCreate MarloweV1 -> showsPrec p TagApplyInputs MarloweV1 -> showsPrec p TagWithdraw MarloweV1 -> showsPrec p - TagBurn -> showsPrec p + TagBurnRoleTokens MarloweV1 -> showsPrec p TagSubmit -> showsPrec p instance Variations V1.TransactionError diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs index 78b66e727a..0424e25a1e 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs @@ -40,7 +40,13 @@ import Language.Marlowe.Runtime.Core.Api (MarloweVersion (..), renderContractId) import Language.Marlowe.Runtime.Core.ScriptRegistry (MarloweScripts, ReferenceScriptUtxo (..)) import Language.Marlowe.Runtime.Transaction.Api (MarloweTxCommand) import Language.Marlowe.Runtime.Transaction.BuildConstraints (MkRoleTokenMintingPolicy) -import Language.Marlowe.Runtime.Transaction.Chain +import Language.Marlowe.Runtime.Transaction.Chain ( + TransactionChainClientDependencies ( + TransactionChainClientDependencies, + chainSyncConnector + ), + transactionChainClient, + ) import Language.Marlowe.Runtime.Transaction.Constraints (MarloweContext (..), PayoutContext (..), WalletContext (..)) import Language.Marlowe.Runtime.Transaction.Query ( LoadMarloweContext, @@ -50,7 +56,33 @@ import Language.Marlowe.Runtime.Transaction.Query ( import qualified Language.Marlowe.Runtime.Transaction.Query as Q import Language.Marlowe.Runtime.Transaction.Query.Helper (LoadHelpersContext) import qualified Language.Marlowe.Runtime.Transaction.Query.Helper as QH -import Language.Marlowe.Runtime.Transaction.Server +import Language.Marlowe.Runtime.Transaction.Server ( + BuildTxField (Constraints, ResultingTxBody), + ExecField ( + Era, + EraHistory, + NetworkId, + ProtocolParameters, + SystemStart + ), + TransactionServerDependencies ( + TransactionServerDependencies, + analysisTimeout, + chainSyncQueryConnector, + contractQueryConnector, + getCurrentScripts, + getTip, + loadHelpersContext, + loadMarloweContext, + loadPayoutContext, + loadWalletContext, + marloweQueryConnector, + mkRoleTokenMintingPolicy, + mkSubmitJob + ), + TransactionServerSelector (..), + transactionServer, + ) import Language.Marlowe.Runtime.Transaction.Submit (SubmitJob) import Network.Protocol.Connection (Connector, ServerSource) import Network.Protocol.Job.Server (JobServer) @@ -140,6 +172,14 @@ renderTransactionServerSelectorOTel = \case Constraints MarloweV1 constraints -> [("marlowe.tx.constraints", fromString $ show constraints)] ResultingTxBody txBody -> [("cardano.tx_body.babbage", fromString $ show txBody)] } + ExecBurnRoleTokens -> + OTelRendered + { eventName = "marlowe_tx/exec/burn_role_tokens" + , eventKind = OTel.Server + , renderField = \case + Constraints MarloweV1 constraints -> [("marlowe.tx.constraints", fromString $ show constraints)] + ResultingTxBody txBody -> [("cardano.tx_body.babbage", fromString $ show txBody)] + } renderLoadWalletContextSelectorOTel :: RenderSelectorOTel Q.LoadWalletContextSelector renderLoadWalletContextSelectorOTel = \case diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs index e7a530f1bc..8d719b2508 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Burn.hs @@ -51,8 +51,8 @@ import Language.Marlowe.Runtime.ChainSync.Api ( ) import Language.Marlowe.Runtime.Core.Api (MarloweVersion (..)) import Language.Marlowe.Runtime.Transaction.Api ( - BurnError (..), - BurnTxInEra (..), + BurnRoleTokensError (..), + BurnRoleTokensTxInEra (..), RoleTokenFilter, evalRoleTokenFilter, ) @@ -75,11 +75,12 @@ burnRoleTokens -> Connector (QueryClient ChainSyncQuery) m -> BabbageEraOnwards era -> LedgerProtocolParameters era + -> MarloweVersion v -> WalletContext -> Set RoleCurrency -> RoleTokenFilter - -> ExceptT BurnError m (BurnTxInEra era) -burnRoleTokens start history chainQueryConnector era protocol walletCtx@WalletContext{..} currencies tokenFilter = do + -> ExceptT BurnRoleTokensError m (BurnRoleTokensTxInEra era v) +burnRoleTokens start history chainQueryConnector era protocol version walletCtx@WalletContext{..} currencies tokenFilter = do -- convert role currency info into a list let currenciesList = Set.toList currencies -- collect the policy IDs which are used by active contracts @@ -140,7 +141,8 @@ burnRoleTokens start history chainQueryConnector era protocol walletCtx@WalletCo >>= selectCoins era protocol MarloweV1 scriptCtx walletCtx helpersCtx >>= balanceTx era start (C.toLedgerEpochInfo history) protocol MarloweV1 scriptCtx walletCtx helpersCtx let burnedTokens = foldMap fst inputs - pure BurnTxInEra{..} + + pure BurnRoleTokensTxInEra{..} scriptHashesFromTokens :: Tokens -> Set ScriptHash scriptHashesFromTokens = Set.map (ScriptHash . unPolicyId . policyId) . Map.keysSet . unTokens diff --git a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs index ab9071f7f3..1d940b0e99 100644 --- a/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs +++ b/marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs @@ -109,8 +109,8 @@ import Language.Marlowe.Runtime.Core.ScriptRegistry (HelperScript (..), MarloweS import Language.Marlowe.Runtime.Transaction.Api ( Account, ApplyInputsError (..), - BurnError (..), - BurnTx (BurnTx), + BurnRoleTokensError (..), + BurnRoleTokensTx (BurnRoleTokensTx), ContractCreated (..), ContractCreatedInEra (..), CreateError (..), @@ -184,6 +184,7 @@ data TransactionServerSelector f where ExecCreate :: TransactionServerSelector BuildTxField ExecApplyInputs :: TransactionServerSelector BuildTxField ExecWithdraw :: TransactionServerSelector BuildTxField + ExecBurnRoleTokens :: TransactionServerSelector BuildTxField data ExecField = SystemStart SystemStart @@ -307,8 +308,8 @@ transactionServer = component "tx-job-server" \TransactionServerDependencies{..} version addresses payouts - Burn addresses tokenFilter -> - withEvent ExecWithdraw \_ -> + BurnRoleTokens version addresses tokenFilter -> + withEvent ExecBurnRoleTokens \_ -> execBurn systemStart eraHistory @@ -317,6 +318,7 @@ transactionServer = component "tx-job-server" \TransactionServerDependencies{..} era ledgerProtocolParameters loadWalletContext + version addresses tokenFilter Submit BabbageEraOnwardsBabbage tx -> @@ -707,7 +709,8 @@ execExceptT execExceptT = fmap (either (flip SendMsgFail ()) (flip SendMsgSucceed ())) . runExceptT execBurn - :: (MonadUnliftIO m, IsCardanoEra era) + :: forall era v m + . (MonadUnliftIO m, IsCardanoEra era) => SystemStart -> EraHistory -> Connector (QueryClient ChainSyncQuery) m @@ -715,15 +718,16 @@ execBurn -> CardanoEra era -> LedgerProtocolParameters era -> LoadWalletContext m + -> MarloweVersion v -> WalletAddresses -> RoleTokenFilter - -> m (ServerStCmd MarloweTxCommand Void BurnError BurnTx m ()) -execBurn start history chainQueryConnector marloweQueryConnector era protocol loadWalletContext addresses tokenFilter = execExceptT do + -> m (ServerStCmd MarloweTxCommand Void BurnRoleTokensError (BurnRoleTokensTx v) m ()) +execBurn start history chainQueryConnector marloweQueryConnector era protocol loadWalletContext version addresses tokenFilter = execExceptT do eon <- toBabbageEraOnwards (BurnEraUnsupported $ AnyCardanoEra era) era let tokenFilter' = optimizeRoleTokenFilter tokenFilter when (tokenFilter' == RoleTokenFilterNone) $ throwE BurnNoTokens walletContext <- lift $ loadWalletContext addresses currencies <- lift $ runConnector marloweQueryConnector $ getRoleCurrencies $ roleTokenFilterToRoleCurrencyFilter tokenFilter' - burnTx <- burnRoleTokens start history chainQueryConnector eon protocol walletContext currencies tokenFilter' - pure $ BurnTx eon burnTx + burnTx <- burnRoleTokens start history chainQueryConnector eon protocol version walletContext currencies tokenFilter' + pure $ BurnRoleTokensTx eon burnTx diff --git a/nix/marlowe-cardano/compose.nix b/nix/marlowe-cardano/compose.nix index 5d7949a5ef..ce7a2d4198 100644 --- a/nix/marlowe-cardano/compose.nix +++ b/nix/marlowe-cardano/compose.nix @@ -2,7 +2,7 @@ let inherit (pkgs) z3 sqitchPg postgresql runCommand writeShellScriptBin writeText glibcLocales; - network = inputs.self.networks.sanchonet; + network = inputs.self.networks.preview; inherit (inputs) marlowe-plutus; mkSqitchRunner = name: path: writeShellScriptBin name ''