Add support for additional properties on token file metadata

input-output-hk · Nov 27, 2023 · 739408f · 739408f
1 parent 0904aca
commit 739408f
Show file tree

Hide file tree

Showing 8 changed files with 89 additions and 27 deletions.
diff --git a/marlowe-runtime-web/.golden/OpenApi/golden b/marlowe-runtime-web/.golden/OpenApi/golden
@@ -2418,6 +2418,9 @@
                 "type": "object"
             },
             "TokenMetadataFile": {
+                "additionalProperties": {
+                    "$ref": "#/components/schemas/Metadata"
+                },
                 "properties": {
                     "mediaType": {
                         "type": "string"

diff --git a/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs b/marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs
@@ -855,7 +855,10 @@ instance HasDTO Tx.NFTMetadataFile where
 
 instance FromDTO Tx.NFTMetadataFile where
   fromDTO Web.TokenMetadataFile{..} =
-    Tx.NFTMetadataFile name <$> fromDTO mediaType <*> pure src
+    Tx.NFTMetadataFile name
+      <$> fromDTO mediaType
+      <*> pure src
+      <*> traverse fromDTO (Map.mapKeys Key.toText $ KeyMap.toMap $ Web.Metadata <$> additionalProps)
 
 instance HasDTO Query.Order where
   type DTO Query.Order = Pagination.RangeOrder

diff --git a/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs b/marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Types.hs
@@ -1076,28 +1076,37 @@ 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
+    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
@@ -1108,6 +1117,7 @@ instance ToSchema TokenMetadataFile where
                , ("src", stringSchema)
                , ("mediaType", stringSchema)
                ]
+          & additionalProperties ?~ AdditionalPropertiesSchema metadataSchema
 
 uriFromJSON :: Value -> Parser URI
 uriFromJSON = withText "URI" $ maybe (parseFail "invalid URI") pure . parseURI . T.unpack

diff --git a/marlowe-runtime-web/test/Spec.hs b/marlowe-runtime-web/test/Spec.hs
@@ -46,7 +46,7 @@ import Spec.Marlowe.Semantics.Arbitrary ()
 import Spec.Marlowe.Semantics.Next.Arbitrary ()
 import Test.Hspec (Spec, describe, hspec, it, shouldBe)
 import Test.Hspec.Golden (defaultGolden)
-import Test.QuickCheck (Arbitrary (..), Gen, elements, genericShrink, listOf, oneof, resize, suchThat)
+import Test.QuickCheck (Arbitrary (..), Gen, chooseInt, elements, genericShrink, listOf, oneof, resize, sized, suchThat)
 import Test.QuickCheck.Instances ()
 import Text.Regex.Posix ((=~))
 
@@ -578,12 +578,26 @@ instance Arbitrary Web.TokenMetadata where
       <*> arbitrary
       <*> arbitrary
       <*> arbitrary
-      <*> arbitrary
+      <*> oneof
+        [ pure Nothing
+        , Just <$> sized \size -> do
+            len <- chooseInt (0, size)
+            case len of
+              0 -> pure []
+              _ -> do
+                let itemSize = size `div` len
+                resize itemSize $ replicateM len arbitrary
+        ]
       <*> arbitrary
   shrink = genericShrink
 
 instance Arbitrary Web.TokenMetadataFile where
-  arbitrary = Web.TokenMetadataFile <$> arbitrary <*> arbitrary <*> arbitrary
+  arbitrary =
+    Web.TokenMetadataFile
+      <$> arbitrary
+      <*> arbitrary
+      <*> arbitrary
+      <*> arbitrary
   shrink = genericShrink
 
 instance Arbitrary Web.Address where

diff --git a/marlowe-runtime/.golden/Job MarloweTxCommand/golden b/marlowe-runtime/.golden/Job MarloweTxCommand/golden
diff --git a/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs b/marlowe-runtime/gen/Language/Marlowe/Runtime/Transaction/Gen.hs
@@ -90,6 +90,7 @@ instance Arbitrary NFTMetadataFile where
       <$> arbitrary
       <*> arbitrary
       <*> arbitrary
+      <*> arbitrary
   shrink = genericShrink
 
 instance Arbitrary RoleTokenMetadata where

diff --git a/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ApiSpec.hs b/marlowe-runtime/test/Language/Marlowe/Runtime/Transaction/ApiSpec.hs
@@ -147,7 +147,8 @@ cip25MetadataFileDetailsJSONRelationGen = do
           name <- Gen.oneof [pure "", fromString <$> Gen.listOf1 Gen.arbitrary]
           (mediaType, mediaTypeJSON) <- mediaTypeJSONRelationGen
           (src, srcJSON) <- uriJSONRelationGen
-          let json =
+          let additionalProperties = mempty -- Here we don't test roundtrip for additional properties, which is not in invertible in general.
+              json =
                 Aeson.Object
                   [ ("name", Aeson.String name)
                   , ("mediaType", mediaTypeJSON)

diff --git a/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs b/marlowe-runtime/tx-api/Language/Marlowe/Runtime/Transaction/Api.hs
@@ -171,6 +171,7 @@ data NFTMetadataFile = NFTMetadataFile
   { name :: Text
   , mediaType :: MediaType
   , src :: Network.URI
+  , additionalProperties :: Map Text Metadata
   }
   deriving stock (Show, Eq, Ord, Generic)
   deriving (Binary, Variations)
@@ -188,11 +189,19 @@ parseJsonUri (Text.unpack -> s) =
   maybe (fail $ s <> " is not a valid URI!") pure $ Network.parseURI s
 
 instance Aeson.FromJSON NFTMetadataFile where
-  parseJSON = Aeson.withObject "NFTMetadataFile" \x ->
+  parseJSON = Aeson.withObject "NFTMetadataFile" \x -> do
+    let additionalProperties =
+          Map.mapKeys Key.toText . Map.withoutKeys (Aeson.toMap x) $
+            Set.fromList
+              [ "name"
+              , "mediaType"
+              , "src"
+              ]
     NFTMetadataFile
       <$> x .: "name"
       <*> x .: "mediaType"
       <*> (parseJsonUri =<< x .: "src")
+      <*> forWithKey additionalProperties \key value -> Aeson.parseJSON value <?> Aeson.Types.Key (Key.fromText key)
 
 data RoleTokenMetadata = RoleTokenMetadata
   { name :: Text
@@ -269,6 +278,7 @@ decodeRoleTokenMetadata = parseNFTMetadataDetails
       name <- parseMetadataText =<< Map.lookup "name" textKeyMap
       mediaType <- parseMediaType =<< Map.lookup "mediaType" textKeyMap
       src <- Network.parseURI . Text.unpack =<< parseSplittableText =<< Map.lookup "src" textKeyMap
+      let additionalProperties = Map.withoutKeys textKeyMap $ Set.fromList ["name", "mediaType", "src"]
       Just $ NFTMetadataFile{..}
 
     parseMediaType :: Metadata -> Maybe MediaType