git.iko.soy/servant-reflex
on 340df64 help sign in
f76dbeb
swap
18 ahead, 46 behind
4 files changed+648−179
since splitsnapshots
unifiedsplit
servant-reflex.cabal+4−2 src/Servant/Common/Req.hs+136−79 src/Servant/Reflex.hs+284−56 src/Servant/Reflex/Multi.hs+224−42
servant-reflex.cabal+4−2
@@ -27,6 +27,7 @@ library
2727 hs-source-dirs: src
2828 build-depends:
2929 base >= 4.8 && < 4.10,
30+ aeson >= 0.11 && < 1.3,
3031 bytestring >= 0.10 && < 0.11,
3132 case-insensitive >= 1.2.0.4 && < 1.3,
3233 containers >= 0.5.6 && < 0.6,
@@ -41,8 +42,9 @@ library
4142 reflex >= 0.5 && < 0.6,
4243 reflex-dom-core == 0.4 && < 0.5,
4344 safe >= 0.3.9 && < 0.4,
44− servant >= 0.8 && < 0.12,
45− servant-auth >= 0.2.1 && < 0.3,
45+ servant >= 0.13 && < 0.14,
46+ servant-checked-exceptions >= 1.1.0.0 && < 1.2,
47+ servant-auth >= 0.2.1 && < 0.4,
4648 string-conversions >= 0.4 && < 0.5,
4749 text >= 1.2 && < 1.3,
4850 transformers >= 0.4 && < 0.6
src/Servant/Common/Req.hs+136−79
@@ -1,44 +1,65 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE RankNTypes #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TupleSections #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE ExistentialQuantification #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE LambdaCase #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE NamedFieldPuns #-}
11+{-# LANGUAGE OverloadedStrings #-}
12+{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TupleSections #-}
15+{-# OPTIONS_GHC -fno-warn-orphans #-}
1016
1117module Servant.Common.Req where
1218
1319-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
20+import Control.Applicative (liftA2, liftA3)
1521import Control.Concurrent
16−import Control.Monad (join)
17−import Control.Monad.IO.Class (MonadIO, liftIO)
18−import Data.Bifunctor (first)
19−import qualified Data.ByteString.Builder as Builder
20−import qualified Data.ByteString.Lazy.Char8 as BL
21−import qualified Data.Map as Map
22−import Data.Maybe (catMaybes, fromMaybe)
22+import Control.Monad (join)
23+import Control.Monad.IO.Class (MonadIO, liftIO)
24+import Data.Aeson
25+import Data.Bifunctor (first)
26+import qualified Data.ByteString as BS
27+import qualified Data.ByteString.Builder as BB
28+import Data.ByteString.Lazy (ByteString)
29+import qualified Data.ByteString.Lazy.Char8 as BL
2330import Data.Functor.Compose
24−import Data.Monoid ((<>))
25−import Data.Proxy (Proxy(..))
26−import Data.Text (Text)
27−import qualified Data.Text as T
28−import qualified Data.Text.Encoding as TE
29−import Data.Traversable (forM)
31+import qualified Data.JSString.Text as JS (lazyTextFromJSString)
32+import qualified Data.Map as Map
33+import Data.Maybe (catMaybes, fromMaybe)
34+import Data.Monoid ((<>))
35+import Data.Proxy (Proxy (..))
36+import Data.Text (Text)
37+import qualified Data.Text as T
38+import qualified Data.Text.Encoding as T
39+import qualified Data.Text.Lazy as TL
40+import Data.Traversable (forM)
41+import qualified Language.Javascript.JSaddle as JS
3042import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
31−import qualified Network.URI as N
32−import Reflex.Dom.Core hiding (tag)
33−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
34− SupportsServantReflex)
35−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
36−import Web.HttpApiData (ToHttpApiData(..))
43+import qualified Network.URI as N
44+import Reflex.Dom.Core hiding (tag)
45+import Servant.API.ContentTypes (Accept, FormUrlEncoded,
46+ JSON, NoContent (..),
47+ OctetStream, PlainText)
48+import Servant.Common.BaseUrl (BaseUrl,
49+ SupportsServantReflex,
50+ showBaseUrl)
51+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
52+import Web.HttpApiData (ToHttpApiData (..))
3753-------------------------------------------------------------------------------
3854import Servant.API.BasicAuth
55+-------------------------------------------------------------------------------
3956
57+-- #ifndef __GHCJS__
58+-- jsonDecode :: JS.JSString -> Maybe a
59+-- jsonDecode = error "jsonDecode is only available in GHCJS"
60+-- #endif
4061
41−------------------------------------------------------------------------------
62+-----------------------------------------------------------------------------
4263-- | The result of a request event
4364data ReqResult tag a
4465 = ResponseSuccess tag a XhrResponse
@@ -132,34 +153,35 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
132153-------------------------------------------------------------------------------
133154-- The data structure used to build up request information while traversing
134155-- the shape of a servant API
135−data Req t = Req
156+data Req t = forall o. (IsXhrPayload o, Show o) => Req
136157 { reqMethod :: Text
137158 , reqPathParts :: [Dynamic t (Either Text Text)]
138159 , qParams :: [(Text, QueryPart t)]
139− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
160+ , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
140161 , headers :: [(Text, Dynamic t (Either Text Text))]
141162 , respHeaders :: XhrResponseHeaders
142163 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
143164 }
144165
166+data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
167+
145168defReq :: Req t
146−defReq = Req "GET" [] [] Nothing [] def Nothing
169+defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
147170
148171prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
149172prependToPathParts p req =
150173 req { reqPathParts = p : reqPathParts req }
151174
152175addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
153−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
154−
176+addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
155177
156178reqToReflexRequest
157− :: forall t. Reflex t
158− => Text
159− -> Dynamic t BaseUrl
160− -> Req t
161− -> Dynamic t (Either Text (XhrRequest XhrPayload))
162−reqToReflexRequest reqMeth reqHost req =
179+ :: forall t. Reflex t
180+ => Text
181+ -> Dynamic t BaseUrl
182+ -> Req t
183+ -> Dynamic t (Either Text SomeXhrRequest)
184+reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (Either Text (o, Text)))) _ _ _) =
163185 let t :: Dynamic t [Either Text Text]
164186 t = sequence $ reverse $ reqPathParts req
165187
@@ -211,14 +233,14 @@ reqToReflexRequest reqMeth reqHost req =
211233 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
212234
213235 mkConfigBody :: Either Text [(Text,Text)]
214− -> (Either Text (BL.ByteString, Text))
215− -> Either Text (XhrRequestConfig XhrPayload)
236+ -> (Either Text (o, Text))
237+ -> Either Text (XhrRequestConfig (Maybe o))
216238 mkConfigBody ehs rb = case (ehs, rb) of
217239 (_, Left e) -> Left e
218240 (Left e, _) -> Left e
219241 (Right hs, Right (bBytes, bCT)) ->
220242 Right $ XhrRequestConfig
221− { _xhrRequestConfig_sendData = bytesToPayload bBytes
243+ { _xhrRequestConfig_sendData = Just bBytes
222244 , _xhrRequestConfig_headers =
223245 Map.insert "Content-Type" bCT (Map.fromList hs)
224246 , _xhrRequestConfig_user = Nothing
@@ -228,16 +250,16 @@ reqToReflexRequest reqMeth reqHost req =
228250 , _xhrRequestConfig_responseHeaders = def
229251 }
230252
231− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
232− xhrOpts = case reqBody req of
253+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
254+ xhrOpts = case reqBody of
233255 Nothing -> ffor xhrHeaders $ \case
234256 Left e -> Left e
235257 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
236258 , _xhrRequestConfig_user = Nothing
237259 , _xhrRequestConfig_password = Nothing
238260 , _xhrRequestConfig_responseType = Nothing
239− , _xhrRequestConfig_sendData = ""
240261 , _xhrRequestConfig_withCredentials = False
262+ , _xhrRequestConfig_sendData = Nothing
241263 }
242264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
243265
@@ -245,16 +267,16 @@ reqToReflexRequest reqMeth reqHost req =
245267 mkAuth _ (Left e) = Left e
246268 mkAuth Nothing r = r
247269 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
248− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
249− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
270+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
271+ , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
250272
251273 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
252274 -> Dynamic t (Either Text (XhrRequestConfig x))
253275 addAuth xhr = case authData req of
254− Nothing -> xhr
276+ Nothing -> xhr
255277 Just auth -> liftA2 mkAuth auth xhr
256278
257− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
279+ xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
258280
259281 in xhrReq
260282
@@ -263,8 +285,14 @@ reqToReflexRequest reqMeth reqHost req =
263285displayHttpRequest :: Text -> Text
264286displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
265287
288+instance IsXhrPayload o => IsXhrPayload (Maybe o) where
289+ sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)
290+
291+instance (IsXhrPayload o, IsXhrPayload o') => IsXhrPayload (Either o o') where
292+ sendXhrPayload xhr = either (sendXhrPayload xhr) (sendXhrPayload xhr)
293+
266294-- | This function performs the request
267−performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
295+performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
268296 => Text
269297 -> Dynamic t (f (Req t))
270298 -> Dynamic t BaseUrl
@@ -277,6 +305,7 @@ performRequests reqMeth rs reqHost opts trigger = do
277305 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
278306
279307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
308+ reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))
280309 reqs = attachPromptlyDynWith
281310 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
282311
@@ -292,32 +321,31 @@ performSomeRequestsAsync
292321 HasWebView (Performable m),
293322 PerformEvent t m,
294323 TriggerEvent t m,
295− Traversable f,
296− IsXhrPayload a,
297− Show a
324+ Traversable f
298325 )
299326 => ClientOptions
300− -> Event t (f (Either Text (XhrRequest a)))
327+ -> Event t (f (Either Text SomeXhrRequest))
301328 -> m (Event t (f (Either Text XhrResponse)))
302−performSomeRequestsAsync opts =
303− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
329+performSomeRequestsAsync opts sxhr =
330+ performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr
304331
305332
306333------------------------------------------------------------------------------
307334-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
308335-- that accepts 'f (Either e (XhrRequestb))' events
309336performSomeRequestsAsync'
310− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
337+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
311338 => ClientOptions
312− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
313− -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
339+ -> (forall b. IsXhrPayload b => XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
340+ -> Event t (Performable m (f (Either Text SomeXhrRequest)))
341+ -> m (Event t (f (Either Text a)))
314342performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
315343 rs <- hrs
316344 resps <- forM rs $ \r -> case r of
317345 Left e -> do
318346 resp <- liftIO $ newMVar (Left e)
319347 return resp
320− Right r' -> do
348+ Right (SomeXhrRequest r') -> do
321349 resp <- liftIO newEmptyMVar
322350 r'' <- liftJSM $ (optsRequestFixup opts) r'
323351 _ <- newXhr r'' $ liftIO . putMVar resp . Right
@@ -326,12 +354,6 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
326354 return ()
327355
328356
329−
330−type XhrPayload = T.Text
331−bytesToPayload :: BL.ByteString -> XhrPayload
332−bytesToPayload = TE.decodeUtf8 . BL.toStrict
333−
334−
335357performRequestsCT
336358 :: (SupportsServantReflex t m,
337359 MimeUnrender ct a, Traversable f)
@@ -344,11 +366,10 @@ performRequestsCT
344366 -> m (Event t (f (ReqResult tag a)))
345367performRequestsCT ct reqMeth reqs reqHost opts trigger = do
346368 resps <- performRequests reqMeth reqs reqHost opts trigger
347− let decodeResp x = first T.pack .
348− mimeUnrender ct .
349− BL.fromStrict .
350− TE.encodeUtf8 =<< note "No body text"
351− (_xhrResponse_responseText x)
369+ let decodeResp x = first T.pack
370+ . mimeUnrender ct
371+ . JS.textToJSString
372+ =<< note "No body text" (_xhrResponse_responseText x)
352373 return $ fmap
353374 (\(t,rs) -> ffor rs $ \r -> case r of
354375 Left e -> RequestFailure t e
@@ -379,7 +400,7 @@ evalResponse
379400 :: (XhrResponse -> Either Text a)
380401 -> (tag, XhrResponse)
381402 -> ReqResult tag a
382−evalResponse decode (tag, xhr) =
403+evalResponse decodeRes (tag, xhr) =
383404 let okStatus = _xhrResponse_status xhr < 400
384405 errMsg = fromMaybe
385406 ("Empty response with error code " <>
@@ -389,20 +410,56 @@ evalResponse decode (tag, xhr) =
389410 then either
390411 (\e -> ResponseFailure tag e xhr)
391412 (\v -> ResponseSuccess tag v xhr)
392− (decode xhr)
413+ (decodeRes xhr)
393414 else ResponseFailure tag errMsg xhr
394415 in respPayld
395416
396417
418+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
419+-- the second argument expects a JSString instead of ByteString.
420+-- This can lead to better performance ghcjs.
421+class Accept contentType => MimeUnrender contentType a where
422+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
423+
424+instance FromJSON a => MimeUnrender JSON a where
425+ mimeUnrender _ = note "Failed to decode response" . jsonDecode
426+
427+-- | @urlDecodeAsForm@
428+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
429+-- holds if every element of x is non-null (i.e., not @("", "")@)
430+instance FromForm a => MimeUnrender FormUrlEncoded a where
431+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
432+
433+-- | @left show . TextL.decodeUtf8'@
434+instance MimeUnrender PlainText TL.Text where
435+ mimeUnrender _ = pure . JS.lazyTextFromJSString
436+
437+-- | @left show . TextS.decodeUtf8' . toStrict@
438+instance MimeUnrender PlainText T.Text where
439+ mimeUnrender _ = pure . JS.textFromJSString
440+
441+-- | @Right . BC.unpack@
442+instance MimeUnrender PlainText String where
443+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString
444+
445+-- | @Right . id@
446+instance MimeUnrender OctetStream ByteString where
447+ mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
448+
449+-- | @Right . toStrict@
450+instance MimeUnrender OctetStream BS.ByteString where
451+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
452+
397453note :: e -> Maybe a -> Either e a
398−note e = maybe (Left e) Right
454+note e Nothing = Left e
455+note _ (Just a) = Right a
399456
400457fmapL :: (e -> e') -> Either e a -> Either e' a
401458fmapL _ (Right a) = Right a
402459fmapL f (Left e) = Left (f e)
403460
404−builderToText :: Builder.Builder -> T.Text
405−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
461+builderToText :: BB.Builder -> T.Text
462+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
406463
407464escape :: T.Text -> T.Text
408−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
465+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece
src/Servant/Reflex.hs+284−56
@@ -1,13 +1,18 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
5+{-# LANGUAGE ExtendedDefaultRules #-}
46{-# LANGUAGE FlexibleContexts #-}
57{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE FunctionalDependencies #-}
69{-# LANGUAGE GeneralizedNewtypeDeriving #-}
710{-# LANGUAGE InstanceSigs #-}
11+{-# LANGUAGE LambdaCase #-}
812{-# LANGUAGE MultiParamTypeClasses #-}
913{-# LANGUAGE OverloadedStrings #-}
1014{-# LANGUAGE PolyKinds #-}
15+{-# LANGUAGE RecordWildCards #-}
1116{-# LANGUAGE ScopedTypeVariables #-}
1217{-# LANGUAGE TupleSections #-}
1318{-# LANGUAGE TypeFamilies #-}
@@ -27,6 +32,7 @@ module Servant.Reflex
2732 , clientWithOpts
2833 , clientWithRoute
2934 , BuildHeaderKeysTo(..)
35+ , GHCJS'MimeRender(..)
3036 , toHeaders
3137 , HasClient
3238 , Client
@@ -36,54 +42,101 @@ module Servant.Reflex
3642
3743------------------------------------------------------------------------------
3844import Control.Applicative
39−import Data.Monoid ((<>))
40−import qualified Data.Set as Set
41−import qualified Data.Text.Encoding as E
42−import Data.CaseInsensitive (mk)
45+import qualified Data.ByteString as BS
46+import qualified Data.ByteString.Lazy as BL
47+import Data.CaseInsensitive (mk)
4348import Data.Functor.Identity
44−import Data.Proxy (Proxy (..))
45−import qualified Data.Map as Map
46−import Data.Text (Text)
47−import qualified Data.Text as T
48−import GHC.Exts (Constraint)
49−import GHC.TypeLits (KnownSymbol, symbolVal)
50−import Servant.API ((:<|>)(..),(:>), BasicAuth,
51− BasicAuthData, BuildHeadersTo(..),
52− Capture, contentType, Header,
53− Headers(..), HttpVersion, IsSecure,
54− MimeRender(..), MimeUnrender,
55− NoContent, QueryFlag, QueryParam,
56− QueryParams, Raw, ReflectMethod(..),
57− RemoteHost, ReqBody,
58− ToHttpApiData(..), Vault, Verb)
59−import qualified Servant.Auth as Auth
60−
61−import Reflex.Dom.Core (Dynamic, Event, Reflex,
62− XhrRequest(..),
63− XhrResponseHeaders(..),
64− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
65− leftmost, performRequestsAsync,
66− )
49+import Data.Kind (Type)
50+import qualified Data.Map as Map
51+import Data.Monoid ((<>))
52+import Data.Proxy (Proxy (..))
53+import qualified Data.Set as Set
54+import Data.Text (Text)
55+import qualified Data.Text as T
56+import qualified Data.Text.Encoding as E
57+import qualified Data.Text.Lazy as TL
58+import GHC.Exts (Constraint)
59+import GHC.TypeLits (KnownSymbol,
60+ symbolVal)
61+import GHCJS.DOM.Types (Blob)
62+import Servant.API ((:<|>) (..),
63+ (:>),
64+ Accept (..),
65+ BasicAuth,
66+ BasicAuthData,
67+ BuildHeadersTo (..),
68+ Capture,
69+ FormUrlEncoded,
70+ Header,
71+ Headers (..),
72+ HttpVersion,
73+ IsSecure,
74+ JSON,
75+ MimeRender (..),
76+ NoContent,
77+ OctetStream,
78+ PlainText,
79+ QueryFlag,
80+ QueryParam,
81+ QueryParams,
82+ Raw,
83+ ReflectMethod (..),
84+ RemoteHost,
85+ ReqBody,
86+ ToHttpApiData (..),
87+ Vault, Verb,
88+ contentType)
89+import qualified Servant.Auth as Auth
90+
91+import Reflex.Dom.Core (Dynamic,
92+ Event,
93+ IsXhrPayload,
94+ Reflex,
95+ XhrRequest (..),
96+ XhrResponse (..),
97+ XhrResponseHeaders (..),
98+ attachPromptlyDynWith,
99+ constDyn,
100+ ffor,
101+ fmapMaybe,
102+ leftmost,
103+ performRequestsAsync)
67104------------------------------------------------------------------------------
68−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
69− showBaseUrl,
70− SupportsServantReflex)
71−import Servant.Common.Req (ClientOptions(..),
72− defaultClientOptions,
73− Req, ReqResult(..), QParam(..),
74− QueryPart(..), addHeader, authData,
75− defReq, evalResponse, prependToPathParts,
76− -- performRequestCT,
77− performRequestsCT,
78− -- performRequestNoBody,
79− performRequestsNoBody,
80− performSomeRequestsAsync,
81− qParamToQueryPart, reqBody,
82− reqSuccess, reqFailure,
83− reqMethod, respHeaders,
84− response,
85− reqTag,
86− qParams, withCredentials)
105+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
106+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,
107+ Throwing,
108+ ThrowingNonterminal,
109+ Throws)
110+import Servant.Common.BaseUrl (BaseUrl (..),
111+ Scheme (..),
112+ SupportsServantReflex,
113+ baseUrlWidget,
114+ showBaseUrl)
115+import Servant.Common.Req (ClientOptions (..),
116+ MimeUnrender (..),
117+ QParam (..),
118+ QueryPart (..),
119+ Req (..),
120+ ReqResult (..),
121+ addHeader,
122+ authData,
123+ defReq,
124+ defaultClientOptions,
125+ evalResponse,
126+ performRequestsCT,
127+ performRequestsNoBody,
128+ performSomeRequestsAsync,
129+ prependToPathParts,
130+ qParamToQueryPart,
131+ qParams,
132+ reqBody,
133+ reqFailure,
134+ reqMethod,
135+ reqSuccess,
136+ reqTag,
137+ respHeaders,
138+ response,
139+ withCredentials)
87140
88141
89142-- * Accessing APIs as a Client
@@ -124,8 +177,8 @@ clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
124177-- | This class lets us define how each API combinator
125178-- influences the creation of an HTTP request. It's mostly
126179-- an internal class, you can just use 'client'.
127−class HasClient t m layout (tag :: *) where
128− type Client t m layout tag :: *
180+class HasClient t m layout (tag :: Type) where
181+ type Client t m layout tag :: Type
129182 clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
130183
131184
@@ -461,22 +514,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
461514-- > where host = BaseUrl Http "localhost" 8080
462515-- > -- then you can just use "addBook" to query that endpoint
463516
464−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
465− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
517+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
518+ HasClient t m sublayout tag, Reflex t)
519+ => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where
466520
467521 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
468− Dynamic t (Either Text a) -> Client t m sublayout tag
522+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
469523
470− clientWithRoute Proxy q t req baseurl opts body =
524+ clientWithRoute Proxy q t Req{..} baseurl opts body =
471525 clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
472− where req' = req { reqBody = bodyBytesCT }
526+ where req' = Req { reqBody = Just $ (fmap . fmap)
527+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
528+ , ..}
473529 ctProxy = Proxy :: Proxy ct
530+ atProxy = Proxy :: Proxy a
474531 ctString = T.pack $ show $ contentType ctProxy
475− bodyBytesCT = Just $ (fmap . fmap)
476− (\b -> (mimeRender ctProxy b, ctString))
477− body
478532
533+class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
534+ type ToConvert ctype a :: Type
535+ type ToConvert ctype a = a
536+
537+ type ToSend ctype a :: Type
538+ type ToSend ctype a = BS.ByteString
539+
540+ ghcjsMimeRender
541+ :: IsXhrPayload (ToSend ctype a)
542+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
543+ default ghcjsMimeRender
544+ :: (MimeRender ctype a,
545+ MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)
546+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
547+ ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
548+
549+instance MimeRender JSON x => GHCJS'MimeRender JSON x
550+
551+instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
552+
553+instance GHCJS'MimeRender OctetStream BL.ByteString where
554+ type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob
555+ type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob
556+ ghcjsMimeRender _ _ = \case Left bl -> Left $ BL.toStrict bl; Right x -> Right x
557+
558+instance GHCJS'MimeRender PlainText String where
559+ type ToSend PlainText String = Text
560+ ghcjsMimeRender _ _ = T.pack
561+
562+instance GHCJS'MimeRender PlainText Text where
563+ type ToSend PlainText Text = Text
564+ ghcjsMimeRender _ _ = id
479565
566+instance GHCJS'MimeRender PlainText TL.Text where
567+ type ToSend PlainText TL.Text = Text
568+ ghcjsMimeRender _ _ = TL.toStrict
569+
570+instance GHCJS'MimeRender PlainText BL.ByteString where
571+ type ToSend PlainText BL.ByteString = BS.ByteString
572+ ghcjsMimeRender _ _ = BL.toStrict
573+
574+instance GHCJS'MimeRender PlainText BS.ByteString where
575+ ghcjsMimeRender _ _ = id
480576
481577-- | Make the querying function append @path@ to the request path.
482578instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
@@ -571,3 +667,135 @@ type family HasCookieAuth xs :: Constraint where
571667
572668class CookieAuthNotEnabled
573669
670+{- servant-checked-exceptions
671+~~~~~~~~~~~~~~~~~~~~~
672+-}
673+
674+-- | Change a 'Throws' into 'Throwing'.
675+instance (HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where
676+ type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag
677+
678+ clientWithRoute
679+ :: Proxy (Throws e :> api)
680+ -> Proxy m
681+ -> Proxy tag
682+ -> Req t
683+ -> Dynamic t BaseUrl
684+ -> ClientOptions
685+ -> Client t m (Throwing '[e] :> api) tag
686+ clientWithRoute _ = clientWithRoute (Proxy :: Proxy (Throwing '[e] :> api))
687+
688+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
689+-- but returning an @'Envelope' es@.
690+instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>
691+ HasClient t m (Throwing es :> Verb method status ctypes a) tag where
692+
693+ type Client t m (Throwing es :> Verb method status ctypes a) tag =
694+ Client t m (Verb method status ctypes (Envelope es a)) tag
695+
696+ clientWithRoute
697+ :: Proxy (Throwing es :> Verb method status ctypes a)
698+ -> Proxy m
699+ -> Proxy tag
700+ -> Req t
701+ -> Dynamic t BaseUrl
702+ -> ClientOptions
703+ -> Client t m (Verb method status ctypes (Envelope es a)) tag
704+ clientWithRoute Proxy =
705+ clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
706+
707+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
708+-- but returning an @'Envelope' \'[]@.
709+instance (HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>
710+ HasClient t m (NoThrow :> Verb method status ctypes a) tag where
711+
712+ type Client t m (NoThrow :> Verb method status ctypes a) tag =
713+ Client t m (Verb method status ctypes (Envelope '[] a)) tag
714+
715+ clientWithRoute
716+ :: Proxy (NoThrow :> Verb method status ctypes a)
717+ -> Proxy m
718+ -> Proxy tag
719+ -> Req t
720+ -> Dynamic t BaseUrl
721+ -> ClientOptions
722+ -> Client t m (Verb method status ctypes (Envelope '[] a)) tag
723+ clientWithRoute Proxy =
724+ clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
725+
726+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
727+-- branch of the API.
728+instance HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag =>
729+ HasClient t m (Throwing es :> (api1 :<|> api2)) tag where
730+
731+ type Client t m (Throwing es :> (api1 :<|> api2)) tag =
732+ Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
733+
734+ clientWithRoute
735+ :: Proxy (Throwing es :> (api1 :<|> api2))
736+ -> Proxy m
737+ -> Proxy tag
738+ -> Req t
739+ -> Dynamic t BaseUrl
740+ -> ClientOptions
741+ -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
742+ clientWithRoute _ =
743+ clientWithRoute (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
744+
745+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the
746+-- API.
747+instance HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag =>
748+ HasClient t m (NoThrow :> (api1 :<|> api2)) tag where
749+
750+ type Client t m (NoThrow :> (api1 :<|> api2)) tag =
751+ Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
752+
753+ clientWithRoute
754+ :: Proxy (NoThrow :> (api1 :<|> api2))
755+ -> Proxy m
756+ -> Proxy tag
757+ -> Req t
758+ -> Dynamic t BaseUrl
759+ -> ClientOptions
760+ -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
761+ clientWithRoute _ =
762+ clientWithRoute (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))
763+
764+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
765+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
766+-- combinator, push it down so it is closer to the 'Verb'.
767+instance HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag =>
768+ HasClient t m (Throwing es :> api :> apis) tag where
769+
770+ type Client t m (Throwing es :> api :> apis) tag =
771+ Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
772+
773+ clientWithRoute
774+ :: Proxy (Throwing es :> api :> apis)
775+ -> Proxy m
776+ -> Proxy tag
777+ -> Req t
778+ -> Dynamic t BaseUrl
779+ -> ClientOptions
780+ -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
781+ clientWithRoute _ =
782+ clientWithRoute (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))
783+
784+-- | When 'NoThrow' comes before any other combinator, push it down so it is
785+-- closer to the 'Verb'.
786+instance HasClient t m (api :> NoThrow :> apis) tag =>
787+ HasClient t m (NoThrow :> api :> apis) tag where
788+
789+ type Client t m (NoThrow :> api :> apis) tag =
790+ Client t m (api :> NoThrow :> apis) tag
791+
792+ clientWithRoute
793+ :: Proxy (NoThrow :> api :> apis)
794+ -> Proxy m
795+ -> Proxy tag
796+ -> Req t
797+ -> Dynamic t BaseUrl
798+ -> ClientOptions
799+ -> Client t m (api :> NoThrow :> apis) tag
800+ clientWithRoute _ =
801+ clientWithRoute (Proxy :: Proxy (api :> NoThrow :> apis))
src/Servant/Reflex/Multi.hs+224−42
@@ -7,6 +7,7 @@
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE OverloadedStrings #-}
99{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE RecordWildCards #-}
1011{-# LANGUAGE ScopedTypeVariables #-}
1112{-# LANGUAGE TupleSections #-}
1213{-# LANGUAGE TypeFamilies #-}
@@ -37,44 +38,83 @@ module Servant.Reflex.Multi (
3738 ) where
3839
3940------------------------------------------------------------------------------
40−import Control.Applicative (liftA2)
41−import Data.Functor.Compose (Compose (..), getCompose)
42−import Data.Proxy (Proxy (..))
43−import qualified Data.Set as Set
44−import Data.Text (Text)
45−import qualified Data.Text as T
46−import qualified Data.Text.Encoding as E
47−import GHC.TypeLits (KnownSymbol, symbolVal)
48−import Servant.API ((:<|>) (..), (:>), BasicAuth,
49− BasicAuthData, BuildHeadersTo (..),
50− Capture, Header, Headers (..),
51− HttpVersion, IsSecure, MimeRender (..),
52− MimeUnrender, NoContent, QueryFlag,
53− QueryParam, QueryParams, Raw,
54− ReflectMethod (..), RemoteHost,
55− ReqBody, ToHttpApiData (..), Vault,
56− Verb, contentType)
57−
58−import Reflex.Dom.Core (Dynamic, Event, Reflex,
59− XhrRequest (..),
60− XhrResponseHeaders (..),
61− attachPromptlyDynWith, constDyn)
41+import Control.Applicative (liftA2)
42+import Data.Functor.Compose (Compose (..),
43+ getCompose)
44+import Data.Proxy (Proxy (..))
45+import qualified Data.Set as Set
46+import Data.Text (Text)
47+import qualified Data.Text as T
48+import qualified Data.Text.Encoding as E
49+import GHC.TypeLits (KnownSymbol,
50+ symbolVal)
51+import Servant.API ((:<|>) (..),
52+ (:>),
53+ BasicAuth,
54+ BasicAuthData,
55+ BuildHeadersTo (..),
56+ Capture,
57+ Header,
58+ Headers (..),
59+ HttpVersion,
60+ IsSecure,
61+ NoContent,
62+ QueryFlag,
63+ QueryParam,
64+ QueryParams,
65+ Raw,
66+ ReflectMethod (..),
67+ RemoteHost,
68+ ReqBody,
69+ ToHttpApiData (..),
70+ Vault, Verb,
71+ contentType)
72+
73+import Reflex.Dom.Core (Dynamic,
74+ Event,
75+ IsXhrPayload,
76+ Reflex,
77+ XhrRequest (..),
78+ XhrResponseHeaders (..),
79+ attachPromptlyDynWith,
80+ constDyn)
6281------------------------------------------------------------------------------
63−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
64− SupportsServantReflex)
65−import Servant.Common.Req (ClientOptions,
66− QParam (..), QueryPart (..), Req,
67− ReqResult (..), addHeader, authData,
68− defReq,
69− defaultClientOptions,
70− performRequestsCT,
71− performRequestsNoBody,
72− performSomeRequestsAsync,
73− prependToPathParts, qParamToQueryPart,
74− qParams, reqBody, reqFailure,
75− reqMethod, reqSuccess, reqSuccess',
76− respHeaders, response, withCredentials)
77−import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
82+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
83+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,
84+ Throwing,
85+ ThrowingNonterminal,
86+ Throws)
87+import Servant.Common.BaseUrl (BaseUrl (..),
88+ Scheme (..),
89+ SupportsServantReflex)
90+import Servant.Common.Req (ClientOptions,
91+ MimeUnrender,
92+ QParam (..),
93+ QueryPart (..),
94+ Req (..),
95+ ReqResult (..),
96+ SomeXhrRequest (..),
97+ addHeader,
98+ authData,
99+ defReq,
100+ defaultClientOptions,
101+ performRequestsCT,
102+ performRequestsNoBody,
103+ performSomeRequestsAsync,
104+ prependToPathParts,
105+ qParamToQueryPart,
106+ qParams,
107+ reqBody,
108+ reqFailure,
109+ reqMethod,
110+ reqSuccess,
111+ reqSuccess',
112+ respHeaders,
113+ response,
114+ withCredentials)
115+import Servant.Reflex (BuildHeaderKeysTo (..),
116+ GHCJS'MimeRender (..),
117+ toHeaders)
78118
79119
80120------------------------------------------------------------------------------
@@ -313,29 +353,31 @@ instance (SupportsServantReflex t m,
313353 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
314354 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
315355 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
316− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
356+ rawReqs''' = (fmap . fmap . fmap) (SomeXhrRequest . fmap Just) rawReqs''
357+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs'''
317358 return resps
318359 where
319360 aux (tag, Right r) = ResponseSuccess tag () r
320361 aux (tag, Left e) = RequestFailure tag e
321362
322363
323−instance (MimeRender ct a,
364+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
324365 HasClientMulti t m sublayout f tag,
325366 Reflex t,
326367 Applicative f)
327368 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
328369
329370 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
330− Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
371+ Dynamic t (f (Either Text (ToConvert ct a))) -> ClientMulti t m sublayout f tag
331372
332373 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
333374 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
334− where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
375+ where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }
335376 ctProxy = Proxy :: Proxy ct
377+ atProxy = Proxy :: Proxy a
336378 ctString = T.pack $ show $ contentType ctProxy
337379 bodyBytesCT b = Just $ (fmap . fmap)
338− (\b' -> (mimeRender ctProxy b', ctString))
380+ (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))
339381 b
340382 reqs' = liftA2 req' <$> bodies <*> reqs
341383
@@ -386,3 +428,143 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
386428 where
387429 req' a r = r { authData = Just (constDyn a) }
388430 reqs' = liftA2 req' <$> authdatas <*> reqs
431+
432+{- servant-checked-exceptions
433+~~~~~~~~~~~~~~~~~~~~~
434+-}
435+
436+-- | Change a 'Throws' into 'Throwing'.
437+instance (HasClientMulti t m (Throwing '[e] :> api) f tag) => HasClientMulti t m (Throws e :> api) f tag where
438+ type ClientMulti t m (Throws e :> api) f tag = ClientMulti t m (Throwing '[e] :> api) f tag
439+
440+ clientWithRouteMulti
441+ :: Proxy (Throws e :> api)
442+ -> Proxy m
443+ -> Proxy f
444+ -> Proxy tag
445+ -> Dynamic t (f (Req t))
446+ -> Dynamic t BaseUrl
447+ -> ClientOptions
448+ -> ClientMulti t m (Throwing '[e] :> api) f tag
449+ clientWithRouteMulti _ = clientWithRouteMulti (Proxy :: Proxy (Throwing '[e] :> api))
450+
451+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
452+-- but returning an @'Envelope' es@.
453+instance (HasClientMulti t m (Verb method status ctypes (Envelope es a)) f tag) =>
454+ HasClientMulti t m (Throwing es :> Verb method status ctypes a) f tag where
455+
456+ type ClientMulti t m (Throwing es :> Verb method status ctypes a) f tag =
457+ ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag
458+
459+ clientWithRouteMulti
460+ :: Proxy (Throwing es :> Verb method status ctypes a)
461+ -> Proxy m
462+ -> Proxy f
463+ -> Proxy tag
464+ -> Dynamic t (f (Req t))
465+ -> Dynamic t BaseUrl
466+ -> ClientOptions
467+ -> ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag
468+ clientWithRouteMulti Proxy =
469+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
470+
471+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
472+-- but returning an @'Envelope' \'[]@.
473+instance (HasClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag) =>
474+ HasClientMulti t m (NoThrow :> Verb method status ctypes a) f tag where
475+
476+ type ClientMulti t m (NoThrow :> Verb method status ctypes a) f tag =
477+ ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag
478+
479+ clientWithRouteMulti
480+ :: Proxy (NoThrow :> Verb method status ctypes a)
481+ -> Proxy m
482+ -> Proxy f
483+ -> Proxy tag
484+ -> Dynamic t (f (Req t))
485+ -> Dynamic t BaseUrl
486+ -> ClientOptions
487+ -> ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag
488+ clientWithRouteMulti Proxy =
489+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
490+
491+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
492+-- branch of the API.
493+instance HasClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag =>
494+ HasClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag where
495+
496+ type ClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag =
497+ ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag
498+
499+ clientWithRouteMulti
500+ :: Proxy (Throwing es :> (api1 :<|> api2))
501+ -> Proxy m
502+ -> Proxy f
503+ -> Proxy tag
504+ -> Dynamic t (f (Req t))
505+ -> Dynamic t BaseUrl
506+ -> ClientOptions
507+ -> ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag
508+ clientWithRouteMulti _ =
509+ clientWithRouteMulti (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
510+
511+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the
512+-- API.
513+instance HasClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag =>
514+ HasClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag where
515+
516+ type ClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag =
517+ ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag
518+
519+ clientWithRouteMulti
520+ :: Proxy (NoThrow :> (api1 :<|> api2))
521+ -> Proxy m
522+ -> Proxy f
523+ -> Proxy tag
524+ -> Dynamic t (f (Req t))
525+ -> Dynamic t BaseUrl
526+ -> ClientOptions
527+ -> ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag
528+ clientWithRouteMulti _ =
529+ clientWithRouteMulti (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))
530+
531+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
532+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
533+-- combinator, push it down so it is closer to the 'Verb'.
534+instance HasClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag =>
535+ HasClientMulti t m (Throwing es :> api :> apis) f tag where
536+
537+ type ClientMulti t m (Throwing es :> api :> apis) f tag =
538+ ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag
539+
540+ clientWithRouteMulti
541+ :: Proxy (Throwing es :> api :> apis)
542+ -> Proxy m
543+ -> Proxy f
544+ -> Proxy tag
545+ -> Dynamic t (f (Req t))
546+ -> Dynamic t BaseUrl
547+ -> ClientOptions
548+ -> ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag
549+ clientWithRouteMulti _ =
550+ clientWithRouteMulti (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))
551+
552+-- | When 'NoThrow' comes before any other combinator, push it down so it is
553+-- closer to the 'Verb'.
554+instance HasClientMulti t m (api :> NoThrow :> apis) f tag =>
555+ HasClientMulti t m (NoThrow :> api :> apis) f tag where
556+
557+ type ClientMulti t m (NoThrow :> api :> apis) f tag =
558+ ClientMulti t m (api :> NoThrow :> apis) f tag
559+
560+ clientWithRouteMulti
561+ :: Proxy (NoThrow :> api :> apis)
562+ -> Proxy m
563+ -> Proxy f
564+ -> Proxy tag
565+ -> Dynamic t (f (Req t))
566+ -> Dynamic t BaseUrl
567+ -> ClientOptions
568+ -> ClientMulti t m (api :> NoThrow :> apis) f tag
569+ clientWithRouteMulti _ =
570+ clientWithRouteMulti (Proxy :: Proxy (api :> NoThrow :> apis))