ddbf55d · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

Merge remote-tracking branch 'origin/text-jsstring' into text-jsstring

ddbf55dKen Micklas8 years ago

src/Servant/Common/Req.hs+86−75

compare with master

unifiedsplit

@@ -1,56 +1,65 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE ExistentialQuantification #-}

3−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE NamedFieldPuns #-}

11+{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TupleSections #-}

10−

15+{-# OPTIONS_GHC -fno-warn-orphans #-}

11−{-# LANGUAGE MultiParamTypeClasses #-}

16+

12−{-# LANGUAGE FlexibleInstances #-}

13module Servant.Common.Req where

17module Servant.Common.Req where

15-------------------------------------------------------------------------------

19-------------------------------------------------------------------------------

16−import Control.Applicative (liftA2, liftA3)

20+import Control.Applicative (liftA2, liftA3)

17import Control.Concurrent

21import Control.Concurrent

18−import Control.Monad (join)

22+import Control.Monad (join)

19−import Control.Monad.IO.Class (MonadIO, liftIO)

23+import Control.Monad.IO.Class (MonadIO, liftIO)

20import Data.Aeson

24import Data.Aeson

21−import Data.Bifunctor (first)

25+import Data.Bifunctor (first)

22−import qualified Data.ByteString.Builder as BB

26+import qualified Data.ByteString as BS

23−import qualified Data.ByteString as BS

27+import qualified Data.ByteString.Builder as BB

24−import Data.ByteString.Lazy (ByteString)

28+import Data.ByteString.Lazy (ByteString)

25−import qualified Data.ByteString.Lazy.Char8 as BL

29+import qualified Data.ByteString.Lazy.Char8 as BL

26−import qualified Data.Map as Map

27−import Data.Maybe (catMaybes, fromMaybe)

28import Data.Functor.Compose

30import Data.Functor.Compose

31+import qualified Data.JSString.Text as JS (lazyTextFromJSString)

32+import qualified Data.Map as Map

33+import Data.Maybe (catMaybes, fromMaybe)

29−import Data.Monoid ((<>))

34+import Data.Monoid ((<>))

30−import Data.Proxy (Proxy(..))

35+import Data.Proxy (Proxy (..))

31−import Data.Text (Text)

36+import Data.Text (Text)

32−import qualified Data.Text as T

37+import qualified Data.Text as T

38+import qualified Data.Text.Encoding as T

33−import qualified Data.Text.Lazy as TL

39+import qualified Data.Text.Lazy as TL

34−import qualified Data.Text.Encoding as T

35−import Data.Traversable (forM)

40+import Data.Traversable (forM)

41+import qualified Language.Javascript.JSaddle as JS

36import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)

42import 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

43+import qualified Network.URI as N

40−import Reflex.Dom.Core hiding (tag)

44+import Reflex.Dom.Core hiding (tag)

41−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

42− SupportsServantReflex)

43−import Servant.API.ContentTypes ( NoContent(..), Accept, JSON

45+import Servant.API.ContentTypes (Accept, FormUrlEncoded,

46+ JSON, NoContent (..),

44− , OctetStream, PlainText

47+ OctetStream, PlainText)

45− , FormUrlEncoded)

48+import Servant.Common.BaseUrl (BaseUrl,

46−import Web.HttpApiData (ToHttpApiData(..))

49+ SupportsServantReflex,

50+ showBaseUrl)

47−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

51+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

52+import Web.HttpApiData (ToHttpApiData (..))

48-------------------------------------------------------------------------------

53-------------------------------------------------------------------------------

49import Servant.API.BasicAuth

54import Servant.API.BasicAuth

50-------------------------------------------------------------------------------

55-------------------------------------------------------------------------------

57+-- #ifndef __GHCJS__

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

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

60+-- #endif

53−------------------------------------------------------------------------------

62+-----------------------------------------------------------------------------

54-- | The result of a request event

63-- | The result of a request event

55data ReqResult tag a

64data ReqResult tag a

56 = ResponseSuccess tag a XhrResponse

65 = ResponseSuccess tag a XhrResponse

@@ -144,18 +153,20 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

144-------------------------------------------------------------------------------

153-------------------------------------------------------------------------------

145-- The data structure used to build up request information while traversing

154-- The data structure used to build up request information while traversing

146-- the shape of a servant API

155-- the shape of a servant API

147−data Req t = Req

156+data Req t = forall o. (IsXhrPayload o, Show o) => Req

148 { reqMethod :: Text

157 { reqMethod :: Text

149 , reqPathParts :: [Dynamic t (Either Text Text)]

158 , reqPathParts :: [Dynamic t (Either Text Text)]

150 , qParams :: [(Text, QueryPart t)]

159 , qParams :: [(Text, QueryPart t)]

151− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))

160+ , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))

