Merge pull request #2509 from input-output-hk/rvl/adp-413/metadata-va…

…lidation

Add detailed validation of metadata-server responses

lib/core-integration/src/Test/Integration/Framework/TestData.hs

@@ -24,6 +24,9 @@ module Test.Integration.Framework.TestData
     , russianWalletName
     , wildcardsWalletName
 
+    -- * Assets
+    , steveToken
+
     -- * Helpers
     , cmdOk
     , versionLine
@@ -78,6 +81,10 @@ module Test.Integration.Framework.TestData
 
 import Prelude
 
+import Cardano.Wallet.Api.Types
+    ( ApiAssetMetadata (ApiAssetMetadata), ApiT (..) )
+import Cardano.Wallet.Unsafe
+    ( unsafeFromText )
 import Cardano.Wallet.Version
     ( gitRevision, showFullVersion, version )
 import Data.Text
@@ -87,6 +94,8 @@ import Data.Word
 import Test.Integration.Framework.DSL
     ( Payload (..), fixturePassphrase, json )
 
+import qualified Cardano.Wallet.Primitive.Types.TokenPolicy as W
+
 falseWalletIds :: [(String, String)]
 falseWalletIds =
         [ ("40 chars hex", replicate 40 '1')
@@ -169,6 +178,17 @@ wildcardsWalletName = "`~`!@#$%^&*()_+-=<>,./?;':\"\"'{}[]\\|❤️ 💔 💌 
 \💓 💗 💖 💘 💝 💟 💜 💛 💚 💙0️⃣ 1️⃣ 2️⃣ 3️⃣ 4️⃣ 5️⃣ 6️⃣ 7️⃣ 8️⃣ 9️⃣ 🔟🇺🇸🇷🇺🇸 🇦🇫🇦🇲🇸"
 
 
+---
+--- Assets
+---
+
+steveToken :: ApiAssetMetadata
+steveToken = ApiAssetMetadata
+    "SteveToken" "A sample description" (Just "STV")
+    (Just (ApiT (unsafeFromText "https://iohk.io/stevetoken")))
+    (Just (ApiT (W.AssetLogo "Almost a logo")))
+    (Just (ApiT (W.AssetUnit "MegaSteve" 6)))
+
 ---
 --- Helpers
 ---

lib/core-integration/src/Test/Integration/Scenario/API/Byron/Transactions.hs

@@ -36,8 +36,6 @@ import Cardano.Wallet.Primitive.AddressDerivation.Icarus
     ( IcarusKey )
 import Cardano.Wallet.Primitive.Types.Hash
     ( Hash (..) )
-import Cardano.Wallet.Primitive.Types.TokenPolicy
-    ( AssetLogo (..), AssetMetadata (AssetMetadata), AssetUnit (AssetUnit) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Direction (..), TxStatus (..) )
 import Cardano.Wallet.Unsafe
@@ -105,7 +103,11 @@ import Test.Integration.Framework.DSL
 import Test.Integration.Framework.Request
     ( RequestException )
 import Test.Integration.Framework.TestData
-    ( errMsg400StartTimeLaterThanEndTime, errMsg404NoAsset, errMsg404NoWallet )
+    ( errMsg400StartTimeLaterThanEndTime
+    , errMsg404NoAsset
+    , errMsg404NoWallet
+    , steveToken
+    )
 
 import qualified Cardano.Wallet.Api.Link as Link
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
@@ -253,14 +255,11 @@ spec = describe "BYRON_TRANSACTIONS" $ do
                 pickAnAsset assetsSrc
         let ep = Link.getByronAsset wal polId assName
         r <- request @(ApiAsset) ctx ep Default Empty
-        let meta = ApiT $ AssetMetadata "SteveToken" "A sample description"
-                (Just "STV") (Just "https://iohk.io/stevetoken")
-                (Just (AssetLogo "Almost a logo")) (Just (AssetUnit "MegaSteve" 6))
         verify r
             [ expectSuccess
             , expectField #policyId (`shouldBe` ApiT polId)
             , expectField #assetName (`shouldBe` ApiT assName)
-            , expectField #metadata (`shouldBe` Just meta)
+            , expectField #metadata (`shouldBe` Just steveToken)
             ]
 
     describe "BYRON_TRANS_ASSETS_GET_02 - Asset not present when isn't associated" $

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs

@@ -48,8 +48,6 @@ import Cardano.Wallet.Primitive.Types.Address
     ( Address )
 import Cardano.Wallet.Primitive.Types.Hash
     ( Hash (..) )
-import Cardano.Wallet.Primitive.Types.TokenPolicy
-    ( AssetLogo (..), AssetMetadata (..), AssetUnit (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Direction (..), TxMetadata (..), TxMetadataValue (..), TxStatus (..) )
 import Cardano.Wallet.Unsafe
@@ -169,6 +167,7 @@ import Test.Integration.Framework.TestData
     , errMsg404CannotFindTx
     , errMsg404NoAsset
     , errMsg404NoWallet
+    , steveToken
     )
 import UnliftIO.Concurrent
     ( threadDelay )
@@ -616,12 +615,9 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
             , expectField (#assets . #total . #getApiT) (`shouldNotBe` TokenMap.empty)
             ]
 
-        let meta = ApiT $ AssetMetadata "SteveToken" "A sample description"
-                (Just "STV") (Just "https://iohk.io/stevetoken")
-                (Just (AssetLogo "Almost a logo")) (Just (AssetUnit "MegaSteve" 6))
         r2 <- request @[ApiAsset] ctx (Link.listAssets w) Default Empty
         verify r2
-            [ expectListField 0 #metadata (`shouldBe` Just meta)
+            [ expectListField 0 #metadata (`shouldBe` Just steveToken)
             ]
 
     it "TRANS_ASSETS_CREATE_01a - Multi-asset transaction with Ada" $ \ctx -> runResourceT $ do
@@ -806,19 +802,11 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 pickAnAsset assetsSrc
         let ep = Link.getAsset wal polId assName
         r <- request @(ApiAsset) ctx ep Default Empty
-        let meta = ApiT $ AssetMetadata
-                { name = "SteveToken"
-                , description = "A sample description"
-                , acronym = Just "STV"
-                , url = Just "https://iohk.io/stevetoken"
-                , unit = Just $ AssetUnit "MegaSteve" 6
-                , logo = Just $ AssetLogo "Almost a logo"
-                }
         verify r
             [ expectSuccess
             , expectField #policyId (`shouldBe` ApiT polId)
             , expectField #assetName (`shouldBe` ApiT assName)
-            , expectField #metadata (`shouldBe` Just meta)
+            , expectField #metadata (`shouldBe` Just steveToken)
             ]
 
     it "TRANS_ASSETS_GET_02 - Asset not present when isn't associated" $ \ctx -> runResourceT $ do

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -49,6 +49,8 @@ module Cardano.Wallet.Api.Types
     -- * API Types
     , ApiAsset (..)
     , toApiAsset
+    , ApiAssetMetadata (..)
+    , toApiAssetMetadata
     , ApiAddress (..)
     , ApiCredential (..)
     , ApiAddressData (..)
@@ -284,7 +286,7 @@ import Data.Aeson.Types
 import Data.Bifunctor
     ( bimap, first )
 import Data.ByteArray.Encoding
-    ( Base (Base16), convertFromBase, convertToBase )
+    ( Base (Base16, Base64), convertFromBase, convertToBase )
 import Data.ByteString
     ( ByteString )
 import Data.Data
@@ -357,6 +359,7 @@ import qualified Codec.Binary.Bech32.TH as Bech32
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map as Map
@@ -450,7 +453,17 @@ data ApiAsset = ApiAsset
     { policyId :: ApiT W.TokenPolicyId
     , assetName :: ApiT W.TokenName
     , fingerprint :: ApiT W.TokenFingerprint
-    , metadata :: Maybe (ApiT W.AssetMetadata)
+    , metadata :: Maybe ApiAssetMetadata
+    } deriving (Eq, Generic, Ord, Show)
+      deriving anyclass NFData
+
+data ApiAssetMetadata = ApiAssetMetadata
+    { name :: Text
+    , description :: Text
+    , acronym :: Maybe Text
+    , url :: Maybe (ApiT W.AssetURL)
+    , logo :: Maybe (ApiT W.AssetLogo)
+    , unit :: Maybe (ApiT W.AssetUnit)
     } deriving (Eq, Generic, Ord, Show)
       deriving anyclass NFData
 
@@ -459,9 +472,14 @@ toApiAsset metadata_ (W.AssetId policyId_ assetName_) = ApiAsset
     { policyId = ApiT policyId_
     , assetName = ApiT assetName_
     , fingerprint = ApiT $ W.mkTokenFingerprint policyId_ assetName_
-    , metadata = ApiT <$> metadata_
+    , metadata = toApiAssetMetadata <$> metadata_
     }
 
+toApiAssetMetadata :: W.AssetMetadata -> ApiAssetMetadata
+toApiAssetMetadata W.AssetMetadata{name,description,acronym,url,logo,unit} =
+    ApiAssetMetadata name description acronym
+        (ApiT <$> url) (ApiT <$> logo) (ApiT <$> unit)
+
 data ApiAddress (n :: NetworkDiscriminant) = ApiAddress
     { id :: !(ApiT Address, Proxy n)
     , state :: !(ApiT AddressState)
@@ -1284,11 +1302,28 @@ instance FromJSON (ApiT W.TokenFingerprint) where
 instance ToJSON (ApiT W.TokenFingerprint) where
     toJSON = toTextJSON
 
-instance FromJSON (ApiT W.AssetMetadata) where
+instance FromJSON ApiAssetMetadata where
+    parseJSON = genericParseJSON defaultRecordTypeOptions
+instance ToJSON ApiAssetMetadata where
+    toJSON = genericToJSON defaultRecordTypeOptions
+
+instance FromJSON (ApiT W.AssetURL) where
+    parseJSON value = parseJSON value >>= either fail (pure . ApiT) . W.validateMetadataURL
+instance ToJSON (ApiT W.AssetURL) where
+    toJSON = toJSON . show . W.unAssetURL . getApiT
+
+instance FromJSON (ApiT W.AssetUnit) where
     parseJSON = fmap ApiT . genericParseJSON defaultRecordTypeOptions
-instance ToJSON (ApiT W.AssetMetadata) where
+instance ToJSON (ApiT W.AssetUnit) where
     toJSON = genericToJSON defaultRecordTypeOptions . getApiT
 
+-- TODO: clean up duplication with TokenMetadata
+instance FromJSON (ApiT W.AssetLogo) where
+    parseJSON = withText "base64 bytestring" $
+        either fail (pure . ApiT . W.AssetLogo) . convertFromBase Base64 . T.encodeUtf8
+instance ToJSON (ApiT W.AssetLogo) where
+    toJSON = toJSON . B8.unpack . convertToBase Base64 . W.unAssetLogo . getApiT
+
 instance ToJSON (ApiT DerivationIndex) where
     toJSON = toTextJSON
 instance FromJSON (ApiT DerivationIndex) where

lib/core/src/Cardano/Wallet/Primitive/Types/TokenPolicy.hs

@@ -3,8 +3,10 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Cardano.Wallet.Primitive.Types.TokenPolicy
     (
@@ -23,8 +25,15 @@ module Cardano.Wallet.Primitive.Types.TokenPolicy
 
       -- * Token Metadata
     , AssetMetadata (..)
+    , AssetURL (..)
     , AssetLogo (..)
     , AssetUnit (..)
+    , validateMetadataName
+    , validateMetadataAcronym
+    , validateMetadataDescription
+    , validateMetadataURL
+    , validateMetadataUnit
+    , validateMetadataLogo
     ) where
 
 import Prelude
@@ -53,6 +62,8 @@ import Data.ByteString
     ( ByteString )
 import Data.Function
     ( (&) )
+import Data.Functor
+    ( ($>) )
 import Data.Hashable
     ( Hashable )
 import Data.Text
@@ -63,16 +74,18 @@ import Fmt
     ( Buildable (..) )
 import GHC.Generics
     ( Generic )
+import Network.URI
+    ( URI, parseAbsoluteURI, uriScheme )
 import Numeric.Natural
     ( Natural )
 import Quiet
     ( Quiet (..) )
 
 import qualified Codec.Binary.Bech32 as Bech32
 import qualified Data.ByteString as BS
+import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 
-
 -- | Token policy identifiers, represented by the hash of the monetary policy
 -- script.
 newtype TokenPolicyId =
@@ -191,7 +204,7 @@ data AssetMetadata = AssetMetadata
     { name :: Text
     , description :: Text
     , acronym :: Maybe Text
-    , url :: Maybe Text
+    , url :: Maybe AssetURL
     , logo :: Maybe AssetLogo
     , unit :: Maybe AssetUnit
     } deriving stock (Eq, Ord, Generic)
@@ -215,3 +228,63 @@ newtype AssetLogo = AssetLogo
     deriving (Show) via (Quiet AssetLogo)
 
 instance NFData AssetLogo
+
+-- | The validated URL for the asset.
+newtype AssetURL = AssetURL
+    { unAssetURL :: URI
+    } deriving (Eq, Ord, Generic)
+    deriving (Show) via (Quiet AssetURL)
+
+instance NFData AssetURL
+
+instance ToText AssetURL where
+    toText = T.pack . show . unAssetURL
+
+instance FromText AssetURL where
+    fromText = first TextDecodingError . validateMetadataURL
+
+validateMinLength :: Int -> Text -> Either String Text
+validateMinLength n text
+    | len >= n = Right text
+    | otherwise = Left $ "Length must be at least " ++ show n ++ " characters, got " ++ show len
+  where
+    len = T.length text
+
+validateMaxLength :: Int -> Text -> Either String Text
+validateMaxLength n text
+    | len <= n = Right text
+    | otherwise = Left $ "Length must be no more than " ++ show n ++ " characters, got " ++ show len
+  where
+    len = T.length text
+
+validateMetadataName :: Text -> Either String Text
+validateMetadataName = validateMinLength 1 >=> validateMaxLength 50
+
+validateMetadataAcronym :: Text -> Either String Text
+validateMetadataAcronym = validateMinLength 2 >=> validateMaxLength 4
+
+validateMetadataDescription :: Text -> Either String Text
+validateMetadataDescription = validateMaxLength 500
+
+validateMetadataURL :: Text -> Either String AssetURL
+validateMetadataURL = fmap AssetURL .
+    (validateMaxLength 250 >=> validateURI >=> validateHttps)
+  where
+      validateURI = maybe (Left "Not an absolute URI") Right
+          . parseAbsoluteURI
+          . T.unpack
+      validateHttps u@(uriScheme -> scheme)
+          | scheme == "https:" = Right u
+          | otherwise = Left $ "Scheme must be https: but got " ++ scheme
+
+validateMetadataUnit :: AssetUnit -> Either String AssetUnit
+validateMetadataUnit assetUnit@AssetUnit{name} =
+    (validateMinLength 1 name >>= validateMaxLength 30) $> assetUnit
+
+validateMetadataLogo :: AssetLogo -> Either String AssetLogo
+validateMetadataLogo logo
+    | len <= maxLen = Right logo
+    | otherwise = Left $ "Length must be no more than " ++ show maxLen ++ " bytes, got " ++ show len
+  where
+    len = BS.length $ unAssetLogo logo
+    maxLen = 65536