{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Copyright: © 2018-2021 IOHK
-- License: Apache-2.0
--
-- A client used to query asset metadata from the Cardano metadata-server.
--
-- The OpenAPI specification is here:
-- <https://github.com/input-output-hk/metadata-server/blob/master/specifications/api/openapi.yaml>
--
-- An important consideration is that cardano-wallet should not trust the
-- metadata-server operator to produce correct, valid, authentic, or even
-- non-malicious data.
--
-- In future, signatures of property values will be checked to determine
-- authenticity. The exact details are not yet specified.
--
-- In any case, we should not rely on the validation that the metadata-server
-- may or may not have applied to the user-supplied metadata.

module Cardano.Wallet.TokenMetadata
    (
    -- * Associating metadata with assets
      fillMetadata

    -- * Token Metadata Client
    , TokenMetadataClient
    , newMetadataClient
    , getTokenMetadata
    , TokenMetadataError (..)

    -- * Logging
    , TokenMetadataLog (..)

    -- * Generic metadata server client
    , metadataClient
    , BatchRequest (..)
    , BatchResponse (..)
    , SubjectProperties (..)
    , Property (..)
    , PropertyName (..)
    , propertyName
    , PropertyValue
    , Subject (..)
    , Signature (..)

    -- * Parsing
    , metadataFromProperties
    ) where

import Prelude

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation, HasSeverityAnnotation (..) )
import Cardano.Wallet.Logging
    ( BracketLog
    , BracketLog' (..)
    , LoggedException (..)
    , bracketTracer
    , produceTimings
    )
import Cardano.Wallet.Primitive.Types
    ( TokenMetadataServer (..) )
import Cardano.Wallet.Primitive.Types.Hash
    ( Hash (..) )
import Cardano.Wallet.Primitive.Types.TokenMap
    ( AssetId (..) )
import Cardano.Wallet.Primitive.Types.TokenPolicy
    ( AssetDecimals (..)
    , AssetLogo (..)
    , AssetMetadata (..)
    , AssetURL (..)
    , TokenName (..)
    , TokenPolicyId (..)
    , validateMetadataDecimals
    , validateMetadataDescription
    , validateMetadataLogo
    , validateMetadataName
    , validateMetadataTicker
    , validateMetadataURL
    )
import Control.Applicative
    ( (<|>) )
import Control.DeepSeq
    ( NFData (..) )
import Control.Monad
    ( when, (>=>) )
import Control.Tracer
    ( Tracer, contramap, traceWith )
import Data.Aeson
    ( FromJSON (..)
    , Object
    , ToJSON (..)
    , Value (..)
    , eitherDecodeStrict'
    , encode
    , withObject
    , withText
    , (.!=)
    , (.:)
    , (.:?)
    )
import Data.Aeson.Types
    ( Parser, fromJSON )
import Data.Bifunctor
    ( first )
import Data.ByteArray.Encoding
    ( Base (Base16, Base64), convertFromBase, convertToBase )
import Data.ByteString
    ( ByteString )
import Data.Foldable
    ( toList )
import Data.Functor
    ( ($>) )
import Data.Hashable
    ( Hashable )
import Data.Kind
    ( Type )
import Data.Maybe
    ( catMaybes, mapMaybe )
import Data.Proxy
    ( Proxy (..) )
import Data.String
    ( IsString (..) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( DiffTime )
import GHC.Generics
    ( Generic )
import GHC.TypeLits
    ( KnownSymbol, Symbol, symbolVal )
import Network.HTTP.Client
    ( HttpException
    , Manager
    , Request (..)
    , RequestBody (..)
    , Response (..)
    , brReadSome
    , requestFromURI
    , setRequestCheckStatus
    , withResponse
    )
import Network.HTTP.Client.TLS
    ( newTlsManager )
import Network.URI
    ( URI, relativeTo )
import Network.URI.Static
    ( relativeReference )
import UnliftIO.Exception
    ( SomeException, handle, handleAny )

import qualified Data.Aeson.Types as Aeson
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.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T

{-------------------------------------------------------------------------------
                                 Token Metadata
-------------------------------------------------------------------------------}

-- | Helper for adding metadata to sets of assets.
fillMetadata
    :: (Foldable t, Functor t)
    => TokenMetadataClient IO
    -> t AssetId
    -> (Either TokenMetadataError (Maybe AssetMetadata) -> AssetId -> a)
    -> IO (t a)
fillMetadata :: TokenMetadataClient IO
-> t AssetId
-> (Either TokenMetadataError (Maybe AssetMetadata)
    -> AssetId -> a)
-> IO (t a)
fillMetadata TokenMetadataClient IO
client t AssetId
assets Either TokenMetadataError (Maybe AssetMetadata) -> AssetId -> a
f = do
    Either TokenMetadataError (Map AssetId AssetMetadata)
res <- ([(AssetId, AssetMetadata)] -> Map AssetId AssetMetadata)
-> Either TokenMetadataError [(AssetId, AssetMetadata)]
-> Either TokenMetadataError (Map AssetId AssetMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(AssetId, AssetMetadata)] -> Map AssetId AssetMetadata
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Either TokenMetadataError [(AssetId, AssetMetadata)]
 -> Either TokenMetadataError (Map AssetId AssetMetadata))
-> IO (Either TokenMetadataError [(AssetId, AssetMetadata)])
-> IO (Either TokenMetadataError (Map AssetId AssetMetadata))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenMetadataClient IO
-> [AssetId]
-> IO (Either TokenMetadataError [(AssetId, AssetMetadata)])
getTokenMetadata TokenMetadataClient IO
client (t AssetId -> [AssetId]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t AssetId
assets)
    t a -> IO (t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t a -> IO (t a)) -> t a -> IO (t a)
forall a b. (a -> b) -> a -> b
$ Either TokenMetadataError (Map AssetId AssetMetadata)
-> AssetId -> a
findAsset Either TokenMetadataError (Map AssetId AssetMetadata)
res (AssetId -> a) -> t AssetId -> t a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t AssetId
assets
  where
    findAsset :: Either TokenMetadataError (Map AssetId AssetMetadata)
-> AssetId -> a
findAsset Either TokenMetadataError (Map AssetId AssetMetadata)
res AssetId
aid = Either TokenMetadataError (Maybe AssetMetadata) -> AssetId -> a
f (AssetId -> Map AssetId AssetMetadata -> Maybe AssetMetadata
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AssetId
aid (Map AssetId AssetMetadata -> Maybe AssetMetadata)
-> Either TokenMetadataError (Map AssetId AssetMetadata)
-> Either TokenMetadataError (Maybe AssetMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TokenMetadataError (Map AssetId AssetMetadata)
res) AssetId
aid

{-------------------------------------------------------------------------------
                            Cardano Metadata Server
-------------------------------------------------------------------------------}

-- | Models a request to the @POST /metadata/query@ endpoint of the metadata
-- server -- the only one that we need.
data BatchRequest = BatchRequest
    { BatchRequest -> [Subject]
subjects :: [Subject]
    , BatchRequest -> [PropertyName]
properties :: [PropertyName]
    } deriving ((forall x. BatchRequest -> Rep BatchRequest x)
-> (forall x. Rep BatchRequest x -> BatchRequest)
-> Generic BatchRequest
forall x. Rep BatchRequest x -> BatchRequest
forall x. BatchRequest -> Rep BatchRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BatchRequest x -> BatchRequest
$cfrom :: forall x. BatchRequest -> Rep BatchRequest x
Generic, Int -> BatchRequest -> ShowS
[BatchRequest] -> ShowS
BatchRequest -> String
(Int -> BatchRequest -> ShowS)
-> (BatchRequest -> String)
-> ([BatchRequest] -> ShowS)
-> Show BatchRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchRequest] -> ShowS
$cshowList :: [BatchRequest] -> ShowS
show :: BatchRequest -> String
$cshow :: BatchRequest -> String
showsPrec :: Int -> BatchRequest -> ShowS
$cshowsPrec :: Int -> BatchRequest -> ShowS
Show, BatchRequest -> BatchRequest -> Bool
(BatchRequest -> BatchRequest -> Bool)
-> (BatchRequest -> BatchRequest -> Bool) -> Eq BatchRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatchRequest -> BatchRequest -> Bool
$c/= :: BatchRequest -> BatchRequest -> Bool
== :: BatchRequest -> BatchRequest -> Bool
$c== :: BatchRequest -> BatchRequest -> Bool
Eq)

