master...69d855f · servant-reflex

git.iko.soy/servant-reflex

on 69d855f help sign in

servant-reflex.cabal+2−1

since splitsnapshots

unifiedsplit

@@ -27,6 +27,7 @@ library

27 hs-source-dirs: src

28 build-depends:

29 base >= 4.8 && < 4.10,

30+ aeson >= 0.11 && < 1.3,

30 bytestring >= 0.10 && < 0.11,

31 bytestring >= 0.10 && < 0.11,

31 case-insensitive >= 1.2.0.4 && < 1.3,

32 case-insensitive >= 1.2.0.4 && < 1.3,

32 containers >= 0.5.6 && < 0.6,

33 containers >= 0.5.6 && < 0.6,

@@ -42,7 +43,7 @@ library

42 reflex-dom-core == 0.4 && < 0.5,

43 reflex-dom-core == 0.4 && < 0.5,

43 safe >= 0.3.9 && < 0.4,

44 safe >= 0.3.9 && < 0.4,

44 servant >= 0.8 && < 0.12,

45 servant >= 0.8 && < 0.12,

45− servant-auth >= 0.2.1 && < 0.3,

46+ servant-auth >= 0.2.1 && < 0.4,

46 string-conversions >= 0.4 && < 0.5,

47 string-conversions >= 0.4 && < 0.5,

47 text >= 1.2 && < 1.3,

48 text >= 1.2 && < 1.3,

48 transformers >= 0.4 && < 0.6

49 transformers >= 0.4 && < 0.6

src/Servant/Common/Req.hs+136−79

@@ -1,44 +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 #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE NamedFieldPuns #-}

5−{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TupleSections #-}

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

11module Servant.Common.Req where

17module Servant.Common.Req where

13-------------------------------------------------------------------------------

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

14−import Control.Applicative (liftA2, liftA3)

20+import Control.Applicative (liftA2, liftA3)

15import Control.Concurrent

21import Control.Concurrent

16−import Control.Monad (join)

22+import Control.Monad (join)

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

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

24+import Data.Aeson

18−import Data.Bifunctor (first)

25+import Data.Bifunctor (first)

19−import qualified Data.ByteString.Builder as Builder

26+import qualified Data.ByteString as BS

27+import qualified Data.ByteString.Builder as BB

28+import Data.ByteString.Lazy (ByteString)

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

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

21−import qualified Data.Map as Map

22−import Data.Maybe (catMaybes, fromMaybe)

23import 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)

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

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

25−import Data.Proxy (Proxy(..))

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

26−import Data.Text (Text)

36+import Data.Text (Text)

27−import qualified Data.Text as T

37+import qualified Data.Text as T

28−import qualified Data.Text.Encoding as TE

38+import qualified Data.Text.Encoding as T

39+import qualified Data.Text.Lazy as TL

29−import Data.Traversable (forM)

40+import Data.Traversable (forM)

41+import qualified Language.Javascript.JSaddle as JS

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

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

31−import qualified Network.URI as N

43+import qualified Network.URI as N

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

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

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

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

34− SupportsServantReflex)

46+ JSON, NoContent (..),

35−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

47+ OctetStream, PlainText)

48+import Servant.Common.BaseUrl (BaseUrl,

49+ SupportsServantReflex,

50+ showBaseUrl)

51+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

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

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

37-------------------------------------------------------------------------------

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

38import Servant.API.BasicAuth

54import Servant.API.BasicAuth

55+-------------------------------------------------------------------------------

57+-- #ifndef __GHCJS__

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

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

60+-- #endif

41−------------------------------------------------------------------------------

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

42-- | The result of a request event

63-- | The result of a request event

43data ReqResult tag a

64data ReqResult tag a

44 = ResponseSuccess tag a XhrResponse

65 = ResponseSuccess tag a XhrResponse

@@ -132,34 +153,35 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

132-------------------------------------------------------------------------------

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

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

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

134-- the shape of a servant API

155-- the shape of a servant API

135−data Req t = Req

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

136 { reqMethod :: Text

157 { reqMethod :: Text

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

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

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

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

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

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

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

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

141 , respHeaders :: XhrResponseHeaders

162 , respHeaders :: XhrResponseHeaders

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

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

143 }

164 }

