master...bdbcbfa · servant-reflex

git.iko.soy/servant-reflex

on bdbcbfa help sign in

servant-reflex.cabal+3−1

since splitsnapshots

unifiedsplit

@@ -24,6 +24,7 @@ library

25 hs-source-dirs: src

26 build-depends:

27+ aeson >= 0.11 && < 1.5,

27 base >= 4.8 && < 5,

28 base >= 4.8 && < 5,

28 bytestring >= 0.10 && < 0.11,

29 bytestring >= 0.10 && < 0.11,

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

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

@@ -39,7 +40,8 @@ library

39 reflex >= 0.5 && < 0.7,

40 reflex >= 0.5 && < 0.7,

40 reflex-dom-core >= 0.4 && < 0.6,

41 reflex-dom-core >= 0.4 && < 0.6,

41 safe >= 0.3.9 && < 0.4,

42 safe >= 0.3.9 && < 0.4,

42− servant >= 0.8 && < 0.15,

43+ servant >= 0.13 && < 0.16,

44+ servant-checked-exceptions >= 2.0 && < 2.2,

43 servant-auth >= 0.2.1 && < 0.4,

45 servant-auth >= 0.2.1 && < 0.4,

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

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

45 text >= 1.2 && < 1.3,

47 text >= 1.2 && < 1.3,

src/Servant/Common/Req.hs+134−78

@@ -1,45 +1,66 @@

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)

15−import Control.Arrow ((&&&))

21+import Control.Arrow ((&&&))

16import Control.Concurrent

22import Control.Concurrent

17−import Control.Monad (join)

23+import Control.Monad (join)

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

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

25+import Data.Aeson

19−import Data.Bifunctor (first)

26+import Data.Bifunctor (first)

20−import qualified Data.ByteString.Builder as Builder

27+import qualified Data.ByteString as BS

28+import qualified Data.ByteString.Builder as Builder

29+import Data.ByteString.Lazy (ByteString)

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

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

22−import qualified Data.Map as Map

23−import Data.Maybe (catMaybes, fromMaybe)

24import Data.Functor.Compose

31import Data.Functor.Compose

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

33+import qualified Data.Map as Map

34+import Data.Maybe (catMaybes, fromMaybe)

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

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

26−import Data.Proxy (Proxy(..))

36+import Data.Proxy (Proxy (..))

27−import Data.Text (Text)

37+import Data.Text (Text)

28−import qualified Data.Text as T

38+import qualified Data.Text as T

29−import qualified Data.Text.Encoding as TE

39+import qualified Data.Text.Encoding as TE

40+import qualified Data.Text.Lazy as TL

30−import Data.Traversable (forM)

41+import Data.Traversable (forM)

42+import qualified Language.Javascript.JSaddle as JS

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

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

32−import qualified Network.URI as N

44+import qualified Network.URI as N

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

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

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

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

35− SupportsServantReflex)

47+ JSON, NoContent (..),

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

48+ OctetStream, PlainText)

49+import Servant.Common.BaseUrl (BaseUrl,

50+ SupportsServantReflex,

51+ showBaseUrl)

52+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

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

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

38-------------------------------------------------------------------------------

54-------------------------------------------------------------------------------

39import Servant.API.BasicAuth

55import Servant.API.BasicAuth

56+-------------------------------------------------------------------------------

58+-- #ifndef __GHCJS__

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

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

61+-- #endif

42−------------------------------------------------------------------------------

63+-----------------------------------------------------------------------------

43-- | The result of a request event

64-- | The result of a request event

44data ReqResult tag a

65data ReqResult tag a

45 = ResponseSuccess tag a XhrResponse

66 = ResponseSuccess tag a XhrResponse

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

140-------------------------------------------------------------------------------

161-------------------------------------------------------------------------------

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

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

142-- the shape of a servant API

163-- the shape of a servant API

143−data Req t = Req

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