-- | Models the response from the @POST /metadata/query@ endpoint of the
-- metadata server. This should contain properties each subject in the
-- 'BatchRequest'.
newtype BatchResponse = BatchResponse
    { BatchResponse -> [SubjectProperties]
getBatchResponse :: [SubjectProperties]
    } deriving ((forall x. BatchResponse -> Rep BatchResponse x)
-> (forall x. Rep BatchResponse x -> BatchResponse)
-> Generic BatchResponse
forall x. Rep BatchResponse x -> BatchResponse
forall x. BatchResponse -> Rep BatchResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BatchResponse x -> BatchResponse
$cfrom :: forall x. BatchResponse -> Rep BatchResponse x
Generic, Int -> BatchResponse -> ShowS
[BatchResponse] -> ShowS
BatchResponse -> String
(Int -> BatchResponse -> ShowS)
-> (BatchResponse -> String)
-> ([BatchResponse] -> ShowS)
-> Show BatchResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchResponse] -> ShowS
$cshowList :: [BatchResponse] -> ShowS
show :: BatchResponse -> String
$cshow :: BatchResponse -> String
showsPrec :: Int -> BatchResponse -> ShowS
$cshowsPrec :: Int -> BatchResponse -> ShowS
Show, BatchResponse -> BatchResponse -> Bool
(BatchResponse -> BatchResponse -> Bool)
-> (BatchResponse -> BatchResponse -> Bool) -> Eq BatchResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatchResponse -> BatchResponse -> Bool
$c/= :: BatchResponse -> BatchResponse -> Bool
== :: BatchResponse -> BatchResponse -> Bool
$c== :: BatchResponse -> BatchResponse -> Bool
Eq)

-- | Property values and signatures for a given subject.
data SubjectProperties = SubjectProperties
    { SubjectProperties -> Subject
subject :: Subject
    , SubjectProperties -> Maybe Signature
owner :: Maybe Signature
    -- TODO: use Data.SOP.NP and parameterize type by property names
    -- Name and description are required, both others may be missing the
    -- response.
    , SubjectProperties
-> (Maybe (Property "name"), Maybe (Property "description"),
    Maybe (Property "ticker"), Maybe (Property "url"),
    Maybe (Property "logo"), Maybe (Property "decimals"))
properties ::
        ( Maybe (Property "name")
        , Maybe (Property "description")
        , Maybe (Property "ticker")
        , Maybe (Property "url")
        , Maybe (Property "logo")
        , Maybe (Property "decimals")
        )
    } deriving ((forall x. SubjectProperties -> Rep SubjectProperties x)
-> (forall x. Rep SubjectProperties x -> SubjectProperties)
-> Generic SubjectProperties
forall x. Rep SubjectProperties x -> SubjectProperties
forall x. SubjectProperties -> Rep SubjectProperties x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SubjectProperties x -> SubjectProperties
$cfrom :: forall x. SubjectProperties -> Rep SubjectProperties x
Generic, Int -> SubjectProperties -> ShowS
[SubjectProperties] -> ShowS
SubjectProperties -> String
(Int -> SubjectProperties -> ShowS)
-> (SubjectProperties -> String)
-> ([SubjectProperties] -> ShowS)
-> Show SubjectProperties
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubjectProperties] -> ShowS
$cshowList :: [SubjectProperties] -> ShowS
show :: SubjectProperties -> String
$cshow :: SubjectProperties -> String
showsPrec :: Int -> SubjectProperties -> ShowS
$cshowsPrec :: Int -> SubjectProperties -> ShowS
Show, SubjectProperties -> SubjectProperties -> Bool
(SubjectProperties -> SubjectProperties -> Bool)
-> (SubjectProperties -> SubjectProperties -> Bool)
-> Eq SubjectProperties
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubjectProperties -> SubjectProperties -> Bool
$c/= :: SubjectProperties -> SubjectProperties -> Bool
== :: SubjectProperties -> SubjectProperties -> Bool
$c== :: SubjectProperties -> SubjectProperties -> Bool
Eq)

-- | A property value and its signatures.
data Property name = Property
    { Property name -> Either (String, Value) (PropertyValue name)
value :: Either (String, Value) (PropertyValue name)
        -- ^ The result of JSON parsing and validating the property value.
    , Property name -> [Signature]
signatures :: [Signature]
       -- ^ Zero or more signatures of the property value.
    , Property name -> Int
sequenceNumber :: Int
       -- ^ Counter to prevent replaying old signatures.
    } deriving ((forall x. Property name -> Rep (Property name) x)
-> (forall x. Rep (Property name) x -> Property name)
-> Generic (Property name)
forall x. Rep (Property name) x -> Property name
forall x. Property name -> Rep (Property name) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (name :: Symbol) x. Rep (Property name) x -> Property name
forall (name :: Symbol) x. Property name -> Rep (Property name) x
$cto :: forall (name :: Symbol) x. Rep (Property name) x -> Property name
$cfrom :: forall (name :: Symbol) x. Property name -> Rep (Property name) x
Generic)

propertyName :: forall name. KnownSymbol name => Property name -> PropertyName
propertyName :: Property name -> PropertyName
propertyName Property name
_ = Text -> PropertyName
PropertyName (Text -> PropertyName) -> Text -> PropertyName
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name

deriving instance Show (PropertyValue name) => Show (Property name)
deriving instance Eq (PropertyValue name) => Eq (Property name)

-- | A metadata server subject, which can be any string.
newtype Subject = Subject { Subject -> Text
unSubject :: Text }
    deriving ((forall x. Subject -> Rep Subject x)
-> (forall x. Rep Subject x -> Subject) -> Generic Subject
forall x. Rep Subject x -> Subject
forall x. Subject -> Rep Subject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Subject x -> Subject
$cfrom :: forall x. Subject -> Rep Subject x
Generic, Int -> Subject -> ShowS
[Subject] -> ShowS
Subject -> String
(Int -> Subject -> ShowS)
-> (Subject -> String) -> ([Subject] -> ShowS) -> Show Subject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Subject] -> ShowS
$cshowList :: [Subject] -> ShowS
show :: Subject -> String
$cshow :: Subject -> String
showsPrec :: Int -> Subject -> ShowS
$cshowsPrec :: Int -> Subject -> ShowS
Show, Subject -> Subject -> Bool
(Subject -> Subject -> Bool)
-> (Subject -> Subject -> Bool) -> Eq Subject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Subject -> Subject -> Bool
$c/= :: Subject -> Subject -> Bool
== :: Subject -> Subject -> Bool
$c== :: Subject -> Subject -> Bool
Eq, Eq Subject
Eq Subject
-> (Subject -> Subject -> Ordering)
-> (Subject -> Subject -> Bool)
-> (Subject -> Subject -> Bool)
-> (Subject -> Subject -> Bool)
-> (Subject -> Subject -> Bool)
-> (Subject -> Subject -> Subject)
-> (Subject -> Subject -> Subject)
-> Ord Subject
Subject -> Subject -> Bool
Subject -> Subject -> Ordering
Subject -> Subject -> Subject
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Subject -> Subject -> Subject
$cmin :: Subject -> Subject -> Subject
max :: Subject -> Subject -> Subject
$cmax :: Subject -> Subject -> Subject
>= :: Subject -> Subject -> Bool
$c>= :: Subject -> Subject -> Bool
> :: Subject -> Subject -> Bool
$c> :: Subject -> Subject -> Bool
<= :: Subject -> Subject -> Bool
$c<= :: Subject -> Subject -> Bool
< :: Subject -> Subject -> Bool
$c< :: Subject -> Subject -> Bool
compare :: Subject -> Subject -> Ordering
$ccompare :: Subject -> Subject -> Ordering
$cp1Ord :: Eq Subject
Ord)
    deriving newtype (String -> Subject
(String -> Subject) -> IsString Subject
forall a. (String -> a) -> IsString a
fromString :: String -> Subject
$cfromString :: String -> Subject
IsString, Int -> Subject -> Int
Subject -> Int
(Int -> Subject -> Int) -> (Subject -> Int) -> Hashable Subject
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Subject -> Int
$chash :: Subject -> Int
hashWithSalt :: Int -> Subject -> Int
$chashWithSalt :: Int -> Subject -> Int
Hashable)

-- | Metadata property identifier.
newtype PropertyName = PropertyName { PropertyName -> Text
unPropertyName :: Text }
    deriving ((forall x. PropertyName -> Rep PropertyName x)
-> (forall x. Rep PropertyName x -> PropertyName)
-> Generic PropertyName
forall x. Rep PropertyName x -> PropertyName
forall x. PropertyName -> Rep PropertyName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PropertyName x -> PropertyName
$cfrom :: forall x. PropertyName -> Rep PropertyName x
Generic, Int -> PropertyName -> ShowS
[PropertyName] -> ShowS
PropertyName -> String
(Int -> PropertyName -> ShowS)
-> (PropertyName -> String)
-> ([PropertyName] -> ShowS)
-> Show PropertyName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropertyName] -> ShowS
$cshowList :: [PropertyName] -> ShowS
show :: PropertyName -> String
$cshow :: PropertyName -> String
showsPrec :: Int -> PropertyName -> ShowS
$cshowsPrec :: Int -> PropertyName -> ShowS
Show, PropertyName -> PropertyName -> Bool
(PropertyName -> PropertyName -> Bool)
-> (PropertyName -> PropertyName -> Bool) -> Eq PropertyName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PropertyName -> PropertyName -> Bool
$c/= :: PropertyName -> PropertyName -> Bool
== :: PropertyName -> PropertyName -> Bool
$c== :: PropertyName -> PropertyName -> Bool
Eq)
    deriving newtype (String -> PropertyName
(String -> PropertyName) -> IsString PropertyName
forall a. (String -> a) -> IsString a
fromString :: String -> PropertyName
$cfromString :: String -> PropertyName
IsString, Int -> PropertyName -> Int
PropertyName -> Int
(Int -> PropertyName -> Int)
-> (PropertyName -> Int) -> Hashable PropertyName
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: PropertyName -> Int
$chash :: PropertyName -> Int
hashWithSalt :: Int -> PropertyName -> Int
$chashWithSalt :: Int -> PropertyName -> Int
Hashable)

