PLT-7111 Web and Tx api changes supporting open roles.

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs

@@ -791,6 +791,7 @@ instance FromDTO Tx.RoleTokensConfig where
   fromDTO = \case
     Nothing -> pure Tx.RoleTokensNone
     Just (Web.UsePolicy policy) -> Tx.RoleTokensUsePolicy <$> fromDTO policy
+    Just (Web.UsePolicyWithOpenRoles policy openRoleNames) -> Tx.RoleTokensUsePolicyWithOpenRoles <$> fromDTO policy <*> fromDTO openRoleNames
     Just (Web.Mint mint) -> Tx.RoleTokensMint <$> fromDTO mint
 
 instance HasDTO Tx.Mint where
@@ -804,11 +805,13 @@ instance FromDTO Tx.Mint where
         . Map.toList
     where
       convertConfig = \case
-        Web.RoleTokenSimple address -> (,Nothing) <$> fromDTO address
+        Web.RoleTokenSimple address -> (,Nothing) . Tx.ToAddress <$> fromDTO address
         Web.RoleTokenAdvanced address metadata ->
-          curry (second Just)
+          curry (second Just) . Tx.ToAddress
             <$> fromDTO address
             <*> fromDTO metadata
+        Web.OpenRoleTokenSimple -> pure (Tx.ToScript Tx.OpenRoleScript, Nothing)
+        Web.OpenRoleTokenAdvanced metadata -> (Tx.ToScript Tx.OpenRoleScript,) . Just <$> fromDTO metadata
 
 instance HasDTO Tx.RoleTokenMetadata where
   type DTO Tx.RoleTokenMetadata = Web.TokenMetadata

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

@@ -12,8 +12,9 @@
 -- | Web API.
 module Language.Marlowe.Runtime.Web.Types where
 
+import Control.Applicative ((<|>))
 import Control.Lens hiding ((.=))
-import Control.Monad ((<=<))
+import Control.Monad (guard, (<=<))
 import Data.Aeson
 import Data.Aeson.Text (encodeToLazyText)
 import Data.Aeson.Types (Parser, parseFail, toJSONKeyText)
@@ -772,6 +773,7 @@ data PostContractsRequest = PostContractsRequest
   , metadata :: Map Word64 Metadata
   , version :: MarloweVersion
   , roles :: Maybe RolesConfig
+  , threadTokenName :: Maybe String
   , contract :: ContractOrSourceId
   , minUTxODeposit :: Word64
   }
@@ -807,15 +809,34 @@ instance ToSchema ContractOrSourceId where
 
 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 = Mint <$> parseJSON value
+  parseJSON value =
+    withObject
+      "RoleConfig"
+      ( \obj ->
+          let parseMint = Mint <$> parseJSON value
+              parseOpen =
+                do
+                  script <- obj .: "script"
+                  guard $ script == ("OpenRole" :: String)
+                  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
@@ -830,14 +851,24 @@ instance ToSchema RolesConfig where
 data RoleTokenConfig
   = RoleTokenSimple Address
   | RoleTokenAdvanced Address TokenMetadata
+  | OpenRoleTokenSimple
+  | OpenRoleTokenAdvanced TokenMetadata
   deriving (Show, Eq, Ord, Generic)
 
 instance FromJSON RoleTokenConfig where
   parseJSON (String s) = pure $ RoleTokenSimple $ Address s
   parseJSON value =
     withObject
       "RoleTokenConfig"
-      (\obj -> RoleTokenAdvanced <$> obj .: "address" <*> obj .: "metadata")
+      ( \obj ->
+          let parseAdvanced = RoleTokenAdvanced <$> obj .: "address" <*> obj .: "metadata"
+              parseOpen =
+                do
+                  script <- obj .: "script"
+                  guard $ script == ("OpenRole" :: String)
+                  OpenRoleTokenAdvanced <$> obj .: "metadata" <|> pure OpenRoleTokenSimple
+           in parseAdvanced <|> parseOpen
+      )
       value
 
 instance ToJSON RoleTokenConfig where
@@ -847,6 +878,14 @@ instance ToJSON RoleTokenConfig where
       [ ("address", toJSON address)
       , ("metadata", toJSON config)
       ]
+  toJSON OpenRoleTokenSimple =
+    object
+      [("script", "OpenRole")]
+  toJSON (OpenRoleTokenAdvanced config) =
+    object
+      [ ("script", "OpenRole")
+      , ("metadata", toJSON config)
+      ]
 
 instance ToSchema RoleTokenConfig where
   declareNamedSchema _ = do
@@ -860,10 +899,23 @@ instance ToSchema RoleTokenConfig where
               .~ [ ("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 ?~ [simpleSchema, Inline advancedSchema]
+          & oneOf ?~ [simpleSchema, Inline advancedSchema, Inline openSchema]
 
 data TokenMetadata = TokenMetadata
   { name :: Text

marlowe-runtime-web/test/Spec.hs

@@ -207,6 +207,7 @@ instance Arbitrary Web.PostContractsRequest where
       <*> arbitrary
       <*> arbitrary
       <*> arbitrary
+      <*> arbitrary
       -- size of 6 will result in a 1-layer deep contract being generated (this is
       -- all we care about for the purposes of schema checking).
       <*> arbitrary