144 { reqMethod :: Text

165 { reqMethod :: Text

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

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

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

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

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

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

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

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

149 , respHeaders :: XhrResponseHeaders

170 , respHeaders :: XhrResponseHeaders

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

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

151 }

172 }

152

173

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

175+

153defReq :: Req t

176defReq :: Req t

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

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

155

178

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

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

157prependToPathParts p req =

180prependToPathParts p req =

@@ -160,14 +183,13 @@ prependToPathParts p req =

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

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

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

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

162

185

163−

164reqToReflexRequest

186reqToReflexRequest

165− :: forall t. Reflex t

187+ :: forall t. Reflex t

166− => Text

188+ => Text

167− -> Dynamic t BaseUrl

189+ -> Dynamic t BaseUrl

168− -> Req t

190+ -> Req t

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

191+ -> Dynamic t (Either Text SomeXhrRequest)

170−reqToReflexRequest reqMeth reqHost req =

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

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

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

172 t = sequence $ reverse $ reqPathParts req

194 t = sequence $ reverse $ reqPathParts req

173

195

@@ -219,33 +241,33 @@ reqToReflexRequest reqMeth reqHost req =

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

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

220

242

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

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

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

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

223− -> Either Text (XhrRequestConfig XhrPayload)

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

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

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

225 (_, Left e) -> Left e

247 (_, Left e) -> Left e

226 (Left e, _) -> Left e

248 (Left e, _) -> Left e

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

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

228 Right $ XhrRequestConfig

250 Right $ XhrRequestConfig

229− { _xhrRequestConfig_sendData = bytesToPayload bBytes

251+ { _xhrRequestConfig_sendData = Just bBytes

230 , _xhrRequestConfig_headers =

252 , _xhrRequestConfig_headers =

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

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

232 , _xhrRequestConfig_user = Nothing

254 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_password = Nothing

255 , _xhrRequestConfig_password = Nothing

234− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

256+ , _xhrRequestConfig_responseType = Nothing

235 , _xhrRequestConfig_withCredentials = False

257 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_responseHeaders = def

258 , _xhrRequestConfig_responseHeaders = def

237 }

259 }

238

260

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

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

240− xhrOpts = case reqBody req of

262+ xhrOpts = case reqBody of

241 Nothing -> ffor xhrHeaders $ \case

263 Nothing -> ffor xhrHeaders $ \case

242 Left e -> Left e

264 Left e -> Left e

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

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

244 , _xhrRequestConfig_user = Nothing

266 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_password = Nothing

267 , _xhrRequestConfig_password = Nothing

246− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

268+ , _xhrRequestConfig_responseType = Nothing

247− , _xhrRequestConfig_sendData = ""

248 , _xhrRequestConfig_withCredentials = False

269 , _xhrRequestConfig_withCredentials = False

270+ , _xhrRequestConfig_sendData = Nothing

249 }

271 }

250 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

272 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251

273

@@ -259,10 +281,10 @@ reqToReflexRequest reqMeth reqHost req =

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

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

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

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

261 addAuth xhr = case authData req of

283 addAuth xhr = case authData req of

262− Nothing -> xhr

284+ Nothing -> xhr

263 Just auth -> liftA2 mkAuth auth xhr

285 Just auth -> liftA2 mkAuth auth xhr

264

286

265− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)

287+ xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)

266

288

267 in xhrReq

289 in xhrReq

268

290

@@ -271,8 +293,14 @@ reqToReflexRequest reqMeth reqHost req =

271displayHttpRequest :: Text -> Text

293displayHttpRequest :: Text -> Text

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

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

273

295

296+instance IsXhrPayload o => IsXhrPayload (Maybe o) where

297+ sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)

298+

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

300+ sendXhrPayload xhr = either (sendXhrPayload xhr) (sendXhrPayload xhr)

301+

274-- | This function performs the request

302-- | This function performs the request

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

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

276 => Text

304 => Text

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

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

278 -> Dynamic t BaseUrl

306 -> Dynamic t BaseUrl

@@ -285,6 +313,7 @@ performRequests reqMeth rs reqHost opts trigger = do

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

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