-- | The type of a given property name.
type family PropertyValue (name :: Symbol) :: Type
type instance PropertyValue "name" = Text
type instance PropertyValue "description" = Text
type instance PropertyValue "ticker" = Text
type instance PropertyValue "url" = AssetURL
type instance PropertyValue "logo" = AssetLogo
type instance PropertyValue "decimals" = AssetDecimals

class HasValidator (name :: Symbol) where
    -- TODO: requires AllowAmbiguousTypes extension
    validatePropertyValue :: PropertyValue name -> Either String (PropertyValue name)

instance HasValidator "name" where
    validatePropertyValue :: PropertyValue "name" -> Either String (PropertyValue "name")
validatePropertyValue = Text -> Either String Text
PropertyValue "name" -> Either String (PropertyValue "name")
validateMetadataName
instance HasValidator "description" where
    validatePropertyValue :: PropertyValue "description"
-> Either String (PropertyValue "description")
validatePropertyValue = Text -> Either String Text
PropertyValue "description"
-> Either String (PropertyValue "description")
validateMetadataDescription
instance HasValidator "ticker" where
    validatePropertyValue :: PropertyValue "ticker" -> Either String (PropertyValue "ticker")
validatePropertyValue = Text -> Either String Text
PropertyValue "ticker" -> Either String (PropertyValue "ticker")
validateMetadataTicker
instance HasValidator "url" where
    -- validation is done before parsing
    validatePropertyValue :: PropertyValue "url" -> Either String (PropertyValue "url")
validatePropertyValue = PropertyValue "url" -> Either String (PropertyValue "url")
forall a b. b -> Either a b
Right
instance HasValidator "logo" where
    validatePropertyValue :: PropertyValue "logo" -> Either String (PropertyValue "logo")
validatePropertyValue = AssetLogo -> Either String AssetLogo
PropertyValue "logo" -> Either String (PropertyValue "logo")
validateMetadataLogo
instance HasValidator "decimals" where
    validatePropertyValue :: PropertyValue "decimals"
-> Either String (PropertyValue "decimals")
validatePropertyValue = AssetDecimals -> Either String AssetDecimals
PropertyValue "decimals"
-> Either String (PropertyValue "decimals")
validateMetadataDecimals

-- | Will be used in future for checking integrity and authenticity of metadata.
data Signature = Signature
    { Signature -> ByteString
signature :: ByteString
    , Signature -> ByteString
publicKey :: ByteString
    } deriving ((forall x. Signature -> Rep Signature x)
-> (forall x. Rep Signature x -> Signature) -> Generic Signature
forall x. Rep Signature x -> Signature
forall x. Signature -> Rep Signature x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Signature x -> Signature
$cfrom :: forall x. Signature -> Rep Signature x
Generic, Int -> Signature -> ShowS
[Signature] -> ShowS
Signature -> String
(Int -> Signature -> ShowS)
-> (Signature -> String)
-> ([Signature] -> ShowS)
-> Show Signature
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signature] -> ShowS
$cshowList :: [Signature] -> ShowS
show :: Signature -> String
$cshow :: Signature -> String
showsPrec :: Int -> Signature -> ShowS
$cshowsPrec :: Int -> Signature -> ShowS
Show, Signature -> Signature -> Bool
(Signature -> Signature -> Bool)
-> (Signature -> Signature -> Bool) -> Eq Signature
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signature -> Signature -> Bool
$c/= :: Signature -> Signature -> Bool
== :: Signature -> Signature -> Bool
$c== :: Signature -> Signature -> Bool
Eq)

{-------------------------------------------------------------------------------
                       Client for Cardano metadata-server
-------------------------------------------------------------------------------}

metadataClient
    :: Tracer IO TokenMetadataLog
    -> TokenMetadataServer
    -> Manager
    -> BatchRequest
    -> IO (Either TokenMetadataError BatchResponse)
metadataClient :: Tracer IO TokenMetadataLog
-> TokenMetadataServer
-> Manager
-> BatchRequest
-> IO (Either TokenMetadataError BatchResponse)
metadataClient Tracer IO TokenMetadataLog
tr (TokenMetadataServer URI
baseURI) Manager
manager BatchRequest
batch = do
    Either TokenMetadataError BatchResponse
res <- IO (Either TokenMetadataError BatchResponse)
-> IO (Either TokenMetadataError BatchResponse)
forall b.
IO (Either TokenMetadataError b)
-> IO (Either TokenMetadataError b)
handleExc (IO (Either TokenMetadataError BatchResponse)
 -> IO (Either TokenMetadataError BatchResponse))
