Merge branch 'main' into main

marlowe-chain-sync/gen/Language/Marlowe/Runtime/ChainSync/Gen.hs

@@ -29,6 +29,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.ByteString.Short (fromShort)
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as Map
 import Data.Maybe (mapMaybe)
 import Data.SOP.Counting (Exactly (..))
 import Data.SOP.Strict (K (..), NP (..))
@@ -107,14 +108,14 @@ instance Arbitrary ValidityRange where
 instance Arbitrary Metadata where
   arbitrary =
     oneofStructured
-      [ (Node, MetadataMap <$> listOf (resized (`div` 10) arbitrary))
+      [ (Node, MetadataMap . Map.toList . Map.fromList <$> listOf (resized (`div` 10) arbitrary))
       , (Node, MetadataList <$> listOf (resized (`div` 10) arbitrary))
       , (Leaf, MetadataNumber <$> arbitrary)
       , (Leaf, MetadataBytes <$> genBytes)
       , (Leaf, MetadataText . T.pack <$> arbitrary)
       ]
   shrink = \case
-    MetadataMap ds -> MetadataMap <$> shrink ds
+    MetadataMap ds -> MetadataMap . Map.toList <$> shrink (Map.fromList ds)
     MetadataList ds -> MetadataList <$> shrink ds
     MetadataNumber _ -> []
     MetadataBytes bytes -> MetadataBytes . BS.pack <$> shrinkList shrink (BS.unpack bytes)

marlowe-chain-sync/marlowe-chain-sync.cabal

@@ -70,6 +70,7 @@ library
   other-modules:
   build-depends:
     , aeson >=2 && <3
+    , attoparsec
     , base >=4.9 && <5
     , base16 ^>=0.3.2
     , binary ^>=0.8.8
@@ -97,6 +98,7 @@ library
     , ouroboros-consensus ^>=0.7
     , plutus-core ^>=1.5
     , plutus-ledger-api ^>=1.5
+    , scientific
     , serialise ^>=0.2.6
     , text ^>=1.2
     , these >=1.1 && <2
@@ -220,6 +222,7 @@ library gen
     , bytestring >=0.10.12 && <0.12
     , cardano-api ^>=8.2
     , cardano-api-gen ^>=8.1
+    , containers ^>=0.6.5
     , hedgehog-quickcheck ^>=0.1
     , marlowe-chain-sync ==0.0.5
     , marlowe-protocols ==0.2.1.0

marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs

@@ -41,7 +41,8 @@ import qualified Cardano.Ledger.BaseTypes as Base
 import Cardano.Ledger.Credential (ptrCertIx, ptrSlotNo, ptrTxIx)
 import Cardano.Ledger.Slot (EpochSize)
 import Codec.Serialise (deserialiseOrFail, serialise)
-import Control.Monad (guard, join, (<=<), (>=>))
+import Control.Applicative ((<|>))
+import Control.Monad (guard, join, when, (<=<), (>=>))
 import Data.Aeson (
   FromJSON (..),
   FromJSONKey (..),
@@ -55,23 +56,27 @@ import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KeyMap
 import Data.Aeson.Text (encodeToLazyText)
-import Data.Aeson.Types (parseFail, toJSONKeyText)
+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.ByteString (ByteString)
+import qualified Data.ByteString as BS
 import Data.ByteString.Base16 (decodeBase16, encodeBase16)
-import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Char8 as BSC
 import Data.Foldable (Foldable (..))
 import Data.Function (on)
 import Data.Functor (($>))
 import Data.Hashable (Hashable)
+import Data.List (sortOn)
 import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe (fromJust, mapMaybe)
+import Data.Maybe (fromJust, fromMaybe, mapMaybe)
 import Data.Proxy (Proxy (..))
 import qualified Data.SOP.Counting as Counting
 import Data.SOP.Strict (K (..), NP (..))
+import qualified Data.Scientific as Scientific
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Set.NonEmpty (NESet)
@@ -80,6 +85,7 @@ import Data.String (IsString (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy as TL
 import Data.Time (UTCTime (..), diffTimeToPicoseconds, picosecondsToDiffTime)
 import Data.Time.Calendar.OrdinalDate (fromOrdinalDateValid, toOrdinalDate)
@@ -245,6 +251,72 @@ instance Variations Metadata where
 instance ToJSON Metadata where
   toJSON = metadataValueToJsonNoSchema . toCardanoMetadata
 
+-- TODO replace with metadataValueFromJsonNoSchema when it is exported!
+instance FromJSON Metadata where
+  parseJSON = go
+    where
+      go
+        :: Aeson.Value
+        -> Parser Metadata
+      go Aeson.Null = fail "Null not allowed"
+      go Aeson.Bool{} = fail "Booleans not allowed"
+      go (Aeson.Number d) =
+        case Scientific.floatingOrInteger d :: Either Double Integer of
+          Left _ -> fail "not an integer"
+          Right n -> pure $ MetadataNumber n
+      go (Aeson.String s)
+        | Just s' <- T.stripPrefix "0x" s
+        , let bs' = T.encodeUtf8 s'
+        , Right bs <- decodeBase16 bs'
+        , not (BSC.any (\c -> c >= 'A' && c <= 'F') bs') =
+            pure $ MetadataBytes bs
+      go (Aeson.String s) = pure $ MetadataText s
+      go (Aeson.Array vs) = fmap MetadataList . traverse go $ Vector.toList vs
+      go (Aeson.Object kvs) =
+        fmap MetadataMap
+          . traverse (\(k, v) -> (,) (parseKey k) <$> go v)
+          . sortOn fst
+          . fmap (first Key.toText)
+          $ KeyMap.toList kvs
+
+      parseKey :: Text -> Metadata
+      parseKey s =
+        fromMaybe (MetadataText s) $
+          parseAll
+            ( (MetadataNumber <$> pSigned <* Atto.endOfInput)
+                <|> (MetadataBytes <$> pBytes <* Atto.endOfInput)
+            )
+            s
+
+      parseAll :: Atto.Parser a -> Text -> Maybe a
+      parseAll p =
+        either (const Nothing) Just
+          . Atto.parseOnly p
+          . T.encodeUtf8
+
+      pUnsigned :: Atto.Parser Integer
+      pUnsigned = do
+        bs <- Atto.takeWhile1 Atto.isDigit
+        -- no redundant leading 0s allowed, or we cannot round-trip properly
+        guard (not (BS.length bs > 1 && BSC.head bs == '0'))
+        return $! BS.foldl' step 0 bs
+        where
+          step a w = a * 10 + fromIntegral (w - 48)
+
+      pSigned :: Atto.Parser Integer
+      pSigned = Atto.signed pUnsigned
+
+      pBytes :: Atto.Parser ByteString
+      pBytes = do
+        _ <- Atto.string "0x"
+        remaining <- Atto.takeByteString
+        when (BSC.any hexUpper remaining) $ fail ("Unexpected uppercase hex characters in " <> show remaining)
+        case decodeBase16 remaining of
+          Right bs -> return bs
+          _ -> fail ("Expecting base16 encoded string, found: " <> show remaining)
+        where
+          hexUpper c = c >= 'A' && c <= 'F'
+
 toCardanoMetadata :: Metadata -> C.TxMetadataValue
 toCardanoMetadata = \case
   MetadataMap ms -> C.TxMetaMap $ bimap toCardanoMetadata toCardanoMetadata <$> ms
@@ -553,16 +625,16 @@ newtype TokenName = TokenName {unTokenName :: ByteString}
   deriving newtype (Show, IsString, Binary, Variations, Hashable)
 
 instance ToJSONKey TokenName where
-  toJSONKey = toJSONKeyText $ T.pack . BS.unpack . unTokenName
+  toJSONKey = toJSONKeyText $ T.pack . BSC.unpack . unTokenName
 
 instance ToJSON TokenName where
-  toJSON = Aeson.String . T.pack . BS.unpack . unTokenName
+  toJSON = Aeson.String . T.pack . BSC.unpack . unTokenName
 
 instance FromJSON TokenName where
-  parseJSON = Aeson.withText "TokenName" (pure . TokenName . BS.pack . T.unpack)
+  parseJSON = Aeson.withText "TokenName" (pure . TokenName . BSC.pack . T.unpack)
 
 instance FromJSONKey TokenName where
-  fromJSONKey = FromJSONKeyText (TokenName . BS.pack . T.unpack)
+  fromJSONKey = FromJSONKeyText (TokenName . BSC.pack . T.unpack)
 
 newtype Quantity = Quantity {unQuantity :: Word64}
   deriving stock (Show, Eq, Ord, Generic)

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

@@ -399,6 +399,7 @@ testNftMetadata =
     , mediaType = Just "image/png"
     , files = []
     , description = Nothing
+    , additionalProperties = mempty
     }
 
 mkMarloweTxMetadata :: MetadataCase -> MarloweTransactionMetadata

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs

@@ -1,25 +1,43 @@
+{-# LANGUAGE GADTs #-}
+
 module Language.Marlowe.Runtime.Web.Contracts.Contract.Post where
 
 import Control.Monad.IO.Class (MonadIO (liftIO))
 
+import Cardano.Api (
+  AsType (..),
+  TxBody (..),
+  TxBodyContent (..),
+  TxMetadata (TxMetadata),
+  TxMetadataInEra (..),
+  TxMetadataSupportedInEra (TxMetadataInBabbageEra),
+  TxMetadataValue (..),
+  deserialiseFromTextEnvelope,
+ )
+import Data.Aeson (Value (String))
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
 import Data.Functor (void)
 import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust)
 import qualified Data.Set as Set
 import Data.Text (Text)
 import Data.Time (getCurrentTime, secondsToNominalDiffTime)
+import qualified Language.Marlowe.Core.V1.Semantics.Types as V1
 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 (..))
+import Language.Marlowe.Runtime.Web (ContractOrSourceId (..), CreateTxEnvelope (..))
 import qualified Language.Marlowe.Runtime.Web as Web
 import Language.Marlowe.Runtime.Web.Client (postContract)
-import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO))
-import Test.Hspec (Spec, describe, it)
+import Language.Marlowe.Runtime.Web.Server.DTO (FromDTO (..), ToDTO (toDTO))
+import Network.URI (parseURI)
+import Test.Hspec (Spec, describe, it, shouldBe)
 import Test.Integration.Marlowe.Local (withLocalMarloweRuntime)
 
 spec :: Spec
-spec = describe "Valid POST /contracts" do
+spec = describe "POST /contracts" do
   it "returns the contract header"
     . specWithRolesConfig Nothing
     $ Web.Mint . Map.singleton "PartyA" . flip Web.RoleTokenConfig Nothing . flip Map.singleton 1 . Web.ClosedRole
@@ -30,6 +48,7 @@ spec = describe "Valid POST /contracts" do
     $ Map.fromList
       [ ("PartyA", Web.RoleTokenConfig (Map.singleton Web.OpenRole 1) Nothing)
       ]
+  bugPLT8712
 
 specWithRolesConfig :: Maybe Text -> (Web.Address -> Web.RolesConfig) -> IO ()
 specWithRolesConfig threadTokenName roles =
@@ -68,3 +87,68 @@ specWithRolesConfig threadTokenName roles =
     case result of
       Left _ -> fail $ "Expected 200 response code - got " <> show result
       Right _ -> pure ()
+
+bugPLT8712 :: Spec
+bugPLT8712 = do
+  describe "[BUG] PLT-8712: Runtime drops field from minting metadata" do
+    it "Marlowe Runtime supports additional properties" $ withLocalMarloweRuntime $ runIntegrationTest do
+      wallet <- getGenesisWallet 0
+      either (fail . show) pure =<< runWebClient do
+        let walletAddress = toDTO $ changeAddress $ addresses wallet
+        CreateTxEnvelope{..} <-
+          postContract
+            Nothing
+            walletAddress
+            Nothing
+            Nothing
+            Web.PostContractsRequest
+              { metadata = mempty
+              , version = Web.V1
+              , threadTokenName = Nothing
+              , roles =
+                  Just $
+                    Web.Mint $
+                      Map.singleton "Test Role" $
+                        Web.RoleTokenConfig
+                          { recipients = Map.singleton Web.OpenRole 1
+                          , metadata =
+                              Just
+                                Web.TokenMetadata
+                                  { name = "Name"
+                                  , image = fromJust $ parseURI "https://example.com"
+                                  , mediaType = Just "image/png"
+                                  , description = Just "Test description"
+                                  , files = Nothing
+                                  , additionalProps =
+                                      KeyMap.fromList
+                                        [ (Key.fromText "url", String "https://example.com")
+                                        ]
+                                  }
+                          }
+              , contract = ContractOrSourceId $ Left V1.Close
+              , minUTxODeposit = Nothing
+              , tags = mempty
+              }
+        liftIO do
+          textEnvelope <- expectJust "Failed to convert text envelope" $ fromDTO txEnvelope
+          TxBody TxBodyContent{..} <-
+            expectRight "Failed to deserialise tx body" $
+              deserialiseFromTextEnvelope (AsTxBody AsBabbageEra) textEnvelope
+          case txMetadata of
+            TxMetadataNone -> fail "expected metadata"
+            TxMetadataInEra TxMetadataInBabbageEra (TxMetadata m) -> do
+              TxMetaMap [(TxMetaBytes _, tokenMetadata)] <- expectJust "Failed to lookup metadata" $ Map.lookup 721 m
+              let expected =
+                    TxMetaMap
+                      [
+                        ( TxMetaBytes "Test Role"
+                        , TxMetaMap
+                            [ (TxMetaText "name", TxMetaText "Name")
+                            , (TxMetaText "image", TxMetaList [TxMetaText "https://example.com"])
+                            , (TxMetaText "mediaType", TxMetaText "image/png")
+                            , (TxMetaText "description", TxMetaList [TxMetaText "Test description"])
+                            , (TxMetaText "url", TxMetaText "https://example.com")
+                            ]
+                        )
+                      ]
+              tokenMetadata `shouldBe` expected

marlowe-runtime-web/.golden/OpenApi/golden

@@ -1435,7 +1435,35 @@
                 "type": "string"
             },
             "Metadata": {
-                "description": "An arbitrary JSON value for storage in a metadata key"
+                "description": "Arbitrary JSON-encoded transaction metadata",
+                "oneOf": [
+                    {
+                        "type": "integer"
+                    },
+                    {
+                        "description": "Hex-encoded binary data of up to 64 bytes",
+                        "pattern": "0x[A-Fa-f0-9]{0,128}",
+                        "type": "string"
+                    },
+                    {
+                        "description": "Text data of up to 64 characters",
+                        "type": "string"
+                    },
+                    {
+                        "description": "Array of metadata values",
+                        "items": {
+                            "$ref": "#/components/schemas/Metadata"
+                        },
+                        "type": "array"
+                    },
+                    {
+                        "additionalProperties": {
+                            "$ref": "#/components/schemas/Metadata"
+                        },
+                        "description": "Object of metadata values",
+                        "type": "object"
+                    }
+                ]
             },
             "Next": {
                 "description": "Describe the reducibility (Can be Reduced ?) and the applicability (Can Inputs be Applied ?) for a given contract.",
@@ -2359,6 +2387,9 @@
                 "type": "object"
             },
             "TokenMetadata": {
+                "additionalProperties": {
+                    "$ref": "#/components/schemas/Metadata"
+                },
                 "description": "Metadata for an NFT, as described by https://cips.cardano.org/cips/cip25/",
                 "properties": {
                     "description": {
@@ -2387,6 +2418,9 @@
                 "type": "object"
             },
             "TokenMetadataFile": {
+                "additionalProperties": {
+                    "$ref": "#/components/schemas/Metadata"
+                },
                 "properties": {
                     "mediaType": {
                         "type": "string"