286

314

287 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

315 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

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

288 reqs = attachPromptlyDynWith

317 reqs = attachPromptlyDynWith

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

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

290

319

@@ -300,32 +329,31 @@ performSomeRequestsAsync

300 HasWebView (Performable m),

329 HasWebView (Performable m),

301 PerformEvent t m,

330 PerformEvent t m,

302 TriggerEvent t m,

331 TriggerEvent t m,

303− Traversable f,

332+ Traversable f

304− IsXhrPayload a,

305− Show a

306 )

333 )

307 => ClientOptions

334 => ClientOptions

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

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

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

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

310−performSomeRequestsAsync opts =

337+performSomeRequestsAsync opts sxhr =

311− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

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

312

339

313

340

314------------------------------------------------------------------------------

341------------------------------------------------------------------------------

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

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

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

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

317performSomeRequestsAsync'

344performSomeRequestsAsync'

318− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

345+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

319 => ClientOptions

346 => ClientOptions

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

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

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

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

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

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

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

323 rs <- hrs

351 rs <- hrs

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

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

325 Left e -> do

353 Left e -> do

326 resp <- liftIO $ newMVar (Left e)

354 resp <- liftIO $ newMVar (Left e)

327 return resp

355 return resp

328− Right r' -> do

356+ Right (SomeXhrRequest r') -> do

329 resp <- liftIO newEmptyMVar

357 resp <- liftIO newEmptyMVar

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

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

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

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

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

334 return ()

362 return ()

335

363

336

364

337−

338−type XhrPayload = T.Text

339−bytesToPayload :: BL.ByteString -> XhrPayload

340−bytesToPayload = TE.decodeUtf8 . BL.toStrict

341−

342−

343performRequestsCT

365performRequestsCT

344 :: (SupportsServantReflex t m,

366 :: (SupportsServantReflex t m,

345 MimeUnrender ct a, Traversable f)

367 MimeUnrender ct a, Traversable f)

@@ -352,15 +374,14 @@ performRequestsCT

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

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

353performRequestsCT ct reqMeth reqs reqHost opts trigger = do

375performRequestsCT ct reqMeth reqs reqHost opts trigger = do

354 resps <- performRequests reqMeth reqs reqHost opts trigger

376 resps <- performRequests reqMeth reqs reqHost opts trigger

355− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =

356− first T.pack .

377+ let decodeResp x = first T.pack

357− mimeUnrender ct $

378+ . mimeUnrender ct

358− BL.fromStrict x

379+ . JS.textToJSString

359− decodeResp _ = Left "No body"

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

360 return $ fmap

381 return $ fmap

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

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

362 Left e -> RequestFailure t e

383 Left e -> RequestFailure t e

363− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)

384+ Right g -> evalResponse decodeResp (t,g)

364 )

385 )

365 resps

386 resps

366

387

@@ -387,7 +408,7 @@ evalResponse

387 :: (XhrResponse -> Either Text a)

408 :: (XhrResponse -> Either Text a)

388 -> (tag, XhrResponse)

409 -> (tag, XhrResponse)

389 -> ReqResult tag a

410 -> ReqResult tag a

390−evalResponse decode (tag, xhr) =

411+evalResponse decodeRes (tag, xhr) =

391 let status = _xhrResponse_status xhr

412 let status = _xhrResponse_status xhr

392 okStatus = status >= 200 && status < 400

413 okStatus = status >= 200 && status < 400

393 errMsg = fromMaybe

414 errMsg = fromMaybe

@@ -398,7 +419,7 @@ evalResponse decode (tag, xhr) =

398 then either

419 then either

399 (\e -> ResponseFailure tag e xhr)

420 (\e -> ResponseFailure tag e xhr)

400 (\v -> ResponseSuccess tag v xhr)

421 (\v -> ResponseSuccess tag v xhr)

401− (decode xhr)

422+ (decodeRes xhr)

402 else ResponseFailure tag errMsg xhr