-> IO (Either TokenMetadataError BatchResponse)
-> IO (Either TokenMetadataError BatchResponse)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Either TokenMetadataError BatchResponse)
-> IO ByteString -> IO (Either TokenMetadataError BatchResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either TokenMetadataError BatchResponse
forall c. FromJSON c => ByteString -> Either TokenMetadataError c
parseResponse (IO ByteString -> IO (Either TokenMetadataError BatchResponse))
-> (Request -> IO ByteString)
-> Request
-> IO (Either TokenMetadataError BatchResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> IO ByteString
doRequest (Request -> IO (Either TokenMetadataError BatchResponse))
-> IO Request -> IO (Either TokenMetadataError BatchResponse)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BatchRequest -> IO Request
makeHttpReq BatchRequest
batch
    Tracer IO TokenMetadataLog -> TokenMetadataLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TokenMetadataLog
tr (TokenMetadataLog -> IO ()) -> TokenMetadataLog -> IO ()
forall a b. (a -> b) -> a -> b
$ BatchRequest
-> Either TokenMetadataError BatchResponse -> TokenMetadataLog
MsgFetchResult BatchRequest
batch Either TokenMetadataError BatchResponse
res
    Either TokenMetadataError BatchResponse
-> IO (Either TokenMetadataError BatchResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return Either TokenMetadataError BatchResponse
res
  where
    -- Construct a Request from the batch.
    makeHttpReq :: BatchRequest -> IO Request
makeHttpReq BatchRequest
query = do
        let json :: ByteString
json = BatchRequest -> ByteString
forall a. ToJSON a => a -> ByteString
encode BatchRequest
query
            uri :: URI
uri = URI
endpoint URI -> URI -> URI
`relativeTo` URI
baseURI
        Tracer IO TokenMetadataLog -> TokenMetadataLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TokenMetadataLog
tr (TokenMetadataLog -> IO ()) -> TokenMetadataLog -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> ByteString -> TokenMetadataLog
MsgFetchRequestBody URI
uri ByteString
json
        Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
requestFromURI URI
uri
        Request -> IO Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request -> Request
setRequestCheckStatus Request
req
            { method :: ByteString
method = ByteString
"POST"
            , requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
json
            , requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
"Content-type", ByteString
"application/json")]
            }
    endpoint :: URI
endpoint = [relativeReference|metadata/query|]

    -- Read the request body. Status code has already been checked via
    -- 'setRequestStatus'.
    doRequest :: Request -> IO ByteString
doRequest Request
req = Tracer IO BracketLog -> IO ByteString -> IO ByteString
forall (m :: * -> *) a.
MonadUnliftIO m =>
Tracer m BracketLog -> m a -> m a
bracketTracer ((BracketLog -> TokenMetadataLog)
-> Tracer IO TokenMetadataLog -> Tracer IO BracketLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (BatchRequest -> BracketLog -> TokenMetadataLog
MsgFetchRequest BatchRequest
batch) Tracer IO TokenMetadataLog
tr) (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
        Request
-> Manager
-> (Response (IO ByteString) -> IO ByteString)
-> IO ByteString
forall a.
Request -> Manager -> (Response (IO ByteString) -> IO a) -> IO a
withResponse Request
req Manager
manager ((Response (IO ByteString) -> IO ByteString) -> IO ByteString)
-> (Response (IO ByteString) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Response (IO ByteString)
res -> do
            ByteString
bs <- IO ByteString -> Int -> IO ByteString
brReadSome (Response (IO ByteString) -> IO ByteString
forall body. Response body -> body
responseBody Response (IO ByteString)
res) Int
maxResponseSize
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int64
BL.length ByteString
bs Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxResponseSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Tracer IO TokenMetadataLog -> TokenMetadataLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TokenMetadataLog
tr (Int -> TokenMetadataLog
MsgFetchMetadataMaxSize Int
maxResponseSize)
            ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
bs

    -- decode and parse json
    parseResponse :: ByteString -> Either TokenMetadataError c
parseResponse ByteString
bs =
        (String -> TokenMetadataError)
-> Either String c -> Either TokenMetadataError c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> String -> TokenMetadataError
TokenMetadataJSONParseError ByteString
bs) (ByteString -> Either String c
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' ByteString
bs)

    -- Convert http-client exceptions to Left, handle any other synchronous
    -- exceptions that may occur.
    handleExc :: IO (Either TokenMetadataError b)
-> IO (Either TokenMetadataError b)
handleExc = (HttpException -> IO (Either TokenMetadataError b))
-> IO (Either TokenMetadataError b)
-> IO (Either TokenMetadataError b)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle ((LoggedException HttpException -> TokenMetadataError)
-> HttpException -> IO (Either TokenMetadataError b)
forall (f :: * -> *) e a b.
Applicative f =>
(LoggedException e -> a) -> e -> f (Either a b)
loggedErr LoggedException HttpException -> TokenMetadataError
TokenMetadataFetchError)
        (IO (Either TokenMetadataError b)
 -> IO (Either TokenMetadataError b))
-> (IO (Either TokenMetadataError b)
    -> IO (Either TokenMetadataError b))
-> IO (Either TokenMetadataError b)
-> IO (Either TokenMetadataError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> IO (Either TokenMetadataError b))
-> IO (Either TokenMetadataError b)
-> IO (Either TokenMetadataError b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny ((LoggedException SomeException -> TokenMetadataError)
-> SomeException -> IO (Either TokenMetadataError b)
forall (f :: * -> *) e a b.
Applicative f =>
(LoggedException e -> a) -> e -> f (Either a b)
loggedErr LoggedException SomeException -> TokenMetadataError
TokenMetadataClientError)
    loggedErr :: (LoggedException e -> a) -> e -> f (Either a b)
loggedErr LoggedException e -> a
c = Either a b -> f (Either a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> f (Either a b))
-> (e -> Either a b) -> e -> f (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> (e -> a) -> e -> Either a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggedException e -> a
c (LoggedException e -> a) -> (e -> LoggedException e) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> LoggedException e
forall e. e -> LoggedException e
LoggedException

    -- Don't let a metadata server consume all our memory - limit to 10MiB
    maxResponseSize :: Int
maxResponseSize = Int
10Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024

-----------
-- Errors

-- | The possible errors which can occur when fetching metadata.
data TokenMetadataError
    = TokenMetadataClientError (LoggedException SomeException)
        -- ^ Unhandled exception
    | TokenMetadataFetchError (LoggedException HttpException)
        -- ^ Error with HTTP request
    | TokenMetadataJSONParseError ByteString String
        -- ^ Error from aeson decoding of JSON
    deriving ((forall x. TokenMetadataError -> Rep TokenMetadataError x)
-> (forall x. Rep TokenMetadataError x -> TokenMetadataError)
-> Generic TokenMetadataError
forall x. Rep TokenMetadataError x -> TokenMetadataError
forall x. TokenMetadataError -> Rep TokenMetadataError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TokenMetadataError x -> TokenMetadataError
$cfrom :: forall x. TokenMetadataError -> Rep TokenMetadataError x
Generic, Int -> TokenMetadataError -> ShowS
[TokenMetadataError] -> ShowS
TokenMetadataError -> String
(Int -> TokenMetadataError -> ShowS)
-> (TokenMetadataError -> String)
-> ([TokenMetadataError] -> ShowS)
-> Show TokenMetadataError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenMetadataError] -> ShowS
$cshowList :: [TokenMetadataError] -> ShowS
show :: TokenMetadataError -> String
$cshow :: TokenMetadataError -> String
showsPrec :: Int -> TokenMetadataError -> ShowS
$cshowsPrec :: Int -> TokenMetadataError -> ShowS
Show, TokenMetadataError -> TokenMetadataError -> Bool
(TokenMetadataError -> TokenMetadataError -> Bool)
-> (TokenMetadataError -> TokenMetadataError -> Bool)
-> Eq TokenMetadataError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenMetadataError -> TokenMetadataError -> Bool
$c/= :: TokenMetadataError -> TokenMetadataError -> Bool
== :: TokenMetadataError -> TokenMetadataError -> Bool
$c== :: TokenMetadataError -> TokenMetadataError -> Bool
Eq)

instance NFData TokenMetadataError where
    rnf :: TokenMetadataError -> ()
rnf = String -> ()
forall a. NFData a => a -> ()
rnf (String -> ())
-> (TokenMetadataError -> String) -> TokenMetadataError -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenMetadataError -> String
forall a. Show a => a -> String
show

instance ToText TokenMetadataError where
    toText :: TokenMetadataError -> Text
toText = \case
        TokenMetadataClientError LoggedException SomeException
e ->
             Text
"Unhandled exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LoggedException SomeException -> Text
forall a. ToText a => a -> Text
toText LoggedException SomeException
e
        TokenMetadataFetchError LoggedException HttpException
e ->
             Text
"Error querying metadata server: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LoggedException HttpException -> Text
forall a. ToText a => a -> Text
toText LoggedException HttpException
e
        TokenMetadataJSONParseError ByteString
json String
e -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Error parsing metadata server response JSON: "
            , String -> Text
T.pack String
e
            , Text
"\nThe first 250 characters of the response are:\n"
            , OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B8.take Int
250 ByteString
json
            ]

-----------
-- Logging

data TokenMetadataLog
    = MsgNotConfigured
    | MsgFetchRequest BatchRequest BracketLog
    | MsgFetchRequestBody URI BL.ByteString
    | MsgFetchMetadataMaxSize Int
    | MsgFetchResult BatchRequest (Either TokenMetadataError BatchResponse)
    | MsgFetchMetadataTime BatchRequest DiffTime
    deriving (Int -> TokenMetadataLog -> ShowS
[TokenMetadataLog] -> ShowS
TokenMetadataLog -> String
(Int -> TokenMetadataLog -> ShowS)
-> (TokenMetadataLog -> String)
-> ([TokenMetadataLog] -> ShowS)
-> Show TokenMetadataLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenMetadataLog] -> ShowS
$cshowList :: [TokenMetadataLog] -> ShowS
show :: TokenMetadataLog -> String
$cshow :: TokenMetadataLog -> String
showsPrec :: Int -> TokenMetadataLog -> ShowS
$cshowsPrec :: Int -> TokenMetadataLog -> ShowS
Show, TokenMetadataLog -> TokenMetadataLog -> Bool
(TokenMetadataLog -> TokenMetadataLog -> Bool)
-> (TokenMetadataLog -> TokenMetadataLog -> Bool)
-> Eq TokenMetadataLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenMetadataLog -> TokenMetadataLog -> Bool
$c/= :: TokenMetadataLog -> TokenMetadataLog -> Bool
== :: TokenMetadataLog -> TokenMetadataLog -> Bool
$c== :: TokenMetadataLog -> TokenMetadataLog -> Bool
Eq)

instance HasSeverityAnnotation TokenMetadataLog where
    getSeverityAnnotation :: TokenMetadataLog -> Severity
getSeverityAnnotation = \case
        TokenMetadataLog
MsgNotConfigured -> Severity
Notice
        MsgFetchRequest BatchRequest
_ BracketLog
b -> BracketLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation BracketLog
b
        MsgFetchRequestBody URI
_ ByteString
_ -> Severity
Debug
        MsgFetchMetadataMaxSize Int
_ -> Severity
Warning
        MsgFetchResult BatchRequest
_ (Right BatchResponse
_) -> Severity
Info
        MsgFetchResult BatchRequest
_ (Left TokenMetadataError
_) -> Severity
Error
        MsgFetchMetadataTime BatchRequest
_ DiffTime
_ -> Severity
Debug

instance ToText TokenMetadataLog where
    toText :: TokenMetadataLog -> Text
toText = \case
        TokenMetadataLog
MsgNotConfigured -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"No token metadata server is configured."
            ]
        MsgFetchRequest BatchRequest
r BracketLog
BracketStart -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Will fetch metadata: "
            , String -> Text
T.pack (BatchRequest -> String
forall a. Show a => a -> String
show BatchRequest
r)
            ]
        MsgFetchRequest BatchRequest
_ BracketLog
b -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Metadata fetch: "
            , BracketLog -> Text
forall a. ToText a => a -> Text
toText BracketLog
b
            ]
        MsgFetchRequestBody URI
uri ByteString
bs -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"POST ", String -> Text
T.pack (URI -> String
forall a. Show a => a -> String
show URI
uri), Text
"\n"
            , OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> ByteString
BL.toStrict ByteString
bs) ]
        MsgFetchMetadataMaxSize Int
maxSize -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Metadata server returned more data than the permitted maximum of"
            , Int -> Text
forall a. ToText a => a -> Text
toText Int
maxSize
            , Text
" bytes."
            ]
        MsgFetchResult BatchRequest
req Either TokenMetadataError BatchResponse
res -> case Either TokenMetadataError BatchResponse
res of
            Right (BatchResponse [SubjectProperties]
batch) -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"Successfully queried metadata-server for "
                , Int -> Text
forall a. ToText a => a -> Text
toText ([Subject] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Subject] -> Int) -> [Subject] -> Int
forall a b. (a -> b) -> a -> b
$ BatchRequest -> [Subject]
subjects BatchRequest
req)
                , Text
" assets, and received "
                , Int -> Text
forall a. ToText a => a -> Text
toText ([SubjectProperties] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SubjectProperties]
batch)
                , Text
" in response."
                ]
            Left TokenMetadataError
e -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"An error occurred while fetching metadata: "
                , TokenMetadataError -> Text
forall a. ToText a => a -> Text
toText TokenMetadataError
e
                ]
        MsgFetchMetadataTime BatchRequest
_ DiffTime
dt -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Metadata request took: "
            , String -> Text
T.pack (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
dt)
            ]

instance HasPrivacyAnnotation TokenMetadataLog