144

165

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

167+

145defReq :: Req t

168defReq :: Req t

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

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

147

170

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

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

149prependToPathParts p req =

172prependToPathParts p req =

150 req { reqPathParts = p : reqPathParts req }

173 req { reqPathParts = p : reqPathParts req }

151

174

152addHeader :: (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

153−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }

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

154−

155

177

156reqToReflexRequest

178reqToReflexRequest

157− :: forall t. Reflex t

179+ :: forall t. Reflex t

158− => Text

180+ => Text

159− -> Dynamic t BaseUrl

181+ -> Dynamic t BaseUrl

160− -> Req t

182+ -> Req t

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

183+ -> Dynamic t (Either Text SomeXhrRequest)

162−reqToReflexRequest reqMeth reqHost req =

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

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

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

164 t = sequence $ reverse $ reqPathParts req

186 t = sequence $ reverse $ reqPathParts req

165

187

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

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

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

212

234

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

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

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

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

215− -> Either Text (XhrRequestConfig XhrPayload)

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

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

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

217 (_, Left e) -> Left e

239 (_, Left e) -> Left e

218 (Left e, _) -> Left e

240 (Left e, _) -> Left e

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

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

220 Right $ XhrRequestConfig

242 Right $ XhrRequestConfig

221− { _xhrRequestConfig_sendData = bytesToPayload bBytes

243+ { _xhrRequestConfig_sendData = Just bBytes

222 , _xhrRequestConfig_headers =

244 , _xhrRequestConfig_headers =

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

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

224 , _xhrRequestConfig_user = Nothing

246 , _xhrRequestConfig_user = Nothing

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

228 , _xhrRequestConfig_responseHeaders = def

250 , _xhrRequestConfig_responseHeaders = def

229 }

251 }

230

252

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

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

232− xhrOpts = case reqBody req of

254+ xhrOpts = case reqBody of

233 Nothing -> ffor xhrHeaders $ \case

255 Nothing -> ffor xhrHeaders $ \case

234 Left e -> Left e

256 Left e -> Left e

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

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

236 , _xhrRequestConfig_user = Nothing

258 , _xhrRequestConfig_user = Nothing

237 , _xhrRequestConfig_password = Nothing

259 , _xhrRequestConfig_password = Nothing

238 , _xhrRequestConfig_responseType = Nothing

260 , _xhrRequestConfig_responseType = Nothing

239− , _xhrRequestConfig_sendData = ""

240 , _xhrRequestConfig_withCredentials = False

261 , _xhrRequestConfig_withCredentials = False

262+ , _xhrRequestConfig_sendData = Nothing

241 }

263 }

242 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

243

265

@@ -245,16 +267,16 @@ reqToReflexRequest reqMeth reqHost req =

245 mkAuth _ (Left e) = Left e

267 mkAuth _ (Left e) = Left e

246 mkAuth Nothing r = r

268 mkAuth Nothing r = r

247 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

269 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

248− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

270+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u

249− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

271+ , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}

250

272

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

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

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

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

253 addAuth xhr = case authData req of

275 addAuth xhr = case authData req of

254− Nothing -> xhr

276+ Nothing -> xhr

255 Just auth -> liftA2 mkAuth auth xhr

277 Just auth -> liftA2 mkAuth auth xhr

256

278

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)

258

280

259 in xhrReq

281 in xhrReq

260

282

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

263displayHttpRequest :: Text -> Text

285displayHttpRequest :: Text -> Text

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

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

265

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+

266-- | This function performs the request

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

268 => Text

296 => Text

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

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

270 -> Dynamic t BaseUrl

298 -> Dynamic t BaseUrl

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

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

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

278

306

279 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

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

280 reqs = attachPromptlyDynWith

309 reqs = attachPromptlyDynWith

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

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

282

311

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

292 HasWebView (Performable m),

321 HasWebView (Performable m),

293 PerformEvent t m,

322 PerformEvent t m,

294 TriggerEvent t m,

323 TriggerEvent t m,

295− Traversable f,

324+ Traversable f

296− IsXhrPayload a,

297− Show a

298 )

325 )

299 => ClientOptions

326 => ClientOptions

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

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

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

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

302−performSomeRequestsAsync opts =

