69d855f · servant-reflex

git.iko.soy/servant-reflex

Gromit, I think we've got it

commit69d855f235f4be54297807f2b69a0cce7ea34f27 authorIsaac Shapira <fresheyeball@gmail.com> dateFri 2 Mar 2018, 16:35 (9 years ago) parent18039ca

3 files changed+34−29

compare with master

unifiedsplit

src/Servant/Common/Req.hs+10−10 src/Servant/Reflex.hs+7−5 src/Servant/Reflex/Multi.hs+17−14

src/Servant/Common/Req.hs+10−10

@@ -54,7 +54,11 @@ import Web.HttpApiData (ToHttpApiData (..))

5454import Servant.API.BasicAuth

5555-------------------------------------------------------------------------------

5656

57−jsonDecode = undefined

57+-- #ifndef __GHCJS__

58+-- jsonDecode :: JS.JSString -> Maybe a

59+-- jsonDecode = error "jsonDecode is only available in GHCJS"

60+-- #endif

61+

5862-----------------------------------------------------------------------------

5963-- | The result of a request event

6064data ReqResult tag a

@@ -159,6 +163,8 @@ data Req t = forall o. (IsXhrPayload o, Show o) => Req

159163 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

160164 }

161165

166+data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))

167+

162168defReq :: Req t

163169defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing

164170

@@ -169,15 +175,6 @@ prependToPathParts p req =

169175addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t

170176addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }

171177

172−

173−-- class ReflexDom'MimeRender a b | b -> a where

174−-- ghcjsMimerender :: IsXhrPayload c => Proxy a -> b -> c

175−

176−-- instance ReflexDom'MimeRender BL.ByteString Blob where

177−-- ghcjsMimerender _ = id

178−

179−data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))

180−

181178reqToReflexRequest

182179 :: forall t. Reflex t

183180 => Text

@@ -291,6 +288,9 @@ displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

291288instance IsXhrPayload o => IsXhrPayload (Maybe o) where

292289 sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)

293290

291+instance (IsXhrPayload o, IsXhrPayload o') => IsXhrPayload (Either o o') where

292+ sendXhrPayload xhr = either (sendXhrPayload xhr) (sendXhrPayload xhr)

293+

294294-- | This function performs the request

295295performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)

296296 => Text

src/Servant/Reflex.hs+7−5

@@ -8,6 +8,7 @@

88{-# LANGUAGE FunctionalDependencies #-}

99{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1010{-# LANGUAGE InstanceSigs #-}

11+{-# LANGUAGE LambdaCase #-}

1112{-# LANGUAGE MultiParamTypeClasses #-}

1213{-# LANGUAGE OverloadedStrings #-}

1314{-# LANGUAGE PolyKinds #-}

@@ -31,6 +32,7 @@ module Servant.Reflex

3132 , clientWithOpts

3233 , clientWithRoute

3334 , BuildHeaderKeysTo(..)

35+ , GHCJS'MimeRender(..)

3436 , toHeaders

3537 , HasClient

3638 , Client

@@ -55,7 +57,7 @@ import qualified Data.Text.Encoding as E

5557import qualified Data.Text.Lazy as TL

5658import GHC.Exts (Constraint)

5759import GHC.TypeLits (KnownSymbol, symbolVal)

58−import GHCJS.DOM.Types (Blob, Document, FormData)

60+import GHCJS.DOM.Types (Blob)

5961import Servant.API ((:<|>) (..), (:>), Accept (..),

6062 BasicAuth, BasicAuthData,

6163 BuildHeadersTo (..), Capture,

@@ -494,7 +496,7 @@ class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where

494496 :: IsXhrPayload (ToSend ctype a)

495497 => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a

496498 default ghcjsMimeRender

497− :: (IsXhrPayload (ToSend ctype a), MimeRender ctype a,

499+ :: (MimeRender ctype a,

498500 MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)

499501 => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a

500502 ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype

@@ -504,9 +506,9 @@ instance MimeRender JSON x => GHCJS'MimeRender JSON x

504506instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x

505507

506508instance GHCJS'MimeRender OctetStream BL.ByteString where

507− type ToConvert OctetStream BL.ByteString = Blob

508− type ToSend OctetStream BL.ByteString = Blob

509− ghcjsMimeRender _ _ = id

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

510512

511513instance GHCJS'MimeRender PlainText String where

512514 type ToSend PlainText String = Text

src/Servant/Reflex/Multi.hs+17−14

@@ -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,14 +49,13 @@ import GHC.TypeLits (KnownSymbol, symbolVal)

4849import Servant.API ((:<|>) (..), (:>), BasicAuth,

4950 BasicAuthData, BuildHeadersTo (..),

5051 Capture, Header, Headers (..),

51− HttpVersion, IsSecure, MimeRender (..),

52− 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)

@@ -63,9 +63,9 @@ import Reflex.Dom.Core (Dynamic, Event, Reflex,

6363import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

6464 SupportsServantReflex)

6565import Servant.Common.Req (ClientOptions, MimeUnrender,

66− QParam (..), QueryPart (..), Req,

67− ReqResult (..), addHeader, authData,

68− defReq,

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, MimeUnrender,

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