traceRequestTimings :: Tracer IO TokenMetadataLog -> IO (Tracer IO TokenMetadataLog)
traceRequestTimings :: Tracer IO TokenMetadataLog -> IO (Tracer IO TokenMetadataLog)
traceRequestTimings Tracer IO TokenMetadataLog
tr = (TokenMetadataLog -> Maybe (BatchRequest, BracketLog))
-> Tracer IO (BatchRequest, DiffTime)
-> IO (Tracer IO TokenMetadataLog)
forall (m :: * -> *) a ctx.
(MonadUnliftIO m, MonadMask m) =>
(a -> Maybe (ctx, BracketLog))
-> Tracer m (ctx, DiffTime) -> m (Tracer m a)
produceTimings TokenMetadataLog -> Maybe (BatchRequest, BracketLog)
msgQuery Tracer IO (BatchRequest, DiffTime)
trDiffTime
  where
    trDiffTime :: Tracer IO (BatchRequest, DiffTime)
trDiffTime = ((BatchRequest, DiffTime) -> TokenMetadataLog)
-> Tracer IO TokenMetadataLog -> Tracer IO (BatchRequest, DiffTime)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((BatchRequest -> DiffTime -> TokenMetadataLog)
-> (BatchRequest, DiffTime) -> TokenMetadataLog
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BatchRequest -> DiffTime -> TokenMetadataLog
MsgFetchMetadataTime) Tracer IO TokenMetadataLog
tr
    msgQuery :: TokenMetadataLog -> Maybe (BatchRequest, BracketLog)
msgQuery = \case
        MsgFetchRequest BatchRequest
req BracketLog
b -> (BatchRequest, BracketLog) -> Maybe (BatchRequest, BracketLog)
forall a. a -> Maybe a
Just (BatchRequest
req, BracketLog
b)
        TokenMetadataLog
_ -> Maybe (BatchRequest, BracketLog)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
                           Requesting token metadata
-------------------------------------------------------------------------------}

-- | Represents a client for the metadata server.
newtype TokenMetadataClient m = TokenMetadataClient
    { TokenMetadataClient m
-> BatchRequest -> m (Either TokenMetadataError BatchResponse)
_batchQuery :: BatchRequest -> m (Either TokenMetadataError BatchResponse)
    }

-- | Not a client for the metadata server.
nullTokenMetadataClient :: Applicative m => TokenMetadataClient m
nullTokenMetadataClient :: TokenMetadataClient m
nullTokenMetadataClient =
    (BatchRequest -> m (Either TokenMetadataError BatchResponse))
-> TokenMetadataClient m
forall (m :: * -> *).
(BatchRequest -> m (Either TokenMetadataError BatchResponse))
-> TokenMetadataClient m
TokenMetadataClient ((BatchRequest -> m (Either TokenMetadataError BatchResponse))
 -> TokenMetadataClient m)
-> (BatchResponse
    -> BatchRequest -> m (Either TokenMetadataError BatchResponse))
-> BatchResponse
-> TokenMetadataClient m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either TokenMetadataError BatchResponse)
-> BatchRequest -> m (Either TokenMetadataError BatchResponse)
forall a b. a -> b -> a
const (m (Either TokenMetadataError BatchResponse)
 -> BatchRequest -> m (Either TokenMetadataError BatchResponse))
