{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Web.Spock.Api.Client
( Client, ClientConfig (..), defaultClientConfig, Credentials (..),
ClientError (..), Header, Request (..), Response (..), Transport, newClient,
callEndpoint, callEndpoint', callDocumentedEndpoint, callDocumentedEndpoint',
prepareEndpoint, prepareDocumentedEndpoint
) where
import Control.Monad (unless, when)
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.HVect (HVect (..), HVectElim, HasRep, AllHave)
import qualified Data.HVect as HV
import Data.List (nub)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types.URI (renderQuery)
import Network.URI (URI (..), URIAuth (..), parseURIReference, unEscapeString)
import Web.HttpApiData (ToHttpApiData, toHeader, toQueryParam)
import Web.Spock.Api
import Web.Spock.Api.Document
type = (T.Text, T.Text)
data Credentials = SameOrigin | OmitCredentials | IncludeCredentials
deriving (Credentials -> Credentials -> Bool
(Credentials -> Credentials -> Bool)
-> (Credentials -> Credentials -> Bool) -> Eq Credentials
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Credentials -> Credentials -> Bool
== :: Credentials -> Credentials -> Bool
$c/= :: Credentials -> Credentials -> Bool
/= :: Credentials -> Credentials -> Bool
Eq, Int -> Credentials -> ShowS
[Credentials] -> ShowS
Credentials -> String
(Int -> Credentials -> ShowS)
-> (Credentials -> String)
-> ([Credentials] -> ShowS)
-> Show Credentials
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Credentials -> ShowS
showsPrec :: Int -> Credentials -> ShowS
$cshow :: Credentials -> String
show :: Credentials -> String
$cshowList :: [Credentials] -> ShowS
showList :: [Credentials] -> ShowS
Show)
data ClientConfig = ClientConfig
{ ClientConfig -> Text
cc_baseUrl :: T.Text,
:: [Header],
ClientConfig -> Credentials
cc_credentials :: Credentials,
ClientConfig -> Int
cc_timeoutMilliseconds :: Int,
ClientConfig -> Int
cc_maxResponseBytes :: Int,
ClientConfig -> SlashPolicy
cc_slashPolicy :: SlashPolicy
} deriving (ClientConfig -> ClientConfig -> Bool
(ClientConfig -> ClientConfig -> Bool)
-> (ClientConfig -> ClientConfig -> Bool) -> Eq ClientConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientConfig -> ClientConfig -> Bool
== :: ClientConfig -> ClientConfig -> Bool
$c/= :: ClientConfig -> ClientConfig -> Bool
/= :: ClientConfig -> ClientConfig -> Bool
Eq)
defaultClientConfig :: ClientConfig
defaultClientConfig :: ClientConfig
defaultClientConfig = Text
-> [Header]
-> Credentials
-> Int
-> Int
-> SlashPolicy
-> ClientConfig
ClientConfig Text
"" [] Credentials
SameOrigin Int
30000 (Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024) SlashPolicy
IgnoreSlashes
data ClientError = InvalidClientConfig | InvalidEndpoint | InvalidRequest
| NetworkFailure | RequestTimedOut | ResponseTooLarge | HttpError Int | DecodeFailure
deriving (ClientError -> ClientError -> Bool
(ClientError -> ClientError -> Bool)
-> (ClientError -> ClientError -> Bool) -> Eq ClientError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientError -> ClientError -> Bool
== :: ClientError -> ClientError -> Bool
$c/= :: ClientError -> ClientError -> Bool
/= :: ClientError -> ClientError -> Bool
Eq, Int -> ClientError -> ShowS
[ClientError] -> ShowS
ClientError -> String
(Int -> ClientError -> ShowS)
-> (ClientError -> String)
-> ([ClientError] -> ShowS)
-> Show ClientError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientError -> ShowS
showsPrec :: Int -> ClientError -> ShowS
$cshow :: ClientError -> String
show :: ClientError -> String
$cshowList :: [ClientError] -> ShowS
showList :: [ClientError] -> ShowS
Show)
data Request = Request
{ Request -> Text
rq_method :: T.Text,
Request -> Text
rq_url :: T.Text,
:: [(B.ByteString, B.ByteString)],
Request -> Maybe ByteString
rq_body :: Maybe B.ByteString,
Request -> Credentials
rq_credentials :: Credentials,
Request -> Int
rq_timeoutMilliseconds :: Int,
Request -> Int
rq_maxResponseBytes :: Int
}
data Response = Response { Response -> Int
rs_status :: Int, Response -> ByteString
rs_body :: B.ByteString }
type Transport = Request -> IO (Either ClientError Response)
data Client = Client ClientConfig Transport
newClient :: ClientConfig -> Transport -> Either ClientError Client
newClient :: ClientConfig -> Transport -> Either ClientError Client
newClient ClientConfig
cfg Transport
transport = do
Bool -> Either ClientError () -> Either ClientError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
validBaseUrl (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ClientConfig -> Text
cc_baseUrl ClientConfig
cfg) (Either ClientError () -> Either ClientError ())
-> Either ClientError () -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError ()
forall a b. a -> Either a b
Left ClientError
InvalidClientConfig
Bool -> Either ClientError () -> Either ClientError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ClientConfig -> Int
cc_timeoutMilliseconds ClientConfig
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& ClientConfig -> Int
cc_timeoutMilliseconds ClientConfig
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2147483647
Bool -> Bool -> Bool
&& ClientConfig -> Int
cc_maxResponseBytes ClientConfig
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Either ClientError () -> Either ClientError ())
-> Either ClientError () -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError ()
forall a b. a -> Either a b
Left ClientError
InvalidClientConfig
(ClientError -> Either ClientError ())
-> (() -> Either ClientError ())
-> Either ClientError ()
-> Either ClientError ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either ClientError () -> ClientError -> Either ClientError ()
forall a b. a -> b -> a
const (Either ClientError () -> ClientError -> Either ClientError ())
-> Either ClientError () -> ClientError -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError ()
forall a b. a -> Either a b
Left ClientError
InvalidClientConfig) () -> Either ClientError ()
forall a. a -> Either ClientError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError () -> Either ClientError ())
-> Either ClientError () -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Either ClientError ()
validateHeaders ([(ByteString, ByteString)] -> Either ClientError ())
-> [(ByteString, ByteString)] -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ [Header] -> [(ByteString, ByteString)]
encodeHeaders ([Header] -> [(ByteString, ByteString)])
-> [Header] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ClientConfig -> [Header]
cc_headers ClientConfig
cfg
Client -> Either ClientError Client
forall a. a -> Either ClientError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientConfig -> Transport -> Client
Client ClientConfig
cfg Transport
transport)
callEndpoint :: (HasRep p, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client -> Endpoint p i o -> HVectElim p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
callEndpoint :: forall (p :: [*]) (i :: Maybe (*)) o.
(HasRep p, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client
-> Endpoint p i o
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
callEndpoint Client
client Endpoint p i o
endpoint = Client
-> Endpoint p i o
-> [Header]
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
forall (p :: [*]) (i :: Maybe (*)) o.
(HasRep p, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client
-> Endpoint p i o
-> [Header]
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
callEndpoint' Client
client Endpoint p i o
endpoint []
callEndpoint' :: forall p i o. (HasRep p, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client -> Endpoint p i o -> [Header] -> HVectElim p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
callEndpoint' :: forall (p :: [*]) (i :: Maybe (*)) o.
(HasRep p, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client
-> Endpoint p i o
-> [Header]
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
callEndpoint' client :: Client
client@(Client ClientConfig
cfg Transport
_) Endpoint p i o
endpoint [Header]
extra =
(HVect p -> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
forall (ts :: [*]) a.
HasRep ts =>
(HVect ts -> a) -> HVectElim ts a
HV.curry ((HVect p -> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o))))
-> (HVect p
-> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> HVectElim
p (HVectElim (MaybeToList i) (IO (Either ClientError o)))
forall a b. (a -> b) -> a -> b
$ \HVect p
path -> (HVect (MaybeToList i) -> IO (Either ClientError o))
-> HVectElim (MaybeToList i) (IO (Either ClientError o))
forall (ts :: [*]) a.
HasRep ts =>
(HVect ts -> a) -> HVectElim ts a
HV.curry ((HVect (MaybeToList i) -> IO (Either ClientError o))
-> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> (HVect (MaybeToList i) -> IO (Either ClientError o))
-> HVectElim (MaybeToList i) (IO (Either ClientError o))
forall a b. (a -> b) -> a -> b
$ \HVect (MaybeToList i)
body ->
Client
-> Endpoint p i o
-> Either ClientError Request
-> IO (Either ClientError o)
forall (p :: [*]) (i :: Maybe (*)) o.
Client
-> Endpoint p i o
-> Either ClientError Request
-> IO (Either ClientError o)
perform Client
client Endpoint p i o
endpoint (ClientConfig
-> Endpoint p i o
-> [Header]
-> HVect p
-> HVect (MaybeToList i)
-> Either ClientError Request
forall (p :: [*]) (i :: Maybe (*)) o.
AllHave ToHttpApiData p =>
ClientConfig
-> Endpoint p i o
-> [Header]
-> HVect p
-> HVect (MaybeToList i)
-> Either ClientError Request
prepareEndpoint ClientConfig
cfg Endpoint p i o
endpoint [Header]
extra HVect p
path HVect (MaybeToList i)
body)
callDocumentedEndpoint :: (HasRep p, HasRep q, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client -> DocumentedEndpoint p q i o -> HVectElim p (HVectElim q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
callDocumentedEndpoint :: forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
(HasRep p, HasRep q, HasRep (MaybeToList i),
AllHave ToHttpApiData p) =>
Client
-> DocumentedEndpoint p q i o
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
callDocumentedEndpoint Client
client DocumentedEndpoint p q i o
endpoint = Client
-> DocumentedEndpoint p q i o
-> [Header]
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
(HasRep p, HasRep q, HasRep (MaybeToList i),
AllHave ToHttpApiData p) =>
Client
-> DocumentedEndpoint p q i o
-> [Header]
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
callDocumentedEndpoint' Client
client DocumentedEndpoint p q i o
endpoint []
callDocumentedEndpoint' :: forall p q i o. (HasRep p, HasRep q, HasRep (MaybeToList i), AllHave ToHttpApiData p) =>
Client -> DocumentedEndpoint p q i o -> [Header] -> HVectElim p (HVectElim q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
callDocumentedEndpoint' :: forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
(HasRep p, HasRep q, HasRep (MaybeToList i),
AllHave ToHttpApiData p) =>
Client
-> DocumentedEndpoint p q i o
-> [Header]
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
callDocumentedEndpoint' client :: Client
client@(Client ClientConfig
cfg Transport
_) DocumentedEndpoint p q i o
endpoint [Header]
extra =
(HVect p
-> HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
forall (ts :: [*]) a.
HasRep ts =>
(HVect ts -> a) -> HVectElim ts a
HV.curry ((HVect p
-> HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o)))))
-> (HVect p
-> HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
-> HVectElim
p
(HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
forall a b. (a -> b) -> a -> b
$ \HVect p
path -> (HVect q -> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o)))
forall (ts :: [*]) a.
HasRep ts =>
(HVect ts -> a) -> HVectElim ts a
HV.curry ((HVect q -> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o))))
-> (HVect q
-> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> HVectElim
q (HVectElim (MaybeToList i) (IO (Either ClientError o)))
forall a b. (a -> b) -> a -> b
$ \HVect q
parameters -> (HVect (MaybeToList i) -> IO (Either ClientError o))
-> HVectElim (MaybeToList i) (IO (Either ClientError o))
forall (ts :: [*]) a.
HasRep ts =>
(HVect ts -> a) -> HVectElim ts a
HV.curry ((HVect (MaybeToList i) -> IO (Either ClientError o))
-> HVectElim (MaybeToList i) (IO (Either ClientError o)))
-> (HVect (MaybeToList i) -> IO (Either ClientError o))
-> HVectElim (MaybeToList i) (IO (Either ClientError o))
forall a b. (a -> b) -> a -> b
$ \HVect (MaybeToList i)
body ->
Client
-> Endpoint p i o
-> Either ClientError Request
-> IO (Either ClientError o)
forall (p :: [*]) (i :: Maybe (*)) o.
Client
-> Endpoint p i o
-> Either ClientError Request
-> IO (Either ClientError o)
perform Client
client (DocumentedEndpoint p q i o -> Endpoint p i o
forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
DocumentedEndpoint p q i o -> Endpoint p i o
de_endpoint DocumentedEndpoint p q i o
endpoint) (ClientConfig
-> DocumentedEndpoint p q i o
-> [Header]
-> HVect p
-> HVect q
-> HVect (MaybeToList i)
-> Either ClientError Request
forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
AllHave ToHttpApiData p =>
ClientConfig
-> DocumentedEndpoint p q i o
-> [Header]
-> HVect p
-> HVect q
-> HVect (MaybeToList i)
-> Either ClientError Request
prepareDocumentedEndpoint ClientConfig
cfg DocumentedEndpoint p q i o
endpoint [Header]
extra HVect p
path HVect q
parameters HVect (MaybeToList i)
body)
prepareEndpoint :: forall p i o. AllHave ToHttpApiData p => ClientConfig -> Endpoint p i o -> [Header] ->
HVect p -> HVect (MaybeToList i) -> Either ClientError Request
prepareEndpoint :: forall (p :: [*]) (i :: Maybe (*)) o.
AllHave ToHttpApiData p =>
ClientConfig
-> Endpoint p i o
-> [Header]
-> HVect p
-> HVect (MaybeToList i)
-> Either ClientError Request
prepareEndpoint ClientConfig
cfg Endpoint p i o
endpoint [Header]
extra HVect p
path HVect (MaybeToList i)
body = case Endpoint p i o
endpoint of
MethodGet Path p 'Open
route -> case HVect (MaybeToList i)
body of HVect (MaybeToList i)
HNil -> Text
-> Path p 'Open -> Maybe ByteString -> Either ClientError Request
make Text
"GET" Path p 'Open
route Maybe ByteString
forall a. Maybe a
Nothing
MethodDelete Path p 'Open
route -> case HVect (MaybeToList i)
body of HVect (MaybeToList i)
HNil -> Text
-> Path p 'Open -> Maybe ByteString -> Either ClientError Request
make Text
"DELETE" Path p 'Open
route Maybe ByteString
forall a. Maybe a
Nothing
MethodPost Proxy (i1 -> o)
_ Path p 'Open
route -> case HVect (MaybeToList i)
body of t
value :&: HVect ts1
HNil -> Text
-> Path p 'Open -> Maybe ByteString -> Either ClientError Request
make Text
"POST" Path p 'Open
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ t -> ByteString
forall a. ToJSON a => a -> ByteString
jsonBytes t
value)
MethodPut Proxy (i1 -> o)
_ Path p 'Open
route -> case HVect (MaybeToList i)
body of t
value :&: HVect ts1
HNil -> Text
-> Path p 'Open -> Maybe ByteString -> Either ClientError Request
make Text
"PUT" Path p 'Open
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ t -> ByteString
forall a. ToJSON a => a -> ByteString
jsonBytes t
value)
MethodPatch Proxy (i1 -> o)
_ Path p 'Open
route -> case HVect (MaybeToList i)
body of t
value :&: HVect ts1
HNil -> Text
-> Path p 'Open -> Maybe ByteString -> Either ClientError Request
make Text
"PATCH" Path p 'Open
route (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ t -> ByteString
forall a. ToJSON a => a -> ByteString
jsonBytes t
value)
where
make :: T.Text -> Path p 'Open -> Maybe B.ByteString -> Either ClientError Request
make :: Text
-> Path p 'Open -> Maybe ByteString -> Either ClientError Request
make Text
method Path p 'Open
route Maybe ByteString
payload = do
_ <- ClientConfig -> Transport -> Either ClientError Client
newClient ClientConfig
cfg (IO (Either ClientError Response) -> Transport
forall a b. a -> b -> a
const (IO (Either ClientError Response) -> Transport)
-> IO (Either ClientError Response) -> Transport
forall a b. (a -> b) -> a -> b
$ Either ClientError Response -> IO (Either ClientError Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError Response -> IO (Either ClientError Response))
-> Either ClientError Response -> IO (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError Response
forall a b. a -> Either a b
Left ClientError
NetworkFailure)
let headers = [Header] -> [(ByteString, ByteString)]
encodeHeaders (ClientConfig -> [Header]
cc_headers ClientConfig
cfg [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
extra) [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++
[(ByteString
"Content-Type", ByteString
"application/json;charset=UTF-8") | Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe ByteString
payload]
url = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (ClientConfig -> Text
cc_baseUrl ClientConfig
cfg) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SlashPolicy -> Path p 'Open -> HVect p -> Text
forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy -> Path as 'Open -> HVect as -> Text
renderRouteEncodedWith (ClientConfig -> SlashPolicy
cc_slashPolicy ClientConfig
cfg) Path p 'Open
route HVect p
path
validateHeaders headers
unless (validBaseUrl url) $ Left InvalidRequest
pure $ Request method url headers payload (cc_credentials cfg) (cc_timeoutMilliseconds cfg) (cc_maxResponseBytes cfg)
prepareDocumentedEndpoint :: AllHave ToHttpApiData p => ClientConfig -> DocumentedEndpoint p q i o -> [Header] ->
HVect p -> HVect q -> HVect (MaybeToList i) -> Either ClientError Request
prepareDocumentedEndpoint :: forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
AllHave ToHttpApiData p =>
ClientConfig
-> DocumentedEndpoint p q i o
-> [Header]
-> HVect p
-> HVect q
-> HVect (MaybeToList i)
-> Either ClientError Request
prepareDocumentedEndpoint ClientConfig
cfg DocumentedEndpoint p q i o
endpoint [Header]
extra HVect p
path HVect q
parameters HVect (MaybeToList i)
body = do
(OpenApiError -> Either ClientError ())
-> (() -> Either ClientError ())
-> Either OpenApiError ()
-> Either ClientError ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either ClientError () -> OpenApiError -> Either ClientError ()
forall a b. a -> b -> a
const (Either ClientError () -> OpenApiError -> Either ClientError ())
-> Either ClientError () -> OpenApiError -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError ()
forall a b. a -> Either a b
Left ClientError
InvalidEndpoint) () -> Either ClientError ()
forall a. a -> Either ClientError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either OpenApiError () -> Either ClientError ())
-> Either OpenApiError () -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ DocumentedEndpoint p q i o -> Either OpenApiError ()
forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
DocumentedEndpoint p q i o -> Either OpenApiError ()
validateEndpoint DocumentedEndpoint p q i o
endpoint
request <- ClientConfig
-> Endpoint p i o
-> [Header]
-> HVect p
-> HVect (MaybeToList i)
-> Either ClientError Request
forall (p :: [*]) (i :: Maybe (*)) o.
AllHave ToHttpApiData p =>
ClientConfig
-> Endpoint p i o
-> [Header]
-> HVect p
-> HVect (MaybeToList i)
-> Either ClientError Request
prepareEndpoint ClientConfig
cfg (DocumentedEndpoint p q i o -> Endpoint p i o
forall (p :: [*]) (q :: [*]) (i :: Maybe (*)) o.
DocumentedEndpoint p q i o -> Endpoint p i o
de_endpoint DocumentedEndpoint p q i o
endpoint) [Header]
extra HVect p
path HVect (MaybeToList i)
body
let (query, headers) = parameterValues (de_parameters endpoint) parameters
combined = Request -> [(ByteString, ByteString)]
rq_headers Request
request [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
headers
validateHeaders combined
pure request { rq_url = rq_url request <> T.decodeUtf8 (renderQuery True query), rq_headers = combined }
parameterValues :: Parameters q -> HVect q -> ([(B.ByteString, Maybe B.ByteString)], [(B.ByteString, B.ByteString)])
parameterValues :: forall (q :: [*]).
Parameters q
-> HVect q
-> ([(ByteString, Maybe ByteString)], [(ByteString, ByteString)])
parameterValues Parameters q
NoParameters HVect q
HNil = ([], [])
parameterValues (Parameter a
parameter :> Parameters q1
rest) (t
value :&: HVect ts1
values) =
let ([(ByteString, Maybe ByteString)]
query, [(ByteString, ByteString)]
headers) = Parameters q1
-> HVect q1
-> ([(ByteString, Maybe ByteString)], [(ByteString, ByteString)])
forall (q :: [*]).
Parameters q
-> HVect q
-> ([(ByteString, Maybe ByteString)], [(ByteString, ByteString)])
parameterValues Parameters q1
rest HVect q1
HVect ts1
values
in case Parameter a
parameter of
QueryParam ParameterInfo a
info -> (Text -> t -> (ByteString, Maybe ByteString)
forall a.
ToHttpApiData a =>
Text -> a -> (ByteString, Maybe ByteString)
queryValue (ParameterInfo a -> Text
forall a. ParameterInfo a -> Text
pi_name ParameterInfo a
info) t
value (ByteString, Maybe ByteString)
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, Maybe ByteString)]
query, [(ByteString, ByteString)]
headers)
OptionalQueryParam ParameterInfo a1
info -> ([(ByteString, Maybe ByteString)]
-> (a1 -> [(ByteString, Maybe ByteString)])
-> Maybe a1
-> [(ByteString, Maybe ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\a1
v -> [Text -> a1 -> (ByteString, Maybe ByteString)
forall a.
ToHttpApiData a =>
Text -> a -> (ByteString, Maybe ByteString)
queryValue (ParameterInfo a1 -> Text
forall a. ParameterInfo a -> Text
pi_name ParameterInfo a1
info) a1
v]) t
Maybe a1
value [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, Maybe ByteString)]
query, [(ByteString, ByteString)]
headers)
QueryList ParameterInfo a1
info -> ((a1 -> (ByteString, Maybe ByteString))
-> [a1] -> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> a1 -> (ByteString, Maybe ByteString)
forall a.
ToHttpApiData a =>
Text -> a -> (ByteString, Maybe ByteString)
queryValue (Text -> a1 -> (ByteString, Maybe ByteString))
-> Text -> a1 -> (ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ParameterInfo a1 -> Text
forall a. ParameterInfo a -> Text
pi_name ParameterInfo a1
info) t
[a1]
value [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
-> [(ByteString, Maybe ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, Maybe ByteString)]
query, [(ByteString, ByteString)]
headers)
HeaderParam ParameterInfo a
info -> ([(ByteString, Maybe ByteString)]
query, Text -> t -> (ByteString, ByteString)
forall a. ToHttpApiData a => Text -> a -> (ByteString, ByteString)
headerValue (ParameterInfo a -> Text
forall a. ParameterInfo a -> Text
pi_name ParameterInfo a
info) t
value (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(ByteString, ByteString)]
headers)
OptionalHeaderParam ParameterInfo a1
info -> ([(ByteString, Maybe ByteString)]
query, [(ByteString, ByteString)]
-> (a1 -> [(ByteString, ByteString)])
-> Maybe a1
-> [(ByteString, ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\a1
v -> [Text -> a1 -> (ByteString, ByteString)
forall a. ToHttpApiData a => Text -> a -> (ByteString, ByteString)
headerValue (ParameterInfo a1 -> Text
forall a. ParameterInfo a -> Text
pi_name ParameterInfo a1
info) a1
v]) t
Maybe a1
value [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
headers)
queryValue :: ToHttpApiData a => T.Text -> a -> (B.ByteString, Maybe B.ByteString)
queryValue :: forall a.
ToHttpApiData a =>
Text -> a -> (ByteString, Maybe ByteString)
queryValue Text
name a
value = (Text -> ByteString
T.encodeUtf8 Text
name, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ToHttpApiData a => a -> Text
toQueryParam a
value)
headerValue :: ToHttpApiData a => T.Text -> a -> (B.ByteString, B.ByteString)
Text
name a
value = (Text -> ByteString
T.encodeUtf8 Text
name, a -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader a
value)
jsonBytes :: A.ToJSON a => a -> B.ByteString
jsonBytes :: forall a. ToJSON a => a -> ByteString
jsonBytes = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString)
-> (a -> LazyByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
A.encode
perform :: Client -> Endpoint p i o -> Either ClientError Request -> IO (Either ClientError o)
perform :: forall (p :: [*]) (i :: Maybe (*)) o.
Client
-> Endpoint p i o
-> Either ClientError Request
-> IO (Either ClientError o)
perform Client
_ Endpoint p i o
_ (Left ClientError
err) = Either ClientError o -> IO (Either ClientError o)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientError -> Either ClientError o
forall a b. a -> Either a b
Left ClientError
err)
perform (Client ClientConfig
_ Transport
transport) Endpoint p i o
endpoint (Right Request
request) = do
result <- Transport
transport Request
request
pure $ result >>= \Response
response -> Endpoint p i o -> Int -> Response -> Either ClientError o
forall (p :: [*]) (i :: Maybe (*)) o.
Endpoint p i o -> Int -> Response -> Either ClientError o
decodeResponse Endpoint p i o
endpoint (Request -> Int
rq_maxResponseBytes Request
request) Response
response
decodeResponse :: Endpoint p i o -> Int -> Response -> Either ClientError o
decodeResponse :: forall (p :: [*]) (i :: Maybe (*)) o.
Endpoint p i o -> Int -> Response -> Either ClientError o
decodeResponse Endpoint p i o
endpoint Int
limit Response
response = case Endpoint p i o
endpoint of
MethodGet Path p 'Open
_ -> Either ClientError o
forall a. FromJSON a => Either ClientError a
decode
MethodDelete Path p 'Open
_ -> Either ClientError o
forall a. FromJSON a => Either ClientError a
decode
MethodPost Proxy (i1 -> o)
_ Path p 'Open
_ -> Either ClientError o
forall a. FromJSON a => Either ClientError a
decode
MethodPut Proxy (i1 -> o)
_ Path p 'Open
_ -> Either ClientError o
forall a. FromJSON a => Either ClientError a
decode
MethodPatch Proxy (i1 -> o)
_ Path p 'Open
_ -> Either ClientError o
forall a. FromJSON a => Either ClientError a
decode
where
decode :: A.FromJSON a => Either ClientError a
decode :: forall a. FromJSON a => Either ClientError a
decode
| Response -> Int
rs_status Response
response Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
200 Bool -> Bool -> Bool
|| Response -> Int
rs_status Response
response Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300 = ClientError -> Either ClientError a
forall a b. a -> Either a b
Left (ClientError -> Either ClientError a)
-> ClientError -> Either ClientError a
forall a b. (a -> b) -> a -> b
$ Int -> ClientError
HttpError (Int -> ClientError) -> Int -> ClientError
forall a b. (a -> b) -> a -> b
$ Response -> Int
rs_status Response
response
| ByteString -> Int
B.length (Response -> ByteString
rs_body Response
response) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit = ClientError -> Either ClientError a
forall a b. a -> Either a b
Left ClientError
ResponseTooLarge
| Bool
otherwise = (String -> Either ClientError a)
-> (a -> Either ClientError a)
-> Either String a
-> Either ClientError a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either ClientError a -> String -> Either ClientError a
forall a b. a -> b -> a
const (Either ClientError a -> String -> Either ClientError a)
-> Either ClientError a -> String -> Either ClientError a
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError a
forall a b. a -> Either a b
Left ClientError
DecodeFailure) a -> Either ClientError a
forall a b. b -> Either a b
Right (Either String a -> Either ClientError a)
-> Either String a -> Either ClientError a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecodeStrict' (ByteString -> Either String a) -> ByteString -> Either String a
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rs_body Response
response
encodeHeaders :: [Header] -> [(B.ByteString, B.ByteString)]
= (Header -> (ByteString, ByteString))
-> [Header] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
name, Text
value) -> (Text -> ByteString
T.encodeUtf8 Text
name, Text -> ByteString
T.encodeUtf8 Text
value))
validateHeaders :: [(B.ByteString, B.ByteString)] -> Either ClientError ()
[(ByteString, ByteString)]
headers = do
let names :: [ByteString]
names = ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((Word8 -> Word8) -> ByteString -> ByteString
B.map Word8 -> Word8
forall {a}. (Ord a, Num a) => a -> a
lower (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, ByteString)]
headers
validName :: ByteString -> Bool
validName ByteString
name = Bool -> Bool
not (ByteString -> Bool
B.null ByteString
name) Bool -> Bool -> Bool
&& (Word8 -> Bool) -> ByteString -> Bool
B.all (\Word8
c -> Word8 -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
asciiAlphaNum Word8
c Bool -> Bool -> Bool
|| Word8
c Word8 -> ByteString -> Bool
`B.elem` ByteString
"!#$%&'*+-.^_`|~") ByteString
name
validValue :: ByteString -> Bool
validValue = (Word8 -> Bool) -> ByteString -> Bool
B.all (\Word8
c -> Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
9 Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
32 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
127)
lower :: a -> a
lower a
c | a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
90 = a
c a -> a -> a
forall a. Num a => a -> a -> a
+ a
32
| Bool
otherwise = a
c
asciiAlphaNum :: a -> Bool
asciiAlphaNum a
c = a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
90 Bool -> Bool -> Bool
|| a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
97 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
122 Bool -> Bool -> Bool
|| a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57
Bool -> Either ClientError () -> Either ClientError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
names Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ByteString] -> [ByteString]
forall a. Eq a => [a] -> [a]
nub [ByteString]
names) Bool -> Bool -> Bool
|| ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(ByteString
n,ByteString
v) -> Bool -> Bool
not (ByteString -> Bool
validName ByteString
n Bool -> Bool -> Bool
&& ByteString -> Bool
validValue ByteString
v)) [(ByteString, ByteString)]
headers) (Either ClientError () -> Either ClientError ())
-> Either ClientError () -> Either ClientError ()
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError ()
forall a b. a -> Either a b
Left ClientError
InvalidRequest
validBaseUrl :: T.Text -> Bool
validBaseUrl :: Text -> Bool
validBaseUrl Text
value
| (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\DEL') Text
value = Bool
False
| Bool
otherwise = case String -> Maybe URI
parseURIReference (Text -> String
T.unpack Text
value) of
Just URI
uri | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriQuery URI
uri) Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriFragment URI
uri),
Bool -> Bool
not ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Text
piece -> ShowS
unEscapeString (Text -> String
T.unpack Text
piece) String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".", String
".."]) ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
uriPath URI
uri) -> case (URI -> String
uriScheme URI
uri, URI -> Maybe URIAuth
uriAuthority URI
uri) of
(String
"", Maybe URIAuth
Nothing) -> Text -> Bool
T.null Text
value Bool -> Bool -> Bool
|| Text -> Text -> Bool
T.isPrefixOf Text
"/" Text
value
(String
scheme, Just URIAuth
authority) -> String
scheme String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"http:", String
"https:"] Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URIAuth -> String
uriUserInfo URIAuth
authority) Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URIAuth -> String
uriRegName URIAuth
authority)
(String, Maybe URIAuth)
_ -> Bool
False
Maybe URI
_ -> Bool
False