git.iko.soy/servant-reflex
on master help sign in
Merge remote-tracking branch 'origin/text-jsstring' into text-jsstring
commitddbf55d9192a30f5201846b130e419b88d0f9024 authorKen Micklas <ken.micklas@obsidian.systems> dateTue 26 Jun 2018, 13:57 (8 years ago) parente18d6bdf66aad1
3 files changed+320−175
compare with master
unifiedsplit
src/Servant/Common/Req.hs+86−75 src/Servant/Reflex.hs+150−56 src/Servant/Reflex/Multi.hs+84−44
src/Servant/Common/Req.hs+86−75
@@ -1,56 +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 #-}
10−
11−{-# LANGUAGE MultiParamTypeClasses #-}
12−{-# LANGUAGE FlexibleInstances #-}
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 #-}
16+
1317module Servant.Common.Req where
1418
1519-------------------------------------------------------------------------------
16−import Control.Applicative (liftA2, liftA3)
20+import Control.Applicative (liftA2, liftA3)
1721import Control.Concurrent
18−import Control.Monad (join)
19−import Control.Monad.IO.Class (MonadIO, liftIO)
22+import Control.Monad (join)
23+import Control.Monad.IO.Class (MonadIO, liftIO)
2024import Data.Aeson
21−import Data.Bifunctor (first)
22−import qualified Data.ByteString.Builder as BB
23−import qualified Data.ByteString as BS
24−import Data.ByteString.Lazy (ByteString)
25−import qualified Data.ByteString.Lazy.Char8 as BL
26−import qualified Data.Map as Map
27−import Data.Maybe (catMaybes, fromMaybe)
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
2830import Data.Functor.Compose
29−import Data.Monoid ((<>))
30−import Data.Proxy (Proxy(..))
31−import Data.Text (Text)
32−import qualified Data.Text as T
33−import qualified Data.Text.Lazy as TL
34−import qualified Data.Text.Encoding as T
35−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
3642import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
37−import qualified Language.Javascript.JSaddle as JS
38−import qualified Data.JSString.Text as JS (lazyTextFromJSString)
39−import qualified Network.URI as N
40−import Reflex.Dom.Core hiding (tag)
41−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
42− SupportsServantReflex)
43−import Servant.API.ContentTypes ( NoContent(..), Accept, JSON
44− , OctetStream, PlainText
45− , FormUrlEncoded)
46−import Web.HttpApiData (ToHttpApiData(..))
47−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
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 (..))
4853-------------------------------------------------------------------------------
4954import Servant.API.BasicAuth
5055-------------------------------------------------------------------------------
5156
57+-- #ifndef __GHCJS__
58+-- jsonDecode :: JS.JSString -> Maybe a
59+-- jsonDecode = error "jsonDecode is only available in GHCJS"
60+-- #endif
5261
53−------------------------------------------------------------------------------
62+-----------------------------------------------------------------------------
5463-- | The result of a request event
5564data ReqResult tag a
5665 = ResponseSuccess tag a XhrResponse
@@ -144,18 +153,20 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
144153-------------------------------------------------------------------------------
145154-- The data structure used to build up request information while traversing
146155-- the shape of a servant API
147−data Req t = Req
156+data Req t = forall o. (IsXhrPayload o, Show o) => Req
148157 { reqMethod :: Text
149158 , reqPathParts :: [Dynamic t (Either Text Text)]
150159 , qParams :: [(Text, QueryPart t)]
151− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
160+ , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
152161 , headers :: [(Text, Dynamic t (Either Text Text))]
153162 , respHeaders :: XhrResponseHeaders
154163 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
155164 }
156165
166+data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
167+
157168defReq :: Req t
158−defReq = Req "GET" [] [] Nothing [] def Nothing
169+defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
159170
160171prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
161172prependToPathParts p req =
@@ -164,14 +175,13 @@ prependToPathParts p req =
164175addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
165176addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
166177
167−
168178reqToReflexRequest
169− :: forall t. Reflex t
170− => Text
171− -> Dynamic t BaseUrl
172− -> Req t
173− -> Dynamic t (Either Text (XhrRequest XhrPayload))
174−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)))) _ _ _) =
175185 let t :: Dynamic t [Either Text Text]
176186 t = sequence $ reverse $ reqPathParts req
177187
@@ -223,14 +233,14 @@ reqToReflexRequest reqMeth reqHost req =
223233 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
224234
225235 mkConfigBody :: Either Text [(Text,Text)]
226− -> (Either Text (BL.ByteString, Text))
227− -> Either Text (XhrRequestConfig XhrPayload)
236+ -> (Either Text (o, Text))
237+ -> Either Text (XhrRequestConfig (Maybe o))
228238 mkConfigBody ehs rb = case (ehs, rb) of
229239 (_, Left e) -> Left e
230240 (Left e, _) -> Left e
231241 (Right hs, Right (bBytes, bCT)) ->
232242 Right $ XhrRequestConfig
233− { _xhrRequestConfig_sendData = bytesToPayload bBytes
243+ { _xhrRequestConfig_sendData = Just bBytes
234244 , _xhrRequestConfig_headers =
235245 Map.insert "Content-Type" bCT (Map.fromList hs)
236246 , _xhrRequestConfig_user = Nothing
@@ -240,16 +250,16 @@ reqToReflexRequest reqMeth reqHost req =
240250 , _xhrRequestConfig_responseHeaders = def
241251 }
242252
243− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
244− xhrOpts = case reqBody req of
253+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
254+ xhrOpts = case reqBody of
245255 Nothing -> ffor xhrHeaders $ \case
246256 Left e -> Left e
247257 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
248258 , _xhrRequestConfig_user = Nothing
249259 , _xhrRequestConfig_password = Nothing
250260 , _xhrRequestConfig_responseType = Nothing
251− , _xhrRequestConfig_sendData = ""
252261 , _xhrRequestConfig_withCredentials = False
262+ , _xhrRequestConfig_sendData = Nothing
253263 }
254264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
255265
@@ -263,10 +273,10 @@ reqToReflexRequest reqMeth reqHost req =
263273 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
264274 -> Dynamic t (Either Text (XhrRequestConfig x))
265275 addAuth xhr = case authData req of
266− Nothing -> xhr
276+ Nothing -> xhr
267277 Just auth -> liftA2 mkAuth auth xhr
268278
269− 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)
270280
271281 in xhrReq
272282
@@ -275,8 +285,14 @@ reqToReflexRequest reqMeth reqHost req =
275285displayHttpRequest :: Text -> Text
276286displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
277287
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+
278294-- | This function performs the request
279−performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
295+performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
280296 => Text
281297 -> Dynamic t (f (Req t))
282298 -> Dynamic t BaseUrl
@@ -289,6 +305,7 @@ performRequests reqMeth rs reqHost opts trigger = do
289305 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
290306
291307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
308+ reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))
292309 reqs = attachPromptlyDynWith
293310 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
294311
@@ -304,32 +321,31 @@ performSomeRequestsAsync
304321 HasWebView (Performable m),
305322 PerformEvent t m,
306323 TriggerEvent t m,
307− Traversable f,
308− IsXhrPayload a,
309− Show a
324+ Traversable f
310325 )
311326 => ClientOptions
312− -> Event t (f (Either Text (XhrRequest a)))
327+ -> Event t (f (Either Text SomeXhrRequest))
313328 -> m (Event t (f (Either Text XhrResponse)))
314−performSomeRequestsAsync opts =
315− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
329+performSomeRequestsAsync opts sxhr =
330+ performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr
316331
317332
318333------------------------------------------------------------------------------
319334-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
320335-- that accepts 'f (Either e (XhrRequestb))' events
321336performSomeRequestsAsync'
322− :: (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)
323338 => ClientOptions
324− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
325− -> 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)))
326342performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
327343 rs <- hrs
328344 resps <- forM rs $ \r -> case r of
329345 Left e -> do
330346 resp <- liftIO $ newMVar (Left e)
331347 return resp
332− Right r' -> do
348+ Right (SomeXhrRequest r') -> do
333349 resp <- liftIO newEmptyMVar
334350 r'' <- liftJSM $ (optsRequestFixup opts) r'
335351 _ <- newXhr r'' $ liftIO . putMVar resp . Right
@@ -338,11 +354,6 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
338354 return ()
339355
340356
341−type XhrPayload = T.Text
342−bytesToPayload :: BL.ByteString -> XhrPayload
343−bytesToPayload = T.decodeUtf8 . BL.toStrict
344−
345−
346357performRequestsCT
347358 :: (SupportsServantReflex t m,
348359 MimeUnrender ct a, Traversable f)
src/Servant/Reflex.hs+150−56
@@ -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,56 +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(..),
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(..), MimeUnrender(..),
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)
90−import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
91−import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)
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)
92143
93144
94145-- * Accessing APIs as a Client
@@ -496,22 +547,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
496547-- > where host = BaseUrl Http "localhost" 8080
497548-- > -- then you can just use "addBook" to query that endpoint
498549
499−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
500− => 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
501553
502554 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
503− Dynamic t (Either Text a) -> Client t m sublayout tag
555+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
504556
505− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
557+ clientWithRouteAndResultHandler Proxy q t Req{..} baseurl opts wrap body =
506558 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
507− where req' = req { reqBody = bodyBytesCT }
559+ where req' = Req { reqBody = Just $ (fmap . fmap)
560+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
561+ , ..}
508562 ctProxy = Proxy :: Proxy ct
563+ atProxy = Proxy :: Proxy a
509564 ctString = T.pack $ show $ contentType ctProxy
510− bodyBytesCT = Just $ (fmap . fmap)
511− (\b -> (mimeRender ctProxy b, ctString))
512− body
513565
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
590+
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
514606
607+instance GHCJS'MimeRender PlainText BS.ByteString where
608+ ghcjsMimeRender _ _ = id
515609
516610-- | Make the querying function append @path@ to the request path.
517611instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
src/Servant/Reflex/Multi.hs+84−44
@@ -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,46 +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− 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, MimeUnrender,
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.Checked.Exceptions.Internal.Envelope (Envelope)
78−import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)
79−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)
80118
81119
82120------------------------------------------------------------------------------
@@ -315,29 +353,31 @@ instance (SupportsServantReflex t m,
315353 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
316354 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
317355 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
318− 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'''
319358 return resps
320359 where
321360 aux (tag, Right r) = ResponseSuccess tag () r
322361 aux (tag, Left e) = RequestFailure tag e
323362
324363
325−instance (MimeRender ct a,
364+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
326365 HasClientMulti t m sublayout f tag,
327366 Reflex t,
328367 Applicative f)
329368 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
330369
331370 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
332− 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
333372
334373 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
335374 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
336− where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
375+ where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }
337376 ctProxy = Proxy :: Proxy ct
377+ atProxy = Proxy :: Proxy a
338378 ctString = T.pack $ show $ contentType ctProxy
339379 bodyBytesCT b = Just $ (fmap . fmap)
340− (\b' -> (mimeRender ctProxy b', ctString))
380+ (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))
341381 b
342382 reqs' = liftA2 req' <$> bodies <*> reqs
343383