-> (BatchResponse -> m (Either TokenMetadataError BatchResponse))
-> BatchResponse
-> BatchRequest
-> m (Either TokenMetadataError BatchResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either TokenMetadataError BatchResponse
-> m (Either TokenMetadataError BatchResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TokenMetadataError BatchResponse
 -> m (Either TokenMetadataError BatchResponse))
-> (BatchResponse -> Either TokenMetadataError BatchResponse)
-> BatchResponse
-> m (Either TokenMetadataError BatchResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchResponse -> Either TokenMetadataError BatchResponse
forall a b. b -> Either a b
Right (BatchResponse -> TokenMetadataClient m)
-> BatchResponse -> TokenMetadataClient m
forall a b. (a -> b) -> a -> b
$ [SubjectProperties] -> BatchResponse
BatchResponse []

-- | Construct a 'TokenMetadataClient' for use with 'getTokenMetadata'.
newMetadataClient
    :: Tracer IO TokenMetadataLog -- ^ Logging
    -> Maybe TokenMetadataServer -- ^ URL of metadata server, if enabled.
    -> IO (TokenMetadataClient IO)
newMetadataClient :: Tracer IO TokenMetadataLog
-> Maybe TokenMetadataServer -> IO (TokenMetadataClient IO)
newMetadataClient Tracer IO TokenMetadataLog
tr (Just TokenMetadataServer
uri) = do
    Tracer IO TokenMetadataLog
trTimings <- Tracer IO TokenMetadataLog -> IO (Tracer IO TokenMetadataLog)
traceRequestTimings Tracer IO TokenMetadataLog
tr
    (BatchRequest -> IO (Either TokenMetadataError BatchResponse))
-> TokenMetadataClient IO
forall (m :: * -> *).
(BatchRequest -> m (Either TokenMetadataError BatchResponse))
-> TokenMetadataClient m
TokenMetadataClient ((BatchRequest -> IO (Either TokenMetadataError BatchResponse))
 -> TokenMetadataClient IO)
-> (Manager
    -> BatchRequest -> IO (Either TokenMetadataError BatchResponse))
-> Manager
-> TokenMetadataClient IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO TokenMetadataLog
-> TokenMetadataServer
-> Manager
-> BatchRequest
-> IO (Either TokenMetadataError BatchResponse)
metadataClient (Tracer IO TokenMetadataLog
tr Tracer IO TokenMetadataLog
-> Tracer IO TokenMetadataLog -> Tracer IO TokenMetadataLog
forall a. Semigroup a => a -> a -> a
<> Tracer IO TokenMetadataLog
trTimings) TokenMetadataServer
uri (Manager -> TokenMetadataClient IO)
-> IO Manager -> IO (TokenMetadataClient IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
newMetadataClient Tracer IO TokenMetadataLog
tr Maybe TokenMetadataServer
Nothing =
    Tracer IO TokenMetadataLog -> TokenMetadataLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TokenMetadataLog
tr TokenMetadataLog
MsgNotConfigured IO () -> TokenMetadataClient IO -> IO (TokenMetadataClient IO)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TokenMetadataClient IO
forall (m :: * -> *). Applicative m => TokenMetadataClient m
nullTokenMetadataClient

-- | Fetches metadata for a list of assets using the given client.
getTokenMetadata
    :: TokenMetadataClient IO
    -> [AssetId]
    -> IO (Either TokenMetadataError [(AssetId, AssetMetadata)])
getTokenMetadata :: TokenMetadataClient IO
-> [AssetId]
-> IO (Either TokenMetadataError [(AssetId, AssetMetadata)])
getTokenMetadata (TokenMetadataClient BatchRequest -> IO (Either TokenMetadataError BatchResponse)
client) [AssetId]
as =
    (BatchResponse -> [(AssetId, AssetMetadata)])
-> Either TokenMetadataError BatchResponse
-> Either TokenMetadataError [(AssetId, AssetMetadata)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BatchResponse -> [(AssetId, AssetMetadata)]
fromResponse (Either TokenMetadataError BatchResponse
 -> Either TokenMetadataError [(AssetId, AssetMetadata)])
-> IO (Either TokenMetadataError BatchResponse)
-> IO (Either TokenMetadataError [(AssetId, AssetMetadata)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BatchRequest -> IO (Either TokenMetadataError BatchResponse)
client BatchRequest
req
  where
    subjects :: [Subject]
subjects = (AssetId -> Subject) -> [AssetId] -> [Subject]
forall a b. (a -> b) -> [a] -> [b]
map AssetId -> Subject
assetIdToSubject [AssetId]
as
    req :: BatchRequest
req = BatchRequest :: [Subject] -> [PropertyName] -> BatchRequest
BatchRequest
        { [Subject]
subjects :: [Subject]
$sel:subjects:BatchRequest :: [Subject]
subjects
        , $sel:properties:BatchRequest :: [PropertyName]
properties = Text -> PropertyName
PropertyName (Text -> PropertyName) -> [Text] -> [PropertyName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             [ Text
"name", Text
"description", Text
"ticker"
             , Text
"url", Text
"logo", Text
"decimals" ]
        }
    subjectAsset :: HashMap Subject AssetId
subjectAsset = [(Subject, AssetId)] -> HashMap Subject AssetId
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Subject, AssetId)] -> HashMap Subject AssetId)
-> [(Subject, AssetId)] -> HashMap Subject AssetId
forall a b. (a -> b) -> a -> b
$ [Subject] -> [AssetId] -> [(Subject, AssetId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Subject]
subjects [AssetId]
as
    fromResponse :: BatchResponse -> [(AssetId, AssetMetadata)]
    fromResponse :: BatchResponse -> [(AssetId, AssetMetadata)]
fromResponse = (SubjectProperties -> Maybe (AssetId, AssetMetadata))
-> [SubjectProperties] -> [(AssetId, AssetMetadata)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\SubjectProperties
ps -> (,)
        (AssetId -> AssetMetadata -> (AssetId, AssetMetadata))
-> Maybe AssetId
-> Maybe (AssetMetadata -> (AssetId, AssetMetadata))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Subject -> HashMap Subject AssetId -> Maybe AssetId
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (SubjectProperties -> Subject
subject SubjectProperties
ps) HashMap Subject AssetId
subjectAsset
        Maybe (AssetMetadata -> (AssetId, AssetMetadata))
-> Maybe AssetMetadata -> Maybe (AssetId, AssetMetadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SubjectProperties -> Maybe AssetMetadata
metadataFromProperties SubjectProperties
ps)
        ([SubjectProperties] -> [(AssetId, AssetMetadata)])
-> (BatchResponse -> [SubjectProperties])
-> BatchResponse
-> [(AssetId, AssetMetadata)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchResponse -> [SubjectProperties]
getBatchResponse

-- | Creates a metadata server subject from an AssetId. The subject is the
-- policy id and asset name hex-encoded.
assetIdToSubject :: AssetId -> Subject
assetIdToSubject :: AssetId -> Subject
assetIdToSubject (AssetId (UnsafeTokenPolicyId (Hash ByteString
p)) (UnsafeTokenName ByteString
n)) =
    Text -> Subject
Subject (Text -> Subject) -> Text -> Subject
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 (ByteString
p ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n)

-- | Convert metadata server properties response into an 'AssetMetadata' record.
-- Only the values are taken. Signatures are ignored (for now).
metadataFromProperties :: SubjectProperties -> Maybe AssetMetadata
metadataFromProperties :: SubjectProperties -> Maybe AssetMetadata
metadataFromProperties (SubjectProperties Subject
_ Maybe Signature
_ (Maybe (Property "name"), Maybe (Property "description"),
 Maybe (Property "ticker"), Maybe (Property "url"),
 Maybe (Property "logo"), Maybe (Property "decimals"))
properties) =
    Text
-> Text
-> Maybe Text
-> Maybe AssetURL
-> Maybe AssetLogo
-> Maybe AssetDecimals
-> AssetMetadata
AssetMetadata
        (Text
 -> Text
 -> Maybe Text
 -> Maybe AssetURL
 -> Maybe AssetLogo
 -> Maybe AssetDecimals
 -> AssetMetadata)
-> Maybe Text
-> Maybe
     (Text
      -> Maybe Text
      -> Maybe AssetURL
      -> Maybe AssetLogo
      -> Maybe AssetDecimals
      -> AssetMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Property "name") -> Maybe (PropertyValue "name")
forall (a :: Symbol). Maybe (Property a) -> Maybe (PropertyValue a)
getValue Maybe (Property "name")
name
        Maybe
  (Text
   -> Maybe Text
   -> Maybe AssetURL
   -> Maybe AssetLogo
   -> Maybe AssetDecimals
   -> AssetMetadata)
-> Maybe Text
-> Maybe
     (Maybe Text
      -> Maybe AssetURL
      -> Maybe AssetLogo
      -> Maybe AssetDecimals
      -> AssetMetadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Property "description")
-> Maybe (PropertyValue "description")
forall (a :: Symbol). Maybe (Property a) -> Maybe (PropertyValue a)
getValue Maybe (Property "description")
description
        Maybe
  (Maybe Text
   -> Maybe AssetURL
   -> Maybe AssetLogo
   -> Maybe AssetDecimals
   -> AssetMetadata)
-> Maybe (Maybe Text)
-> Maybe
     (Maybe AssetURL
      -> Maybe AssetLogo -> Maybe AssetDecimals -> AssetMetadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> Maybe (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Property "ticker") -> Maybe (PropertyValue "ticker")
forall (a :: Symbol). Maybe (Property a) -> Maybe (PropertyValue a)
getValue Maybe (Property "ticker")
ticker)
        Maybe
  (Maybe AssetURL
   -> Maybe AssetLogo -> Maybe AssetDecimals -> AssetMetadata)
-> Maybe (Maybe AssetURL)
-> Maybe (Maybe AssetLogo -> Maybe AssetDecimals -> AssetMetadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe AssetURL -> Maybe (Maybe AssetURL)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Property "url") -> Maybe (PropertyValue "url")
forall (a :: Symbol). Maybe (Property a) -> Maybe (PropertyValue a)
getValue Maybe (Property "url")
url)
        Maybe (Maybe AssetLogo -> Maybe AssetDecimals -> AssetMetadata)
-> Maybe (Maybe AssetLogo)
-> Maybe (Maybe AssetDecimals -> AssetMetadata)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe AssetLogo -> Maybe (Maybe AssetLogo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Property "logo") -> Maybe (PropertyValue "logo")
forall (a :: Symbol). Maybe (Property a) -> Maybe (PropertyValue a)
getValue Maybe (Property "logo")
logo)
        Maybe (Maybe AssetDecimals -> AssetMetadata)
-> Maybe (Maybe AssetDecimals) -> Maybe AssetMetadata
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe AssetDecimals -> Maybe (Maybe AssetDecimals)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Property "decimals") -> Maybe (PropertyValue "decimals")
forall (a :: Symbol). Maybe (Property a) -> Maybe (PropertyValue a)
getValue Maybe (Property "decimals")
decimals)
  where
    ( Maybe (Property "name")
name, Maybe (Property "description")
description, Maybe (Property "ticker")
ticker, Maybe (Property "url")
url, Maybe (Property "logo")
logo, Maybe (Property "decimals")
decimals ) = (Maybe (Property "name"), Maybe (Property "description"),
 Maybe (Property "ticker"), Maybe (Property "url"),
 Maybe (Property "logo"), Maybe (Property "decimals"))
properties
    getValue :: Maybe (Property a) -> Maybe (PropertyValue a)
    getValue :: Maybe (Property a) -> Maybe (PropertyValue a)
getValue = (Maybe (Property a)
-> (Property a -> Maybe (PropertyValue a))
-> Maybe (PropertyValue a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (((String, Value) -> Maybe (PropertyValue a))
-> (PropertyValue a -> Maybe (PropertyValue a))
-> Either (String, Value) (PropertyValue a)
-> Maybe (PropertyValue a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (PropertyValue a)
-> (String, Value) -> Maybe (PropertyValue a)
forall a b. a -> b -> a
const Maybe (PropertyValue a)
forall a. Maybe a
Nothing) PropertyValue a -> Maybe (PropertyValue a)
forall a. a -> Maybe a
Just (Either (String, Value) (PropertyValue a)
 -> Maybe (PropertyValue a))
-> (Property a -> Either (String, Value) (PropertyValue a))
-> Property a
-> Maybe (PropertyValue a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property a -> Either (String, Value) (PropertyValue a)
forall (name :: Symbol).
Property name -> Either (String, Value) (PropertyValue name)
value))

{-------------------------------------------------------------------------------
                      Aeson instances for metadata-server
-------------------------------------------------------------------------------}

instance ToJSON BatchRequest where

instance ToJSON PropertyName where
    toJSON :: PropertyName -> Value
toJSON = Text -> Value
String (Text -> Value) -> (PropertyName -> Text) -> PropertyName -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyName -> Text
unPropertyName
instance FromJSON PropertyName where
    parseJSON :: Value -> Parser PropertyName
parseJSON = String
-> (Text -> Parser PropertyName) -> Value -> Parser PropertyName
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"PropertyName" (PropertyName -> Parser PropertyName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PropertyName -> Parser PropertyName)
-> (Text -> PropertyName) -> Text -> Parser PropertyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PropertyName
PropertyName)

instance FromJSON BatchResponse where
    parseJSON :: Value -> Parser BatchResponse
parseJSON =  String
-> (Object -> Parser BatchResponse)
-> Value
-> Parser BatchResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BatchResponse" ((Object -> Parser BatchResponse) -> Value -> Parser BatchResponse)
-> (Object -> Parser BatchResponse)
-> Value
-> Parser BatchResponse
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        ([Value]
xs :: [Value]) <- Object
o Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"subjects"
        let maybeParseItem :: Value -> Parser (Maybe a)
maybeParseItem Value
v = (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) Parser (Maybe a) -> Parser (Maybe a) -> Parser (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> Parser (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        [SubjectProperties] -> BatchResponse
BatchResponse ([SubjectProperties] -> BatchResponse)
-> Parser [SubjectProperties] -> Parser BatchResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Maybe SubjectProperties] -> [SubjectProperties]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SubjectProperties] -> [SubjectProperties])
-> Parser [Maybe SubjectProperties] -> Parser [SubjectProperties]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser (Maybe SubjectProperties))
-> [Value] -> Parser [Maybe SubjectProperties]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser (Maybe SubjectProperties)
forall a. FromJSON a => Value -> Parser (Maybe a)
maybeParseItem [Value]
xs)

instance ToJSON Subject where
    toJSON :: Subject -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Subject -> Text) -> Subject -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subject -> Text
unSubject
instance FromJSON Subject where
    parseJSON :: Value -> Parser Subject
parseJSON = String -> (Text -> Parser Subject) -> Value -> Parser Subject
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Subject" (Subject -> Parser Subject
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subject -> Parser Subject)
-> (Text -> Subject) -> Text -> Parser Subject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Subject
Subject)

instance FromJSON SubjectProperties where
    parseJSON :: Value -> Parser SubjectProperties
