git.iko.soy/servant-reflex
on ddbf55d help sign in
f76dbeb
swap
24 ahead, 37 behind
4 files changed+656−179
since splitsnapshots
unifiedsplit
servant-reflex.cabal+3−1 src/Servant/Common/Req.hs+139−82 src/Servant/Reflex.hs+290−54 src/Servant/Reflex/Multi.hs+224−42
servant-reflex.cabal+3−1
@@ -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,7 +42,8 @@ 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.13,
45+ servant >= 0.13 && < 0.14,
46+ servant-checked-exceptions >= 1.1.0.0 && < 1.2,
4547 servant-auth >= 0.2.1 && < 0.4,
4648 string-conversions >= 0.4 && < 0.5,
4749 text >= 1.2 && < 1.3,
src/Servant/Common/Req.hs+139−82
@@ -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,33 +233,33 @@ 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
225247 , _xhrRequestConfig_password = Nothing
226− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248+ , _xhrRequestConfig_responseType = Nothing
227249 , _xhrRequestConfig_withCredentials = False
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
238− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
239− , _xhrRequestConfig_sendData = ""
260+ , _xhrRequestConfig_responseType = Nothing
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,15 +366,14 @@ 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 (Just (XhrResponseBody_ArrayBuffer x)) =
348− first T.pack .
349− mimeUnrender ct $
350− BL.fromStrict x
351− decodeResp _ = Left "No body"
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
355− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
376+ Right g -> evalResponse decodeResp (t,g)
356377 )
357378 resps
358379
@@ -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 status = _xhrResponse_status xhr
384405 okStatus = status >= 200 && status < 400
385406 errMsg = fromMaybe
@@ -390,20 +411,56 @@ evalResponse decode (tag, xhr) =
390411 then either
391412 (\e -> ResponseFailure tag e xhr)
392413 (\v -> ResponseSuccess tag v xhr)
393− (decode xhr)
414+ (decodeRes xhr)
394415 else ResponseFailure tag errMsg xhr
395416 in respPayld
396417
397418
419+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
420+-- the second argument expects a JSString instead of ByteString.
421+-- This can lead to better performance ghcjs.
422+class Accept contentType => MimeUnrender contentType a where
423+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
424+
425+instance FromJSON a => MimeUnrender JSON a where
426+ mimeUnrender _ = note "Failed to decode response" . jsonDecode
427+
428+-- | @urlDecodeAsForm@
429+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
430+-- holds if every element of x is non-null (i.e., not @("", "")@)
431+instance FromForm a => MimeUnrender FormUrlEncoded a where
432+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
433+
434+-- | @left show . TextL.decodeUtf8'@
435+instance MimeUnrender PlainText TL.Text where
436+ mimeUnrender _ = pure . JS.lazyTextFromJSString
437+
438+-- | @left show . TextS.decodeUtf8' . toStrict@
439+instance MimeUnrender PlainText T.Text where
440+ mimeUnrender _ = pure . JS.textFromJSString
441+
442+-- | @Right . BC.unpack@
443+instance MimeUnrender PlainText String where
444+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString
445+
446+-- | @Right . id@
447+instance MimeUnrender OctetStream ByteString where
448+ mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
449+
450+-- | @Right . toStrict@
451+instance MimeUnrender OctetStream BS.ByteString where
452+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
453+
398454note :: e -> Maybe a -> Either e a
399−note e = maybe (Left e) Right
455+note e Nothing = Left e
456+note _ (Just a) = Right a
400457
401458fmapL :: (e -> e') -> Either e a -> Either e' a
402459fmapL _ (Right a) = Right a
403460fmapL f (Left e) = Left (f e)
404461
405−builderToText :: Builder.Builder -> T.Text
406−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
462+builderToText :: BB.Builder -> T.Text
463+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
407464
408465escape :: T.Text -> T.Text
409−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
466+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece
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 (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 (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))