@@ -1,16 +1,23 @@
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 #-}
9−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TupleSections #-}
10−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE MultiParamTypeClasses #-}
17+
18+#if MIN_VERSION_base(4,9,0)
19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
15-- #include "overlapping-compat.h"
22-- #include "overlapping-compat.h"
16-- | This module provides 'client' which can automatically generate
23-- | This module provides 'client' which can automatically generate
@@ -18,48 +25,71 @@
19module Servant.Reflex
26module Servant.Reflex
21− , HasClient(..)
28+ , clientWithOpts
29+ , clientWithOptsAndResultHandler
31+ , clientWithRouteAndResultHandler
32+ , BuildHeaderKeysTo(..)
22 , module Servant.Common.Req
36 , module Servant.Common.Req
23 , module Servant.Common.BaseUrl
37 , module Servant.Common.BaseUrl
26−-------------------------------------------------------------------------------
40+------------------------------------------------------------------------------
27import Control.Applicative
41import Control.Applicative
42+import qualified Data.CaseInsensitive as CI
43+import Data.Functor.Identity
44+import qualified Data.Map as Map
28import Data.Monoid ((<>))
45import Data.Monoid ((<>))
29−import qualified Data.Set as Set
30−import qualified Data.Text.Encoding as E
31−import Data.CaseInsensitive (mk)
32import Data.Proxy (Proxy (..))
46import Data.Proxy (Proxy (..))
33−import qualified Data.Map as Map
47+import qualified Data.Set as Set
34import Data.Text (Text)
48import Data.Text (Text)
35import qualified Data.Text as T
49import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
36import GHC.TypeLits (KnownSymbol, symbolVal)
52import GHC.TypeLits (KnownSymbol, symbolVal)
37−import Servant.API ((:<|>)(..),(:>), BasicAuth,
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
38− BasicAuthData, BuildHeadersTo(..),
54+ BasicAuthData, BuildHeadersTo (..),
39− Capture, contentType, Header,
55+ Capture, Header, Headers (..),
40− Headers(..), HttpVersion, IsSecure,
56+ HttpVersion, IsSecure,
41− MimeRender(..), MimeUnrender,
57+ MimeRender (..), MimeUnrender,
42− NoContent, QueryFlag, QueryParam,
58+ NoContent, QueryFlag, QueryParam',
43− QueryParams, Raw, ReflectMethod(..),
59+ QueryParams, Raw, ReflectMethod (..),
44 RemoteHost, ReqBody,
60 RemoteHost, ReqBody,
45− ToHttpApiData(..), Vault, Verb)
61+ ToHttpApiData (..), Vault, Verb,
63+import Servant.API.Description (Summary)
64+import qualified Servant.Auth as Auth
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
67+ XhrRequest (..), XhrResponse (..),
68+ XhrResponseHeaders (..),
69+ attachPromptlyDynWith, constDyn, ffor,
71+ performRequestsAsync)
72+------------------------------------------------------------------------------
46−import Servant.Common.BaseUrl (BaseUrl, baseUrlWidget, showBaseUrl,
73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
47 SupportsServantReflex)
75 SupportsServantReflex)
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
48−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
78+ Req, ReqResult(..), QParam(..),
49 QueryPart(..), addHeader, authData,
79 QueryPart(..), addHeader, authData,
50− defReq, prependToPathParts,
80+ defReq, evalResponse, prependToPathParts,
51− performRequestCT,
81+ -- performRequestCT,
52− performRequestNoBody,
83+ -- performRequestNoBody,
84+ performRequestsNoBody,
85+ performSomeRequestsAsync,
53 qParamToQueryPart, reqBody,
86 qParamToQueryPart, reqBody,
54 reqSuccess, reqFailure,
87 reqSuccess, reqFailure,
55− reqMethod, respHeaders, response,
88+ reqMethod, respHeaders,
56− qParams)
91+ qParams, withCredentials)
57−import Reflex.Dom (Dynamic, Event, Reflex,
92+
59− XhrResponseHeaders(..),
60− XhrResponse(..), ffor, fmapMaybe,
61− leftmost, performRequestAsync,
64-- * Accessing APIs as a Client
94-- * Accessing APIs as a Client
@@ -71,28 +101,78 @@ import Reflex.Dom (Dynamic, Event, Reflex,
71-- > myApi :: Proxy MyApi
101-- > myApi :: Proxy MyApi
72-- > myApi = Proxy
102-- > myApi = Proxy
74−-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))
104+-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
75−-- > postNewBook :: Dynamic t (Maybe Book) -> Event t ()
105+-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
76−-- -> m (Event t (Either XhrError (Book,Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
77-- > (getAllBooks :<|> postNewBook) = client myApi host
107-- > (getAllBooks :<|> postNewBook) = client myApi host
78-- > 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
79−client :: (HasClient t m layout)
119+ :: (HasClient t m layout tag)
80− => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout
123+ -> Dynamic t BaseUrl
125+ -> Client t m layout tag
81−client p q baseurl = clientWithRoute p q 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
83-- | This class lets us define how each API combinator
143-- | This class lets us define how each API combinator
84-- influences the creation of an HTTP request. It's mostly
144-- influences the creation of an HTTP request. It's mostly
85-- an internal class, you can just use 'client'.
145-- an internal class, you can just use 'client'.
86−class HasClient t m layout where
146+class Monad m => HasClient t m layout (tag :: *) where
87− type Client t m layout :: *
147+ type Client t m layout tag :: *
88− clientWithRoute :: Proxy layout -> Proxy m -> Req t -> Dynamic t BaseUrl -> Client t m 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
91−instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
92− type Client t m (a :<|> b) = Client t m a :<|> Client t m b
93− clientWithRoute Proxy q req baseurl =
94− clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>
95− clientWithRoute (Proxy :: Proxy b) q req baseurl
97-- Capture. Example:
177-- Capture. Example:
98-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
178-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
@@ -102,67 +182,72 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
102-- > getBook :: SupportsServantReflex t m
182-- > getBook :: SupportsServantReflex t m
103-- => Dynamic t BaseUrl
183-- => Dynamic t BaseUrl
104-- -> Dynamic t (Maybe Text)
184-- -> Dynamic t (Maybe Text)
105−-- -> Event t ()
185+-- -> Event t l
106−-- -> m (Event t (Either XhrError (Text, Book)))
186+-- -> m (Event t (l, ReqResult Book))
107-- > getBook = client myApi (constDyn host)
187-- > getBook = client myApi (constDyn host)
108−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)
109− => HasClient t m (Capture capture a :> sublayout) where
189+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)
111− type Client t m (Capture capture a :> sublayout) =
190+ => HasClient t m (Capture capture a :> sublayout) tag where
112− Dynamic t (Either Text a) -> Client t m sublayout
114− clientWithRoute Proxy q req baseurl val =
192+ type Client t m (Capture capture a :> sublayout) tag =
115− clientWithRoute (Proxy :: Proxy sublayout)
193+ Dynamic t (Either Text a) -> Client t m sublayout tag
117− (prependToPathParts p req)
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196+ clientWithRouteAndResultHandler
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
120 where p = (fmap . fmap) (toUrlPiece) val
198 where p = (fmap . fmap) (toUrlPiece) val
122-- VERB (Returning content) --
201-- VERB (Returning content) --
123instance {-# OVERLAPPABLE #-}
202instance {-# OVERLAPPABLE #-}
124 -- Note [Non-Empty Content Types]
203 -- Note [Non-Empty Content Types]
125 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
204 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
126− ) => HasClient t m (Verb method status cts' a) where
205+ ) => HasClient t m (Verb method status cts' a) tag where
127− type Client t m (Verb method status cts' a) =
206+ type Client t m (Verb method status cts' a) tag =
128− Event t () -> m (Event t (ReqResult a))
207+ Event t tag -> m (Event t (ReqResult tag a))
129 -- TODO how to access input types here?
208 -- TODO how to access input types here?
130 -- ExceptT ServantError IO a
209 -- ExceptT ServantError IO a
131− clientWithRoute Proxy _ req baseurl =
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
132− performRequestCT (Proxy :: Proxy ct) method req' baseurl
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
133 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
134 req' = req { reqMethod = method }
213 req' = req { reqMethod = method }
136-- -- VERB (No content) --
216-- -- VERB (No content) --
137instance {-# OVERLAPPING #-}
217instance {-# OVERLAPPING #-}
138 (ReflectMethod method, SupportsServantReflex t m) =>
218 (ReflectMethod method, SupportsServantReflex t m) =>
139− HasClient t m (Verb method status cts NoContent) where
219+ HasClient t m (Verb method status cts NoContent) tag where
140− type Client t m (Verb method status cts NoContent) =
220+ type Client t m (Verb method status cts NoContent) tag =
141− Event t () -> m (Event t (ReqResult NoContent))
221+ Event t tag -> m (Event t (ReqResult tag NoContent))
142 -- TODO: how to access input types here?
222 -- TODO: how to access input types here?
143 -- ExceptT ServantError IO NoContent
223 -- ExceptT ServantError IO NoContent
144− clientWithRoute Proxy _ req baseurl =
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
145− performRequestNoBody method req baseurl
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
146 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
148−toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
229+toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
149toHeaders r =
230toHeaders r =
150− let toBS = E.encodeUtf8
151− hdrs = maybe []
231+ let hdrs = maybe []
152− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
153 (Map.toList $ _xhrResponse_headers xhr))
233 (Map.toList $ _xhrResponse_headers xhr))
154 (response r)
234 (response r)
155 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
157class BuildHeaderKeysTo hs where
238class BuildHeaderKeysTo hs where
158− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
160instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
161 where buildHeaderKeysTo _ = []
242 where buildHeaderKeysTo _ = []
163instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
164− => BuildHeaderKeysTo '[(Header h v) ': xs] where
245+ => BuildHeaderKeysTo ((Header h v) ': xs) where
246+ buildHeaderKeysTo _ =
248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
165− buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
167-- HEADERS Verb (Content) --
252-- HEADERS Verb (Content) --
168-- Headers combinator not treated in fully general case,
253-- Headers combinator not treated in fully general case,
@@ -174,33 +259,35 @@ instance {-# OVERLAPPABLE #-}
174 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
259 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
175 ReflectMethod method, cts' ~ (ct ': cts),
260 ReflectMethod method, cts' ~ (ct ': cts),
176 SupportsServantReflex t m
261 SupportsServantReflex t m
177− ) => HasClient t m (Verb method status cts' (Headers ls a)) where
262+ ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
178− type Client t m (Verb method status cts' (Headers ls a)) =
263+ type Client t m (Verb method status cts' (Headers ls a)) tag =
179− Event t () -> m (Event t (ReqResult (Headers ls a)))
264+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
180− clientWithRoute Proxy _ req baseurl = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
181 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
182− resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
183− return $ (fmap . fmap) toHeaders resp
268+ wrap $ toHeaders <$> resp
184 where req' = req { respHeaders =
269 where req' = req { respHeaders =
185 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
188-- HEADERS Verb (No content) --
274-- HEADERS Verb (No content) --
189instance {-# OVERLAPPABLE #-}
275instance {-# OVERLAPPABLE #-}
190 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
276 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
191 SupportsServantReflex t m
277 SupportsServantReflex t m
192− ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
278+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
193− type Client t m (Verb method status cts (Headers ls NoContent))
279+ type Client t m (Verb method status cts (Headers ls NoContent)) tag
194− = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))
280+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
195− clientWithRoute Proxy _ req baseurl = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
196 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
197− resp <- performRequestNoBody method req' baseurl
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
198− return $ (fmap . fmap) toHeaders resp
284+ wrap $ toHeaders <$> resp
199 where req' = req {respHeaders =
285 where req' = req {respHeaders =
200 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
205-- > newtype Referer = Referer { referrer :: Text }
292-- > newtype Referer = Referer { referrer :: Text }
206-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
293-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
@@ -215,29 +302,45 @@ instance {-# OVERLAPPABLE #-}
215-- > -- then you can just use "viewRefer" to query that endpoint
302-- > -- then you can just use "viewRefer" to query that endpoint
216-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
303-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
217instance (KnownSymbol sym, ToHttpApiData a,
304instance (KnownSymbol sym, ToHttpApiData a,
218− HasClient t m sublayout, SupportsServantReflex t m)
305+ HasClient t m sublayout tag, SupportsServantReflex t m)
219− => HasClient t m (Header sym a :> sublayout) where
306+ => HasClient t m (Header sym a :> sublayout) tag where
221− type Client t m (Header sym a :> sublayout) =
308+ type Client t m (Header sym a :> sublayout) tag =
222− Dynamic t (Either Text a) -> Client t m sublayout
309+ Dynamic t (Either Text a) -> Client t m sublayout tag
224− clientWithRoute Proxy q req baseurl eVal =
311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312+ clientWithRouteAndResultHandler
225− clientWithRoute (Proxy :: Proxy sublayout)
313+ (Proxy :: Proxy sublayout) q t
227− (Servant.Common.Req.addHeader hname eVal req)
314+ (Servant.Common.Req.addHeader hname eVal req)
228− baseurl
315+ baseurl opts wrap
229 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
231-- | 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
232-- functions.
322-- functions.
233−instance HasClient t m sublayout
323+instance HasClient t m sublayout tag
234− => HasClient t m (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)
236− type Client t m (HttpVersion :> sublayout) =
237− Client t m sublayout
239− clientWithRoute Proxy q =
240− clientWithRoute (Proxy :: Proxy sublayout) q
243-- | 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,
@@ -266,16 +369,16 @@ instance HasClient t m sublayout
266-- > -- then you can just use "getBooksBy" to query that endpoint.
369-- > -- then you can just use "getBooksBy" to query that endpoint.
267-- > -- 'getBooksBy Nothing' for all books
370-- > -- 'getBooksBy Nothing' for all books
268-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
371-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
269−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
372+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
270− => HasClient t m (QueryParam sym a :> sublayout) where
373+ => HasClient t m (QueryParam' mods sym a :> sublayout) tag where
272− type Client t m (QueryParam sym a :> sublayout) =
375+ type Client t m (QueryParam' mods sym a :> sublayout) tag =
273− Dynamic t (QParam a) -> Client t m sublayout
376+ Dynamic t (QParam a) -> Client t m sublayout tag
275 -- 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
276− clientWithRoute Proxy q req baseurl mparam =
379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
277− clientWithRoute (Proxy :: Proxy sublayout) q
380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
278− (req {qParams = paramPair : qParams req}) baseurl
381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
280 where pname = symbolVal (Proxy :: Proxy sym)
383 where pname = symbolVal (Proxy :: Proxy sym)
281 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -283,6 +386,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
283 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
386 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
284 paramPair = (T.pack pname, p mparam)
387 paramPair = (T.pack pname, p mparam)
286-- | 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,
287-- the corresponding querying function will automatically take
392-- the corresponding querying function will automatically take
288-- an additional argument, a list of values of the type specified
393-- an additional argument, a list of values of the type specified
@@ -311,21 +416,22 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
311-- > -- 'getBooksBy []' for all books
416-- > -- 'getBooksBy []' for all books
312-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
417-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
313-- > -- to get all books by Asimov and Heinlein
418-- > -- to get all books by Asimov and Heinlein
314−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
419+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
315− => HasClient t m (QueryParams sym a :> sublayout) where
420+ => HasClient t m (QueryParams sym a :> sublayout) tag where
317− type Client t m (QueryParams sym a :> sublayout) =
422+ type Client t m (QueryParams sym a :> sublayout) tag =
318− Dynamic t [a] -> Client t m sublayout
423+ Dynamic t [a] -> Client t m sublayout tag
320− clientWithRoute Proxy q req baseurl paramlist =
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
321− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
323 where req' = req { qParams = (T.pack pname, params') : qParams req }
428 where req' = req { qParams = (T.pack pname, params') : qParams req }
324 pname = symbolVal (Proxy :: Proxy sym)
429 pname = symbolVal (Proxy :: Proxy sym)
325− params' = QueryPartParams $ (fmap . fmap) (toQueryParam)
430+ params' = QueryPartParams $ (fmap . fmap) toQueryParam
326 paramlist
431 paramlist
329-- | 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,
330-- the corresponding querying function will automatically take
436-- the corresponding querying function will automatically take
331-- an additional 'Bool' argument.
437-- an additional 'Bool' argument.
@@ -350,49 +456,42 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
350-- > -- 'getBooksBy True' to only get _already published_ books
456-- > -- 'getBooksBy True' to only get _already published_ books
352-- TODO Bring back
458-- TODO Bring back
353−instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
459+instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
354− => HasClient t m (QueryFlag sym :> sublayout) where
460+ => HasClient t m (QueryFlag sym :> sublayout) tag where
356− type Client t m (QueryFlag sym :> sublayout) =
462+ type Client t m (QueryFlag sym :> sublayout) tag =
357− Dynamic t Bool -> Client t m sublayout
463+ Dynamic t Bool -> Client t m sublayout tag
359− clientWithRoute Proxy q req baseurl flag =
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
360− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
362 where req' = req { qParams = thisPair : qParams req }
468 where req' = req { qParams = thisPair : qParams req }
363 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
364 pName = symbolVal (Proxy :: Proxy sym)
470 pName = symbolVal (Proxy :: Proxy sym)
367−-- | Pick a 'Method' and specify where the server you want to query is. You get
473+
368−-- back the full `Response`.
474+-- | Send a raw 'XhrRequest ()' directly to 'baseurl'
370−instance SupportsServantReflex t m => HasClient t m Raw where
475+instance SupportsServantReflex t m => HasClient t m Raw tag where
371− type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))
476+ type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
372− -> Event t ()
477+ -> Event t tag
373− -> m (Event t (ReqResult ()))
478+ -> m (Event t (ReqResult tag ()))
375− -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw
376− clientWithRoute _ _ _ baseurl xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
377− let xhrs' = liftA2 (\x path -> case x of
482+ let xhrs' = liftA2 (\x path -> case x of
378− Left e -> Left e
483+ Left e -> Left e
379− Right jx -> Right $ jx {_xhrRequest_url = path
484+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }
380− <> _xhrRequest_url jx})
382− (showBaseUrl <$> baseurl)
485+ ) xhrs (showBaseUrl <$> baseurl)
383− reqs = tagPromptlyDyn xhrs' triggers
486+ xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))
384− okReq = fmapMaybe hush reqs
487+ badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)
385− badReq = fmapMaybe tattle reqs
488+ okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
386− resps <- performRequestAsync okReq
489+
387− return $ leftmost [fmap (ResponseSuccess () ) resps
490+ resps <- performRequestsAsync okReq
388− ,fmap RequestFailure badReq]
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
389−
492+ , evalResponse (const $ Right ()) <$> resps
391−hush :: Either e a -> Maybe a
494+
392−hush = either (const Nothing) Just
394−tattle :: Either e a -> Maybe e
395−tattle = either Just (const Nothing)
397-- | 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,
398-- the corresponding querying function will automatically take
497-- the corresponding querying function will automatically take
@@ -414,14 +513,14 @@ tattle = either Just (const Nothing)
414-- > where host = BaseUrl Http "localhost" 8080
513-- > where host = BaseUrl Http "localhost" 8080
415-- > -- then you can just use "addBook" to query that endpoint
514-- > -- then you can just use "addBook" to query that endpoint
417−instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
418− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) where
517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
420− type Client t m (ReqBody (ct ': cts) a :> sublayout) =
519+ type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
421− Dynamic t (Either Text a) -> Client t m sublayout
520+ Dynamic t (Either Text a) -> Client t m sublayout tag
423− clientWithRoute Proxy q req baseurl body =
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
424− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
425 where req' = req { reqBody = bodyBytesCT }
524 where req' = req { reqBody = bodyBytesCT }
426 ctProxy = Proxy :: Proxy ct
525 ctProxy = Proxy :: Proxy ct
427 ctString = T.pack $ show $ contentType ctProxy
526 ctString = T.pack $ show $ contentType ctProxy
@@ -429,43 +528,49 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
429 (\b -> (mimeRender ctProxy b, ctString))
528 (\b -> (mimeRender ctProxy b, ctString))
432-- | Make the querying function append @path@ to the request path.
533-- | Make the querying function append @path@ to the request path.
433−instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where
534+instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
434− type Client t m (path :> sublayout) = Client t m sublayout
535+ type Client t m (path :> sublayout) tag = Client t m sublayout tag
436− clientWithRoute Proxy q req baseurl =
537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
437− clientWithRoute (Proxy :: Proxy sublayout) q
538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
438− (prependToPathParts (pure (Right $ T.pack p)) req)
539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
441 where p = symbolVal (Proxy :: Proxy path)
541 where p = symbolVal (Proxy :: Proxy path)
443−instance HasClient t m api => HasClient t m (Vault :> api) where
444− type Client t m (Vault :> api) = Client t m api
446− clientWithRoute Proxy q req baseurl =
544+instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
447− clientWithRoute (Proxy :: Proxy api) q req baseurl
545+ type Client t m (Vault :> api) tag = Client t m api tag
547+ clientWithRouteAndResultHandler Proxy =
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
449−instance HasClient t m api => HasClient t m (RemoteHost :> api) where
551+instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
450− type Client t m (RemoteHost :> api) = Client t m api
552+ type Client t m (RemoteHost :> api) tag = Client t m api tag
452− clientWithRoute Proxy q req baseurl =
554+ clientWithRouteAndResultHandler Proxy =
453− clientWithRoute (Proxy :: Proxy api) q req baseurl
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
455−instance HasClient t m api => HasClient t m (IsSecure :> api) where
456− type Client t m (IsSecure :> api) = Client t m api
458− clientWithRoute Proxy q req baseurl =
459− clientWithRoute (Proxy :: Proxy api) q req baseurl
461−instance (HasClient t m api, Reflex t)
559+instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
462− => HasClient t m (BasicAuth realm usr :> api) where
560+ type Client t m (IsSecure :> api) tag = Client t m api tag
464− type Client t m (BasicAuth realm usr :> api) = Dynamic t (Maybe BasicAuthData)
562+ clientWithRouteAndResultHandler Proxy =
465− -> Client t m api
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
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
467− clientWithRoute Proxy q req baseurl authdata =
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
468− clientWithRoute (Proxy :: Proxy api) q req' baseurl
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
470 req' = req { authData = Just authdata }
575 req' = req { authData = Just authdata }
@@ -491,3 +596,29 @@ non-empty lists, but is otherwise more specific, no instance will be overall
491more specific. This in turn generally means adding yet another instance (one
596more specific. This in turn generally means adding yet another instance (one
492for 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