parseJSON = String
-> (Object -> Parser SubjectProperties)
-> Value
-> Parser SubjectProperties
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SubjectProperties" ((Object -> Parser SubjectProperties)
 -> Value -> Parser SubjectProperties)
-> (Object -> Parser SubjectProperties)
-> Value
-> Parser SubjectProperties
forall a b. (a -> b) -> a -> b
$ \Object
o -> Subject
-> Maybe Signature
-> (Maybe (Property "name"), Maybe (Property "description"),
    Maybe (Property "ticker"), Maybe (Property "url"),
    Maybe (Property "logo"), Maybe (Property "decimals"))
-> SubjectProperties
SubjectProperties
        (Subject
 -> Maybe Signature
 -> (Maybe (Property "name"), Maybe (Property "description"),
     Maybe (Property "ticker"), Maybe (Property "url"),
     Maybe (Property "logo"), Maybe (Property "decimals"))
 -> SubjectProperties)
-> Parser Subject
-> Parser
     (Maybe Signature
      -> (Maybe (Property "name"), Maybe (Property "description"),
          Maybe (Property "ticker"), Maybe (Property "url"),
          Maybe (Property "logo"), Maybe (Property "decimals"))
      -> SubjectProperties)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Subject
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"subject"
        Parser
  (Maybe Signature
   -> (Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals"))
   -> SubjectProperties)
-> Parser (Maybe Signature)
-> Parser
     ((Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals"))
      -> SubjectProperties)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Signature)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"owner"
        Parser
  ((Maybe (Property "name"), Maybe (Property "description"),
    Maybe (Property "ticker"), Maybe (Property "url"),
    Maybe (Property "logo"), Maybe (Property "decimals"))
   -> SubjectProperties)
-> Parser
     (Maybe (Property "name"), Maybe (Property "description"),
      Maybe (Property "ticker"), Maybe (Property "url"),
      Maybe (Property "logo"), Maybe (Property "decimals"))
-> Parser SubjectProperties
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
-> Parser
     (Maybe (Property "name"), Maybe (Property "description"),
      Maybe (Property "ticker"), Maybe (Property "url"),
      Maybe (Property "logo"), Maybe (Property "decimals"))
parseProperties Object
o
      where
        parseProperties :: Object
-> Parser
     (Maybe (Property "name"), Maybe (Property "description"),
      Maybe (Property "ticker"), Maybe (Property "url"),
      Maybe (Property "logo"), Maybe (Property "decimals"))
parseProperties Object
o = (,,,,,)
            (Maybe (Property "name")
 -> Maybe (Property "description")
 -> Maybe (Property "ticker")
 -> Maybe (Property "url")
 -> Maybe (Property "logo")
 -> Maybe (Property "decimals")
 -> (Maybe (Property "name"), Maybe (Property "description"),
     Maybe (Property "ticker"), Maybe (Property "url"),
     Maybe (Property "logo"), Maybe (Property "decimals")))
-> Parser (Maybe (Property "name"))
-> Parser
     (Maybe (Property "description")
      -> Maybe (Property "ticker")
      -> Maybe (Property "url")
      -> Maybe (Property "logo")
      -> Maybe (Property "decimals")
      -> (Maybe (Property "name"), Maybe (Property "description"),
          Maybe (Property "ticker"), Maybe (Property "url"),
          Maybe (Property "logo"), Maybe (Property "decimals")))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser (Maybe (Property "name"))
forall (name :: Symbol).
(KnownSymbol name, FromJSON (Property name)) =>
Object -> Parser (Maybe (Property name))
prop @"name" Object
o
            Parser
  (Maybe (Property "description")
   -> Maybe (Property "ticker")
   -> Maybe (Property "url")
   -> Maybe (Property "logo")
   -> Maybe (Property "decimals")
   -> (Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals")))
-> Parser (Maybe (Property "description"))
-> Parser
     (Maybe (Property "ticker")
      -> Maybe (Property "url")
      -> Maybe (Property "logo")
      -> Maybe (Property "decimals")
      -> (Maybe (Property "name"), Maybe (Property "description"),
          Maybe (Property "ticker"), Maybe (Property "url"),
          Maybe (Property "logo"), Maybe (Property "decimals")))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe (Property "description"))
forall (name :: Symbol).
(KnownSymbol name, FromJSON (Property name)) =>
Object -> Parser (Maybe (Property name))
prop @"description" Object
o
            Parser
  (Maybe (Property "ticker")
   -> Maybe (Property "url")
   -> Maybe (Property "logo")
   -> Maybe (Property "decimals")
   -> (Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals")))
-> Parser (Maybe (Property "ticker"))
-> Parser
     (Maybe (Property "url")
      -> Maybe (Property "logo")
      -> Maybe (Property "decimals")
      -> (Maybe (Property "name"), Maybe (Property "description"),
          Maybe (Property "ticker"), Maybe (Property "url"),
          Maybe (Property "logo"), Maybe (Property "decimals")))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe (Property "ticker"))
forall (name :: Symbol).
(KnownSymbol name, FromJSON (Property name)) =>
Object -> Parser (Maybe (Property name))
prop @"ticker" Object
o
            Parser
  (Maybe (Property "url")
   -> Maybe (Property "logo")
   -> Maybe (Property "decimals")
   -> (Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals")))
-> Parser (Maybe (Property "url"))
-> Parser
     (Maybe (Property "logo")
      -> Maybe (Property "decimals")
      -> (Maybe (Property "name"), Maybe (Property "description"),
          Maybe (Property "ticker"), Maybe (Property "url"),
          Maybe (Property "logo"), Maybe (Property "decimals")))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe (Property "url"))
forall (name :: Symbol).
(KnownSymbol name, FromJSON (Property name)) =>
Object -> Parser (Maybe (Property name))
prop @"url" Object
o
            Parser
  (Maybe (Property "logo")
   -> Maybe (Property "decimals")
   -> (Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals")))
-> Parser (Maybe (Property "logo"))
-> Parser
     (Maybe (Property "decimals")
      -> (Maybe (Property "name"), Maybe (Property "description"),
          Maybe (Property "ticker"), Maybe (Property "url"),
          Maybe (Property "logo"), Maybe (Property "decimals")))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe (Property "logo"))
forall (name :: Symbol).
(KnownSymbol name, FromJSON (Property name)) =>
Object -> Parser (Maybe (Property name))
prop @"logo" Object
o
            Parser
  (Maybe (Property "decimals")
   -> (Maybe (Property "name"), Maybe (Property "description"),
       Maybe (Property "ticker"), Maybe (Property "url"),
       Maybe (Property "logo"), Maybe (Property "decimals")))
-> Parser (Maybe (Property "decimals"))
-> Parser
     (Maybe (Property "name"), Maybe (Property "description"),
      Maybe (Property "ticker"), Maybe (Property "url"),
      Maybe (Property "logo"), Maybe (Property "decimals"))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe (Property "decimals"))
forall (name :: Symbol).
(KnownSymbol name, FromJSON (Property name)) =>
Object -> Parser (Maybe (Property name))
prop @"decimals" Object
o

        prop
            :: forall name. (KnownSymbol name, FromJSON (Property name))
            => Object
            -> Parser (Maybe (Property name))
        prop :: Object -> Parser (Maybe (Property name))
prop Object
o = (Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
propName) Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe (Property name)))
-> Parser (Maybe (Property name))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Value
p -> Property name -> Maybe (Property name)
forall a. a -> Maybe a
Just (Property name -> Maybe (Property name))
-> Parser (Property name) -> Parser (Maybe (Property name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Property name)
forall a. FromJSON a => Value -> Parser a
parseJSON @(Property name) Value
p
            Maybe Value
Nothing -> Maybe (Property name) -> Parser (Maybe (Property name))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Property name)
forall a. Maybe a
Nothing
          where
            propName :: Key
propName = String -> Key
forall a. IsString a => String -> a
fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)

instance (HasValidator name, FromJSON (PropertyValue name)) => FromJSON (Property name) where
    parseJSON :: Value -> Parser (Property name)
parseJSON = String
-> (Object -> Parser (Property name))
-> Value
-> Parser (Property name)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Property value" ((Object -> Parser (Property name))
 -> Value -> Parser (Property name))
-> (Object -> Parser (Property name))
-> Value
-> Parser (Property name)
forall a b. (a -> b) -> a -> b
$ \Object
o -> Either (String, Value) (PropertyValue name)
-> [Signature] -> Int -> Property name
forall (name :: Symbol).
Either (String, Value) (PropertyValue name)
-> [Signature] -> Int -> Property name
Property
            (Either (String, Value) (PropertyValue name)
 -> [Signature] -> Int -> Property name)
