{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cardano.Wallet.TokenMetadata.MockServer
( withMetadataServer
, withMetadataServerOptions
, queryServerStatic
, queryServerReloading
, assetIdFromSubject
) where
import Prelude
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 (..)
, AssetURL (..)
, TokenName (..)
, TokenPolicyId (..)
)
import Cardano.Wallet.TokenMetadata
( BatchRequest (..)
, BatchResponse (..)
, Property (..)
, PropertyName
, PropertyValue
, Signature (..)
, Subject (..)
, SubjectProperties (..)
, propertyName
)
import Cardano.Wallet.Unsafe
( unsafeFromHex )
import Control.Monad.IO.Class
( liftIO )
import Data.Aeson
( FromJSON (..)
, ToJSON (..)
, Value (..)
, eitherDecodeFileStrict
, object
, (.=)
)
import Data.ByteArray.Encoding
( Base (Base16, Base64), convertToBase )
import Data.Function
( (&) )
import Data.Generics.Internal.VL.Lens
( view )
import Data.HashSet
( HashSet )
import Data.Maybe
( fromMaybe )
import Data.Proxy
( Proxy (..) )
import GHC.TypeLits
( KnownSymbol )
import Network.URI
( parseURI )
import Network.Wai
( Middleware )
import Network.Wai.Handler.Warp
( Port
, defaultSettings
, runSettings
, setBeforeMainLoop
, setPort
, withApplication
)
import Servant.API
( (:>), JSON, Post, ReqBody )
import Servant.Server
( Handler (..), Server, serve )
import UnliftIO.Async
( race )
import UnliftIO.Exception
( throwString )
import UnliftIO.MVar
( newEmptyMVar, putMVar, takeMVar )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.HashSet as Set
import qualified Data.Text.Encoding as T
type MetadataQueryApi = "metadata" :> "query"
:> ReqBody '[JSON] BatchRequest :> Post '[JSON] BatchResponse
withMetadataServer
:: IO (Server MetadataQueryApi)
-> (TokenMetadataServer -> IO a)
-> IO a
withMetadataServer :: IO (Server MetadataQueryApi)
-> (TokenMetadataServer -> IO a) -> IO a
withMetadataServer = Middleware
-> Maybe Port
-> IO (Server MetadataQueryApi)
-> (TokenMetadataServer -> IO a)
-> IO a
forall a.
Middleware
-> Maybe Port
-> IO (Server MetadataQueryApi)
-> (TokenMetadataServer -> IO a)
-> IO a
withMetadataServerOptions Middleware
forall a. a -> a
id Maybe Port
forall a. Maybe a
Nothing
withMetadataServerOptions
:: Middleware
-> Maybe Port
-> IO (Server MetadataQueryApi)
-> (TokenMetadataServer -> IO a)
-> IO a
withMetadataServerOptions :: Middleware
-> Maybe Port
-> IO (Server MetadataQueryApi)
-> (TokenMetadataServer -> IO a)
-> IO a
withMetadataServerOptions Middleware
middleware Maybe Port
mPort IO (Server MetadataQueryApi)
mkServer TokenMetadataServer -> IO a
action = case Maybe Port
mPort of
Just Port
port -> do
Application
app <- IO Application
mkApp
MVar Port
started <- IO (MVar Port)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
let settings :: Settings
settings = Settings
defaultSettings
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
setBeforeMainLoop (MVar Port -> Port -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar Port
started Port
port)
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Port -> Settings -> Settings
setPort Port
port
IO () -> IO a -> IO (Either () a)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (Settings -> Application -> IO ()
runSettings Settings
settings Application
app) (MVar Port -> IO Port
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar Port
started IO Port -> (Port -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Port -> IO a
action') IO (Either () a) -> (Either () a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
a -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left () -> String -> IO a
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Unexpected: runSettings exited"
Maybe Port
Nothing -> IO Application -> (Port -> IO a) -> IO a
forall a. IO Application -> (Port -> IO a) -> IO a
withApplication IO Application
mkApp Port -> IO a
action'
where
mkApp :: IO Application
mkApp = Middleware
middleware Middleware
-> ((BatchRequest -> Handler BatchResponse) -> Application)
-> (BatchRequest -> Handler BatchResponse)
-> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy MetadataQueryApi -> Server MetadataQueryApi -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (Proxy MetadataQueryApi
forall k (t :: k). Proxy t
Proxy @MetadataQueryApi) ((BatchRequest -> Handler BatchResponse) -> Application)
-> IO (BatchRequest -> Handler BatchResponse) -> IO Application
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Server MetadataQueryApi)
IO (BatchRequest -> Handler BatchResponse)
mkServer
mkUrl :: a -> TokenMetadataServer
mkUrl a
port = URI -> TokenMetadataServer
TokenMetadataServer
(URI -> TokenMetadataServer) -> URI -> TokenMetadataServer
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe (String -> URI
forall a. HasCallStack => String -> a
error String
"withMetadataServer: bad uri")
(Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI
(String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ String
"http://localhost:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
port String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
action' :: Port -> IO a
action' = TokenMetadataServer -> IO a
action (TokenMetadataServer -> IO a)
-> (Port -> TokenMetadataServer) -> Port -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> TokenMetadataServer
forall a. Show a => a -> TokenMetadataServer
mkUrl
queryServerStatic :: FilePath -> IO (BatchRequest -> Handler BatchResponse)
queryServerStatic :: String -> IO (BatchRequest -> Handler BatchResponse)
queryServerStatic String
golden = do
BatchResponse
db <- (String -> BatchResponse)
-> (BatchResponse -> BatchResponse)
-> Either String BatchResponse
-> BatchResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> BatchResponse
forall a. HasCallStack => String -> a
error (String -> BatchResponse)
-> (String -> String) -> String -> BatchResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) BatchResponse -> BatchResponse
forall a. a -> a
id (Either String BatchResponse -> BatchResponse)
-> IO (Either String BatchResponse) -> IO BatchResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String BatchResponse)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict String
golden
(BatchRequest -> Handler BatchResponse)
-> IO (BatchRequest -> Handler BatchResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BatchResponse -> Handler BatchResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BatchResponse -> Handler BatchResponse)
-> (BatchRequest -> BatchResponse)
-> BatchRequest
-> Handler BatchResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchResponse -> BatchRequest -> BatchResponse
handler BatchResponse
db)
where
handler :: BatchResponse -> BatchRequest -> BatchResponse
handler (BatchResponse [SubjectProperties]
db) (BatchRequest [Subject]
subs [PropertyName]
props) = [SubjectProperties] -> BatchResponse
BatchResponse ([SubjectProperties] -> BatchResponse)
-> [SubjectProperties] -> BatchResponse
forall a b. (a -> b) -> a -> b
$
HashSet Subject
-> HashSet PropertyName
-> [SubjectProperties]
-> [SubjectProperties]
filterResponse ([Subject] -> HashSet Subject
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [Subject]
subs) ([PropertyName] -> HashSet PropertyName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [PropertyName]
props) [SubjectProperties]
db
filterResponse
:: HashSet Subject
-> HashSet PropertyName
-> [SubjectProperties]
-> [SubjectProperties]
filterResponse :: HashSet Subject
-> HashSet PropertyName
-> [SubjectProperties]
-> [SubjectProperties]
filterResponse HashSet Subject
subs HashSet PropertyName
props = (SubjectProperties -> SubjectProperties)
-> [SubjectProperties] -> [SubjectProperties]
forall a b. (a -> b) -> [a] -> [b]
map SubjectProperties -> SubjectProperties
filterProps ([SubjectProperties] -> [SubjectProperties])
-> ([SubjectProperties] -> [SubjectProperties])
-> [SubjectProperties]
-> [SubjectProperties]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SubjectProperties -> Bool)
-> [SubjectProperties] -> [SubjectProperties]
forall a. (a -> Bool) -> [a] -> [a]
filter SubjectProperties -> Bool
forall s. HasField' "subject" s Subject => s -> Bool
inSubs
where
filterProps :: SubjectProperties -> SubjectProperties
filterProps (SubjectProperties Subject
subj Maybe Signature
own (Maybe (Property "name")
a, Maybe (Property "description")
b, Maybe (Property "ticker")
c, Maybe (Property "url")
d, Maybe (Property "logo")
e, Maybe (Property "decimals")
f)) =
Subject
-> Maybe Signature
-> (Maybe (Property "name"), Maybe (Property "description"),
Maybe (Property "ticker"), Maybe (Property "url"),
Maybe (Property "logo"), Maybe (Property "decimals"))
-> SubjectProperties
SubjectProperties Subject
subj Maybe Signature
own
(Maybe (Property "name") -> Maybe (Property "name")
forall (name :: Symbol).
KnownSymbol name =>
Maybe (Property name) -> Maybe (Property name)
inProps Maybe (Property "name")
a, Maybe (Property "description") -> Maybe (Property "description")
forall (name :: Symbol).
KnownSymbol name =>
Maybe (Property name) -> Maybe (Property name)
inProps Maybe (Property "description")
b, Maybe (Property "ticker") -> Maybe (Property "ticker")
forall (name :: Symbol).
KnownSymbol name =>
Maybe (Property name) -> Maybe (Property name)
inProps Maybe (Property "ticker")
c, Maybe (Property "url") -> Maybe (Property "url")
forall (name :: Symbol).
KnownSymbol name =>
Maybe (Property name) -> Maybe (Property name)
inProps Maybe (Property "url")
d, Maybe (Property "logo") -> Maybe (Property "logo")
forall (name :: Symbol).
KnownSymbol name =>
Maybe (Property name) -> Maybe (Property name)
inProps Maybe (Property "logo")
e, Maybe (Property "decimals") -> Maybe (Property "decimals")
forall (name :: Symbol).
KnownSymbol name =>
Maybe (Property name) -> Maybe (Property name)
inProps Maybe (Property "decimals")
f)
inSubs :: s -> Bool
inSubs s
sp = (((Subject -> Const Subject Subject) -> s -> Const Subject s)
-> s -> Subject
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
"subject"
((Subject -> Const Subject Subject) -> s -> Const Subject s)
(Subject -> Const Subject Subject) -> s -> Const Subject s
#subject s
sp) Subject -> HashSet Subject -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet Subject
subs
inProps :: KnownSymbol name => Maybe (Property name) -> Maybe (Property name)
inProps :: Maybe (Property name) -> Maybe (Property name)
inProps (Just Property name
p) = if (Property name -> PropertyName
forall (name :: Symbol).
KnownSymbol name =>
Property name -> PropertyName
propertyName Property name
p) PropertyName -> HashSet PropertyName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet PropertyName
props then Property name -> Maybe (Property name)
forall a. a -> Maybe a
Just Property name
p else Maybe (Property name)
forall a. Maybe a
Nothing
inProps Maybe (Property name)
Nothing = Maybe (Property name)
forall a. Maybe a
Nothing
queryServerReloading :: FilePath -> BatchRequest -> Handler BatchResponse
queryServerReloading :: String -> BatchRequest -> Handler BatchResponse
queryServerReloading String
golden BatchRequest
req = do
BatchRequest -> Handler BatchResponse
handler <- IO (BatchRequest -> Handler BatchResponse)
-> Handler (BatchRequest -> Handler BatchResponse)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (BatchRequest -> Handler BatchResponse)
-> Handler (BatchRequest -> Handler BatchResponse))
-> IO (BatchRequest -> Handler BatchResponse)
-> Handler (BatchRequest -> Handler BatchResponse)
forall a b. (a -> b) -> a -> b
$ String -> IO (BatchRequest -> Handler BatchResponse)
queryServerStatic String
golden
BatchRequest -> Handler BatchResponse
handler BatchRequest
req
assetIdFromSubject :: Subject -> AssetId
assetIdFromSubject :: Subject -> AssetId
assetIdFromSubject =
(ByteString, ByteString) -> AssetId
mk ((ByteString, ByteString) -> AssetId)
-> (Subject -> (ByteString, ByteString)) -> Subject -> AssetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> ByteString -> (ByteString, ByteString)
BS.splitAt Port
32 (ByteString -> (ByteString, ByteString))
-> (Subject -> ByteString) -> Subject -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall b. (HasCallStack, ByteArray b) => ByteString -> b
unsafeFromHex (ByteString -> ByteString)
-> (Subject -> ByteString) -> Subject -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Subject -> Text) -> Subject -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subject -> Text
unSubject
where
mk :: (ByteString, ByteString) -> AssetId
mk (ByteString
p, ByteString
n) = TokenPolicyId -> TokenName -> AssetId
AssetId (Hash "TokenPolicy" -> TokenPolicyId
UnsafeTokenPolicyId (ByteString -> Hash "TokenPolicy"
forall (tag :: Symbol). ByteString -> Hash tag
Hash ByteString
p)) (ByteString -> TokenName
UnsafeTokenName ByteString
n)
instance FromJSON BatchRequest where
instance ToJSON SubjectProperties where
toJSON :: SubjectProperties -> Value
toJSON (SubjectProperties Subject
s Maybe Signature
o (Maybe (Property "name")
n,Maybe (Property "description")
d,Maybe (Property "ticker")
a,Maybe (Property "url")
u,Maybe (Property "logo")
l,Maybe (Property "decimals")
dec)) = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
[ Key
"subject" Key -> Subject -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Subject
s
, Key
"owner" Key -> Maybe Signature -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Signature
o
] [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair] -> [Pair]
forall a. [(a, Value)] -> [(a, Value)]
optionals
[ Key
"name" Key -> Maybe (Property "name") -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Property "name")
n
, Key
"description" Key -> Maybe (Property "description") -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Property "description")
d
, Key
"ticker" Key -> Maybe (Property "ticker") -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Property "ticker")
a
, Key
"url" Key -> Maybe (Property "url") -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Property "url")
u
, Key
"logo" Key -> Maybe (Property "logo") -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Property "logo")
l
, Key
"decimals" Key -> Maybe (Property "decimals") -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Property "decimals")
dec
]
where
optionals :: [(a, Value)] -> [(a, Value)]
optionals = ((a, Value) -> Bool) -> [(a, Value)] -> [(a, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
Null) (Value -> Bool) -> ((a, Value) -> Value) -> (a, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Value) -> Value
forall a b. (a, b) -> b
snd)
instance ToJSON (PropertyValue name) => ToJSON (Property name) where
toJSON :: Property name -> Value
toJSON (Property Either (String, Value) (PropertyValue name)
v [Signature]
s Port
c) = [Pair] -> Value
object
[ Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ((String, Value) -> Value)
-> (PropertyValue name -> Value)
-> Either (String, Value) (PropertyValue name)
-> Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String, Value) -> Value
forall a b. (a, b) -> b
snd PropertyValue name -> Value
forall a. ToJSON a => a -> Value
toJSON Either (String, Value) (PropertyValue name)
v
, Key
"signatures" Key -> [Signature] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Signature]
s
, Key
"sequenceNumber" Key -> Port -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Port
c
]
instance ToJSON Signature where
toJSON :: Signature -> Value
toJSON (Signature ByteString
s ByteString
k) = [Pair] -> Value
object
[ Key
"signature" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
hex ByteString
s
, Key
"publicKey" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
hex ByteString
k
]
where
hex :: ByteString -> Text
hex = ByteString -> Text
T.decodeLatin1 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16
instance ToJSON BatchResponse where
toJSON :: BatchResponse -> Value
toJSON (BatchResponse [SubjectProperties]
subs) = [Pair] -> Value
object
[ Key
"subjects" Key -> [SubjectProperties] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [SubjectProperties]
subs
]
instance ToJSON AssetLogo where
toJSON :: AssetLogo -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> (AssetLogo -> String) -> AssetLogo -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B8.unpack (ByteString -> String)
-> (AssetLogo -> ByteString) -> AssetLogo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 (ByteString -> ByteString)
-> (AssetLogo -> ByteString) -> AssetLogo -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetLogo -> ByteString
unAssetLogo
instance ToJSON AssetURL where
toJSON :: AssetURL -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> (AssetURL -> String) -> AssetURL -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
forall a. Show a => a -> String
show (URI -> String) -> (AssetURL -> URI) -> AssetURL -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetURL -> URI
unAssetURL
instance ToJSON AssetDecimals where
toJSON :: AssetDecimals -> Value
toJSON = Port -> Value
forall a. ToJSON a => a -> Value
toJSON (Port -> Value)
-> (AssetDecimals -> Port) -> AssetDecimals -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssetDecimals -> Port
unAssetDecimals