423 else ResponseFailure tag errMsg xhr

403 in respPayld

424 in respPayld

404

425

@@ -415,8 +436,44 @@ fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text),

415fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'

436fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'

416

437

417

438

439+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that

440+-- the second argument expects a JSString instead of ByteString.

441+-- This can lead to better performance ghcjs.

442+class Accept contentType => MimeUnrender contentType a where

443+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a

444+

445+instance FromJSON a => MimeUnrender JSON a where

446+ mimeUnrender _ = note "Failed to decode response" . jsonDecode

447+

448+-- | @urlDecodeAsForm@

449+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

450+-- holds if every element of x is non-null (i.e., not @("", "")@)

451+instance FromForm a => MimeUnrender FormUrlEncoded a where

452+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . Builder.toLazyByteString . TE.encodeUtf8Builder . JS.textFromJSString

453+

454+-- | @left show . TextL.decodeUtf8'@

455+instance MimeUnrender PlainText TL.Text where

456+ mimeUnrender _ = pure . JS.lazyTextFromJSString

457+

458+-- | @left show . TextS.decodeUtf8' . toStrict@

459+instance MimeUnrender PlainText T.Text where

460+ mimeUnrender _ = pure . JS.textFromJSString

461+

462+-- | @Right . BC.unpack@

463+instance MimeUnrender PlainText String where

464+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString

465+

466+-- | @Right . id@

467+instance MimeUnrender OctetStream ByteString where

468+ mimeUnrender _ = pure . Builder.toLazyByteString . TE.encodeUtf8Builder . JS.textFromJSString

469+

470+-- | @Right . toStrict@

471+instance MimeUnrender OctetStream BS.ByteString where

472+ mimeUnrender _ = pure . TE.encodeUtf8 . JS.textFromJSString

473+

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

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

419−note e = maybe (Left e) Right

475+note e Nothing = Left e

476+note _ (Just a) = Right a

420

477

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

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

422fmapL _ (Right a) = Right a

479fmapL _ (Right a) = Right a

@@ -427,4 +484,3 @@ builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString

427

484

428escape :: T.Text -> T.Text

485escape :: T.Text -> T.Text

429escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

486escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

430−

src/Servant/Reflex.hs+290−54

@@ -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,54 +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(..), MimeUnrender,

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)

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(..),

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)

143

144

92-- * Accessing APIs as a Client

145-- * Accessing APIs as a Client

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

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

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

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

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

496

549

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

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

551+ HasClient t m sublayout tag, Reflex t)

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

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

499

553

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

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

501− Dynamic t (Either Text a) -> Client t m sublayout tag

555+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag

502

556

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

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

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

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

505− where req' = req { reqBody = bodyBytesCT }

559+ where req' = Req { reqBody = Just $ (fmap . fmap)

560+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body

561+ , ..}

506 ctProxy = Proxy :: Proxy ct

562 ctProxy = Proxy :: Proxy ct

563+ atProxy = Proxy :: Proxy a

507 ctString = T.pack $ show $ contentType ctProxy

564 ctString = T.pack $ show $ contentType ctProxy

508− bodyBytesCT = Just $ (fmap . fmap)

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

510− body

511

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

512

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

606+

607+instance GHCJS'MimeRender PlainText BS.ByteString where

608+ ghcjsMimeRender _ _ = id

513

609

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

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

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

@@ -604,3 +700,143 @@ type family HasCookieAuth xs :: Constraint where

604

700

605class CookieAuthNotEnabled

701class CookieAuthNotEnabled

606

702

703+{- servant-checked-exceptions

704+~~~~~~~~~~~~~~~~~~~~~

705+-}

706+

707+-- | Change a 'Throws' into 'Throwing'.

