git.iko.soy/servant-reflex
on 69d855f help sign in
f76dbeb
swap
13 ahead, 46 behind
4 files changed+263−152
since splitsnapshots
unifiedsplit
servant-reflex.cabal+2−1 src/Servant/Common/Req.hs+136−79 src/Servant/Reflex.hs+107−57 src/Servant/Reflex/Multi.hs+18−15
servant-reflex.cabal+2−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,
@@ -42,7 +43,7 @@ library
4243 reflex-dom-core == 0.4 && < 0.5,
4344 safe >= 0.3.9 && < 0.4,
4445 servant >= 0.8 && < 0.12,
45− servant-auth >= 0.2.1 && < 0.3,
46+ servant-auth >= 0.2.1 && < 0.4,
4647 string-conversions >= 0.4 && < 0.5,
4748 text >= 1.2 && < 1.3,
4849 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+107−57
@@ -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,56 @@ 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, symbolVal)
60+import GHCJS.DOM.Types (Blob)
61+import Servant.API ((:<|>) (..), (:>), Accept (..),
62+ BasicAuth, BasicAuthData,
63+ BuildHeadersTo (..), Capture,
64+ FormUrlEncoded, Header, Headers (..),
65+ HttpVersion, IsSecure, JSON,
66+ MimeRender (..), NoContent,
67+ OctetStream, PlainText, QueryFlag,
68+ QueryParam, QueryParams, Raw,
69+ ReflectMethod (..), RemoteHost,
70+ ReqBody, ToHttpApiData (..), Vault,
71+ Verb, contentType)
72+import qualified Servant.Auth as Auth
73+
74+import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,
75+ XhrRequest (..), XhrResponse (..),
76+ XhrResponseHeaders (..),
77+ attachPromptlyDynWith, constDyn, ffor,
78+ fmapMaybe, leftmost,
79+ performRequestsAsync)
6780------------------------------------------------------------------------------
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)
81+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
82+ SupportsServantReflex, baseUrlWidget,
83+ showBaseUrl)
84+import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),
85+ QParam (..), QueryPart (..), Req (..),
86+ ReqResult (..), addHeader, authData,
87+ defReq, defaultClientOptions,
88+ evalResponse, performRequestsCT,
89+ performRequestsNoBody,
90+ performSomeRequestsAsync,
91+ prependToPathParts, qParamToQueryPart,
92+ qParams, reqBody, reqFailure,
93+ reqMethod, reqSuccess, reqTag,
94+ respHeaders, response, withCredentials)
8795
8896
8997-- * Accessing APIs as a Client
@@ -124,8 +132,8 @@ clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
124132-- | This class lets us define how each API combinator
125133-- influences the creation of an HTTP request. It's mostly
126134-- an internal class, you can just use 'client'.
127−class HasClient t m layout (tag :: *) where
128− type Client t m layout tag :: *
135+class HasClient t m layout (tag :: Type) where
136+ type Client t m layout tag :: Type
129137 clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
130138
131139
@@ -461,22 +469,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
461469-- > where host = BaseUrl Http "localhost" 8080
462470-- > -- then you can just use "addBook" to query that endpoint
463471
464−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
465− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
472+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
473+ HasClient t m sublayout tag, Reflex t)
474+ => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where
466475
467476 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
468− Dynamic t (Either Text a) -> Client t m sublayout tag
477+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
469478
470− clientWithRoute Proxy q t req baseurl opts body =
479+ clientWithRoute Proxy q t Req{..} baseurl opts body =
471480 clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
472− where req' = req { reqBody = bodyBytesCT }
481+ where req' = Req { reqBody = Just $ (fmap . fmap)
482+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
483+ , ..}
473484 ctProxy = Proxy :: Proxy ct
485+ atProxy = Proxy :: Proxy a
474486 ctString = T.pack $ show $ contentType ctProxy
475− bodyBytesCT = Just $ (fmap . fmap)
476− (\b -> (mimeRender ctProxy b, ctString))
477− body
478487
488+class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
489+ type ToConvert ctype a :: Type
490+ type ToConvert ctype a = a
491+
492+ type ToSend ctype a :: Type
493+ type ToSend ctype a = BS.ByteString
494+
495+ ghcjsMimeRender
496+ :: IsXhrPayload (ToSend ctype a)
497+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
498+ default ghcjsMimeRender
499+ :: (MimeRender ctype a,
500+ MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)
501+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
502+ ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
503+
504+instance MimeRender JSON x => GHCJS'MimeRender JSON x
505+
506+instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
507+
508+instance GHCJS'MimeRender OctetStream BL.ByteString where
509+ type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob
510+ type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob
511+ ghcjsMimeRender _ _ = \case Left bl -> Left $ BL.toStrict bl; Right x -> Right x
479512
513+instance GHCJS'MimeRender PlainText String where
514+ type ToSend PlainText String = Text
515+ ghcjsMimeRender _ _ = T.pack
516+
517+instance GHCJS'MimeRender PlainText Text where
518+ type ToSend PlainText Text = Text
519+ ghcjsMimeRender _ _ = id
520+
521+instance GHCJS'MimeRender PlainText TL.Text where
522+ type ToSend PlainText TL.Text = Text
523+ ghcjsMimeRender _ _ = TL.toStrict
524+
525+instance GHCJS'MimeRender PlainText BL.ByteString where
526+ type ToSend PlainText BL.ByteString = BS.ByteString
527+ ghcjsMimeRender _ _ = BL.toStrict
528+
529+instance GHCJS'MimeRender PlainText BS.ByteString where
530+ ghcjsMimeRender _ _ = id
480531
481532-- | Make the querying function append @path@ to the request path.
482533instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
@@ -570,4 +621,3 @@ type family HasCookieAuth xs :: Constraint where
570621 HasCookieAuth '[] = CookieAuthNotEnabled
571622
572623class CookieAuthNotEnabled
573−
src/Servant/Reflex/Multi.hs+18−15
@@ -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 #-}
@@ -48,24 +49,23 @@ import GHC.TypeLits (KnownSymbol, symbolVal)
4849import Servant.API ((:<|>) (..), (:>), BasicAuth,
4950 BasicAuthData, BuildHeadersTo (..),
5051 Capture, Header, Headers (..),
51− HttpVersion, IsSecure, MimeRender (..),
52− MimeUnrender, NoContent, QueryFlag,
53− QueryParam, QueryParams, Raw,
54− ReflectMethod (..), RemoteHost,
52+ HttpVersion, IsSecure, NoContent,
53+ QueryFlag, QueryParam, QueryParams,
54+ Raw, ReflectMethod (..), RemoteHost,
5555 ReqBody, ToHttpApiData (..), Vault,
5656 Verb, contentType)
5757
58−import Reflex.Dom.Core (Dynamic, Event, Reflex,
58+import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,
5959 XhrRequest (..),
6060 XhrResponseHeaders (..),
6161 attachPromptlyDynWith, constDyn)
6262------------------------------------------------------------------------------
6363import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6464 SupportsServantReflex)
65−import Servant.Common.Req (ClientOptions,
66− QParam (..), QueryPart (..), Req,
67− ReqResult (..), addHeader, authData,
68− defReq,
65+import Servant.Common.Req (ClientOptions, MimeUnrender,
66+ QParam (..), QueryPart (..), Req (..),
67+ ReqResult (..), SomeXhrRequest (..),
68+ addHeader, authData, defReq,
6969 defaultClientOptions,
7070 performRequestsCT,
7171 performRequestsNoBody,
@@ -74,7 +74,8 @@ import Servant.Common.Req (ClientOptions,
7474 qParams, reqBody, reqFailure,
7575 reqMethod, reqSuccess, reqSuccess',
7676 respHeaders, response, withCredentials)
77−import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
77+import Servant.Reflex (BuildHeaderKeysTo (..),
78+ GHCJS'MimeRender (..), toHeaders)
7879
7980
8081------------------------------------------------------------------------------
@@ -313,29 +314,31 @@ instance (SupportsServantReflex t m,
313314 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
314315 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
315316 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
316− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
317+ rawReqs''' = (fmap . fmap . fmap) (SomeXhrRequest . fmap Just) rawReqs''
318+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs'''
317319 return resps
318320 where
319321 aux (tag, Right r) = ResponseSuccess tag () r
320322 aux (tag, Left e) = RequestFailure tag e
321323
322324
323−instance (MimeRender ct a,
325+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
324326 HasClientMulti t m sublayout f tag,
325327 Reflex t,
326328 Applicative f)
327329 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
328330
329331 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
330− Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
332+ Dynamic t (f (Either Text (ToConvert ct a))) -> ClientMulti t m sublayout f tag
331333
332334 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
333335 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
334− where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
336+ where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }
335337 ctProxy = Proxy :: Proxy ct
338+ atProxy = Proxy :: Proxy a
336339 ctString = T.pack $ show $ contentType ctProxy
337340 bodyBytesCT b = Just $ (fmap . fmap)
338− (\b' -> (mimeRender ctProxy b', ctString))
341+ (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))
339342 b
340343 reqs' = liftA2 req' <$> bodies <*> reqs
341344