@@ -1,43 +1,95 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE InstanceSigs #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
18+#if MIN_VERSION_base(4,9,0)
19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
13−#include "overlapping-compat.h"
22+-- #include "overlapping-compat.h"
14-- | This module provides 'client' which can automatically generate
23-- | This module provides 'client' which can automatically generate
15-- querying functions for each endpoint just from the type representing your
24-- querying functions for each endpoint just from the type representing your
17module Servant.Reflex
26module Servant.Reflex
29+ , clientWithOptsAndResultHandler
31+ , clientWithRouteAndResultHandler
32+ , BuildHeaderKeysTo(..)
19− , HasClient(..)
34+ , HasClient
20− , ServantError(..)
35+ , Client
36+ , module Servant.Common.Req
21 , module Servant.Common.BaseUrl
37 , module Servant.Common.BaseUrl
24−#if !MIN_VERSION_base(4,8,0)
40+------------------------------------------------------------------------------
25−import Control.Applicative ((<$>))
41+import Control.Applicative
26−#endif
42+import qualified Data.CaseInsensitive as CI
27−import Control.Monad.Trans.Except
43+import Data.Functor.Identity
44+import qualified Data.Map as Map
28−import Data.ByteString.Lazy (ByteString)
45+import Data.Monoid ((<>))
29−import Data.List
46+import Data.Proxy (Proxy (..))
30−import Data.Proxy
47+import qualified Data.Set as Set
31−import Data.String.Conversions
48+import Data.Text (Text)
49+import qualified Data.Text as T
32−import Data.Text (unpack)
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
33−import GHC.TypeLits
52+import GHC.TypeLits (KnownSymbol, symbolVal)
34−import Network.HTTP.Media
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
35−import qualified Network.HTTP.Types as H
54+ BasicAuthData, BuildHeadersTo (..),
36−import qualified Network.HTTP.Types.Header as HTTP
55+ Capture, Header, Headers (..),
37−import Servant.API
56+ HttpVersion, IsSecure,
57+ MimeRender (..), MimeUnrender,
58+ NoContent, QueryFlag, QueryParam,
59+ QueryParams, Raw, ReflectMethod (..),
61+ ToHttpApiData (..), Vault, Verb,
38−import Servant.Common.BaseUrl
63+import Servant.API.Description (Summary)
39−import Servant.Common.Req
64+import qualified Servant.Auth as Auth
40−import Reflex.Dom.Xhr
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
67+ XhrRequest (..), XhrResponse (..),
68+ XhrResponseHeaders (..),
69+ attachPromptlyDynWith, constDyn, ffor,
71+ performRequestsAsync)
72+------------------------------------------------------------------------------
73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
75+ SupportsServantReflex)
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
78+ Req, ReqResult(..), QParam(..),
79+ QueryPart(..), addHeader, authData,
80+ defReq, evalResponse, prependToPathParts,
83+ -- performRequestNoBody,
84+ performRequestsNoBody,
85+ performSomeRequestsAsync,
86+ qParamToQueryPart, reqBody,
87+ reqSuccess, reqFailure,
88+ reqMethod, respHeaders,
91+ qParams, withCredentials)
42-- * Accessing APIs as a Client
94-- * Accessing APIs as a Client
@@ -49,152 +101,247 @@ import Reflex.Dom.Xhr
49-- > myApi :: Proxy MyApi
101-- > myApi :: Proxy MyApi
50-- > myApi = Proxy
102-- > myApi = Proxy
52−-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))
104+-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
53−-- > postNewBook :: Behavior t (Maybe Book) -> Event t ()
105+-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
54−-- -> m (Event t (Either XhrError (Book,Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
55-- > (getAllBooks :<|> postNewBook) = client myApi host
107-- > (getAllBooks :<|> postNewBook) = client myApi host
56-- > where host = constDyn $ BaseUrl Http "localhost" 8080
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
110+ :: (HasClient t m layout tag)
114+ -> Dynamic t BaseUrl
115+ -> Client t m layout tag
116+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
119+ :: (HasClient t m layout tag)
57−client :: (HasClient layout) => Proxy layout -> Dynamic t BaseUrl -> Client layout
123+ -> Dynamic t BaseUrl
125+ -> Client t m layout tag
58−client p baseurl = clientWithRoute p defReq baseurl
126+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
128+-- | Like 'clientWithOpts' but allows passing a function which will process the
129+-- result event in some way. This can be used to handle errors in a uniform way
130+-- across call sites.
131+clientWithOptsAndResultHandler
132+ :: (HasClient t m layout tag)
136+ -> Dynamic t BaseUrl
138+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
139+ -> Client t m layout tag
140+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq
60-- | This class lets us define how each API combinator
143-- | This class lets us define how each API combinator
61-- influences the creation of an HTTP request. It's mostly
144-- influences the creation of an HTTP request. It's mostly
62-- an internal class, you can just use 'client'.
145-- an internal class, you can just use 'client'.
63−class HasClient layout where
146+class Monad m => HasClient t m layout (tag :: *) where
64− type Client layout :: *
147+ type Client t m layout tag :: *
65− clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Client layout
148+ clientWithRoute
153+ -> Dynamic t BaseUrl
155+ -> Client t m layout tag
156+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return
158+ clientWithRouteAndResultHandler
163+ -> Dynamic t BaseUrl
165+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
166+ -> Client t m layout tag
169+instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
170+ type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
173+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
174+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
68−instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
69− type Client (a :<|> b) = Client a :<|> Client b
70− clientWithRoute Proxy req baseurl manager =
71− clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|>
72− clientWithRoute (Proxy :: Proxy b) req baseurl manager
74-- Capture. Example:
177-- Capture. Example:
75-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
178-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
77-- > myApi :: Proxy MyApi = Proxy
180-- > myApi :: Proxy MyApi = Proxy
79−-- > getBook :: MonadWidget t m
182+-- > getBook :: SupportsServantReflex t m
80-- => Dynamic t BaseUrl
183-- => Dynamic t BaseUrl
81−-- -> Behavior t (Maybe Text)
184+-- -> Dynamic t (Maybe Text)
82−-- -> Event t ()
185+-- -> Event t l
83−-- -> m (Event t (Either XhrError (Text, Book)))
186+-- -> m (Event t (l, ReqResult Book))
84-- > getBook = client myApi (constDyn host)
187-- > getBook = client myApi (constDyn host)
85−instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
86− => HasClient (Capture capture a :> sublayout) where
189+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)
88− type Client (Capture capture a :> sublayout) =
190+ => HasClient t m (Capture capture a :> sublayout) tag where
89− a -> Client sublayout
91− clientWithRoute Proxy req baseurl manager val =
192+ type Client t m (Capture capture a :> sublayout) tag =
193+ Dynamic t (Either Text a) -> Client t m sublayout tag
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196+ clientWithRouteAndResultHandler
92− clientWithRoute (Proxy :: Proxy sublayout)
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
93− (appendToPath p req)
198+ where p = (fmap . fmap) (toUrlPiece) val
97− where p = unpack (toUrlPiece val)
99-- VERB (Returning content) --
201-- VERB (Returning content) --
100−instance OVERLAPPABLE_
202+instance {-# OVERLAPPABLE #-}
101 -- Note [Non-Empty Content Types]
203 -- Note [Non-Empty Content Types]
102− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
204+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
103− ) => HasClient (Verb method status cts' a) where
205+ ) => HasClient t m (Verb method status cts' a) tag where
104− type Client (Verb method status cts' a) = ExceptT ServantError IO a
206+ type Client t m (Verb method status cts' a) tag =
105− clientWithRoute Proxy req baseurl manager =
207+ Event t tag -> m (Event t (ReqResult tag a))
106− snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager
208+ -- TODO how to access input types here?
209+ -- ExceptT ServantError IO a
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
107− where method = reflectMethod (Proxy :: Proxy method)
212+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
108−
213+ req' = req { reqMethod = method }
109−-- VERB (No content) --
216+-- -- VERB (No content) --
110−instance OVERLAPPING_
217+instance {-# OVERLAPPING #-}
218+ (ReflectMethod method, SupportsServantReflex t m) =>
111− (ReflectMethod method) => HasClient (Verb method status cts NoContent) where
219+ HasClient t m (Verb method status cts NoContent) tag where
112− type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent
220+ type Client t m (Verb method status cts NoContent) tag =
113− clientWithRoute Proxy req baseurl manager =
221+ Event t tag -> m (Event t (ReqResult tag NoContent))
114− performRequestNoBody method req baseurl manager >> return NoContent
222+ -- TODO: how to access input types here?
223+ -- ExceptT ServantError IO NoContent
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
115− where method = reflectMethod (Proxy :: Proxy method)
226+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
229+toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
233+ (Map.toList $ _xhrResponse_headers xhr))
235+ in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
238+class BuildHeaderKeysTo hs where
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
241+instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242+ where buildHeaderKeysTo _ = []
244+instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245+ => BuildHeaderKeysTo ((Header h v) ': xs) where
246+ buildHeaderKeysTo _ =
248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
117-- HEADERS Verb (Content) --
252-- HEADERS Verb (Content) --
253+-- Headers combinator not treated in fully general case,
254+-- in order to deny instances for (Headers ls (Capture "id" Int)),
255+-- a combinator that wouldn't make sense
256+-- TODO Overlapping??
118−instance OVERLAPPING_
257+instance {-# OVERLAPPABLE #-}
119 -- Note [Non-Empty Content Types]
258 -- Note [Non-Empty Content Types]
259+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
120− ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
260+ ReflectMethod method, cts' ~ (ct ': cts),
261+ SupportsServantReflex t m
121− ) => HasClient (Verb method status cts' (Headers ls a)) where
262+ ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
122− type Client (Verb method status cts' (Headers ls a))
263+ type Client t m (Verb method status cts' (Headers ls a)) tag =
123− = ExceptT ServantError IO (Headers ls a)
264+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
124− clientWithRoute Proxy req baseurl manager = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
125− let method = reflectMethod (Proxy :: Proxy method)
266+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
126− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
127− return $ Headers { getResponse = resp
268+ wrap $ toHeaders <$> resp
128− , getHeadersHList = buildHeadersTo hdrs
269+ where req' = req { respHeaders =
270+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
131-- HEADERS Verb (No content) --
274-- HEADERS Verb (No content) --
132−instance OVERLAPPING_
275+instance {-# OVERLAPPABLE #-}
133− ( BuildHeadersTo ls, ReflectMethod method
276+ ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
277+ SupportsServantReflex t m
134− ) => HasClient (Verb method status cts (Headers ls NoContent)) where
278+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
135− type Client (Verb method status cts (Headers ls NoContent))
279+ type Client t m (Verb method status cts (Headers ls NoContent)) tag
136− = ExceptT ServantError IO (Headers ls NoContent)
280+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
137− clientWithRoute Proxy req baseurl manager = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
138− let method = reflectMethod (Proxy :: Proxy method)
282+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
139− hdrs <- performRequestNoBody method req baseurl manager
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
140− return $ Headers { getResponse = NoContent
284+ wrap $ toHeaders <$> resp
141− , getHeadersHList = buildHeadersTo hdrs
285+ where req' = req {respHeaders =
286+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
145−-- | If you use a 'Header' in one of your endpoints in your API,
290+
146−-- the corresponding querying function will automatically take
291+-- HEADER
147−-- an additional argument of the type specified by your 'Header',
150−-- That function will take care of encoding this argument as Text
151−-- in the request headers.
153−-- All you need is for your type to have a 'ToHttpApiData' instance.
157-- > newtype Referer = Referer { referrer :: Text }
292-- > newtype Referer = Referer { referrer :: Text }
158-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
293-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
160-- > -- GET /view-my-referer
295-- > -- GET /view-my-referer
161-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
296-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
163−-- > myApi :: Proxy MyApi
166-- > viewReferer :: Maybe Referer -> ExceptT String IO Book
299-- > viewReferer :: Maybe Referer -> ExceptT String IO Book
167-- > viewReferer = client myApi host
300-- > viewReferer = client myApi host
168-- > where host = BaseUrl Http "localhost" 8080
301-- > where host = BaseUrl Http "localhost" 8080
169-- > -- then you can just use "viewRefer" to query that endpoint
302-- > -- then you can just use "viewRefer" to query that endpoint
170-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
303-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
171−instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
304+instance (KnownSymbol sym, ToHttpApiData a,
305+ HasClient t m sublayout tag, SupportsServantReflex t m)
172− => HasClient (Header sym a :> sublayout) where
306+ => HasClient t m (Header sym a :> sublayout) tag where
308+ type Client t m (Header sym a :> sublayout) tag =
309+ Dynamic t (Either Text a) -> Client t m sublayout tag
311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312+ clientWithRouteAndResultHandler
313+ (Proxy :: Proxy sublayout) q t
314+ (Servant.Common.Req.addHeader hname eVal req)
316+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
174− type Client (Header sym a :> sublayout) =
175− Maybe a -> Client sublayout
177− clientWithRoute Proxy req baseurl manager mval =
178− clientWithRoute (Proxy :: Proxy sublayout)
180− (\value -> Servant.Common.Req.addHeader hname value req)
186− where hname = symbolVal (Proxy :: Proxy sym)
188-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
321-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
189-- functions.
322-- functions.
190−instance HasClient sublayout
323+instance HasClient t m sublayout tag
191− => HasClient (HttpVersion :> sublayout) where
324+ => HasClient t m (HttpVersion :> sublayout) tag where
326+ type Client t m (HttpVersion :> sublayout) tag =
327+ Client t m sublayout tag
329+ clientWithRouteAndResultHandler Proxy =
330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
332+-- | Using a 'Summary' combinator in your API doesn't affect the client
334+instance (HasClient t m sublayout tag, KnownSymbol sym)
335+ => HasClient t m (Summary sym :> sublayout) tag where
337+ type Client t m (Summary sym :> sublayout) tag =
338+ Client t m sublayout tag
340+ clientWithRouteAndResultHandler Proxy =
341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
193− type Client (HttpVersion :> sublayout) =
196− clientWithRoute Proxy =
197− clientWithRoute (Proxy :: Proxy sublayout)
199-- | If you use a 'QueryParam' in one of your endpoints in your API,
346-- | If you use a 'QueryParam' in one of your endpoints in your API,
200-- the corresponding querying function will automatically take
347-- the corresponding querying function will automatically take
@@ -222,25 +369,24 @@ instance HasClient sublayout
222-- > -- then you can just use "getBooksBy" to query that endpoint.
369-- > -- then you can just use "getBooksBy" to query that endpoint.
223-- > -- 'getBooksBy Nothing' for all books
370-- > -- 'getBooksBy Nothing' for all books
224-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
371-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
225−instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
372+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
226− => HasClient (QueryParam sym a :> sublayout) where
373+ => HasClient t m (QueryParam sym a :> sublayout) tag where
228− type Client (QueryParam sym a :> sublayout) =
375+ type Client t m (QueryParam sym a :> sublayout) tag =
229− Maybe a -> Client sublayout
376+ Dynamic t (QParam a) -> Client t m sublayout tag
231 -- if mparam = Nothing, we don't add it to the query string
378 -- if mparam = Nothing, we don't add it to the query string
232− clientWithRoute Proxy req baseurl manager mparam =
379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
233− clientWithRoute (Proxy :: Proxy sublayout)
380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
234− (maybe req
381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
235− (flip (appendToQueryString pname) req . Just)
382+
241− where pname = cs pname'
242− pname' = symbolVal (Proxy :: Proxy sym)
383+ where pname = symbolVal (Proxy :: Proxy sym)
243− mparamText = fmap toQueryParam mparam
384+ --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
385+ --paramPair = (T.pack pname, p mparam)
386+ p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
387+ paramPair = (T.pack pname, p mparam)
245-- | If you use a 'QueryParams' in one of your endpoints in your API,
391-- | If you use a 'QueryParams' in one of your endpoints in your API,
246-- the corresponding querying function will automatically take
392-- the corresponding querying function will automatically take
@@ -270,23 +416,21 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
270-- > -- 'getBooksBy []' for all books
416-- > -- 'getBooksBy []' for all books
271-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
417-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
272-- > -- to get all books by Asimov and Heinlein
418-- > -- to get all books by Asimov and Heinlein
273−instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
419+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
274− => HasClient (QueryParams sym a :> sublayout) where
420+ => HasClient t m (QueryParams sym a :> sublayout) tag where
422+ type Client t m (QueryParams sym a :> sublayout) tag =
423+ Dynamic t [a] -> Client t m sublayout tag
276− type Client (QueryParams sym a :> sublayout) =
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
277− [a] -> Client sublayout
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
428+ where req' = req { qParams = (T.pack pname, params') : qParams req }
429+ pname = symbolVal (Proxy :: Proxy sym)
430+ params' = QueryPartParams $ (fmap . fmap) toQueryParam
279− clientWithRoute Proxy req baseurl manager paramlist =
280− clientWithRoute (Proxy :: Proxy sublayout)
281− (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
287− where pname = cs pname'
288− pname' = symbolVal (Proxy :: Proxy sym)
289− paramlist' = map (Just . toQueryParam) paramlist
291-- | If you use a 'QueryFlag' in one of your endpoints in your API,
435-- | If you use a 'QueryFlag' in one of your endpoints in your API,
292-- the corresponding querying function will automatically take
436-- the corresponding querying function will automatically take
@@ -310,31 +454,44 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
310-- > -- then you can just use "getBooks" to query that endpoint.
454-- > -- then you can just use "getBooks" to query that endpoint.
311-- > -- 'getBooksBy False' for all books
455-- > -- 'getBooksBy False' for all books
312-- > -- 'getBooksBy True' to only get _already published_ books
456-- > -- 'getBooksBy True' to only get _already published_ books
313−instance (KnownSymbol sym, HasClient sublayout)
314− => HasClient (QueryFlag sym :> sublayout) where
459+instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
460+ => HasClient t m (QueryFlag sym :> sublayout) tag where
316− type Client (QueryFlag sym :> sublayout) =
462+ type Client t m (QueryFlag sym :> sublayout) tag =
317− Bool -> Client sublayout
463+ Dynamic t Bool -> Client t m sublayout tag
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
468+ where req' = req { qParams = thisPair : qParams req }
469+ thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
470+ pName = symbolVal (Proxy :: Proxy sym)
319− clientWithRoute Proxy req baseurl manager flag =
474+-- | Send a raw 'XhrRequest ()' directly to 'baseurl'
320− clientWithRoute (Proxy :: Proxy sublayout)
475+instance SupportsServantReflex t m => HasClient t m Raw tag where
321− (if flag
476+ type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
322− then appendToQueryString paramname Nothing req
477+ -> Event t tag
323− else req
478+ -> m (Event t (ReqResult tag ()))
327− where paramname = cs $ symbolVal (Proxy :: Proxy sym)
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
482+ let xhrs' = liftA2 (\x path -> case x of
484+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }
485+ ) xhrs (showBaseUrl <$> baseurl)
486+ xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))
487+ badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)
488+ okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
330−-- | Pick a 'Method' and specify where the server you want to query is. You get
490+ resps <- performRequestsAsync okReq
331−-- back the full `Response`.
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
332−instance HasClient Raw where
492+ , evalResponse (const $ Right ()) <$> resps
333− type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
493+ ]
335− clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
336− clientWithRoute Proxy req baseurl manager httpMethod = do
337− performRequest httpMethod req baseurl manager
339-- | If you use a 'ReqBody' in one of your endpoints in your API,
496-- | If you use a 'ReqBody' in one of your endpoints in your API,
340-- the corresponding querying function will automatically take
497-- the corresponding querying function will automatically take
@@ -352,58 +509,76 @@ instance HasClient Raw where
352-- > myApi = Proxy
509-- > myApi = Proxy
354-- > addBook :: Book -> ExceptT String IO Book
511-- > addBook :: Book -> ExceptT String IO Book
355−-- > addBook = client myApi host manager
512+-- > addBook = client myApi host
356-- > where host = BaseUrl Http "localhost" 8080
513-- > where host = BaseUrl Http "localhost" 8080
357-- > -- then you can just use "addBook" to query that endpoint
514-- > -- then you can just use "addBook" to query that endpoint
358−instance (MimeRender ct a, HasClient sublayout)
359− => HasClient (ReqBody (ct ': cts) a :> sublayout) where
516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
361− type Client (ReqBody (ct ': cts) a :> sublayout) =
519+ type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
362− a -> Client sublayout
520+ Dynamic t (Either Text a) -> Client t m sublayout tag
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
524+ where req' = req { reqBody = bodyBytesCT }
525+ ctProxy = Proxy :: Proxy ct
526+ ctString = T.pack $ show $ contentType ctProxy
527+ bodyBytesCT = Just $ (fmap . fmap)
528+ (\b -> (mimeRender ctProxy b, ctString))
364− clientWithRoute Proxy req baseurl manager body =
365− clientWithRoute (Proxy :: Proxy sublayout)
366− (let ctProxy = Proxy :: Proxy ct
367− in setRQBody (mimeRender ctProxy body)
368− (contentType ctProxy)
373-- | Make the querying function append @path@ to the request path.
533-- | Make the querying function append @path@ to the request path.
374−instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
534+instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
375− type Client (path :> sublayout) = Client sublayout
535+ type Client t m (path :> sublayout) tag = Client t m sublayout tag
377− clientWithRoute Proxy req baseurl manager =
537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
378− clientWithRoute (Proxy :: Proxy sublayout)
538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
379− (appendToPath p req)
539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
382 where p = symbolVal (Proxy :: Proxy path)
541 where p = symbolVal (Proxy :: Proxy path)
384−instance HasClient api => HasClient (Vault :> api) where
385− type Client (Vault :> api) = Client api
387− clientWithRoute Proxy req baseurl manager =
544+instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
388− clientWithRoute (Proxy :: Proxy api) req baseurl manager
545+ type Client t m (Vault :> api) tag = Client t m api tag
547+ clientWithRouteAndResultHandler Proxy =
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
551+instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552+ type Client t m (RemoteHost :> api) tag = Client t m api tag
554+ clientWithRouteAndResultHandler Proxy =
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
390−instance HasClient api => HasClient (RemoteHost :> api) where
391− type Client (RemoteHost :> api) = Client api
393− clientWithRoute Proxy req baseurl manager =
394− clientWithRoute (Proxy :: Proxy api) req baseurl manager
396−instance HasClient api => HasClient (IsSecure :> api) where
559+instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
397− type Client (IsSecure :> api) = Client api
560+ type Client t m (IsSecure :> api) tag = Client t m api tag
399− clientWithRoute Proxy req baseurl manager =
562+ clientWithRouteAndResultHandler Proxy =
400− clientWithRoute (Proxy :: Proxy api) req baseurl manager
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
402−instance HasClient subapi =>
403− HasClient (WithNamedConfig name config subapi) where
566+instance (HasClient t m api tag, Reflex t)
567+ => HasClient t m (BasicAuth realm usr :> api) tag where
569+ type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570+ -> Client t m api tag
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
575+ req' = req { authData = Just authdata }
577+-- instance HasClient t m subapi =>
578+-- HasClient t m (WithNamedConfig name config subapi) where
405− type Client (WithNamedConfig name config subapi) = Client subapi
580+-- type Client t m (WithNamedConfig name config subapi) = Client t m subapi
406− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
581+-- clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q
409{- Note [Non-Empty Content Types]
584{- Note [Non-Empty Content Types]
@@ -421,3 +596,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall
421more specific. This in turn generally means adding yet another instance (one
596more specific. This in turn generally means adding yet another instance (one
422for empty and one for non-empty lists).
597for empty and one for non-empty lists).
601+-- SUPPORT FOR servant-auth --
603+-- For JavaScript clients we should be sending/storing JSON web tokens in a
604+-- way that is inaccessible to JavaScript.
606+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM
607+-- app this means the @servant-auth@ client should only verify that the API
608+-- supports Cookie-based authentication but do nothing with the token
611+-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures
612+-- we're not trying to rely on cookies when the API does not use them.
613+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
615+ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
619+type family HasCookieAuth xs :: Constraint where
620+ HasCookieAuth (Auth.Cookie ': xs) = ()
621+ HasCookieAuth (x ': xs) = HasCookieAuth xs
622+ HasCookieAuth '[] = CookieAuthNotEnabled
624+class CookieAuthNotEnabled