152 , headers :: [(Text, Dynamic t (Either Text Text))]

161 , headers :: [(Text, Dynamic t (Either Text Text))]

153 , respHeaders :: XhrResponseHeaders

162 , respHeaders :: XhrResponseHeaders

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

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

155 }

164 }

156

165

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

167+

157defReq :: Req t

168defReq :: Req t

158−defReq = Req "GET" [] [] Nothing [] def Nothing

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

159

170

160prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t

171prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t

161prependToPathParts p req =

172prependToPathParts p req =

@@ -164,14 +175,13 @@ prependToPathParts p req =

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

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

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

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

166

177

167−

168reqToReflexRequest

178reqToReflexRequest

169− :: forall t. Reflex t

179+ :: forall t. Reflex t

170− => Text

180+ => Text

171− -> Dynamic t BaseUrl

181+ -> Dynamic t BaseUrl

172− -> Req t

182+ -> Req t

173− -> Dynamic t (Either Text (XhrRequest XhrPayload))

183+ -> Dynamic t (Either Text SomeXhrRequest)

174−reqToReflexRequest reqMeth reqHost req =

184+reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (Either Text (o, Text)))) _ _ _) =

175 let t :: Dynamic t [Either Text Text]

185 let t :: Dynamic t [Either Text Text]

176 t = sequence $ reverse $ reqPathParts req

186 t = sequence $ reverse $ reqPathParts req

177

187

@@ -223,14 +233,14 @@ reqToReflexRequest reqMeth reqHost req =

223 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam

233 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam

224

234

225 mkConfigBody :: Either Text [(Text,Text)]

235 mkConfigBody :: Either Text [(Text,Text)]

226− -> (Either Text (BL.ByteString, Text))

236+ -> (Either Text (o, Text))

227− -> Either Text (XhrRequestConfig XhrPayload)

237+ -> Either Text (XhrRequestConfig (Maybe o))

228 mkConfigBody ehs rb = case (ehs, rb) of

238 mkConfigBody ehs rb = case (ehs, rb) of

229 (_, Left e) -> Left e

239 (_, Left e) -> Left e

230 (Left e, _) -> Left e

240 (Left e, _) -> Left e

231 (Right hs, Right (bBytes, bCT)) ->

241 (Right hs, Right (bBytes, bCT)) ->

232 Right $ XhrRequestConfig

242 Right $ XhrRequestConfig

233− { _xhrRequestConfig_sendData = bytesToPayload bBytes

243+ { _xhrRequestConfig_sendData = Just bBytes

234 , _xhrRequestConfig_headers =

244 , _xhrRequestConfig_headers =

235 Map.insert "Content-Type" bCT (Map.fromList hs)

245 Map.insert "Content-Type" bCT (Map.fromList hs)

236 , _xhrRequestConfig_user = Nothing

246 , _xhrRequestConfig_user = Nothing

@@ -240,16 +250,16 @@ reqToReflexRequest reqMeth reqHost req =

240 , _xhrRequestConfig_responseHeaders = def

250 , _xhrRequestConfig_responseHeaders = def

241 }

251 }

242

252

243− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))

253+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))

244− xhrOpts = case reqBody req of

254+ xhrOpts = case reqBody of

245 Nothing -> ffor xhrHeaders $ \case

255 Nothing -> ffor xhrHeaders $ \case

246 Left e -> Left e

256 Left e -> Left e

247 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs

257 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs

248 , _xhrRequestConfig_user = Nothing

258 , _xhrRequestConfig_user = Nothing

249 , _xhrRequestConfig_password = Nothing

259 , _xhrRequestConfig_password = Nothing

250 , _xhrRequestConfig_responseType = Nothing

260 , _xhrRequestConfig_responseType = Nothing

251− , _xhrRequestConfig_sendData = ""

252 , _xhrRequestConfig_withCredentials = False

261 , _xhrRequestConfig_withCredentials = False

