git.iko.soy/servant-reflex
on bdbcbfa help sign in
f76dbeb
swap
27 ahead, 21 behind
4 files changed+651−175
since splitsnapshots
unifiedsplit
servant-reflex.cabal+3−1 src/Servant/Common/Req.hs+134−78 src/Servant/Reflex.hs+290−54 src/Servant/Reflex/Multi.hs+224−42
servant-reflex.cabal+3−1
@@ -24,6 +24,7 @@ library
2424
2525 hs-source-dirs: src
2626 build-depends:
27+ aeson >= 0.11 && < 1.5,
2728 base >= 4.8 && < 5,
2829 bytestring >= 0.10 && < 0.11,
2930 case-insensitive >= 1.2.0.4 && < 1.3,
@@ -39,7 +40,8 @@ library
3940 reflex >= 0.5 && < 0.7,
4041 reflex-dom-core >= 0.4 && < 0.6,
4142 safe >= 0.3.9 && < 0.4,
42− servant >= 0.8 && < 0.15,
43+ servant >= 0.13 && < 0.16,
44+ servant-checked-exceptions >= 2.0 && < 2.2,
4345 servant-auth >= 0.2.1 && < 0.4,
4446 string-conversions >= 0.4 && < 0.5,
4547 text >= 1.2 && < 1.3,
src/Servant/Common/Req.hs+134−78
@@ -1,45 +1,66 @@
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)
15−import Control.Arrow ((&&&))
20+import Control.Applicative (liftA2, liftA3)
21+import Control.Arrow ((&&&))
1622import Control.Concurrent
17−import Control.Monad (join)
18−import Control.Monad.IO.Class (MonadIO, liftIO)
19−import Data.Bifunctor (first)
20−import qualified Data.ByteString.Builder as Builder
21−import qualified Data.ByteString.Lazy.Char8 as BL
22−import qualified Data.Map as Map
23−import Data.Maybe (catMaybes, fromMaybe)
23+import Control.Monad (join)
24+import Control.Monad.IO.Class (MonadIO, liftIO)
25+import Data.Aeson
26+import Data.Bifunctor (first)
27+import qualified Data.ByteString as BS
28+import qualified Data.ByteString.Builder as Builder
29+import Data.ByteString.Lazy (ByteString)
30+import qualified Data.ByteString.Lazy.Char8 as BL
2431import Data.Functor.Compose
25−import Data.Monoid ((<>))
26−import Data.Proxy (Proxy(..))
27−import Data.Text (Text)
28−import qualified Data.Text as T
29−import qualified Data.Text.Encoding as TE
30−import Data.Traversable (forM)
32+import qualified Data.JSString.Text as JS (lazyTextFromJSString)
33+import qualified Data.Map as Map
34+import Data.Maybe (catMaybes, fromMaybe)
35+import Data.Monoid ((<>))
36+import Data.Proxy (Proxy (..))
37+import Data.Text (Text)
38+import qualified Data.Text as T
39+import qualified Data.Text.Encoding as TE
40+import qualified Data.Text.Lazy as TL
41+import Data.Traversable (forM)
42+import qualified Language.Javascript.JSaddle as JS
3143import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
32−import qualified Network.URI as N
33−import Reflex.Dom.Core hiding (tag)
34−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
35− SupportsServantReflex)
36−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
37−import Web.HttpApiData (ToHttpApiData(..))
44+import qualified Network.URI as N
45+import Reflex.Dom.Core hiding (tag)
46+import Servant.API.ContentTypes (Accept, FormUrlEncoded,
47+ JSON, NoContent (..),
48+ OctetStream, PlainText)
49+import Servant.Common.BaseUrl (BaseUrl,
50+ SupportsServantReflex,
51+ showBaseUrl)
52+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
53+import Web.HttpApiData (ToHttpApiData (..))
3854-------------------------------------------------------------------------------
3955import Servant.API.BasicAuth
56+-------------------------------------------------------------------------------
4057
58+-- #ifndef __GHCJS__
59+-- jsonDecode :: JS.JSString -> Maybe a
60+-- jsonDecode = error "jsonDecode is only available in GHCJS"
61+-- #endif
4162
42−------------------------------------------------------------------------------
63+-----------------------------------------------------------------------------
4364-- | The result of a request event
4465data ReqResult tag a
4566 = ResponseSuccess tag a XhrResponse
@@ -140,18 +161,20 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
140161-------------------------------------------------------------------------------
141162-- The data structure used to build up request information while traversing
142163-- the shape of a servant API
143−data Req t = Req
164+data Req t = forall o. (IsXhrPayload o, Show o) => Req
144165 { reqMethod :: Text
145166 , reqPathParts :: [Dynamic t (Either Text Text)]
146167 , qParams :: [(Text, QueryPart t)]
147− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
168+ , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
148169 , headers :: [(Text, Dynamic t (Either Text Text))]
149170 , respHeaders :: XhrResponseHeaders
150171 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
151172 }
152173
174+data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
175+
153176defReq :: Req t
154−defReq = Req "GET" [] [] Nothing [] def Nothing
177+defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
155178
156179prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
157180prependToPathParts p req =
@@ -160,14 +183,13 @@ prependToPathParts p req =
160183addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
161184addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
162185
163−
164186reqToReflexRequest
165− :: forall t. Reflex t
166− => Text
167− -> Dynamic t BaseUrl
168− -> Req t
169− -> Dynamic t (Either Text (XhrRequest XhrPayload))
170−reqToReflexRequest reqMeth reqHost req =
187+ :: forall t. Reflex t
188+ => Text
189+ -> Dynamic t BaseUrl
190+ -> Req t
191+ -> Dynamic t (Either Text SomeXhrRequest)
192+reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (Either Text (o, Text)))) _ _ _) =
171193 let t :: Dynamic t [Either Text Text]
172194 t = sequence $ reverse $ reqPathParts req
173195
@@ -219,33 +241,33 @@ reqToReflexRequest reqMeth reqHost req =
219241 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
220242
221243 mkConfigBody :: Either Text [(Text,Text)]
222− -> (Either Text (BL.ByteString, Text))
223− -> Either Text (XhrRequestConfig XhrPayload)
244+ -> (Either Text (o, Text))
245+ -> Either Text (XhrRequestConfig (Maybe o))
224246 mkConfigBody ehs rb = case (ehs, rb) of
225247 (_, Left e) -> Left e
226248 (Left e, _) -> Left e
227249 (Right hs, Right (bBytes, bCT)) ->
228250 Right $ XhrRequestConfig
229− { _xhrRequestConfig_sendData = bytesToPayload bBytes
251+ { _xhrRequestConfig_sendData = Just bBytes
230252 , _xhrRequestConfig_headers =
231253 Map.insert "Content-Type" bCT (Map.fromList hs)
232254 , _xhrRequestConfig_user = Nothing
233255 , _xhrRequestConfig_password = Nothing
234− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
256+ , _xhrRequestConfig_responseType = Nothing
235257 , _xhrRequestConfig_withCredentials = False
236258 , _xhrRequestConfig_responseHeaders = def
237259 }
238260
239− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
240− xhrOpts = case reqBody req of
261+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
262+ xhrOpts = case reqBody of
241263 Nothing -> ffor xhrHeaders $ \case
242264 Left e -> Left e
243265 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
244266 , _xhrRequestConfig_user = Nothing
245267 , _xhrRequestConfig_password = Nothing
246− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
247− , _xhrRequestConfig_sendData = ""
268+ , _xhrRequestConfig_responseType = Nothing
248269 , _xhrRequestConfig_withCredentials = False
270+ , _xhrRequestConfig_sendData = Nothing
249271 }
250272 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
251273
@@ -259,10 +281,10 @@ reqToReflexRequest reqMeth reqHost req =
259281 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
260282 -> Dynamic t (Either Text (XhrRequestConfig x))
261283 addAuth xhr = case authData req of
262− Nothing -> xhr
284+ Nothing -> xhr
263285 Just auth -> liftA2 mkAuth auth xhr
264286
265− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
287+ xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
266288
267289 in xhrReq
268290
@@ -271,8 +293,14 @@ reqToReflexRequest reqMeth reqHost req =
271293displayHttpRequest :: Text -> Text
272294displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
273295
296+instance IsXhrPayload o => IsXhrPayload (Maybe o) where
297+ sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)
298+
299+instance (IsXhrPayload o, IsXhrPayload o') => IsXhrPayload (Either o o') where
300+ sendXhrPayload xhr = either (sendXhrPayload xhr) (sendXhrPayload xhr)
301+
274302-- | This function performs the request
275−performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
303+performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
276304 => Text
277305 -> Dynamic t (f (Req t))
278306 -> Dynamic t BaseUrl
@@ -285,6 +313,7 @@ performRequests reqMeth rs reqHost opts trigger = do
285313 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
286314
287315 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
316+ reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))
288317 reqs = attachPromptlyDynWith
289318 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
290319
@@ -300,32 +329,31 @@ performSomeRequestsAsync
300329 HasWebView (Performable m),
301330 PerformEvent t m,
302331 TriggerEvent t m,
303− Traversable f,
304− IsXhrPayload a,
305− Show a
332+ Traversable f
306333 )
307334 => ClientOptions
308− -> Event t (f (Either Text (XhrRequest a)))
335+ -> Event t (f (Either Text SomeXhrRequest))
309336 -> m (Event t (f (Either Text XhrResponse)))
310−performSomeRequestsAsync opts =
311− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
337+performSomeRequestsAsync opts sxhr =
338+ performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr
312339
313340
314341------------------------------------------------------------------------------
315342-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
316343-- that accepts 'f (Either e (XhrRequestb))' events
317344performSomeRequestsAsync'
318− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
345+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
319346 => ClientOptions
320− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
321− -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
347+ -> (forall b. IsXhrPayload b => XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
348+ -> Event t (Performable m (f (Either Text SomeXhrRequest)))
349+ -> m (Event t (f (Either Text a)))
322350performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
323351 rs <- hrs
324352 resps <- forM rs $ \r -> case r of
325353 Left e -> do
326354 resp <- liftIO $ newMVar (Left e)
327355 return resp
328− Right r' -> do
356+ Right (SomeXhrRequest r') -> do
329357 resp <- liftIO newEmptyMVar
330358 r'' <- liftJSM $ (optsRequestFixup opts) r'
331359 _ <- newXhr r'' $ liftIO . putMVar resp . Right
@@ -334,12 +362,6 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
334362 return ()
335363
336364
337−
338−type XhrPayload = T.Text
339−bytesToPayload :: BL.ByteString -> XhrPayload
340−bytesToPayload = TE.decodeUtf8 . BL.toStrict
341−
342−
343365performRequestsCT
344366 :: (SupportsServantReflex t m,
345367 MimeUnrender ct a, Traversable f)
@@ -352,15 +374,14 @@ performRequestsCT
352374 -> m (Event t (f (ReqResult tag a)))
353375performRequestsCT ct reqMeth reqs reqHost opts trigger = do
354376 resps <- performRequests reqMeth reqs reqHost opts trigger
355− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
356− first T.pack .
357− mimeUnrender ct $
358− BL.fromStrict x
359− decodeResp _ = Left "No body"
377+ let decodeResp x = first T.pack
378+ . mimeUnrender ct
379+ . JS.textToJSString
380+ =<< note "No body text" (_xhrResponse_responseText x)
360381 return $ fmap
361382 (\(t,rs) -> ffor rs $ \r -> case r of
362383 Left e -> RequestFailure t e
363− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
384+ Right g -> evalResponse decodeResp (t,g)
364385 )
365386 resps
366387
@@ -387,7 +408,7 @@ evalResponse
387408 :: (XhrResponse -> Either Text a)
388409 -> (tag, XhrResponse)
389410 -> ReqResult tag a
390−evalResponse decode (tag, xhr) =
411+evalResponse decodeRes (tag, xhr) =
391412 let status = _xhrResponse_status xhr
392413 okStatus = status >= 200 && status < 400
393414 errMsg = fromMaybe
@@ -398,7 +419,7 @@ evalResponse decode (tag, xhr) =
398419 then either
399420 (\e -> ResponseFailure tag e xhr)
400421 (\v -> ResponseSuccess tag v xhr)
401− (decode xhr)
422+ (decodeRes xhr)
402423 else ResponseFailure tag errMsg xhr
403424 in respPayld
404425
@@ -415,8 +436,44 @@ fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text),
415436fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
416437
417438
439+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
440+-- the second argument expects a JSString instead of ByteString.
441+-- This can lead to better performance ghcjs.
442+class Accept contentType => MimeUnrender contentType a where
443+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
444+
445+instance FromJSON a => MimeUnrender JSON a where
446+ mimeUnrender _ = note "Failed to decode response" . jsonDecode
447+
448+-- | @urlDecodeAsForm@
449+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
450+-- holds if every element of x is non-null (i.e., not @("", "")@)
451+instance FromForm a => MimeUnrender FormUrlEncoded a where
452+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . Builder.toLazyByteString . TE.encodeUtf8Builder . JS.textFromJSString
453+
454+-- | @left show . TextL.decodeUtf8'@
455+instance MimeUnrender PlainText TL.Text where
456+ mimeUnrender _ = pure . JS.lazyTextFromJSString
457+
458+-- | @left show . TextS.decodeUtf8' . toStrict@
459+instance MimeUnrender PlainText T.Text where
460+ mimeUnrender _ = pure . JS.textFromJSString
461+
462+-- | @Right . BC.unpack@
463+instance MimeUnrender PlainText String where
464+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString
465+
466+-- | @Right . id@
467+instance MimeUnrender OctetStream ByteString where
468+ mimeUnrender _ = pure . Builder.toLazyByteString . TE.encodeUtf8Builder . JS.textFromJSString
469+
470+-- | @Right . toStrict@
471+instance MimeUnrender OctetStream BS.ByteString where
472+ mimeUnrender _ = pure . TE.encodeUtf8 . JS.textFromJSString
473+
418474note :: e -> Maybe a -> Either e a
419−note e = maybe (Left e) Right
475+note e Nothing = Left e
476+note _ (Just a) = Right a
420477
421478fmapL :: (e -> e') -> Either e a -> Either e' a
422479fmapL _ (Right a) = Right a
@@ -427,4 +484,3 @@ builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
427484
428485escape :: T.Text -> T.Text
429486escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
430−
src/Servant/Reflex.hs+290−54
@@ -1,14 +1,19 @@
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 #-}
1115{-# LANGUAGE Rank2Types #-}
16+{-# LANGUAGE RecordWildCards #-}
1217{-# LANGUAGE ScopedTypeVariables #-}
1318{-# LANGUAGE TupleSections #-}
1419{-# LANGUAGE TypeFamilies #-}
@@ -30,6 +35,7 @@ module Servant.Reflex
3035 , clientWithRoute
3136 , clientWithRouteAndResultHandler
3237 , BuildHeaderKeysTo(..)
38+ , GHCJS'MimeRender(..)
3339 , toHeaders
3440 , HasClient
3541 , Client
@@ -39,54 +45,101 @@ module Servant.Reflex
3945
4046------------------------------------------------------------------------------
4147import Control.Applicative
42−import Data.Monoid ((<>))
43−import qualified Data.Set as Set
44−import qualified Data.Text.Encoding as E
45−import Data.CaseInsensitive (mk)
48+import qualified Data.ByteString as BS
49+import qualified Data.ByteString.Lazy as BL
50+import Data.CaseInsensitive (mk)
4651import Data.Functor.Identity
47−import Data.Proxy (Proxy (..))
48−import qualified Data.Map as Map
49−import Data.Text (Text)
50−import qualified Data.Text as T
51−import GHC.Exts (Constraint)
52−import GHC.TypeLits (KnownSymbol, symbolVal)
53−import Servant.API ((:<|>)(..),(:>), BasicAuth,
54− BasicAuthData, BuildHeadersTo(..),
55− Capture, contentType, Header,
56− Headers(..), HttpVersion, IsSecure,
57− MimeRender(..), MimeUnrender,
58− NoContent, QueryFlag, QueryParam,
59− QueryParams, Raw, ReflectMethod(..),
60− RemoteHost, ReqBody,
61− ToHttpApiData(..), Vault, Verb)
62−import qualified Servant.Auth as Auth
63−
64−import Reflex.Dom.Core (Dynamic, Event, Reflex,
65− XhrRequest(..),
66− XhrResponseHeaders(..),
67− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
68− leftmost, performRequestsAsync,
69− )
52+import Data.Kind (Type)
53+import qualified Data.Map as Map
54+import Data.Monoid ((<>))
55+import Data.Proxy (Proxy (..))
56+import qualified Data.Set as Set
57+import Data.Text (Text)
58+import qualified Data.Text as T
59+import qualified Data.Text.Encoding as E
60+import qualified Data.Text.Lazy as TL
61+import GHC.Exts (Constraint)
62+import GHC.TypeLits (KnownSymbol,
63+ symbolVal)
64+import GHCJS.DOM.Types (Blob)
65+import Servant.API ((:<|>) (..),
66+ (:>),
67+ Accept (..),
68+ BasicAuth,
69+ BasicAuthData,
70+ BuildHeadersTo (..),
71+ Capture,
72+ FormUrlEncoded,
73+ Header,
74+ Headers (..),
75+ HttpVersion,
76+ IsSecure,
77+ JSON,
78+ MimeRender (..),
79+ NoContent,
80+ OctetStream,
81+ PlainText,
82+ QueryFlag,
83+ QueryParam,
84+ QueryParams,
85+ Raw,
86+ ReflectMethod (..),
87+ RemoteHost,
88+ ReqBody,
89+ ToHttpApiData (..),
90+ Vault, Verb,
91+ contentType)
92+import qualified Servant.Auth as Auth
93+
94+import Reflex.Dom.Core (Dynamic,
95+ Event,
96+ IsXhrPayload,
97+ Reflex,
98+ XhrRequest (..),
99+ XhrResponse (..),
100+ XhrResponseHeaders (..),
101+ attachPromptlyDynWith,
102+ constDyn,
103+ ffor,
104+ fmapMaybe,
105+ leftmost,
106+ performRequestsAsync)
70107------------------------------------------------------------------------------
71−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
72− showBaseUrl,
73− SupportsServantReflex)
74−import Servant.Common.Req (ClientOptions(..),
75− defaultClientOptions,
76− Req, ReqResult(..), QParam(..),
77− QueryPart(..), addHeader, authData,
78− defReq, evalResponse, prependToPathParts,
79− -- performRequestCT,
80− performRequestsCT,
81− -- performRequestNoBody,
82− performRequestsNoBody,
83− performSomeRequestsAsync,
84− qParamToQueryPart, reqBody,
85− reqSuccess, reqFailure,
86− reqMethod, respHeaders,
87− response,
88− reqTag,
89− qParams, withCredentials)
108+import Servant.Checked.Exceptions.Internal (Envelope)
109+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,
110+ Throwing,
111+ ThrowingNonterminal,
112+ Throws)
113+import Servant.Common.BaseUrl (BaseUrl (..),
114+ Scheme (..),
115+ SupportsServantReflex,
116+ baseUrlWidget,
117+ showBaseUrl)
118+import Servant.Common.Req (ClientOptions (..),
119+ MimeUnrender (..),
120+ QParam (..),
121+ QueryPart (..),
122+ Req (..),
123+ ReqResult (..),
124+ addHeader,
125+ authData,
126+ defReq,
127+ defaultClientOptions,
128+ evalResponse,
129+ performRequestsCT,
130+ performRequestsNoBody,
131+ performSomeRequestsAsync,
132+ prependToPathParts,
133+ qParamToQueryPart,
134+ qParams,
135+ reqBody,
136+ reqFailure,
137+ reqMethod,
138+ reqSuccess,
139+ reqTag,
140+ respHeaders,
141+ response,
142+ withCredentials)
90143
91144
92145-- * Accessing APIs as a Client
@@ -494,22 +547,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
494547-- > where host = BaseUrl Http "localhost" 8080
495548-- > -- then you can just use "addBook" to query that endpoint
496549
497−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
498− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
550+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
551+ HasClient t m sublayout tag, Reflex t)
552+ => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where
499553
500554 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
501− Dynamic t (Either Text a) -> Client t m sublayout tag
555+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
502556
503− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
557+ clientWithRouteAndResultHandler Proxy q t Req{..} baseurl opts wrap body =
504558 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
505− where req' = req { reqBody = bodyBytesCT }
559+ where req' = Req { reqBody = Just $ (fmap . fmap)
560+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
561+ , ..}
506562 ctProxy = Proxy :: Proxy ct
563+ atProxy = Proxy :: Proxy a
507564 ctString = T.pack $ show $ contentType ctProxy
508− bodyBytesCT = Just $ (fmap . fmap)
509− (\b -> (mimeRender ctProxy b, ctString))
510− body
511565
566+class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
567+ type ToConvert ctype a :: Type
568+ type ToConvert ctype a = a
569+
570+ type ToSend ctype a :: Type
571+ type ToSend ctype a = BS.ByteString
572+
573+ ghcjsMimeRender
574+ :: IsXhrPayload (ToSend ctype a)
575+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
576+ default ghcjsMimeRender
577+ :: (MimeRender ctype a,
578+ MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)
579+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
580+ ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
581+
582+instance MimeRender JSON x => GHCJS'MimeRender JSON x
583+
584+instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
585+
586+instance GHCJS'MimeRender OctetStream BL.ByteString where
587+ type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob
588+ type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob
589+ ghcjsMimeRender _ _ = \case Left bl -> Left $ BL.toStrict bl; Right x -> Right x
512590
591+instance GHCJS'MimeRender PlainText String where
592+ type ToSend PlainText String = Text
593+ ghcjsMimeRender _ _ = T.pack
594+
595+instance GHCJS'MimeRender PlainText Text where
596+ type ToSend PlainText Text = Text
597+ ghcjsMimeRender _ _ = id
598+
599+instance GHCJS'MimeRender PlainText TL.Text where
600+ type ToSend PlainText TL.Text = Text
601+ ghcjsMimeRender _ _ = TL.toStrict
602+
603+instance GHCJS'MimeRender PlainText BL.ByteString where
604+ type ToSend PlainText BL.ByteString = BS.ByteString
605+ ghcjsMimeRender _ _ = BL.toStrict
606+
607+instance GHCJS'MimeRender PlainText BS.ByteString where
608+ ghcjsMimeRender _ _ = id
513609
514610-- | Make the querying function append @path@ to the request path.
515611instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
@@ -604,3 +700,143 @@ type family HasCookieAuth xs :: Constraint where
604700
605701class CookieAuthNotEnabled
606702
703+{- servant-checked-exceptions
704+~~~~~~~~~~~~~~~~~~~~~
705+-}
706+
707+-- | Change a 'Throws' into 'Throwing'.
708+instance (Monad m, HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where
709+ type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag
710+
711+ clientWithRouteAndResultHandler
712+ :: Proxy (Throws e :> api)
713+ -> Proxy m
714+ -> Proxy tag
715+ -> Req t
716+ -> Dynamic t BaseUrl
717+ -> ClientOptions
718+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
719+ -> Client t m (Throwing '[e] :> api) tag
720+ clientWithRouteAndResultHandler _ = clientWithRouteAndResultHandler (Proxy :: Proxy (Throwing '[e] :> api))
721+
722+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
723+-- but returning an @'Envelope' es@.
724+instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>
725+ HasClient t m (Throwing es :> Verb method status ctypes a) tag where
726+
727+ type Client t m (Throwing es :> Verb method status ctypes a) tag =
728+ Client t m (Verb method status ctypes (Envelope es a)) tag
729+
730+ clientWithRouteAndResultHandler
731+ :: Proxy (Throwing es :> Verb method status ctypes a)
732+ -> Proxy m
733+ -> Proxy tag
734+ -> Req t
735+ -> Dynamic t BaseUrl
736+ -> ClientOptions
737+ -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))
738+ -> Client t m (Verb method status ctypes (Envelope es a)) tag
739+ clientWithRouteAndResultHandler Proxy =
740+ clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
741+
742+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
743+-- but returning an @'Envelope' \'[]@.
744+instance (Monad m, HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>
745+ HasClient t m (NoThrow :> Verb method status ctypes a) tag where
746+
747+ type Client t m (NoThrow :> Verb method status ctypes a) tag =
748+ Client t m (Verb method status ctypes (Envelope '[] a)) tag
749+
750+ clientWithRouteAndResultHandler
751+ :: Proxy (NoThrow :> Verb method status ctypes a)
752+ -> Proxy m
753+ -> Proxy tag
754+ -> Req t
755+ -> Dynamic t BaseUrl
756+ -> ClientOptions
757+ -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))
758+ -> Client t m (Verb method status ctypes (Envelope '[] a)) tag
759+ clientWithRouteAndResultHandler Proxy =
760+ clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
761+
762+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
763+-- branch of the API.
764+instance (Monad m, HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag) =>
765+ HasClient t m (Throwing es :> (api1 :<|> api2)) tag where
766+
767+ type Client t m (Throwing es :> (api1 :<|> api2)) tag =
768+ Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
769+
770+ clientWithRouteAndResultHandler
771+ :: Proxy (Throwing es :> (api1 :<|> api2))
772+ -> Proxy m
773+ -> Proxy tag
774+ -> Req t
775+ -> Dynamic t BaseUrl
776+ -> ClientOptions
777+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
778+ -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
779+ clientWithRouteAndResultHandler _ =
780+ clientWithRouteAndResultHandler (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
781+
782+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the
783+-- API.
784+instance (Monad m, HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag) =>
785+ HasClient t m (NoThrow :> (api1 :<|> api2)) tag where
786+
787+ type Client t m (NoThrow :> (api1 :<|> api2)) tag =
788+ Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
789+
790+ clientWithRouteAndResultHandler
791+ :: Proxy (NoThrow :> (api1 :<|> api2))
792+ -> Proxy m
793+ -> Proxy tag
794+ -> Req t
795+ -> Dynamic t BaseUrl
796+ -> ClientOptions
797+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
798+ -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
799+ clientWithRouteAndResultHandler _ =
800+ clientWithRouteAndResultHandler (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))
801+
802+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
803+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
804+-- combinator, push it down so it is closer to the 'Verb'.
805+instance (Monad m, HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag) =>
806+ HasClient t m (Throwing es :> api :> apis) tag where
807+
808+ type Client t m (Throwing es :> api :> apis) tag =
809+ Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
810+
811+ clientWithRouteAndResultHandler
812+ :: Proxy (Throwing es :> api :> apis)
813+ -> Proxy m
814+ -> Proxy tag
815+ -> Req t
816+ -> Dynamic t BaseUrl
817+ -> ClientOptions
818+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
819+ -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
820+ clientWithRouteAndResultHandler _ =
821+ clientWithRouteAndResultHandler (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))
822+
823+-- | When 'NoThrow' comes before any other combinator, push it down so it is
824+-- closer to the 'Verb'.
825+instance (Monad m, HasClient t m (api :> NoThrow :> apis) tag) =>
826+ HasClient t m (NoThrow :> api :> apis) tag where
827+
828+ type Client t m (NoThrow :> api :> apis) tag =
829+ Client t m (api :> NoThrow :> apis) tag
830+
831+ clientWithRouteAndResultHandler
832+ :: Proxy (NoThrow :> api :> apis)
833+ -> Proxy m
834+ -> Proxy tag
835+ -> Req t
836+ -> Dynamic t BaseUrl
837+ -> ClientOptions
838+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
839+ -> Client t m (api :> NoThrow :> apis) tag
840+ clientWithRouteAndResultHandler _ =
841+ clientWithRouteAndResultHandler (Proxy :: Proxy (api :> NoThrow :> apis))
842+
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)
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))