@@ -0,0 +1,993 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE InstanceSigs #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+
17+module Servant.Client.Core.HasClient (
18+ clientIn,
19+ HasClient (..),
20+ EmptyClient (..),
21+ AsClientT,
22+ (//),
23+ (/:),
24+ foldMapUnion,
25+ matchUnion,
26+ ) where
27+
28+import Prelude ()
29+import Prelude.Compat
30+
31+import Control.Arrow
32+ (left, (+++))
33+import Control.Monad
34+ (unless)
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
37+import Data.Either
38+ (partitionEithers)
39+import Data.Constraint (Dict(..))
40+import Data.Foldable
41+ (toList)
42+import Data.List
43+ (foldl')
44+import Data.Sequence
45+ (fromList)
46+import qualified Data.Text as T
47+import Network.HTTP.Media
48+ (MediaType, matches, parseAccept)
49+import qualified Network.HTTP.Media as Media
50+import qualified Data.Sequence as Seq
51+import Data.SOP.BasicFunctors
52+ (I (I), (:.:) (Comp))
53+import Data.SOP.Constraint
54+ (All)
55+import Data.SOP.NP
56+ (NP (..), cpure_NP)
57+import Data.SOP.NS
58+ (NS (S))
59+import Data.String
60+ (fromString)
61+import Data.Text
62+ (Text, pack)
63+import Data.Proxy
64+ (Proxy (Proxy))
65+import GHC.TypeLits
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
67+import Network.HTTP.Types
68+ (Status)
69+import qualified Network.HTTP.Types as H
70+import Servant.API
71+ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
72+ BuildHeadersTo (..), Capture', CaptureAll, Description,
73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
74+ FromSourceIO (..), Header', Headers (..), HttpVersion,
75+ IsSecure, MimeRender (mimeRender),
76+ MimeUnrender (mimeUnrender), NoContent (NoContent),
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
85+import Servant.API.ContentTypes
86+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
90+import Servant.API.Modifiers
91+ (FoldRequired, RequiredArgument, foldRequiredArgument)
92+import Servant.API.TypeErrors
93+import Servant.API.UVerb
94+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
95+
96+import Servant.Client.Core.Auth
97+import Servant.Client.Core.BasicAuth
98+import Servant.Client.Core.ClientError
99+import Servant.Client.Core.Request
100+import Servant.Client.Core.Response
101+import Servant.Client.Core.RunClient
102+
103+-- * Accessing APIs as a Client
104+
105+-- | 'clientIn' allows you to produce operations to query an API from a client
106+-- within a 'RunClient' monad.
107+--
108+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
109+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
110+-- >
111+-- > myApi :: Proxy MyApi
112+-- > myApi = Proxy
113+-- >
114+-- > clientM :: Proxy ClientM
115+-- > clientM = Proxy
116+-- >
117+-- > getAllBooks :: ClientM [Book]
118+-- > postNewBook :: Book -> ClientM Book
119+-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
120+clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
121+clientIn p pm = clientWithRoute pm p defaultRequest
122+
123+
124+-- | This class lets us define how each API combinator influences the creation
125+-- of an HTTP request.
126+--
127+-- Unless you are writing a new backend for @servant-client-core@ or new
128+-- combinators that you want to support client-generation, you can ignore this
129+-- class.
130+class RunClient m => HasClient m api where
131+ type Client (m :: * -> *) (api :: *) :: *
132+ clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
133+ hoistClientMonad
134+ :: Proxy m
135+ -> Proxy api
136+ -> (forall x. mon x -> mon' x)
137+ -> Client mon api
138+ -> Client mon' api
139+
140+
141+-- | A client querying function for @a ':<|>' b@ will actually hand you
142+-- one function for querying @a@ and another one for querying @b@,
143+-- stitching them together with ':<|>', which really is just like a pair.
144+--
145+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
146+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
147+-- >
148+-- > myApi :: Proxy MyApi
149+-- > myApi = Proxy
150+-- >
151+-- > getAllBooks :: ClientM [Book]
152+-- > postNewBook :: Book -> ClientM Book
153+-- > (getAllBooks :<|> postNewBook) = client myApi
154+instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
155+ type Client m (a :<|> b) = Client m a :<|> Client m b
156+ clientWithRoute pm Proxy req =
157+ clientWithRoute pm (Proxy :: Proxy a) req :<|>
158+ clientWithRoute pm (Proxy :: Proxy b) req
159+
160+ hoistClientMonad pm _ f (ca :<|> cb) =
161+ hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
162+ hoistClientMonad pm (Proxy :: Proxy b) f cb
163+
164+-- | Singleton type representing a client for an empty API.
165+data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
166+
167+-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
168+--
169+-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
170+-- > :<|> "nothing" :> EmptyAPI
171+-- >
172+-- > myApi :: Proxy MyApi
173+-- > myApi = Proxy
174+-- >
175+-- > getAllBooks :: ClientM [Book]
176+-- > (getAllBooks :<|> EmptyClient) = client myApi
177+instance RunClient m => HasClient m EmptyAPI where
178+ type Client m EmptyAPI = EmptyClient
179+ clientWithRoute _pm Proxy _ = EmptyClient
180+ hoistClientMonad _ _ _ EmptyClient = EmptyClient
181+
182+-- | If you use a 'Capture' in one of your endpoints in your API,
183+-- the corresponding querying function will automatically take
184+-- an additional argument of the type specified by your 'Capture'.
185+-- That function will take care of inserting a textual representation
186+-- of this value at the right place in the request path.
187+--
188+-- You can control how values for this type are turned into
189+-- text by specifying a 'ToHttpApiData' instance for your type.
190+--
191+-- Example:
192+--
193+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
194+-- >
195+-- > myApi :: Proxy MyApi
196+-- > myApi = Proxy
197+-- >
198+-- > getBook :: Text -> ClientM Book
199+-- > getBook = client myApi
200+-- > -- then you can just use "getBook" to query that endpoint
201+instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
202+ => HasClient m (Capture' mods capture a :> api) where
203+
204+ type Client m (Capture' mods capture a :> api) =
205+ a -> Client m api
206+
207+ clientWithRoute pm Proxy req val =
208+ clientWithRoute pm (Proxy :: Proxy api)
209+ (appendToPath p req)
210+
211+ where p = toEncodedUrlPiece val
212+
213+ hoistClientMonad pm _ f cl = \a ->
214+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
215+
216+-- | If you use a 'CaptureAll' in one of your endpoints in your API,
217+-- the corresponding querying function will automatically take an
218+-- additional argument of a list of the type specified by your
219+-- 'CaptureAll'. That function will take care of inserting a textual
220+-- representation of this value at the right place in the request
221+-- path.
222+--
223+-- You can control how these values are turned into text by specifying
224+-- a 'ToHttpApiData' instance of your type.
225+--
226+-- Example:
227+--
228+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
229+-- >
230+-- > myApi :: Proxy
231+-- > myApi = Proxy
232+--
233+-- > getSourceFile :: [Text] -> ClientM SourceFile
234+-- > getSourceFile = client myApi
235+-- > -- then you can use "getSourceFile" to query that endpoint
236+instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
237+ => HasClient m (CaptureAll capture a :> sublayout) where
238+
239+ type Client m (CaptureAll capture a :> sublayout) =
240+ [a] -> Client m sublayout
241+
242+ clientWithRoute pm Proxy req vals =
243+ clientWithRoute pm (Proxy :: Proxy sublayout)
244+ (foldl' (flip appendToPath) req ps)
245+
246+ where ps = map toEncodedUrlPiece vals
247+
248+ hoistClientMonad pm _ f cl = \as ->
249+ hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
250+
251+instance {-# OVERLAPPABLE #-}
252+ -- Note [Non-Empty Content Types]
253+ ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
255+ ) => HasClient m (Verb method status cts' a) where
256+ type Client m (Verb method status cts' a) = m a
257+ clientWithRoute _pm Proxy req = do
258+ response <- runRequestAcceptStatus (Just [status]) req
259+ { requestAccept = fromList $ toList accept
260+ , requestMethod = method
261+ }
262+ response `decodedAs` (Proxy :: Proxy ct)
263+ where
264+ accept = contentTypes (Proxy :: Proxy ct)
265+ method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
267+
268+ hoistClientMonad _ _ f ma = f ma
269+
270+instance {-# OVERLAPPING #-}
271+ ( RunClient m, ReflectMethod method, KnownNat status
272+ ) => HasClient m (Verb method status cts NoContent) where
273+ type Client m (Verb method status cts NoContent)
274+ = m NoContent
275+ clientWithRoute _pm Proxy req = do
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
277+ return NoContent
278+ where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
280+
281+ hoistClientMonad _ _ f ma = f ma
282+
283+instance (RunClient m, ReflectMethod method) =>
284+ HasClient m (NoContentVerb method) where
285+ type Client m (NoContentVerb method)
286+ = m NoContent
287+ clientWithRoute _pm Proxy req = do
288+ _response <- runRequest req { requestMethod = method }
289+ return NoContent
290+ where method = reflectMethod (Proxy :: Proxy method)
291+
292+ hoistClientMonad _ _ f ma = f ma
293+
294+instance {-# OVERLAPPING #-}
295+ -- Note [Non-Empty Content Types]
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
297+ , ReflectMethod method, cts' ~ (ct ': cts)
298+ ) => HasClient m (Verb method status cts' (Headers ls a)) where
299+ type Client m (Verb method status cts' (Headers ls a))
300+ = m (Headers ls a)
301+ clientWithRoute _pm Proxy req = do
302+ response <- runRequestAcceptStatus (Just [status]) req
303+ { requestMethod = method
304+ , requestAccept = fromList $ toList accept
305+ }
306+ val <- response `decodedAs` (Proxy :: Proxy ct)
307+ return $ Headers { getResponse = val
308+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
309+ }
310+ where
311+ method = reflectMethod (Proxy :: Proxy method)
312+ accept = contentTypes (Proxy :: Proxy ct)
313+ status = statusFromNat (Proxy :: Proxy status)
314+
315+ hoistClientMonad _ _ f ma = f ma
316+
317+instance {-# OVERLAPPING #-}
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
319+ ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320+ type Client m (Verb method status cts (Headers ls NoContent))
321+ = m (Headers ls NoContent)
322+ clientWithRoute _pm Proxy req = do
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
324+ return $ Headers { getResponse = NoContent
325+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
326+ }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
330+
331+ hoistClientMonad _ _ f ma = f ma
332+
333+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
334+ deriving (Eq, Show)
335+
336+class UnrenderResponse (cts :: [*]) (a :: *) where
337+ unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
338+ -> [Either (MediaType, String) a]
339+
340+instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
341+ unrenderResponse _ body = map parse . allMimeUnrender
342+ where parse (mediaType, parser) = left ((,) mediaType) (parser body)
343+
344+instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
345+ => UnrenderResponse cts (Headers h a) where
346+ unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
347+ where
348+ setHeaders :: a -> Headers h a
349+ setHeaders x = Headers x (buildHeadersTo (toList hs))
350+
351+instance {-# OVERLAPPING #-} UnrenderResponse cts a
352+ => UnrenderResponse cts (WithStatus n a) where
353+ unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
354+
355+instance {-# OVERLAPPING #-}
356+ ( RunClient m,
357+ contentTypes ~ (contentType ': otherContentTypes),
358+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
359+ -- allow this in instance types as of 8.8.3.)
360+ as ~ (a ': as'),
361+ AllMime contentTypes,
362+ ReflectMethod method,
363+ All (UnrenderResponse contentTypes) as,
364+ All HasStatus as, HasStatuses as',
365+ Unique (Statuses as)
366+ ) =>
367+ HasClient m (UVerb method contentTypes as)
368+ where
369+ type Client m (UVerb method contentTypes as) = m (Union as)
370+
371+ clientWithRoute _ _ request = do
372+ let accept = Seq.fromList . allMime $ Proxy @contentTypes
373+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,
374+ -- we might not own the server implementation, and the server may choose to support
375+ -- only part of the api.
376+
377+ method = reflectMethod $ Proxy @method
378+ acceptStatus = statuses (Proxy @as)
379+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
380+ responseContentType <- checkContentTypeHeader response
381+ unless (any (matches responseContentType) accept) $ do
382+ throwClientError $ UnsupportedContentType responseContentType response
383+
384+ let status = responseStatusCode response
385+ body = responseBody response
386+ headers = responseHeaders response
387+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
388+ case res of
389+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
390+ Right x -> return x
391+ where
392+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
393+ -- failures it encountered along the way
394+ -- TODO; better name, rewrite haddocs.
395+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
396+ tryParsers _ Nil = Left [ClientNoMatchingStatus]
397+ tryParsers status (Comp x :* xs)
398+ | status == statusOf (Comp x) =
399+ case partitionEithers x of
400+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
401+ (_, (res : _)) -> Right . inject . I $ res
402+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
403+ (ClientStatusMismatch :) +++ S $ tryParsers status xs
404+
405+ -- | Given a list of types, parses the given response body as each type
406+ mimeUnrenders ::
407+ forall cts xs.
408+ All (UnrenderResponse cts) xs =>
409+ Proxy cts ->
410+ Seq.Seq H.Header ->
411+ BL.ByteString ->
412+ NP ([] :.: Either (MediaType, String)) xs
413+ mimeUnrenders ctp headers body = cpure_NP
414+ (Proxy @(UnrenderResponse cts))
415+ (Comp . unrenderResponse headers body $ ctp)
416+
417+ hoistClientMonad _ _ nt s = nt s
418+
419+instance {-# OVERLAPPABLE #-}
420+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
421+ FramingUnrender framing, FromSourceIO chunk a
422+ ) => HasClient m (Stream method status framing ct a) where
423+
424+ type Client m (Stream method status framing ct a) = m a
425+
426+ hoistClientMonad _ _ f ma = f ma
427+
428+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
429+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
430+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
431+ return $ fromSourceIO $ framingUnrender' $ responseBody gres
432+ where
433+ req' = req
434+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
435+ , requestMethod = reflectMethod (Proxy :: Proxy method)
436+ }
437+
438+instance {-# OVERLAPPING #-}
439+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
440+ FramingUnrender framing, FromSourceIO chunk a,
441+ BuildHeadersTo hs
442+ ) => HasClient m (Stream method status framing ct (Headers hs a)) where
443+
444+ type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
445+
446+ hoistClientMonad _ _ f ma = f ma
447+
448+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
449+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
450+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
451+ val = fromSourceIO $ framingUnrender' $ responseBody gres
452+ return $ Headers
453+ { getResponse = val
454+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
455+ }
456+
457+ where
458+ req' = req
459+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
460+ , requestMethod = reflectMethod (Proxy :: Proxy method)
461+ }
462+
463+-- | If you use a 'Header' in one of your endpoints in your API,
464+-- the corresponding querying function will automatically take
465+-- an additional argument of the type specified by your 'Header',
466+-- wrapped in Maybe.
467+--
468+-- That function will take care of encoding this argument as Text
469+-- in the request headers.
470+--
471+-- All you need is for your type to have a 'ToHttpApiData' instance.
472+--
473+-- Example:
474+--
475+-- > newtype Referer = Referer { referrer :: Text }
476+-- > deriving (Eq, Show, Generic, ToHttpApiData)
477+-- >
478+-- > -- GET /view-my-referer
479+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
480+-- >
481+-- > myApi :: Proxy MyApi
482+-- > myApi = Proxy
483+-- >
484+-- > viewReferer :: Maybe Referer -> ClientM Book
485+-- > viewReferer = client myApi
486+-- > -- then you can just use "viewRefer" to query that endpoint
487+-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
488+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
489+ => HasClient m (Header' mods sym a :> api) where
490+
491+ type Client m (Header' mods sym a :> api) =
492+ RequiredArgument mods a -> Client m api
493+
494+ clientWithRoute pm Proxy req mval =
495+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
496+ (Proxy :: Proxy mods) add (maybe req add) mval
497+ where
498+ hname = fromString $ symbolVal (Proxy :: Proxy sym)
499+
500+ add :: a -> Request
501+ add value = addHeader hname value req
502+
503+ hoistClientMonad pm _ f cl = \arg ->
504+ hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
505+
506+-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
507+-- functions.
508+instance HasClient m api
509+ => HasClient m (HttpVersion :> api) where
510+
511+ type Client m (HttpVersion :> api) =
512+ Client m api
513+
514+ clientWithRoute pm Proxy =
515+ clientWithRoute pm (Proxy :: Proxy api)
516+
517+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
518+
519+-- | Ignore @'Summary'@ in client functions.
520+instance HasClient m api => HasClient m (Summary desc :> api) where
521+ type Client m (Summary desc :> api) = Client m api
522+
523+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
524+
525+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
526+
527+-- | Ignore @'Description'@ in client functions.
528+instance HasClient m api => HasClient m (Description desc :> api) where
529+ type Client m (Description desc :> api) = Client m api
530+
531+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
532+
533+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
534+
535+-- | If you use a 'QueryParam' in one of your endpoints in your API,
536+-- the corresponding querying function will automatically take
537+-- an additional argument of the type specified by your 'QueryParam',
538+-- enclosed in Maybe.
539+--
540+-- If you give Nothing, nothing will be added to the query string.
541+--
542+-- If you give a non-'Nothing' value, this function will take care
543+-- of inserting a textual representation of this value in the query string.
544+--
545+-- You can control how values for your type are turned into
546+-- text by specifying a 'ToHttpApiData' instance for your type.
547+--
548+-- Example:
549+--
550+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
551+-- >
552+-- > myApi :: Proxy MyApi
553+-- > myApi = Proxy
554+-- >
555+-- > getBooksBy :: Maybe Text -> ClientM [Book]
556+-- > getBooksBy = client myApi
557+-- > -- then you can just use "getBooksBy" to query that endpoint.
558+-- > -- 'getBooksBy Nothing' for all books
559+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
560+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
561+ => HasClient m (QueryParam' mods sym a :> api) where
562+
563+ type Client m (QueryParam' mods sym a :> api) =
564+ RequiredArgument mods a -> Client m api
565+
566+ -- if mparam = Nothing, we don't add it to the query string
567+ clientWithRoute pm Proxy req mparam =
568+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
569+ (Proxy :: Proxy mods) add (maybe req add) mparam
570+ where
571+ add :: a -> Request
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
573+
574+ pname :: Text
575+ pname = pack $ symbolVal (Proxy :: Proxy sym)
576+
577+ hoistClientMonad pm _ f cl = \arg ->
578+ hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
579+
580+-- | If you use a 'QueryParams' in one of your endpoints in your API,
581+-- the corresponding querying function will automatically take
582+-- an additional argument, a list of values of the type specified
583+-- by your 'QueryParams'.
584+--
585+-- If you give an empty list, nothing will be added to the query string.
586+--
587+-- Otherwise, this function will take care
588+-- of inserting a textual representation of your values in the query string,
589+-- under the same query string parameter name.
590+--
591+-- You can control how values for your type are turned into
592+-- text by specifying a 'ToHttpApiData' instance for your type.
593+--
594+-- Example:
595+--
596+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
597+-- >
598+-- > myApi :: Proxy MyApi
599+-- > myApi = Proxy
600+-- >
601+-- > getBooksBy :: [Text] -> ClientM [Book]
602+-- > getBooksBy = client myApi
603+-- > -- then you can just use "getBooksBy" to query that endpoint.
604+-- > -- 'getBooksBy []' for all books
605+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
606+-- > -- to get all books by Asimov and Heinlein
607+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
608+ => HasClient m (QueryParams sym a :> api) where
609+
610+ type Client m (QueryParams sym a :> api) =
611+ [a] -> Client m api
612+
613+ clientWithRoute pm Proxy req paramlist =
614+ clientWithRoute pm (Proxy :: Proxy api)
615+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
616+ req
617+ paramlist'
618+ )
619+
620+ where pname = pack $ symbolVal (Proxy :: Proxy sym)
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
622+
623+ hoistClientMonad pm _ f cl = \as ->
624+ hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
625+
626+-- | If you use a 'QueryFlag' in one of your endpoints in your API,
627+-- the corresponding querying function will automatically take
628+-- an additional 'Bool' argument.
629+--
630+-- If you give 'False', nothing will be added to the query string.
631+--
632+-- Otherwise, this function will insert a value-less query string
633+-- parameter under the name associated to your 'QueryFlag'.
634+--
635+-- Example:
636+--
637+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
638+-- >
639+-- > myApi :: Proxy MyApi
640+-- > myApi = Proxy
641+-- >
642+-- > getBooks :: Bool -> ClientM [Book]
643+-- > getBooks = client myApi
644+-- > -- then you can just use "getBooks" to query that endpoint.
645+-- > -- 'getBooksBy False' for all books
646+-- > -- 'getBooksBy True' to only get _already published_ books
647+instance (KnownSymbol sym, HasClient m api)
648+ => HasClient m (QueryFlag sym :> api) where
649+
650+ type Client m (QueryFlag sym :> api) =
651+ Bool -> Client m api
652+
653+ clientWithRoute pm Proxy req flag =
654+ clientWithRoute pm (Proxy :: Proxy api)
655+ (if flag
656+ then appendToQueryString paramname Nothing req
657+ else req
658+ )
659+
660+ where paramname = pack $ symbolVal (Proxy :: Proxy sym)
661+
662+ hoistClientMonad pm _ f cl = \b ->
663+ hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
664+
665+-- | Pick a 'Method' and specify where the server you want to query is. You get
666+-- back the full `Response`.
667+instance RunClient m => HasClient m Raw where
668+ type Client m Raw
669+ = H.Method -> m Response
670+
671+ clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
672+ clientWithRoute _pm Proxy req httpMethod = do
673+ runRequest req { requestMethod = httpMethod }
674+
675+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)
676+
677+-- | If you use a 'ReqBody' in one of your endpoints in your API,
678+-- the corresponding querying function will automatically take
679+-- an additional argument of the type specified by your 'ReqBody'.
680+-- That function will take care of encoding this argument as JSON and
681+-- of using it as the request body.
682+--
683+-- All you need is for your type to have a 'ToJSON' instance.
684+--
685+-- Example:
686+--
687+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
688+-- >
689+-- > myApi :: Proxy MyApi
690+-- > myApi = Proxy
691+-- >
692+-- > addBook :: Book -> ClientM Book
693+-- > addBook = client myApi
694+-- > -- then you can just use "addBook" to query that endpoint
695+instance (MimeRender ct a, HasClient m api)
696+ => HasClient m (ReqBody' mods (ct ': cts) a :> api) where
697+
698+ type Client m (ReqBody' mods (ct ': cts) a :> api) =
699+ a -> Client m api
700+
701+ clientWithRoute pm Proxy req body =
702+ clientWithRoute pm (Proxy :: Proxy api)
703+ (let ctProxy = Proxy :: Proxy ct
704+ in setRequestBodyLBS (mimeRender ctProxy body)
705+ -- We use first contentType from the Accept list
706+ (contentType ctProxy)
707+ req
708+ )
709+
710+ hoistClientMonad pm _ f cl = \a ->
711+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
712+
713+instance
714+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
715+ ) => HasClient m (StreamBody' mods framing ctype a :> api)
716+ where
717+
718+ type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
719+
720+ hoistClientMonad pm _ f cl = \a ->
721+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
722+
723+ clientWithRoute pm Proxy req body
724+ = clientWithRoute pm (Proxy :: Proxy api)
725+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
726+ where
727+ ctypeP = Proxy :: Proxy ctype
728+ framingP = Proxy :: Proxy framing
729+
730+ sourceIO = framingRender
731+ framingP
732+ (mimeRender ctypeP :: chunk -> BL.ByteString)
733+ (toSourceIO body)
734+
735+-- | Make the querying function append @path@ to the request path.
736+instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
737+ type Client m (path :> api) = Client m api
738+
739+ clientWithRoute pm Proxy req =
740+ clientWithRoute pm (Proxy :: Proxy api)
741+ (appendToPath p req)
742+
743+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
744+
745+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
746+
747+instance HasClient m api => HasClient m (Vault :> api) where
748+ type Client m (Vault :> api) = Client m api
749+
750+ clientWithRoute pm Proxy req =
751+ clientWithRoute pm (Proxy :: Proxy api) req
752+
753+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
754+
755+instance HasClient m api => HasClient m (RemoteHost :> api) where
756+ type Client m (RemoteHost :> api) = Client m api
757+
758+ clientWithRoute pm Proxy req =
759+ clientWithRoute pm (Proxy :: Proxy api) req
760+
761+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
762+
763+instance HasClient m api => HasClient m (IsSecure :> api) where
764+ type Client m (IsSecure :> api) = Client m api
765+
766+ clientWithRoute pm Proxy req =
767+ clientWithRoute pm (Proxy :: Proxy api) req
768+
769+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
770+
771+instance HasClient m subapi =>
772+ HasClient m (WithNamedContext name context subapi) where
773+
774+ type Client m (WithNamedContext name context subapi) = Client m subapi
775+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
776+
777+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
778+
779+instance ( HasClient m api
780+ ) => HasClient m (AuthProtect tag :> api) where
781+ type Client m (AuthProtect tag :> api)
782+ = AuthenticatedRequest (AuthProtect tag) -> Client m api
783+
784+ clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
785+ clientWithRoute pm (Proxy :: Proxy api) (func val req)
786+
787+ hoistClientMonad pm _ f cl = \authreq ->
788+ hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
789+
790+-- | Ignore @'Fragment'@ in client functions.
791+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
792+--
793+-- Example:
794+--
795+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
796+-- >
797+-- > myApi :: Proxy MyApi
798+-- > myApi = Proxy
799+-- >
800+-- > getBooks :: ClientM [Book]
801+-- > getBooks = client myApi
802+-- > -- then you can just use "getBooksBy" to query that endpoint.
803+-- > -- 'getBooks' for all books.
804+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
805+ ) => HasClient m (Fragment a :> api) where
806+
807+ type Client m (Fragment a :> api) = Client m api
808+
809+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
810+
811+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
812+
813+-- * Basic Authentication
814+
815+instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
816+ type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
817+
818+ clientWithRoute pm Proxy req val =
819+ clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
820+
821+ hoistClientMonad pm _ f cl = \bauth ->
822+ hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
823+
824+-- | A type that specifies that an API record contains a client implementation.
825+data AsClientT (m :: * -> *)
826+instance GenericMode (AsClientT m) where
827+ type AsClientT m :- api = Client m api
828+
829+
830+type GClientConstraints api m =
831+ ( GenericServant api (AsClientT m)
832+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
833+ )
834+
835+class GClient (api :: * -> *) m where
836+ gClientProof :: Dict (GClientConstraints api m)
837+
838+instance GClientConstraints api m => GClient api m where
839+ gClientProof = Dict
840+
841+instance
842+ ( forall n. GClient api n
843+ , HasClient m (ToServantApi api)
844+ , RunClient m
845+ )
846+ => HasClient m (NamedRoutes api) where
847+ type Client m (NamedRoutes api) = api (AsClientT m)
848+
849+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
850+ clientWithRoute pm _ request =
851+ case gClientProof @api @m of
852+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
853+
854+ hoistClientMonad
855+ :: forall ma mb.
856+ Proxy m
857+ -> Proxy (NamedRoutes api)
858+ -> (forall x. ma x -> mb x)
859+ -> Client ma (NamedRoutes api)
860+ -> Client mb (NamedRoutes api)
861+ hoistClientMonad _ _ nat clientA =
862+ case (gClientProof @api @ma, gClientProof @api @mb) of
863+ (Dict, Dict) ->
864+ fromServant @api @(AsClientT mb) $
865+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
866+ toServant @api @(AsClientT ma) clientA
867+
868+infixl 1 //
869+infixl 2 /:
870+
871+-- | Helper to make code using records of clients more readable.
872+--
873+-- Can be mixed with (/:) for supplying arguments.
874+--
875+-- Example:
876+--
877+-- @
878+-- type Api = NamedRoutes RootApi
879+--
880+-- data RootApi mode = RootApi
881+-- { subApi :: mode :- NamedRoutes SubApi
882+-- , …
883+-- } deriving Generic
884+--
885+-- data SubApi mode = SubApi
886+-- { endpoint :: mode :- Get '[JSON] Person
887+-- , …
888+-- } deriving Generic
889+--
890+-- api :: Proxy API
891+-- api = Proxy
892+--
893+-- rootClient :: RootApi (AsClientT ClientM)
894+-- rootClient = client api
895+--
896+-- endpointClient :: ClientM Person
897+-- endpointClient = client // subApi // endpoint
898+-- @
899+(//) :: a -> (a -> b) -> b
900+x // f = f x
901+
902+-- | Convenience function for supplying arguments to client functions when
903+-- working with records of clients.
904+--
905+-- Intended to be used in conjunction with '(//)'.
906+--
907+-- Example:
908+--
909+-- @
910+-- type Api = NamedRoutes RootApi
911+--
912+-- data RootApi mode = RootApi
913+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
914+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
915+-- , …
916+-- } deriving Generic
917+--
918+-- data SubApi mode = SubApi
919+-- { endpoint :: mode :- Get '[JSON] Person
920+-- , …
921+-- } deriving Generic
922+--
923+-- api :: Proxy API
924+-- api = Proxy
925+--
926+-- rootClient :: RootApi (AsClientT ClientM)
927+-- rootClient = client api
928+--
929+-- hello :: String -> ClientM String
930+-- hello name = rootClient // hello /: name
931+--
932+-- endpointClient :: ClientM Person
933+-- endpointClient = client // subApi /: "foobar123" // endpoint
934+-- @
935+(/:) :: (a -> b -> c) -> b -> a -> c
936+(/:) = flip
937+
938+
939+{- Note [Non-Empty Content Types]
940+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
941+Rather than have
942+
943+ instance (..., cts' ~ (ct ': cts)) => ... cts' ...
944+
945+It may seem to make more sense to have:
946+
947+ instance (...) => ... (ct ': cts) ...
948+
949+But this means that if another instance exists that does *not* require
950+non-empty lists, but is otherwise more specific, no instance will be overall
951+more specific. This in turn generally means adding yet another instance (one
952+for empty and one for non-empty lists).
953+-}
954+
955+-------------------------------------------------------------------------------
956+-- helpers
957+-------------------------------------------------------------------------------
958+
959+checkContentTypeHeader :: RunClient m => Response -> m MediaType
960+checkContentTypeHeader response =
961+ case lookup "Content-Type" $ toList $ responseHeaders response of
962+ Nothing -> return $ "application" Media.// "octet-stream"
963+ Just t -> case parseAccept t of
964+ Nothing -> throwClientError $ InvalidContentTypeHeader response
965+ Just t' -> return t'
966+
967+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
968+ => Response -> Proxy ct -> m a
969+decodedAs response ct = do
970+ responseContentType <- checkContentTypeHeader response
971+ unless (any (matches responseContentType) accept) $
972+ throwClientError $ UnsupportedContentType responseContentType response
973+ case mimeUnrender ct $ responseBody response of
974+ Left err -> throwClientError $ DecodeFailure (T.pack err) response
975+ Right val -> return val
976+ where
977+ accept = toList $ contentTypes ct
978+
979+-------------------------------------------------------------------------------
980+-- Custom type errors
981+-------------------------------------------------------------------------------
982+
983+-- Erroring instance for HasClient' when a combinator is not fully applied
984+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
985+ where
986+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
987+ clientWithRoute _ _ _ = error "unreachable"
988+ hoistClientMonad _ _ _ _ = error "unreachable"
989+
990+-- Erroring instances for 'HasClient' for unknown API combinators
991+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
992+
993+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api