262+ , _xhrRequestConfig_sendData = Nothing

253 }

263 }

254 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

255

265

@@ -263,10 +273,10 @@ reqToReflexRequest reqMeth reqHost req =

263 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

273 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

264 -> Dynamic t (Either Text (XhrRequestConfig x))

274 -> Dynamic t (Either Text (XhrRequestConfig x))

265 addAuth xhr = case authData req of

275 addAuth xhr = case authData req of

266− Nothing -> xhr

276+ Nothing -> xhr

267 Just auth -> liftA2 mkAuth auth xhr

277 Just auth -> liftA2 mkAuth auth xhr

268

278

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)

270

280

271 in xhrReq

281 in xhrReq

272

282

@@ -275,8 +285,14 @@ reqToReflexRequest reqMeth reqHost req =

275displayHttpRequest :: Text -> Text

285displayHttpRequest :: Text -> Text

276displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

286displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

277

287

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+

278-- | This function performs the request

294-- | 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)

280 => Text

296 => Text

281 -> Dynamic t (f (Req t))

297 -> Dynamic t (f (Req t))

282 -> Dynamic t BaseUrl

298 -> Dynamic t BaseUrl

@@ -289,6 +305,7 @@ performRequests reqMeth rs reqHost opts trigger = do

289 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

305 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

290

306

291 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

308+ reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))

292 reqs = attachPromptlyDynWith

309 reqs = attachPromptlyDynWith

293 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

310 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

294

311

@@ -304,32 +321,31 @@ performSomeRequestsAsync

304 HasWebView (Performable m),

321 HasWebView (Performable m),

305 PerformEvent t m,

322 PerformEvent t m,

306 TriggerEvent t m,

323 TriggerEvent t m,

307− Traversable f,

324+ Traversable f

308− IsXhrPayload a,

309− Show a

310 )

325 )

311 => ClientOptions

326 => ClientOptions

312− -> Event t (f (Either Text (XhrRequest a)))

327+ -> Event t (f (Either Text SomeXhrRequest))

313 -> m (Event t (f (Either Text XhrResponse)))

328 -> m (Event t (f (Either Text XhrResponse)))

314−performSomeRequestsAsync opts =

329+performSomeRequestsAsync opts sxhr =

315− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

330+ performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr

316

331

317

332

318------------------------------------------------------------------------------

333------------------------------------------------------------------------------

319-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

334-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

320-- that accepts 'f (Either e (XhrRequestb))' events

335-- that accepts 'f (Either e (XhrRequestb))' events

321performSomeRequestsAsync'

336performSomeRequestsAsync'

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)

323 => ClientOptions

338 => ClientOptions

324− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

339+ -> (forall b. IsXhrPayload b => XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

325− -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))

340+ -> Event t (Performable m (f (Either Text SomeXhrRequest)))

341+ -> m (Event t (f (Either Text a)))

326performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

342performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

327 rs <- hrs

343 rs <- hrs

328 resps <- forM rs $ \r -> case r of

344 resps <- forM rs $ \r -> case r of

329 Left e -> do

345 Left e -> do

330 resp <- liftIO $ newMVar (Left e)

346 resp <- liftIO $ newMVar (Left e)

331 return resp

347 return resp

332− Right r' -> do

