@@ -1,15 +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 #-}
13+{-# LANGUAGE TupleSections #-}
9−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
12−{-# LANGUAGE MultiParamTypeClasses #-}
17+
18+#if MIN_VERSION_base(4,9,0)
19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
14-- #include "overlapping-compat.h"
22-- #include "overlapping-compat.h"
15-- | This module provides 'client' which can automatically generate
23-- | This module provides 'client' which can automatically generate
@@ -17,29 +25,71 @@
18module Servant.Reflex
26module Servant.Reflex
20− , HasClient(..)
28+ , clientWithOpts
29+ , clientWithOptsAndResultHandler
31+ , clientWithRouteAndResultHandler
32+ , BuildHeaderKeysTo(..)
36+ , module Servant.Common.Req
21 , module Servant.Common.BaseUrl
37 , module Servant.Common.BaseUrl
40+------------------------------------------------------------------------------
24−import Control.Applicative ((<$>))
41+import Control.Applicative
25−import Control.Monad.Trans.Except
42+import qualified Data.CaseInsensitive as CI
26−import Data.ByteString.Lazy (ByteString)
43+import Data.Functor.Identity
27−import Data.List
44+import qualified Data.Map as Map
28−import Data.Proxy
45+import Data.Monoid ((<>))
29−import Data.String.Conversions
46+import Data.Proxy (Proxy (..))
47+import qualified Data.Set as Set
30−import Data.Text (unpack)
48+import Data.Text (Text)
31−import qualified Data.ByteString.Char8 as BS
49+import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
32−import GHC.TypeLits
52+import GHC.TypeLits (KnownSymbol, symbolVal)
33−-- import Network.HTTP.Media
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
54+ BasicAuthData, BuildHeadersTo (..),
55+ Capture, Header, Headers (..),
56+ HttpVersion, IsSecure,
57+ MimeRender (..), MimeUnrender,
58+ NoContent, QueryFlag, QueryParam,
59+ QueryParams, Raw, ReflectMethod (..),
61+ ToHttpApiData (..), Vault, Verb,
63+import Servant.API.Description (Summary)
34−-- import qualified Network.HTTP.Types as H
64+import qualified Servant.Auth as Auth
35−-- import qualified Network.HTTP.Types.Header as HTTP
65+
36−import Servant.API
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
37−import Servant.Common.BaseUrl
67+ XhrRequest (..), XhrResponse (..),
68+ XhrResponseHeaders (..),
69+ attachPromptlyDynWith, constDyn, ffor,
71+ performRequestsAsync)
72+------------------------------------------------------------------------------
73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
75+ SupportsServantReflex)
38−import Servant.Common.Req
76+import Servant.Common.Req (ClientOptions(..),
39−import Servant.API.ContentTypes
77+ defaultClientOptions,
40−import Reflex
78+ Req, ReqResult(..), QParam(..),
41−import Reflex.Dom
79+ QueryPart(..), addHeader, authData,
42−import Reflex.Dom.Xhr
80+ defReq, evalResponse, prependToPathParts,
83+ -- performRequestNoBody,
84+ performRequestsNoBody,
85+ performSomeRequestsAsync,
86+ qParamToQueryPart, reqBody,
87+ reqSuccess, reqFailure,
88+ reqMethod, respHeaders,
91+ qParams, withCredentials)
44-- * Accessing APIs as a Client
94-- * Accessing APIs as a Client
@@ -51,116 +101,191 @@ import Reflex.Dom.Xhr
51-- > myApi :: Proxy MyApi
101-- > myApi :: Proxy MyApi
52-- > myApi = Proxy
102-- > myApi = Proxy
54−-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))
104+-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
55−-- > postNewBook :: Behavior t (Maybe Book) -> Event t ()
105+-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
56−-- -> m (Event t (Either XhrError (Book,Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
57-- > (getAllBooks :<|> postNewBook) = client myApi host
107-- > (getAllBooks :<|> postNewBook) = client myApi host
58-- > where host = constDyn $ BaseUrl Http "localhost" 8080
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
59−client :: (HasClient t m layout, MonadWidget t m)
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)
60− => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout
123+ -> Dynamic t BaseUrl
125+ -> Client t m layout tag
61−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
63-- | This class lets us define how each API combinator
143-- | This class lets us define how each API combinator
64-- influences the creation of an HTTP request. It's mostly
144-- influences the creation of an HTTP request. It's mostly
65-- an internal class, you can just use 'client'.
145-- an internal class, you can just use 'client'.
66−class HasClient t m layout where
146+class Monad m => HasClient t m layout (tag :: *) where
67− type Client t m layout :: *
147+ type Client t m layout tag :: *
68− 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
71−instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
72− type Client t m (a :<|> b) = Client t m a :<|> Client t m b
73− clientWithRoute Proxy q req baseurl =
74− clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>
75− clientWithRoute (Proxy :: Proxy b) q req baseurl
77-- Capture. Example:
177-- Capture. Example:
78-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
178-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
80-- > myApi :: Proxy MyApi = Proxy
180-- > myApi :: Proxy MyApi = Proxy
82−-- > getBook :: MonadWidget t m
182+-- > getBook :: SupportsServantReflex t m
83-- => Dynamic t BaseUrl
183-- => Dynamic t BaseUrl
84−-- -> Behavior t (Maybe Text)
184+-- -> Dynamic t (Maybe Text)
85−-- -> Event t ()
185+-- -> Event t l
86−-- -> m (Event t (Either XhrError (Text, Book)))
186+-- -> m (Event t (l, ReqResult Book))
87-- > getBook = client myApi (constDyn host)
187-- > getBook = client myApi (constDyn host)
88−instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m sublayout)
89− => HasClient t m (Capture capture a :> sublayout) where
189+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)
190+ => HasClient t m (Capture capture a :> sublayout) tag where
91− type Client t m (Capture capture a :> sublayout) =
192+ type Client t m (Capture capture a :> sublayout) tag =
92− Behavior t (Maybe a) -> Client t m sublayout
193+ Dynamic t (Either Text a) -> Client t m sublayout tag
94− clientWithRoute Proxy q req baseurl val =
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
95− clientWithRoute (Proxy :: Proxy sublayout)
196+ clientWithRouteAndResultHandler
97− (prependToPathParts p req)
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
98− baseurl
198+ where p = (fmap . fmap) (toUrlPiece) val
100− where p = (fmap . fmap) (unpack . toUrlPiece) val
102-- VERB (Returning content) --
201-- VERB (Returning content) --
103instance {-# OVERLAPPABLE #-}
202instance {-# OVERLAPPABLE #-}
104 -- Note [Non-Empty Content Types]
203 -- Note [Non-Empty Content Types]
105− (MimeUnrender ct a, FromHttpApiData a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m
204+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
106− ) => HasClient t m (Verb method status cts' a) where
205+ ) => HasClient t m (Verb method status cts' a) tag where
107− type Client t m (Verb method status cts' a) =
206+ type Client t m (Verb method status cts' a) tag =
108− Event t () -> m (Event t (Maybe a, XhrResponse))
207+ Event t tag -> m (Event t (ReqResult tag a))
109 -- TODO how to access input types here?
208 -- TODO how to access input types here?
110 -- ExceptT ServantError IO a
209 -- ExceptT ServantError IO a
111− clientWithRoute Proxy q req baseurl =
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
112− performRequestCT (Proxy :: Proxy ct) method req baseurl
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
113− where method = BS.unpack $ reflectMethod (Proxy :: Proxy method)
212+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213+ req' = req { reqMethod = method }
115−-- TODO Overlapping error??
116-- -- VERB (No content) --
216-- -- VERB (No content) --
117−-- instance {-# OVERLAPPABLE #-}
217+instance {-# OVERLAPPING #-}
118−-- (ReflectMethod method, MonadWidget t m) =>
218+ (ReflectMethod method, SupportsServantReflex t m) =>
119−-- HasClient t m (Verb method status cts NoContent) where
219+ HasClient t m (Verb method status cts NoContent) tag where
120−-- type Client t m (Verb method status cts NoContent) =
220+ type Client t m (Verb method status cts NoContent) tag =
121−-- Event t () -> m (Event t XhrResponse)
221+ Event t tag -> m (Event t (ReqResult tag NoContent))
122−-- -- TODO: how to access input types here?
222+ -- TODO: how to access input types here?
123−-- -- ExceptT ServantError IO NoContent
223+ -- ExceptT ServantError IO NoContent
124−-- clientWithRoute Proxy req baseurl =
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
125−-- performRequestNoBody method req baseurl
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
126−-- 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)
128-- HEADERS Verb (Content) --
252-- HEADERS Verb (Content) --
129-- Headers combinator not treated in fully general case,
253-- Headers combinator not treated in fully general case,
130-- in order to deny instances for (Headers ls (Capture "id" Int)),
254-- in order to deny instances for (Headers ls (Capture "id" Int)),
131-- a combinator that wouldn't make sense
255-- a combinator that wouldn't make sense
132-- TODO Overlapping??
256-- TODO Overlapping??
133−-- instance {-# OVERLAPPABLE #-}
257+instance {-# OVERLAPPABLE #-}
134−-- -- Note [Non-Empty Content Types]
258+ -- Note [Non-Empty Content Types]
135−-- ( MimeUnrender ct a, BuildHeadersTo ls,
259+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
136−-- ReflectMethod method, cts' ~ (ct ': cts),
260+ ReflectMethod method, cts' ~ (ct ': cts),
137−-- MonadWidget t m
261+ SupportsServantReflex t m
138−-- ) => HasClient t m (Verb method status cts' (Headers ls a)) where
262+ ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
139−-- type Client t m (Verb method status cts' (Headers ls a))
263+ type Client t m (Verb method status cts' (Headers ls a)) tag =
140−-- = Event t () -> m (Event t (Maybe a, XhrResponse))
264+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
141−-- -- ExceptT ServantError IO (Headers ls a)
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
142−-- clientWithRoute Proxy req baseurl = do
143−-- let method = reflectMethod (Proxy :: Proxy method)
266+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
144−-- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
145−-- return $ Headers { getResponse = resp
268+ wrap $ toHeaders <$> resp
146−-- , getHeadersHList = buildHeadersTo hdrs
269+ where req' = req { respHeaders =
270+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
274+-- HEADERS Verb (No content) --
275+instance {-# OVERLAPPABLE #-}
276+ ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
277+ SupportsServantReflex t m
278+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
279+ type Client t m (Verb method status cts (Headers ls NoContent)) tag
280+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
282+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
284+ wrap $ toHeaders <$> resp
285+ where req' = req {respHeaders =
286+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
149−-- TODO Overlapping??
150−-- -- HEADERS Verb (No content) --
151−-- instance {-# OVERLAPPABLE #-}
152−-- ( BuildHeadersTo ls, ReflectMethod method,
154−-- ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
155−-- type Client t m (Verb method status cts (Headers ls NoContent))
156−-- = Event t () -> m (Event t XhrResponse)
157−-- -- ExceptT ServantError IO (Headers ls NoContent)
158−-- clientWithRoute Proxy req baseurl = do
159−-- let method = reflectMethod (Proxy :: Proxy method)
160−-- hdrs <- performRequestNoBody method req baseurl
161−-- return $ Headers { getResponse = NoContent
162−-- , getHeadersHList = buildHeadersTo hdrs
@@ -177,34 +302,46 @@ instance {-# OVERLAPPABLE #-}
177-- > -- then you can just use "viewRefer" to query that endpoint
302-- > -- then you can just use "viewRefer" to query that endpoint
178-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
303-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
179instance (KnownSymbol sym, ToHttpApiData a,
304instance (KnownSymbol sym, ToHttpApiData a,
180− HasClient t m sublayout, MonadWidget t m)
305+ HasClient t m sublayout tag, SupportsServantReflex t m)
181− => HasClient t m (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)
183− type Client t m (Header sym a :> sublayout) =
184− Behavior t (Maybe a) -> Client t m sublayout
186− clientWithRoute Proxy q req baseurl mval =
187− clientWithRoute (Proxy :: Proxy sublayout)
190− -- (maybe req -- TODO Need to pass the header in
191− -- (\value -> Servant.Common.Req.addHeader hname value req)
196− where hname = symbolVal (Proxy :: Proxy sym)
198-- | 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
199-- functions.
322-- functions.
200−instance HasClient t m sublayout
323+instance HasClient t m sublayout tag
201− => 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)
203− type Client t m (HttpVersion :> sublayout) =
204− Client t m sublayout
206− clientWithRoute Proxy q =
207− clientWithRoute (Proxy :: Proxy sublayout) q
209-- | 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,
210-- the corresponding querying function will automatically take
347-- the corresponding querying function will automatically take
@@ -232,24 +369,24 @@ instance HasClient t m sublayout
232-- > -- then you can just use "getBooksBy" to query that endpoint.
369-- > -- then you can just use "getBooksBy" to query that endpoint.
233-- > -- 'getBooksBy Nothing' for all books
370-- > -- 'getBooksBy Nothing' for all books
234-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
371-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
235−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
372+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
236− => HasClient t m (QueryParam sym a :> sublayout) where
373+ => HasClient t m (QueryParam sym a :> sublayout) tag where
238− type Client t m (QueryParam sym a :> sublayout) =
375+ type Client t m (QueryParam sym a :> sublayout) tag =
239− -- TODO (Maybe a), or (Maybe (Maybe a))? (should the user be able to send a Nothing)
240− Behavior t (Maybe a) -> Client t m sublayout
376+ Dynamic t (QParam a) -> Client t m sublayout tag
242 -- 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
243− clientWithRoute Proxy q req baseurl mparam =
379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
244− clientWithRoute (Proxy :: Proxy sublayout)
380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
246− req -- TODO Must pass in the query param
247− -- (req {qParams = (pname', map show mparam) : qParams req})
381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
383+ where pname = symbolVal (Proxy :: Proxy sym)
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)
250− -- where pname = cs pname'
251− -- pname' = symbolVal (Proxy :: Proxy sym)
252− -- mparamText = fmap toQueryParam mparam
254-- | 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,
255-- the corresponding querying function will automatically take
392-- the corresponding querying function will automatically take
@@ -279,24 +416,21 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
279-- > -- 'getBooksBy []' for all books
416-- > -- 'getBooksBy []' for all books
280-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
417-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
281-- > -- to get all books by Asimov and Heinlein
418-- > -- to get all books by Asimov and Heinlein
282−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
419+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
283− => HasClient t m (QueryParams sym a :> sublayout) where
420+ => HasClient t m (QueryParams sym a :> sublayout) tag where
285− type Client t m (QueryParams sym a :> sublayout) =
422+ type Client t m (QueryParams sym a :> sublayout) tag =
286− [a] -> Client t m sublayout
423+ Dynamic t [a] -> Client t m sublayout tag
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
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
288− clientWithRoute Proxy _ req baseurl paramlist = undefined
289− -- clientWithRoute (Proxy :: Proxy sublayout)
290− -- (foldl' prependPathParts req paramlist')
291− -- (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
297− -- where pname = cs pname'
298− -- pname' = symbolVal (Proxy :: Proxy sym)
299− -- paramlist' = map (Just . toQueryParam) paramlist
301-- | 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,
302-- the corresponding querying function will automatically take
436-- the corresponding querying function will automatically take
@@ -322,35 +456,42 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
322-- > -- 'getBooksBy True' to only get _already published_ books
456-- > -- 'getBooksBy True' to only get _already published_ books
324-- TODO Bring back
458-- TODO Bring back
325−-- instance (KnownSymbol sym, HasClient t m sublayout)
459+instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
326−-- => HasClient t m (QueryFlag sym :> sublayout) where
460+ => HasClient t m (QueryFlag sym :> sublayout) tag where
462+ type Client t m (QueryFlag sym :> sublayout) tag =
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
328−-- type Client t m (QueryFlag sym :> sublayout) =
468+ where req' = req { qParams = thisPair : qParams req }
329−-- Bool -> Client t m sublayout
469+ thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
470+ pName = symbolVal (Proxy :: Proxy sym)
331−-- clientWithRoute Proxy req baseurl flag =
332−-- clientWithRoute (Proxy :: Proxy sublayout)
334−-- then appendToQueryString paramname Nothing req
339−-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)
474+-- | Send a raw 'XhrRequest ()' directly to 'baseurl'
475+instance SupportsServantReflex t m => HasClient t m Raw tag where
476+ type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
478+ -> m (Event t (ReqResult tag ()))
342−-- | Pick a 'Method' and specify where the server you want to query is. You get
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
343−-- back the full `Response`.
481+
344−-- TODO redo
482+ let xhrs' = liftA2 (\x path -> case x of
345−instance (MonadWidget t m) => HasClient t m Raw where
483+ Left e -> Left e
346− type Client t m Raw = Behavior t (Maybe XhrRequest)
484+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }
347− -> Event t ()
485+ ) xhrs (showBaseUrl <$> baseurl)
348− -> m (Event t XhrResponse)
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 ())
490+ resps <- performRequestsAsync okReq
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
492+ , evalResponse (const $ Right ()) <$> resps
350− -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw
351− clientWithRoute p q req baseurl xhrs triggers = do
352− let okReq = fmapMaybe id $ tag xhrs triggers
353− performRequestAsync okReq
355-- | 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,
356-- the corresponding querying function will automatically take
497-- the corresponding querying function will automatically take
@@ -368,60 +509,76 @@ instance (MonadWidget t m) => HasClient t m Raw where
368-- > myApi = Proxy
509-- > myApi = Proxy
370-- > addBook :: Book -> ExceptT String IO Book
511-- > addBook :: Book -> ExceptT String IO Book
371−-- > addBook = client myApi host
512+-- > addBook = client myApi host
372-- > where host = BaseUrl Http "localhost" 8080
513-- > where host = BaseUrl Http "localhost" 8080
373-- > -- then you can just use "addBook" to query that endpoint
514-- > -- then you can just use "addBook" to query that endpoint
376−-- instance (MimeRender ct a, HasClient t m sublayout)
516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
377−-- => HasClient t m (ReqBody (ct ': cts) a :> sublayout) where
517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
519+ type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
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))
379−-- type Client t m (ReqBody (ct ': cts) a :> sublayout) =
380−-- a -> Client sublayout
382−-- clientWithRoute Proxy req baseurl body =
383−-- clientWithRoute (Proxy :: Proxy sublayout)
384−-- (let ctProxy = Proxy :: Proxy ct
385−-- in setRQBody (mimeRender ctProxy body)
386−-- (contentType ctProxy)
391-- | Make the querying function append @path@ to the request path.
533-- | Make the querying function append @path@ to the request path.
392−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
393− type Client t m (path :> sublayout) = Client t m sublayout
535+ type Client t m (path :> sublayout) tag = Client t m sublayout tag
395− clientWithRoute Proxy q req baseurl =
537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
396− clientWithRoute (Proxy :: Proxy sublayout) q
538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
397− (prependToPathParts (constant (Just p)) req)
539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
400 where p = symbolVal (Proxy :: Proxy path)
541 where p = symbolVal (Proxy :: Proxy path)
402−instance HasClient t m api => HasClient t m (Vault :> api) where
403− type Client t m (Vault :> api) = Client t m api
405− clientWithRoute Proxy q req baseurl =
544+instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
406− 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)
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)
408−instance HasClient t m api => HasClient t m (RemoteHost :> api) where
409− type Client t m (RemoteHost :> api) = Client t m api
411− clientWithRoute Proxy q req baseurl =
559+instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
412− clientWithRoute (Proxy :: Proxy api) q req baseurl
560+ type Client t m (IsSecure :> api) tag = Client t m api tag
414−instance HasClient t m api => HasClient t m (IsSecure :> api) where
562+ clientWithRouteAndResultHandler Proxy =
415− type Client t m (IsSecure :> api) = Client t m api
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
417− clientWithRoute Proxy q req baseurl =
418− clientWithRoute (Proxy :: Proxy api) q req baseurl
420−instance HasClient t m subapi =>
566+instance (HasClient t m api tag, Reflex t)
421− HasClient t m (WithNamedConfig name config subapi) where
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 =>
423− type Client t m (WithNamedConfig name config subapi) = Client t m subapi
578+-- HasClient t m (WithNamedConfig name config subapi) where
580+-- type Client t m (WithNamedConfig name config subapi) = Client t m subapi
424− clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q
581+-- clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q
427{- Note [Non-Empty Content Types]
584{- Note [Non-Empty Content Types]
@@ -439,3 +596,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall
439more specific. This in turn generally means adding yet another instance (one
596more specific. This in turn generally means adding yet another instance (one
440for 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