329+performSomeRequestsAsync opts sxhr =

303− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

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

304

331

305

332

306------------------------------------------------------------------------------

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

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

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

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

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

309performSomeRequestsAsync'

336performSomeRequestsAsync'

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)

311 => ClientOptions

338 => ClientOptions

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

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

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

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

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

315 rs <- hrs

343 rs <- hrs

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

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

317 Left e -> do

345 Left e -> do

318 resp <- liftIO $ newMVar (Left e)

346 resp <- liftIO $ newMVar (Left e)

319 return resp

347 return resp

320− Right r' -> do

348+ Right (SomeXhrRequest r') -> do

321 resp <- liftIO newEmptyMVar

349 resp <- liftIO newEmptyMVar

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

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

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

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

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

326 return ()

354 return ()

327

355

328

356

329−

330−type XhrPayload = T.Text

331−bytesToPayload :: BL.ByteString -> XhrPayload

332−bytesToPayload = TE.decodeUtf8 . BL.toStrict

333−

334−

335performRequestsCT

357performRequestsCT

336 :: (SupportsServantReflex t m,

358 :: (SupportsServantReflex t m,

337 MimeUnrender ct a, Traversable f)

359 MimeUnrender ct a, Traversable f)

@@ -344,11 +366,10 @@ performRequestsCT

344 -> m (Event t (f (ReqResult tag a)))

366 -> m (Event t (f (ReqResult tag a)))

345performRequestsCT ct reqMeth reqs reqHost opts trigger = do

367performRequestsCT ct reqMeth reqs reqHost opts trigger = do

346 resps <- performRequests reqMeth reqs reqHost opts trigger

368 resps <- performRequests reqMeth reqs reqHost opts trigger

347− let decodeResp x = first T.pack .

369+ let decodeResp x = first T.pack

348− mimeUnrender ct .

370+ . mimeUnrender ct

349− BL.fromStrict .

371+ . JS.textToJSString

350− TE.encodeUtf8 =<< note "No body text"

351− (_xhrResponse_responseText x)

372+ =<< note "No body text" (_xhrResponse_responseText x)

352 return $ fmap

373 return $ fmap

353 (\(t,rs) -> ffor rs $ \r -> case r of

374 (\(t,rs) -> ffor rs $ \r -> case r of

354 Left e -> RequestFailure t e

375 Left e -> RequestFailure t e

@@ -379,7 +400,7 @@ evalResponse

379 :: (XhrResponse -> Either Text a)

400 :: (XhrResponse -> Either Text a)

380 -> (tag, XhrResponse)

401 -> (tag, XhrResponse)

381 -> ReqResult tag a

402 -> ReqResult tag a

382−evalResponse decode (tag, xhr) =

403+evalResponse decodeRes (tag, xhr) =

383 let okStatus = _xhrResponse_status xhr < 400

404 let okStatus = _xhrResponse_status xhr < 400

384 errMsg = fromMaybe

405 errMsg = fromMaybe

385 ("Empty response with error code " <>

406 ("Empty response with error code " <>

@@ -389,20 +410,56 @@ evalResponse decode (tag, xhr) =

389 then either

410 then either

390 (\e -> ResponseFailure tag e xhr)

411 (\e -> ResponseFailure tag e xhr)

391 (\v -> ResponseSuccess tag v xhr)

412 (\v -> ResponseSuccess tag v xhr)

392− (decode xhr)

413+ (decodeRes xhr)

393 else ResponseFailure tag errMsg xhr

414 else ResponseFailure tag errMsg xhr

394 in respPayld

415 in respPayld

395

416

396

417

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+

397note :: e -> Maybe a -> Either e a

453note :: 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

399

456

400fmapL :: (e -> e') -> Either e a -> Either e' a

457fmapL :: (e -> e') -> Either e a -> Either e' a

401fmapL _ (Right a) = Right a

458fmapL _ (Right a) = Right a

402fmapL f (Left e) = Left (f e)

459fmapL f (Left e) = Left (f e)

403

460

404−builderToText :: Builder.Builder -> T.Text

461+builderToText :: BB.Builder -> T.Text

405−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString

462+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString

406

463

407escape :: T.Text -> T.Text

464escape :: 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 @@

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 #-}

15+{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TupleSections #-}

17{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

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

27 , clientWithOpts

32 , clientWithOpts

28 , clientWithRoute

33 , clientWithRoute

29 , BuildHeaderKeysTo(..)

34 , BuildHeaderKeysTo(..)

35+ , GHCJS'MimeRender(..)

30 , toHeaders

36 , toHeaders

31 , HasClient

37 , HasClient

32 , Client

38 , Client

@@ -36,54 +42,56 @@ module Servant.Reflex

37------------------------------------------------------------------------------

43------------------------------------------------------------------------------

38import Control.Applicative

44import Control.Applicative

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

40−import qualified Data.Set as Set

45+import qualified Data.ByteString as BS

41−import qualified Data.Text.Encoding as E

46+import qualified Data.ByteString.Lazy as BL

42−import Data.CaseInsensitive (mk)

47+import Data.CaseInsensitive (mk)

43import Data.Functor.Identity

48import Data.Functor.Identity

44−import Data.Proxy (Proxy (..))

49+import Data.Kind (Type)

50+import qualified Data.Map as Map

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

52+import Data.Proxy (Proxy (..))

45−import qualified Data.Map as Map

53+import qualified Data.Set as Set

46−import Data.Text (Text)

54+import Data.Text (Text)

47−import qualified Data.Text as T

55+import qualified Data.Text as T

56+import qualified Data.Text.Encoding as E

57+import qualified Data.Text.Lazy as TL

48−import GHC.Exts (Constraint)

58+import GHC.Exts (Constraint)

49−import GHC.TypeLits (KnownSymbol, symbolVal)

59+import GHC.TypeLits (KnownSymbol, symbolVal)

60+import GHCJS.DOM.Types (Blob)

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

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

62+ BasicAuth, BasicAuthData,

51− BasicAuthData, BuildHeadersTo(..),

63+ BuildHeadersTo (..), Capture,

52− Capture, contentType, Header,

64+ FormUrlEncoded, Header, Headers (..),

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

65+ HttpVersion, IsSecure, JSON,

54− MimeRender(..), MimeUnrender,

66+ MimeRender (..), NoContent,

55− NoContent, QueryFlag, QueryParam,

67+ OctetStream, PlainText, QueryFlag,

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

68+ QueryParam, QueryParams, Raw,

57− RemoteHost, ReqBody,

69+ ReflectMethod (..), RemoteHost,

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

70+ ReqBody, ToHttpApiData (..), Vault,

71+ Verb, contentType)

59−import qualified Servant.Auth as Auth

72+import qualified Servant.Auth as Auth

60−

73+

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

74+import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,

62− XhrRequest(..),

75+ XhrRequest (..), XhrResponse (..),

63− XhrResponseHeaders(..),

76+ XhrResponseHeaders (..),

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

77+ attachPromptlyDynWith, constDyn, ffor,

78+ fmapMaybe, leftmost,

65− leftmost, performRequestsAsync,

79+ performRequestsAsync)

66− )

67------------------------------------------------------------------------------

80------------------------------------------------------------------------------

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

81+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

82+ SupportsServantReflex, baseUrlWidget,

69− showBaseUrl,

83+ showBaseUrl)

70− SupportsServantReflex)

71−import Servant.Common.Req (ClientOptions(..),

84+import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),

72− defaultClientOptions,

85+ QParam (..), QueryPart (..), Req (..),

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

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

86+ ReqResult (..), addHeader, authData,

75− defReq, evalResponse, prependToPathParts,

87+ defReq, defaultClientOptions,

76− -- performRequestCT,

77− performRequestsCT,

88+ evalResponse, performRequestsCT,

78− -- performRequestNoBody,

79− performRequestsNoBody,

89+ performRequestsNoBody,

80− performSomeRequestsAsync,

90+ performSomeRequestsAsync,

81− qParamToQueryPart, reqBody,

91+ prependToPathParts, qParamToQueryPart,

82− reqSuccess, reqFailure,

92+ qParams, reqBody, reqFailure,

83− reqMethod, respHeaders,

93+ reqMethod, reqSuccess, reqTag,

84− response,

85− reqTag,

86− qParams, withCredentials)

94+ respHeaders, response, withCredentials)

89-- * Accessing APIs as a Client

97-- * Accessing APIs as a Client

@@ -124,8 +132,8 @@ clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

124-- | This class lets us define how each API combinator

132-- | This class lets us define how each API combinator

125-- influences the creation of an HTTP request. It's mostly

133-- influences the creation of an HTTP request. It's mostly

126-- an internal class, you can just use 'client'.

134-- an internal class, you can just use 'client'.

127−class HasClient t m layout (tag :: *) where

135+class HasClient t m layout (tag :: Type) where

128− type Client t m layout tag :: *

136+ type Client t m layout tag :: Type

129 clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

137 clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

130

138

131

139

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

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

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

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

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

463

471

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

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

473+ HasClient t m sublayout tag, Reflex t)

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

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

466

475

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

476 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

469

478

470− clientWithRoute Proxy q t req baseurl opts body =

479+ clientWithRoute Proxy q t Req{..} baseurl opts body =

471 clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts

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

473 ctProxy = Proxy :: Proxy ct

484 ctProxy = Proxy :: Proxy ct

485+ atProxy = Proxy :: Proxy a

474 ctString = T.pack $ show $ contentType ctProxy

486 ctString = T.pack $ show $ contentType ctProxy

475− bodyBytesCT = Just $ (fmap . fmap)

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

477− body

478

487

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

479

512

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

480

531

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

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

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

533instance (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

570 HasCookieAuth '[] = CookieAuthNotEnabled

621 HasCookieAuth '[] = CookieAuthNotEnabled

571

622

572class CookieAuthNotEnabled

623class CookieAuthNotEnabled

573−

src/Servant/Reflex/Multi.hs+18−15

@@ -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 #-}

@@ -48,24 +49,23 @@ import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

49 BasicAuthData, BuildHeadersTo (..),

50 BasicAuthData, BuildHeadersTo (..),

50 Capture, Header, Headers (..),

51 Capture, Header, Headers (..),

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

52+ HttpVersion, IsSecure, NoContent,

52− MimeUnrender, NoContent, QueryFlag,

53− QueryParam, QueryParams, Raw,

53+ QueryFlag, QueryParam, QueryParams,

54− ReflectMethod (..), RemoteHost,

54+ Raw, ReflectMethod (..), RemoteHost,

55 ReqBody, ToHttpApiData (..), Vault,

56 Verb, contentType)

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

58+import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,

59 XhrRequest (..),

60 XhrResponseHeaders (..),

61 attachPromptlyDynWith, constDyn)

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

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