708+instance (Monad m, HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where

709+ type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag

710+

711+ clientWithRouteAndResultHandler

712+ :: Proxy (Throws e :> api)

713+ -> Proxy m

714+ -> Proxy tag

715+ -> Req t

716+ -> Dynamic t BaseUrl

717+ -> ClientOptions

718+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

719+ -> Client t m (Throwing '[e] :> api) tag

720+ clientWithRouteAndResultHandler _ = clientWithRouteAndResultHandler (Proxy :: Proxy (Throwing '[e] :> api))

721+

722+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'

723+-- but returning an @'Envelope' es@.

724+instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>

725+ HasClient t m (Throwing es :> Verb method status ctypes a) tag where

726+

727+ type Client t m (Throwing es :> Verb method status ctypes a) tag =

728+ Client t m (Verb method status ctypes (Envelope es a)) tag

729+

730+ clientWithRouteAndResultHandler

731+ :: Proxy (Throwing es :> Verb method status ctypes a)

732+ -> Proxy m

733+ -> Proxy tag

734+ -> Req t

735+ -> Dynamic t BaseUrl

736+ -> ClientOptions

737+ -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))

738+ -> Client t m (Verb method status ctypes (Envelope es a)) tag

739+ clientWithRouteAndResultHandler Proxy =

740+ clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))

741+

742+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'

743+-- but returning an @'Envelope' \'[]@.

744+instance (Monad m, HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>

745+ HasClient t m (NoThrow :> Verb method status ctypes a) tag where

746+

747+ type Client t m (NoThrow :> Verb method status ctypes a) tag =

748+ Client t m (Verb method status ctypes (Envelope '[] a)) tag

749+

750+ clientWithRouteAndResultHandler

751+ :: Proxy (NoThrow :> Verb method status ctypes a)

752+ -> Proxy m

753+ -> Proxy tag

754+ -> Req t

755+ -> Dynamic t BaseUrl

756+ -> ClientOptions

757+ -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))

758+ -> Client t m (Verb method status ctypes (Envelope '[] a)) tag

759+ clientWithRouteAndResultHandler Proxy =

760+ clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))

761+

762+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each

763+-- branch of the API.

764+instance (Monad m, HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag) =>

765+ HasClient t m (Throwing es :> (api1 :<|> api2)) tag where

766+

767+ type Client t m (Throwing es :> (api1 :<|> api2)) tag =

768+ Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag

769+

770+ clientWithRouteAndResultHandler

771+ :: Proxy (Throwing es :> (api1 :<|> api2))

772+ -> Proxy m

773+ -> Proxy tag

774+ -> Req t

775+ -> Dynamic t BaseUrl

776+ -> ClientOptions

777+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

778+ -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag

779+ clientWithRouteAndResultHandler _ =

780+ clientWithRouteAndResultHandler (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

781+

782+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the

783+-- API.

784+instance (Monad m, HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag) =>

785+ HasClient t m (NoThrow :> (api1 :<|> api2)) tag where

786+

787+ type Client t m (NoThrow :> (api1 :<|> api2)) tag =

788+ Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag

789+

790+ clientWithRouteAndResultHandler

791+ :: Proxy (NoThrow :> (api1 :<|> api2))

792+ -> Proxy m

793+ -> Proxy tag

794+ -> Req t

795+ -> Dynamic t BaseUrl

796+ -> ClientOptions

797+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

798+ -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag

799+ clientWithRouteAndResultHandler _ =

800+ clientWithRouteAndResultHandler (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

801+

802+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the

803+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other

804+-- combinator, push it down so it is closer to the 'Verb'.

805+instance (Monad m, HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag) =>

806+ HasClient t m (Throwing es :> api :> apis) tag where

807+

808+ type Client t m (Throwing es :> api :> apis) tag =

809+ Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag

810+

811+ clientWithRouteAndResultHandler

812+ :: Proxy (Throwing es :> api :> apis)

813+ -> Proxy m

814+ -> Proxy tag

815+ -> Req t

816+ -> Dynamic t BaseUrl

817+ -> ClientOptions

818+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

819+ -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag

820+ clientWithRouteAndResultHandler _ =

821+ clientWithRouteAndResultHandler (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

822+

823+-- | When 'NoThrow' comes before any other combinator, push it down so it is

824+-- closer to the 'Verb'.

825+instance (Monad m, HasClient t m (api :> NoThrow :> apis) tag) =>

826+ HasClient t m (NoThrow :> api :> apis) tag where

827+

828+ type Client t m (NoThrow :> api :> apis) tag =

829+ Client t m (api :> NoThrow :> apis) tag

830+

831+ clientWithRouteAndResultHandler

832+ :: Proxy (NoThrow :> api :> apis)

833+ -> Proxy m

834+ -> Proxy tag

835+ -> Req t

836+ -> Dynamic t BaseUrl

837+ -> ClientOptions

838+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

839+ -> Client t m (api :> NoThrow :> apis) tag

840+ clientWithRouteAndResultHandler _ =

841+ clientWithRouteAndResultHandler (Proxy :: Proxy (api :> NoThrow :> apis))

842+

src/Servant/Reflex/Multi.hs+224−42

@@ -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,44 +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− MimeUnrender, 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)

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,

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.Reflex (BuildHeaderKeysTo (..), toHeaders)

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

116+ GHCJS'MimeRender (..),

117+ toHeaders)

118

119

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

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

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

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

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

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

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

315 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''

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

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

317 return resps

358 return resps

318 where

359 where

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

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

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

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

321

362

322

363

323−instance (MimeRender ct a,

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

324 HasClientMulti t m sublayout f tag,

365 HasClientMulti t m sublayout f tag,

325 Reflex t,

366 Reflex t,

326 Applicative f)

367 Applicative f)

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

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

328

369

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

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

330− 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

331

372

332 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

373 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

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

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

334− where req' b r = r { reqBody = bodyBytesCT (constDyn b) }

375+ where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }

335 ctProxy = Proxy :: Proxy ct

376 ctProxy = Proxy :: Proxy ct

377+ atProxy = Proxy :: Proxy a

336 ctString = T.pack $ show $ contentType ctProxy

378 ctString = T.pack $ show $ contentType ctProxy

337 bodyBytesCT b = Just $ (fmap . fmap)

379 bodyBytesCT b = Just $ (fmap . fmap)

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

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

339 b

381 b

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

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

341

383

@@ -386,3 +428,143 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

386 where

428 where

387 req' a r = r { authData = Just (constDyn a) }

429 req' a r = r { authData = Just (constDyn a) }

388 reqs' = liftA2 req' <$> authdatas <*> reqs

430 reqs' = liftA2 req' <$> authdatas <*> reqs

431+

432+{- servant-checked-exceptions

433+~~~~~~~~~~~~~~~~~~~~~

434+-}

435+

436+-- | Change a 'Throws' into 'Throwing'.

437+instance (HasClientMulti t m (Throwing '[e] :> api) f tag) => HasClientMulti t m (Throws e :> api) f tag where

438+ type ClientMulti t m (Throws e :> api) f tag = ClientMulti t m (Throwing '[e] :> api) f tag

439+

440+ clientWithRouteMulti

441+ :: Proxy (Throws e :> api)

442+ -> Proxy m

443+ -> Proxy f

444+ -> Proxy tag

445+ -> Dynamic t (f (Req t))

446+ -> Dynamic t BaseUrl

447+ -> ClientOptions

448+ -> ClientMulti t m (Throwing '[e] :> api) f tag

449+ clientWithRouteMulti _ = clientWithRouteMulti (Proxy :: Proxy (Throwing '[e] :> api))

450+

451+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'

452+-- but returning an @'Envelope' es@.

453+instance (HasClientMulti t m (Verb method status ctypes (Envelope es a)) f tag) =>

454+ HasClientMulti t m (Throwing es :> Verb method status ctypes a) f tag where

455+

456+ type ClientMulti t m (Throwing es :> Verb method status ctypes a) f tag =

457+ ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag

458+

459+ clientWithRouteMulti

460+ :: Proxy (Throwing es :> Verb method status ctypes a)

461+ -> Proxy m

462+ -> Proxy f

463+ -> Proxy tag

464+ -> Dynamic t (f (Req t))

465+ -> Dynamic t BaseUrl

466+ -> ClientOptions

467+ -> ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag

468+ clientWithRouteMulti Proxy =

469+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))

470+

471+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'

472+-- but returning an @'Envelope' \'[]@.

473+instance (HasClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag) =>

474+ HasClientMulti t m (NoThrow :> Verb method status ctypes a) f tag where

475+

476+ type ClientMulti t m (NoThrow :> Verb method status ctypes a) f tag =

477+ ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag

478+

479+ clientWithRouteMulti

480+ :: Proxy (NoThrow :> Verb method status ctypes a)

481+ -> Proxy m

482+ -> Proxy f

483+ -> Proxy tag

484+ -> Dynamic t (f (Req t))

485+ -> Dynamic t BaseUrl

486+ -> ClientOptions

487+ -> ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag

488+ clientWithRouteMulti Proxy =

489+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))

490+

491+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each

492+-- branch of the API.

493+instance HasClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag =>

494+ HasClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag where

495+

496+ type ClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag =

497+ ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag

498+

499+ clientWithRouteMulti

500+ :: Proxy (Throwing es :> (api1 :<|> api2))

501+ -> Proxy m

502+ -> Proxy f

503+ -> Proxy tag

504+ -> Dynamic t (f (Req t))

505+ -> Dynamic t BaseUrl

506+ -> ClientOptions

507+ -> ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag

508+ clientWithRouteMulti _ =

509+ clientWithRouteMulti (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

510+

511+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the

512+-- API.

513+instance HasClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag =>

514+ HasClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag where

515+

516+ type ClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag =

517+ ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag

518+

519+ clientWithRouteMulti

520+ :: Proxy (NoThrow :> (api1 :<|> api2))

521+ -> Proxy m

522+ -> Proxy f

523+ -> Proxy tag

524+ -> Dynamic t (f (Req t))

525+ -> Dynamic t BaseUrl

526+ -> ClientOptions

527+ -> ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag

528+ clientWithRouteMulti _ =

529+ clientWithRouteMulti (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

530+

531+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the

532+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other

533+-- combinator, push it down so it is closer to the 'Verb'.

534+instance HasClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag =>

535+ HasClientMulti t m (Throwing es :> api :> apis) f tag where

536+

537+ type ClientMulti t m (Throwing es :> api :> apis) f tag =

538+ ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag

539+

540+ clientWithRouteMulti

541+ :: Proxy (Throwing es :> api :> apis)

542+ -> Proxy m

543+ -> Proxy f

544+ -> Proxy tag

545+ -> Dynamic t (f (Req t))

546+ -> Dynamic t BaseUrl

547+ -> ClientOptions

548+ -> ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag

549+ clientWithRouteMulti _ =

550+ clientWithRouteMulti (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

551+

552+-- | When 'NoThrow' comes before any other combinator, push it down so it is

553+-- closer to the 'Verb'.

554+instance HasClientMulti t m (api :> NoThrow :> apis) f tag =>

555+ HasClientMulti t m (NoThrow :> api :> apis) f tag where

556+

557+ type ClientMulti t m (NoThrow :> api :> apis) f tag =

558+ ClientMulti t m (api :> NoThrow :> apis) f tag

559+

560+ clientWithRouteMulti

561+ :: Proxy (NoThrow :> api :> apis)

562+ -> Proxy m

563+ -> Proxy f

564+ -> Proxy tag

565+ -> Dynamic t (f (Req t))

566+ -> Dynamic t BaseUrl

567+ -> ClientOptions

568+ -> ClientMulti t m (api :> NoThrow :> apis) f tag

569+ clientWithRouteMulti _ =

570+ clientWithRouteMulti (Proxy :: Proxy (api :> NoThrow :> apis))