348+ Right (SomeXhrRequest r') -> do

333 resp <- liftIO newEmptyMVar

349 resp <- liftIO newEmptyMVar

334 r'' <- liftJSM $ (optsRequestFixup opts) r'

350 r'' <- liftJSM $ (optsRequestFixup opts) r'

335 _ <- newXhr r'' $ liftIO . putMVar resp . Right

351 _ <- newXhr r'' $ liftIO . putMVar resp . Right

@@ -338,11 +354,6 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

338 return ()

354 return ()

339

355

340

356

341−type XhrPayload = T.Text

342−bytesToPayload :: BL.ByteString -> XhrPayload

343−bytesToPayload = T.decodeUtf8 . BL.toStrict

344−

345−

346performRequestsCT

357performRequestsCT

347 :: (SupportsServantReflex t m,

358 :: (SupportsServantReflex t m,

348 MimeUnrender ct a, Traversable f)

359 MimeUnrender ct a, Traversable f)

src/Servant/Reflex.hs+150−56

@@ -1,14 +1,19 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DefaultSignatures #-}

5+{-# LANGUAGE ExtendedDefaultRules #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE InstanceSigs #-}

10{-# LANGUAGE InstanceSigs #-}

11+{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE OverloadedStrings #-}

13{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

14{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE Rank2Types #-}

15{-# LANGUAGE Rank2Types #-}

16+{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TupleSections #-}

18{-# LANGUAGE TupleSections #-}

14{-# LANGUAGE TypeFamilies #-}

19{-# LANGUAGE TypeFamilies #-}

@@ -30,6 +35,7 @@ module Servant.Reflex

30 , clientWithRoute

35 , clientWithRoute

31 , clientWithRouteAndResultHandler

36 , clientWithRouteAndResultHandler

32 , BuildHeaderKeysTo(..)

37 , BuildHeaderKeysTo(..)

38+ , GHCJS'MimeRender(..)

33 , toHeaders

39 , toHeaders

34 , HasClient

40 , HasClient

35 , Client

41 , Client

@@ -39,56 +45,101 @@ module Servant.Reflex

40------------------------------------------------------------------------------

46------------------------------------------------------------------------------

41import Control.Applicative

47import Control.Applicative

42−import Data.Monoid ((<>))

43−import qualified Data.Set as Set

48+import qualified Data.ByteString as BS

44−import qualified Data.Text.Encoding as E

49+import qualified Data.ByteString.Lazy as BL

45−import Data.CaseInsensitive (mk)

50+import Data.CaseInsensitive (mk)

46import Data.Functor.Identity

51import Data.Functor.Identity

47−import Data.Proxy (Proxy (..))

52+import Data.Kind (Type)

53+import qualified Data.Map as Map

54+import Data.Monoid ((<>))

55+import Data.Proxy (Proxy (..))

48−import qualified Data.Map as Map

56+import qualified Data.Set as Set

49−import Data.Text (Text)

57+import Data.Text (Text)

50−import qualified Data.Text as T

58+import qualified Data.Text as T

59+import qualified Data.Text.Encoding as E

60+import qualified Data.Text.Lazy as TL

51−import GHC.Exts (Constraint)

61+import GHC.Exts (Constraint)

52−import GHC.TypeLits (KnownSymbol, symbolVal)

62+import GHC.TypeLits (KnownSymbol,

63+ symbolVal)

64+import GHCJS.DOM.Types (Blob)

65+import Servant.API ((:<|>) (..),

66+ (:>),

67+ Accept (..),

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

68+ BasicAuth,

69+ BasicAuthData,

54− BasicAuthData, BuildHeadersTo(..),

70+ BuildHeadersTo (..),

55− Capture, contentType, Header,

71+ Capture,

72+ FormUrlEncoded,

73+ Header,

74+ Headers (..),

56− Headers(..), HttpVersion, IsSecure,

75+ HttpVersion,

76+ IsSecure,

77+ JSON,

57− MimeRender(..),

78+ MimeRender (..),

79+ NoContent,

80+ OctetStream,

81+ PlainText,

82+ QueryFlag,

58− NoContent, QueryFlag, QueryParam,

83+ QueryParam,

84+ QueryParams,

85+ Raw,

59− QueryParams, Raw, ReflectMethod(..),

86+ ReflectMethod (..),

60− RemoteHost, ReqBody,

87+ RemoteHost,

88+ ReqBody,

61− ToHttpApiData(..), Vault, Verb)

89+ ToHttpApiData (..),

90+ Vault, Verb,

91+ contentType)

62−import qualified Servant.Auth as Auth

92+import qualified Servant.Auth as Auth

63−

93+

64−import Reflex.Dom.Core (Dynamic, Event, Reflex,

94+import Reflex.Dom.Core (Dynamic,

95+ Event,

96+ IsXhrPayload,

97+ Reflex,

65− XhrRequest(..),

98+ XhrRequest (..),

66− XhrResponseHeaders(..),

99+ XhrResponse (..),

100+ XhrResponseHeaders (..),

67− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,

101+ attachPromptlyDynWith,

102+ constDyn,

103+ ffor,

104+ fmapMaybe,

105+ leftmost,

68− leftmost, performRequestsAsync,

106+ performRequestsAsync)

69− )

70------------------------------------------------------------------------------

107------------------------------------------------------------------------------

108+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

109+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,

110+ Throwing,

111+ ThrowingNonterminal,

112+ Throws)

71−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

113+import Servant.Common.BaseUrl (BaseUrl (..),

114+ Scheme (..),

115+ SupportsServantReflex,

116+ baseUrlWidget,

72− showBaseUrl,

117+ showBaseUrl)

73− SupportsServantReflex)

74−import Servant.Common.Req (ClientOptions(..), MimeUnrender(..),

118+import Servant.Common.Req (ClientOptions (..),

75− defaultClientOptions,

119+ MimeUnrender (..),

76− Req, ReqResult(..), QParam(..),

120+ QParam (..),

77− QueryPart(..), addHeader, authData,

121+ QueryPart (..),

122+ Req (..),

123+ ReqResult (..),

124+ addHeader,

125+ authData,

126+ defReq,

127+ defaultClientOptions,

78− defReq, evalResponse, prependToPathParts,

128+ evalResponse,

79− -- performRequestCT,

80− performRequestsCT,

129+ performRequestsCT,

81− -- performRequestNoBody,

82− performRequestsNoBody,

130+ performRequestsNoBody,

83− performSomeRequestsAsync,

131+ performSomeRequestsAsync,

132+ prependToPathParts,

84− qParamToQueryPart, reqBody,

133+ qParamToQueryPart,

134+ qParams,

135+ reqBody,

85− reqSuccess, reqFailure,

136+ reqFailure,

137+ reqMethod,

138+ reqSuccess,

139+ reqTag,

86− reqMethod, respHeaders,

140+ respHeaders,

87− response,

141+ response,

88− reqTag,

89− qParams, withCredentials)

142+ withCredentials)

90−import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

91−import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)

143

144

94-- * Accessing APIs as a Client

145-- * Accessing APIs as a Client

@@ -496,22 +547,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

496-- > where host = BaseUrl Http "localhost" 8080

547-- > where host = BaseUrl Http "localhost" 8080

497-- > -- then you can just use "addBook" to query that endpoint

548-- > -- then you can just use "addBook" to query that endpoint

498

549

550+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),

499−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

551+ HasClient t m sublayout tag, Reflex t)

500− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where

552+ => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where

501

553

502 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =

554 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

504

556

505− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =

557+ clientWithRouteAndResultHandler Proxy q t Req{..} baseurl opts wrap body =

506 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

558 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+ , ..}

508 ctProxy = Proxy :: Proxy ct

562 ctProxy = Proxy :: Proxy ct

563+ atProxy = Proxy :: Proxy a

509 ctString = T.pack $ show $ contentType ctProxy

564 ctString = T.pack $ show $ contentType ctProxy

510− bodyBytesCT = Just $ (fmap . fmap)

511− (\b -> (mimeRender ctProxy b, ctString))

512− body

513

565

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

514

606

607+instance GHCJS'MimeRender PlainText BS.ByteString where

608+ ghcjsMimeRender _ _ = id

515

609

516-- | Make the querying function append @path@ to the request path.

610-- | Make the querying function append @path@ to the request path.

517instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where

611instance (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 @@

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

@@ -37,46 +38,83 @@ module Servant.Reflex.Multi (

37 ) where

38 ) where

39------------------------------------------------------------------------------

40------------------------------------------------------------------------------

40−import Control.Applicative (liftA2)

41+import Control.Applicative (liftA2)

41−import Data.Functor.Compose (Compose (..), getCompose)

42+import Data.Functor.Compose (Compose (..),

43+ getCompose)

42−import Data.Proxy (Proxy (..))

44+import Data.Proxy (Proxy (..))

43−import qualified Data.Set as Set

45+import qualified Data.Set as Set

44−import Data.Text (Text)

46+import Data.Text (Text)

45−import qualified Data.Text as T

47+import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

48+import qualified Data.Text.Encoding as E

47−import GHC.TypeLits (KnownSymbol, symbolVal)

49+import GHC.TypeLits (KnownSymbol,

50+ symbolVal)

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

51+import Servant.API ((:<|>) (..),

52+ (:>),

53+ BasicAuth,

54+ BasicAuthData,

49− BasicAuthData, BuildHeadersTo (..),

55+ BuildHeadersTo (..),

50− Capture, Header, Headers (..),

56+ Capture,

57+ Header,

58+ Headers (..),

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

59+ HttpVersion,

60+ IsSecure,

52− NoContent, QueryFlag,

61+ NoContent,

62+ QueryFlag,

63+ QueryParam,

53− QueryParam, QueryParams, Raw,

64+ QueryParams,

65+ Raw,

54− ReflectMethod (..), RemoteHost,

66+ ReflectMethod (..),

67+ RemoteHost,

68+ ReqBody,

55− ReqBody, ToHttpApiData (..), Vault,

69+ ToHttpApiData (..),

70+ Vault, Verb,

56− Verb, contentType)

71+ contentType)

57−

72+

58−import Reflex.Dom.Core (Dynamic, Event, Reflex,

73+import Reflex.Dom.Core (Dynamic,

74+ Event,

75+ IsXhrPayload,

76+ Reflex,

59− XhrRequest (..),

77+ XhrRequest (..),

60− XhrResponseHeaders (..),

78+ XhrResponseHeaders (..),

61− attachPromptlyDynWith, constDyn)

79+ attachPromptlyDynWith,

80+ constDyn)

62------------------------------------------------------------------------------

81------------------------------------------------------------------------------

82+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

83+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,

84+ Throwing,

85+ ThrowingNonterminal,

86+ Throws)

63−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

87+import Servant.Common.BaseUrl (BaseUrl (..),

88+ Scheme (..),

64− SupportsServantReflex)

89+ SupportsServantReflex)

65−import Servant.Common.Req (ClientOptions, MimeUnrender,

90+import Servant.Common.Req (ClientOptions,

91+ MimeUnrender,

92+ QParam (..),

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

93+ QueryPart (..),

94+ Req (..),

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

95+ ReqResult (..),

96+ SomeXhrRequest (..),

97+ addHeader,

98+ authData,

68− defReq,

99+ defReq,

69− defaultClientOptions,

100+ defaultClientOptions,

70− performRequestsCT,

101+ performRequestsCT,

71− performRequestsNoBody,

102+ performRequestsNoBody,

72− performSomeRequestsAsync,

103+ performSomeRequestsAsync,

73− prependToPathParts, qParamToQueryPart,

104+ prependToPathParts,

105+ qParamToQueryPart,

106+ qParams,

107+ reqBody,

74− qParams, reqBody, reqFailure,

108+ reqFailure,

109+ reqMethod,

75− reqMethod, reqSuccess, reqSuccess',

110+ reqSuccess,

111+ reqSuccess',

112+ respHeaders,

113+ response,

76− respHeaders, response, withCredentials)

114+ 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)

115+import Servant.Reflex (BuildHeaderKeysTo (..),

116+ GHCJS'MimeRender (..),

117+ toHeaders)

118

119

82------------------------------------------------------------------------------

120------------------------------------------------------------------------------

@@ -315,29 +353,31 @@ instance (SupportsServantReflex t m,

315 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

353 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

316 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

354 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

317 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

355 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

356+ rawReqs''' = (fmap . fmap . fmap) (SomeXhrRequest . fmap Just) rawReqs''

318− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''

357+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs'''

319 return resps

358 return resps

320 where

359 where

321 aux (tag, Right r) = ResponseSuccess tag () r

360 aux (tag, Right r) = ResponseSuccess tag () r

322 aux (tag, Left e) = RequestFailure tag e

361 aux (tag, Left e) = RequestFailure tag e

323

362

324

363

325−instance (MimeRender ct a,

364+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),

326 HasClientMulti t m sublayout f tag,

365 HasClientMulti t m sublayout f tag,

327 Reflex t,

366 Reflex t,

328 Applicative f)

367 Applicative f)

329 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

368 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

330

369

331 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =

370 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

333

372

334 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

373 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

335 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

374 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), .. }

337 ctProxy = Proxy :: Proxy ct

376 ctProxy = Proxy :: Proxy ct

377+ atProxy = Proxy :: Proxy a

338 ctString = T.pack $ show $ contentType ctProxy

378 ctString = T.pack $ show $ contentType ctProxy

339 bodyBytesCT b = Just $ (fmap . fmap)

379 bodyBytesCT b = Just $ (fmap . fmap)

340− (\b' -> (mimeRender ctProxy b', ctString))

380+ (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))

341 b

381 b

342 reqs' = liftA2 req' <$> bodies <*> reqs

382 reqs' = liftA2 req' <$> bodies <*> reqs

343

383