64 SupportsServantReflex)

65−import Servant.Common.Req (ClientOptions,

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

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

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

67+ ReqResult (..), SomeXhrRequest (..),

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

68+ addHeader, authData, defReq,

68− defReq,

69 defaultClientOptions,

70 performRequestsCT,

71 performRequestsNoBody,

@@ -74,7 +74,8 @@ import Servant.Common.Req (ClientOptions,

74 qParams, reqBody, reqFailure,

75 reqMethod, reqSuccess, reqSuccess',

76 respHeaders, response, withCredentials)

77−import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

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

78+ GHCJS'MimeRender (..), toHeaders)

80------------------------------------------------------------------------------

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

@@ -313,29 +314,31 @@ instance (SupportsServantReflex t m,

313 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

314 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

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

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

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

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

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

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

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

317 return resps

319 return resps

318 where

320 where

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

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

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

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

321

323

322

324

323−instance (MimeRender ct a,

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

324 HasClientMulti t m sublayout f tag,

326 HasClientMulti t m sublayout f tag,

325 Reflex t,

327 Reflex t,

326 Applicative f)

328 Applicative f)

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

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

328

330

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

331 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

331

333

332 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

334 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

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

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

335 ctProxy = Proxy :: Proxy ct

337 ctProxy = Proxy :: Proxy ct

338+ atProxy = Proxy :: Proxy a

336 ctString = T.pack $ show $ contentType ctProxy

339 ctString = T.pack $ show $ contentType ctProxy

337 bodyBytesCT b = Just $ (fmap . fmap)

340 bodyBytesCT b = Just $ (fmap . fmap)

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

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

339 b

342 b

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

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

341

344