PLT-5187 Work in progress on OpenAPI for Plutus addresses.

marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Orphans.hs

@@ -1,11 +1,12 @@
+-- editorconfig-checker-disable-file
+
 {-# LANGUAGE OverloadedLists #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Language.Marlowe.Runtime.Web.Orphans where
 
 import Control.Lens hiding (both, from, to)
-import qualified Data.Aeson as A
 import Data.OpenApi hiding (value)
 import Data.Proxy (Proxy(Proxy))
 import Data.Text (Text)
@@ -476,8 +477,7 @@ instance ToSchema V1.SafetyError where
       choiceIdSchema <- ("choice-id", ) <$> declareSchemaRef (Proxy @ChoiceId)
       costSchema <- ("cost", ) <$> declareSchemaRef (Proxy @P.ExBudget)
       transactionSchema <- ("transaction", ) <$> declareSchemaRef (Proxy @V1.Transaction)
---    addressSchema <- ("address", ) <$> declareSchemaRef (Proxy @P.Address)
-      addressSchema <- ("address", ) <$> declareSchemaRef (Proxy @A.Object)
+      addressSchema <- ("address", ) <$> declareSchemaRef (Proxy @P.Address)
       let
         errorSchema = ("error", stringSchema)
         detailSchema = ("detail", stringSchema)
@@ -505,20 +505,171 @@ instance ToSchema V1.SafetyError where
 instance ToSchema V1.ValueId where
   declareNamedSchema _ = pure . NamedSchema (Just "ValueId") $ sketchSchema $ V1.ValueId "x"
 
+instance ToSchema V1.Payment where
+  declareNamedSchema _ =
+    do
+      accountIdSchema <- ("payment_from", ) <$> declareSchemaRef (Proxy @V1.AccountId)
+      payeeSchema <- ("to", ) <$> declareSchemaRef (Proxy @V1.Payee)
+      tokenSchema <- ("token", ) <$> declareSchemaRef (Proxy @V1.Token)
+      amountSchema <- ("amount", ) <$> declareSchemaRef (Proxy @Integer)
+      pure
+        $ NamedSchema (Just "Payment")
+        $ mempty
+        & description ?~ "A Marlowe payment."
+        & required .~ fmap fst [accountIdSchema, payeeSchema, tokenSchema, amountSchema]
+        & properties .~ [accountIdSchema, payeeSchema, tokenSchema, amountSchema]
+
 instance ToSchema V1.Transaction where
   declareNamedSchema _ =
     do
       stateSchema <- ("state", ) <$> declareSchemaRef (Proxy @State)
       contractSchema <- ("contract", ) <$> declareSchemaRef (Proxy @Contract)
-      inputSchema <- ("input", ) <$> declareSchemaRef (Proxy @A.Object)  -- FIXME
-      outputSchema <- ("output", ) <$> declareSchemaRef (Proxy @A.Object)  -- FIXME
+      inputSchema <- ("input", ) <$> declareSchemaRef (Proxy @V1.TransactionInput)
+      outputSchema <- ("output", ) <$> declareSchemaRef (Proxy @V1.TransactionOutput)
       pure
         $ NamedSchema (Just "Transaction")
         $ mempty
         & description ?~ "Information about a Marlowe transaction."
         & required .~ fmap fst [stateSchema, contractSchema, inputSchema, outputSchema]
         & properties .~ [stateSchema, contractSchema, inputSchema, outputSchema]
 
+instance ToSchema V1.TransactionInput where
+  declareNamedSchema _ =
+    do
+      integerSchema <- declareSchemaRef $ Proxy @Integer
+      let
+        intervalSchema' =
+          mempty
+            & type_ ?~ OpenApiObject
+            & description ?~ "Time interval."
+            & required .~ fmap fst [lower, upper]
+            & properties .~ [lower, upper]
+            where
+              lower = ("from", integerSchema)
+              upper = ("to", integerSchema)
+        intervalSchema = ("tx_interval", Inline intervalSchema')
+      inputsSchema <- ("tx_inputs" ,) <$> declareSchemaRef (Proxy @[V1.Input])
+      pure
+        $ NamedSchema (Just "TransactionInput")
+        $ mempty
+        & description ?~ "Marlowe transaction input."
+        & required .~ fmap fst [intervalSchema, inputsSchema]
+        & properties .~ [intervalSchema, inputsSchema]
+
+instance ToSchema V1.TransactionOutput where
+  declareNamedSchema _ =
+    do
+      txErrorSchema <- declareSchemaRef $ Proxy @V1.TransactionError
+      warningsSchema <- ("warnings", ) <$> declareSchemaRef (Proxy @[V1.TransactionWarning])
+      paymentsSchema <- ("payments", ) <$> declareSchemaRef (Proxy @[V1.Payment])
+      stateSchema <- ("state", ) <$> declareSchemaRef (Proxy @V1.State)
+      contractSchema <- ("contract", ) <$> declareSchemaRef (Proxy @V1.Contract)
+      let
+        noErrorSchema =
+          mempty
+            & type_ ?~ OpenApiObject
+            & description ?~ "Marlowe transaction output information."
+            & required .~ fmap fst [warningsSchema, paymentsSchema, stateSchema, contractSchema]
+            & properties .~ [warningsSchema, paymentsSchema, stateSchema, contractSchema]
+        errorSchema =
+          mempty
+            & type_ ?~ OpenApiObject
+            & description ?~ "Marlowe transaction error."
+            & required .~ fmap fst [message]
+            & properties .~ [message]
+            where
+              message = ("transaction_error", txErrorSchema)
+      pure
+        $ NamedSchema (Just "TransactionOutput")
+        $ mempty
+        & description ?~ "Marlowe transaction output."
+        & oneOf ?~ fmap Inline [noErrorSchema, errorSchema]
+
+instance ToSchema V1.TransactionError where
+  declareNamedSchema _ =
+    do
+      ieSchema <- declareSchemaRef $ Proxy @V1.IntervalError
+      let
+        ambiguousIntervalSchema =
+          mempty
+            & type_ ?~ OpenApiString
+            & description ?~ "Ambiguous time interval."
+            & enum_ ?~ ["TEAmbiguousTimeIntervalError"]
+        applyNoMatchSchema =
+          mempty
+            & type_ ?~ OpenApiString
+            & description ?~ "No match on applying input."
+            & enum_ ?~ ["TEApplyNoMatchError"]
+        uselessTransactionSchema =
+          mempty
+            & type_ ?~ OpenApiString
+            & description ?~ "A useless application of input."
+            & enum_ ?~ ["TEUselessTransaction"]
+        intervalErrorSchema =
+          mempty
+            & type_ ?~ OpenApiObject
+            & description ?~ "An invalid time interval."
+            & required .~ fmap fst [message, interval]
+            & properties .~ [message, interval]
+            where
+              message = ("error", Inline $  mempty & type_ ?~ OpenApiString & enum_ ?~ ["TEIntervalError"])
+              interval = ("context", ieSchema)
+        hashMismatchSchema =
+          mempty
+            & type_ ?~ OpenApiString
+            & description ?~ "A mismatch in the continuation hash."
+            & enum_ ?~ ["TEHashMismatch"]
+      pure
+        $ NamedSchema (Just "TransactionError")
+        $ mempty
+        & description ?~ "A Marlowe transaction error."
+        & oneOf ?~ fmap Inline [ambiguousIntervalSchema, applyNoMatchSchema, intervalErrorSchema, uselessTransactionSchema, hashMismatchSchema]
+
+instance ToSchema V1.IntervalError where
+  declareNamedSchema _ =
+    do
+      integerSchema <- declareSchemaRef $ Proxy @Integer
+      let
+        from = ("from", integerSchema)
+        to = ("to", integerSchema)
+        minTime = ("minTime", integerSchema)
+        invalidIntervalSchema =
+          mempty
+            & type_ ?~ OpenApiObject
+            & description ?~ "Invalid Marlowe transaction interval."
+            & required .~ fmap fst [invalid]
+            & properties .~ [invalid]
+            where
+              invalid =
+                (
+                  "invalidInterval"
+                , Inline
+                    $ mempty
+                    & type_ ?~ OpenApiObject
+                    & required .~ fmap fst [from, to]
+                    & properties .~ [from, to]
+                )
+        intervalInPastSchema =
+          mempty
+            & type_ ?~ OpenApiObject
+            & description ?~ "Marlowe transaction interval in past."
+            & required .~ fmap fst [past]
+            & properties .~ [past]
+            where
+              past =
+                (
+                  "intervalInPastError"
+                , Inline
+                    $ mempty
+                    & type_ ?~ OpenApiObject
+                    & required .~ fmap fst [minTime, from, to]
+                    & properties .~ [minTime, from, to]
+                )
+      pure
+        $ NamedSchema (Just "IntervalError")
+        $ mempty
+        & description ?~ "A Marlowe transaction interval error."
+        & oneOf ?~ fmap Inline [invalidIntervalSchema, intervalInPastSchema]
 
 instance ToSchema V1.TransactionWarning where
   declareNamedSchema _ =
@@ -651,6 +802,8 @@ instance ToSchema P.StakingCredential where
         $ mempty
         & description ?~ "A Plutus staking credential."
         & oneOf ?~ fmap Inline [stakingHashSchema, stakingPtrSchema]
+        & nullable ?~ True
 
 instance ToSchema P.ExBudget where
   declareNamedSchema _ = pure . NamedSchema (Just "ExBudget") $ sketchSchema $ P.ExBudget 10 10
+

marlowe-runtime-web/test/Spec.hs

@@ -143,7 +143,7 @@ instance Arbitrary Web.PostTransactionsRequest where
   shrink = genericShrink
 
 instance Arbitrary (Web.CreateTxEnvelope tx) where
-  arbitrary = Web.CreateTxEnvelope <$> arbitrary <*> arbitrary <*> arbitrary
+  arbitrary = Web.CreateTxEnvelope <$> arbitrary <*> arbitrary <*> resize 5 arbitrary
   shrink = genericShrink
 
 instance Arbitrary (Web.WithdrawTxEnvelope tx) where

marlowe-test/src/Spec/Marlowe/Semantics/Arbitrary.hs

@@ -1326,7 +1326,7 @@ instance Arbitrary Transaction where
      do
        context <- arbitrary
        txState <- semiArbitrary context
-       txContract <- resize 5 $ semiArbitrary context
+       txContract <- semiArbitrary context
        txInput <- semiArbitrary context
        txOutput <- arbitrary
        pure Transaction{..}