-> Parser (Either (String, Value) (PropertyValue name))
-> Parser ([Signature] -> Int -> Property name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either (String, Value) (PropertyValue name)
validate (Value -> Either (String, Value) (PropertyValue name))
-> Parser Value
-> Parser (Either (String, Value) (PropertyValue name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value")
            Parser ([Signature] -> Int -> Property name)
-> Parser [Signature] -> Parser (Int -> Property name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Signature])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"signatures" Parser (Maybe [Signature]) -> [Signature] -> Parser [Signature]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
            Parser (Int -> Property name)
-> Parser Int -> Parser (Property name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"sequenceNumber" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
0
      where
        validate :: Value -> Either (String, Value) (PropertyValue name)
validate Value
v = (String -> (String, Value))
-> Either String (PropertyValue name)
-> Either (String, Value) (PropertyValue name)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (,Value
v) (Either String (PropertyValue name)
 -> Either (String, Value) (PropertyValue name))
-> Either String (PropertyValue name)
-> Either (String, Value) (PropertyValue name)
forall a b. (a -> b) -> a -> b
$ (Either String (PropertyValue name)
-> (PropertyValue name -> Either String (PropertyValue name))
-> Either String (PropertyValue name)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasValidator name =>
PropertyValue name -> Either String (PropertyValue name)
forall (name :: Symbol).
HasValidator name =>
PropertyValue name -> Either String (PropertyValue name)
validatePropertyValue @name) (Either String (PropertyValue name)
 -> Either String (PropertyValue name))
-> Either String (PropertyValue name)
-> Either String (PropertyValue name)
forall a b. (a -> b) -> a -> b
$ Value -> Either String (PropertyValue name)
tryParse Value
v
        tryParse :: Value -> Either String (PropertyValue name)
tryParse = Result (PropertyValue name) -> Either String (PropertyValue name)
forall a. Result a -> Either String a
resultToEither (Result (PropertyValue name) -> Either String (PropertyValue name))
-> (Value -> Result (PropertyValue name))
-> Value
-> Either String (PropertyValue name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result (PropertyValue name)
forall a. FromJSON a => Value -> Result a
fromJSON

resultToEither :: Aeson.Result a -> Either String a
resultToEither :: Result a -> Either String a
resultToEither = \case
    Aeson.Success a
a -> a -> Either String a
forall a b. b -> Either a b
Right a
a
    Aeson.Error String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e

applyValidator :: (a -> Either String b) -> a -> Parser b
applyValidator :: (a -> Either String b) -> a -> Parser b
applyValidator a -> Either String b
validate = (String -> Parser b)
-> (b -> Parser b) -> Either String b -> Parser b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail b -> Parser b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> Parser b)
-> (a -> Either String b) -> a -> Parser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String b
validate

instance FromJSON Signature where
    parseJSON :: Value -> Parser Signature
parseJSON = String -> (Object -> Parser Signature) -> Value -> Parser Signature
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Signature" ((Object -> Parser Signature) -> Value -> Parser Signature)
-> (Object -> Parser Signature) -> Value -> Parser Signature
forall a b. (a -> b) -> a -> b
$ \Object
o -> ByteString -> ByteString -> Signature
Signature
        (ByteString -> ByteString -> Signature)
-> Parser ByteString -> Parser (ByteString -> Signature)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Encoded 'Base16 -> ByteString)
-> Parser (Encoded 'Base16) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Encoded 'Base16 -> ByteString
forall (base :: Base). Encoded base -> ByteString
raw @'Base16) (Object
o Object -> Key -> Parser (Encoded 'Base16)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"signature")
        Parser (ByteString -> Signature)
-> Parser ByteString -> Parser Signature
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Encoded 'Base16 -> ByteString)
-> Parser (Encoded 'Base16) -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Encoded 'Base16 -> ByteString
forall (base :: Base). Encoded base -> ByteString
raw @'Base16) (Object
o Object -> Key -> Parser (Encoded 'Base16)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"publicKey")

instance FromJSON AssetURL where
    parseJSON :: Value -> Parser AssetURL
parseJSON = Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Text)
-> (Text -> Parser AssetURL) -> Value -> Parser AssetURL
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Text -> Either String AssetURL) -> Text -> Parser AssetURL
forall a b. (a -> Either String b) -> a -> Parser b
applyValidator Text -> Either String AssetURL
validateMetadataURL

instance FromJSON AssetLogo where
    parseJSON :: Value -> Parser AssetLogo
parseJSON = (Encoded 'Base64 -> AssetLogo)
-> Parser (Encoded 'Base64) -> Parser AssetLogo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> AssetLogo
AssetLogo (ByteString -> AssetLogo)
-> (Encoded 'Base64 -> ByteString) -> Encoded 'Base64 -> AssetLogo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoded 'Base64 -> ByteString
forall (base :: Base). Encoded base -> ByteString
raw @'Base64) (Parser (Encoded 'Base64) -> Parser AssetLogo)
-> (Value -> Parser (Encoded 'Base64)) -> Value -> Parser AssetLogo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (Encoded 'Base64)
forall a. FromJSON a => Value -> Parser a
parseJSON

instance FromJSON AssetDecimals where
    parseJSON :: Value -> Parser AssetDecimals
parseJSON = (Int -> AssetDecimals) -> Parser Int -> Parser AssetDecimals
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> AssetDecimals
AssetDecimals (Parser Int -> Parser AssetDecimals)
-> (Value -> Parser Int) -> Value -> Parser AssetDecimals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON

--
-- Helpers
--

newtype Encoded (base :: Base) = Encoded
    { Encoded base -> ByteString
raw :: ByteString }
    deriving ((forall x. Encoded base -> Rep (Encoded base) x)
-> (forall x. Rep (Encoded base) x -> Encoded base)
-> Generic (Encoded base)
forall x. Rep (Encoded base) x -> Encoded base
forall x. Encoded base -> Rep (Encoded base) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (base :: Base) x. Rep (Encoded base) x -> Encoded base
forall (base :: Base) x. Encoded base -> Rep (Encoded base) x
$cto :: forall (base :: Base) x. Rep (Encoded base) x -> Encoded base
$cfrom :: forall (base :: Base) x. Encoded base -> Rep (Encoded base) x
Generic, Int -> Encoded base -> ShowS
[Encoded base] -> ShowS
Encoded base -> String
(Int -> Encoded base -> ShowS)
-> (Encoded base -> String)
-> ([Encoded base] -> ShowS)
-> Show (Encoded base)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (base :: Base). Int -> Encoded base -> ShowS
forall (base :: Base). [Encoded base] -> ShowS
forall (base :: Base). Encoded base -> String
showList :: [Encoded base] -> ShowS
$cshowList :: forall (base :: Base). [Encoded base] -> ShowS
show :: Encoded base -> String
$cshow :: forall (base :: Base). Encoded base -> String
showsPrec :: Int -> Encoded base -> ShowS
$cshowsPrec :: forall (base :: Base). Int -> Encoded base -> ShowS
Show, Encoded base -> Encoded base -> Bool
(Encoded base -> Encoded base -> Bool)
-> (Encoded base -> Encoded base -> Bool) -> Eq (Encoded base)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (base :: Base). Encoded base -> Encoded base -> Bool
/= :: Encoded base -> Encoded base -> Bool
$c/= :: forall (base :: Base). Encoded base -> Encoded base -> Bool
== :: Encoded base -> Encoded base -> Bool
$c== :: forall (base :: Base). Encoded base -> Encoded base -> Bool
Eq)

instance FromJSON (Encoded 'Base16) where
    parseJSON :: Value -> Parser (Encoded 'Base16)
parseJSON = String
-> (Text -> Parser (Encoded 'Base16))
-> Value
-> Parser (Encoded 'Base16)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"base16 bytestring" ((Text -> Parser (Encoded 'Base16))
 -> Value -> Parser (Encoded 'Base16))
-> (Text -> Parser (Encoded 'Base16))
-> Value
-> Parser (Encoded 'Base16)
forall a b. (a -> b) -> a -> b
$
        (String -> Parser (Encoded 'Base16))
-> (ByteString -> Parser (Encoded 'Base16))
-> Either String ByteString
-> Parser (Encoded 'Base16)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser (Encoded 'Base16)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Encoded 'Base16 -> Parser (Encoded 'Base16)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoded 'Base16 -> Parser (Encoded 'Base16))
-> (ByteString -> Encoded 'Base16)
-> ByteString
-> Parser (Encoded 'Base16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoded 'Base16
forall (base :: Base). ByteString -> Encoded base
Encoded) (Either String ByteString -> Parser (Encoded 'Base16))
-> (Text -> Either String ByteString)
-> Text
-> Parser (Encoded 'Base16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base16 (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

instance FromJSON (Encoded 'Base64) where
    parseJSON :: Value -> Parser (Encoded 'Base64)
parseJSON = String
-> (Text -> Parser (Encoded 'Base64))
-> Value
-> Parser (Encoded 'Base64)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"base64 bytestring" ((Text -> Parser (Encoded 'Base64))
 -> Value -> Parser (Encoded 'Base64))
-> (Text -> Parser (Encoded 'Base64))
-> Value
-> Parser (Encoded 'Base64)
forall a b. (a -> b) -> a -> b
$
        (String -> Parser (Encoded 'Base64))
-> (ByteString -> Parser (Encoded 'Base64))
-> Either String ByteString
-> Parser (Encoded 'Base64)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser (Encoded 'Base64)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Encoded 'Base64 -> Parser (Encoded 'Base64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoded 'Base64 -> Parser (Encoded 'Base64))
-> (ByteString -> Encoded 'Base64)
-> ByteString
-> Parser (Encoded 'Base64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoded 'Base64
forall (base :: Base). ByteString -> Encoded base
Encoded) (Either String ByteString -> Parser (Encoded 'Base64))
-> (Text -> Either String ByteString)
-> Text
-> Parser (Encoded 'Base64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64 (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8