19d68d3 · servant-reflex

git.iko.soy/servant-reflex

Merge branch 'master' into text-jsstring

commit19d68d307da8d563d3a2bb86629dd2b276177578 authorGreg Hale <imalsogreg@gmail.com> dateMon 25 Sep 2017, 22:49 (9 years ago) parent8c3d754 1cf61d3

12 files changed+296−194

compare with master

unifiedsplit

build.sh+1−1 changelog.md+15 deps/reflex-platform+1−1 deps/servant-snap+1−1 exec/API.hs+1 exec/Example.hs+26−5 servant-reflex.cabal+5−4 src/Servant/Common/Req.hs+76−82 src/Servant/Reflex.hs+106−59 src/Servant/Reflex/Multi.hs+47−32 testserver/Main.hs+11−3 testserver/testserver.cabal+6−6

build.sh+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

3−deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs && cabal build && exec/toSite.sh"

3+deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs -f Example && cabal build && exec/toSite.sh"

changelog.md+15

@@ -1,3 +1,18 @@

1+0.3.3

2+-----

4+Explicitly escape reserved characters from path pieces and query parameters

7+0.3.2

8+-----

10+- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which

11+allows the users to apply a final adjustment to Requests before

12+thery are sent, such as setting the 'withCredentials' flag

13+or print the Request to the console for debugging

14+[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)

15+

1160.3

217---

318

deps/reflex-platform+1−1

Submodule changed.

deps/servant-snap+1−1

Submodule changed.

exec/API.hs+1

@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()

4040 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

4141 :<|> "qna" :> ReqBody '[JSON] Question

4242 :> Post '[JSON] Answer

43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

4344 :<|> Raw

4445

4546type GET = Get '[JSON] ()

exec/Example.hs+26−5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DataKinds #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE OverloadedStrings #-}

@@ -14,6 +15,7 @@ import Control.Monad.Fix (MonadFix)

1415import Data.Monoid (First(..), (<>))

1516import Data.Text (Text)

1617import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

1719import GHC.TypeLits

1820import Servant.API

1921import API

@@ -43,7 +45,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,

4345runMulti = do

4446 url <- baseUrlWidget

4547 el "br" blank

46− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =

48+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =

4749 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url

4850

4951 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def

@@ -66,9 +68,12 @@ runMulti = do

6668 textInput def

6769 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def

6870 b <- button "Go"

69− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)

71+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)

72+ (constDyn [True, False]) (1 <$ b)

73+

74+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .

75+ fmap reqSuccess <$> r')

7076

71− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')

7277

7378 return ()

7479

@@ -91,8 +96,12 @@ run = mdo

9196 el "br" (return ())

9297

9398 -- Name the computed API client functions

95− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url

99+ let tweakRequest = ClientOptions $ \r -> do

100+ putStrLn ("Got req: " ++ show r)

101+ return $ r & withCredentials .~ True

102+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl

103+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =

104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest

96105

97106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now

98107

@@ -177,6 +186,18 @@ run = mdo

177186 el "p" $

178187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)

179188

189+ divClass "demo-group" $ do

190+ un <- fmap value $ text "Username" >> textArea def

191+ pw <- fmap value $ text "Unhidden PW" >> textArea def

192+ let ba :: Dynamic t (BasicAuthData ) = BasicAuthData

193+ <$> fmap T.encodeUtf8 un

194+ <*> fmap T.encodeUtf8 pw

195+ b <- button "Get secret"

196+ r <- secret (Just <$> ba) (0 <$ b)

197+ res <- holdDyn Nothing (reqSuccess <$> r)

198+ display res

199+

200+

180201showXhrResponse :: XhrResponse -> Text

181202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

182203 T.unlines ["stat: " <> tShow stat

servant-reflex.cabal+5−4

@@ -1,8 +1,8 @@

11Name: servant-reflex

2−Version: 0.3.1

2+Version: 0.3.3

33Synopsis: Servant reflex API generator

44Description: Servant reflex API generator

5−License: AllRightsReserved

5+License: BSD3

66License-file: LICENSE.md

77Author: Greg Hale, Doug Beardsley

88Maintainer: imalsogreg@gmail.com

@@ -34,7 +34,7 @@ library

3434 data-default >= 0.5 && < 0.8,

3535 exceptions >= 0.8 && < 0.9,

3636 ghcjs-dom >= 0.2 && < 0.10,

37− http-api-data >= 0.2 && < 0.4,

37+ http-api-data >= 0.3.6 && < 0.4,

3838 http-media >= 0.6 && < 0.7,

3939 jsaddle >= 0.8 && < 0.10,

4040 mtl >= 2.2.1 && < 2.3,

@@ -42,7 +42,8 @@ library

4242 reflex >= 0.5 && < 0.6,

4343 reflex-dom == 0.4 && < 0.5,

4444 safe >= 0.3.9 && < 0.4,

45− servant >= 0.8 && < 0.11,

45+ servant >= 0.8 && < 0.12,

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

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

4748 text >= 1.2 && < 1.3,

4849 transformers >= 0.4 && < 0.6

src/Servant/Common/Req.hs+76−82

@@ -4,6 +4,7 @@

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE OverloadedStrings #-}

66{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

78{-# LANGUAGE ScopedTypeVariables #-}

89{-# LANGUAGE TupleSections #-}

910

@@ -12,8 +13,8 @@

1213module Servant.Common.Req where

1314

1415-------------------------------------------------------------------------------

15−import Control.Concurrent

1616import Control.Applicative (liftA2, liftA3)

17+import Control.Concurrent

1718import Control.Monad (join)

1819import Control.Monad.IO.Class (MonadIO, liftIO)

1920import Data.Aeson

@@ -35,6 +36,7 @@ import Data.Traversable (forM)

3536import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)

3637import qualified Language.Javascript.JSaddle as JS

3738import qualified Data.JSString.Text as JS (lazyTextFromJSString)

39+import qualified Network.URI as N

3840import Reflex.Dom hiding (tag)

3941import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

4042 SupportsServantReflex)

@@ -60,6 +62,23 @@ data ReqResult tag a

6062 -- ^ A failure to construct the request tagged with 'tag' at trigger time

6163 deriving (Functor)

6264

65+data ClientOptions = ClientOptions

66+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> IO (XhrRequest a)

67+ -- ^ Aribtrarily modify requests just before they are sent.

68+ -- Warning: This escape hatch opens the possibility for your

69+ -- requests to diverge from what the server expects, when the

70+ -- server is also derived from a servant API

71+ }

72+

73+defaultClientOptions :: ClientOptions

74+defaultClientOptions = ClientOptions { optsRequestFixup = return }

75+

76+-- withCredentials :: Lens' (XhrRequest a) Bool

77+withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)

78+withCredentials inj r@(XhrRequest _ _ cfg) =

79+ let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>

80+ inj (_xhrRequestConfig_withCredentials cfg)

81+ in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'

6382

6483------------------------------------------------------------------------------

6584-- | Simple filter/accessor for successful responses, when you want to

@@ -151,7 +170,7 @@ reqToReflexRequest

151170 => Text

152171 -> Dynamic t BaseUrl

153172 -> Req t

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

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

155174reqToReflexRequest reqMeth reqHost req =

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

157176 t = sequence $ reverse $ reqPathParts req

@@ -163,7 +182,9 @@ reqToReflexRequest reqMeth reqHost req =

163182 urlParts = fmap sequence t

164183

165184 urlPath :: Dynamic t (Either Text Text)

166− urlPath = (fmap.fmap) (T.intercalate "/") urlParts

185+ urlPath = (fmap.fmap)

186+ (T.intercalate "/" . fmap escape)

187+ urlParts

167188

168189 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))

169190 queryPartString (pName, qp) = case qp of

@@ -174,7 +195,9 @@ reqToReflexRequest reqMeth reqHost req =

174195 QueryPartParams ps -> ffor ps $ \pStrings ->

175196 if null pStrings

176197 then Nothing

177− else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))

198+ else Just . Right

199+ . T.intercalate "&"

200+ $ fmap (\p -> pName <> "=" <> escape p) pStrings

178201 QueryPartFlag fl -> ffor fl $ \case

179202 True -> Just $ Right pName

180203 False -> Nothing

@@ -209,7 +232,7 @@ reqToReflexRequest reqMeth reqHost req =

209232 Right $ XhrRequestConfig

210233 { _xhrRequestConfig_sendData = bytesToPayload bBytes

211234 , _xhrRequestConfig_headers =

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

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

213236 , _xhrRequestConfig_user = Nothing

214237 , _xhrRequestConfig_password = Nothing

215238 , _xhrRequestConfig_responseType = Nothing

@@ -252,21 +275,29 @@ reqToReflexRequest reqMeth reqHost req =

252275displayHttpRequest :: Text -> Text

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

254277

255−-- | This function actually performs the request.

278+-- | This function performs the request

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

257280 => Text

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

259282 -> Dynamic t BaseUrl

283+ -> ClientOptions

260284 -> Event t tag

261285 -> m (Event t (tag, f (Either Text XhrResponse)))

262−performRequests reqMeth rs reqHost trigger = do

263− -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))

264− let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

265− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

266− resps <- performSomeRequestsAsync reqs

286+performRequests reqMeth rs reqHost opts trigger = do

287+ let xhrReqs =

288+ join $ (\(fxhr :: f (Req t)) -> sequence $

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

290+

291+ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

292+ reqs = attachPromptlyDynWith

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

294+

295+ resps <- performSomeRequestsAsync opts reqs

267296 return $ getCompose <$> resps

268297

269−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.

298+-- | Issues a collection of requests when the supplied Event fires.

299+-- When ALL requests from a given firing complete, the results are

300+-- collected and returned via the return Event.

270301performSomeRequestsAsync

271302 :: (MonadIO (Performable m),

272303 MonadJSM (Performable m),

@@ -274,20 +305,25 @@ performSomeRequestsAsync

274305 PerformEvent t m,

275306 TriggerEvent t m,

276307 Traversable f,

277− IsXhrPayload a)

278− => Event t (f (Either Text (XhrRequest a)))

308+ IsXhrPayload a,

309+ Show a

310+ )

311+ => ClientOptions

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

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

280−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

314+performSomeRequestsAsync opts =

315+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

281316

282317

283318------------------------------------------------------------------------------

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

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

286321performSomeRequestsAsync'

287− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

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

322+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

323+ => ClientOptions

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

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

290−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

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

291327 rs <- hrs

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

293329 Left e -> do

@@ -295,71 +331,18 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->

295331 return resp

296332 Right r' -> do

297333 resp <- liftIO newEmptyMVar

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

334+ r'' <- liftIO $ (optsRequestFixup opts) r'

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

299336 return resp

300337 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

301338 return ()

302339

303340

304−

305−-- | This function actually performs the request.

306−performRequest :: forall t m tag .(SupportsServantReflex t m)

307− => Text

308− -> (Req t)

309− -> Dynamic t BaseUrl

310− -> Event t tag

311− -> m (Event t (tag, XhrResponse), Event t (tag, Text))

312−performRequest reqMeth req reqHost trigger = do

313−

314− let xhrReq = reqToReflexRequest reqMeth reqHost req

315− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger

316− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs

317− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs

318−

319− resps <- performRequestsAsync okReqs

320−

321− return (resps, badReqs)

322−

323−

324341type XhrPayload = T.Text

325342bytesToPayload :: BL.ByteString -> XhrPayload

326343bytesToPayload = T.decodeUtf8 . BL.toStrict

327344

328345

329−-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

330−-- => Text

331−-- -> Req t

332−-- -> Dynamic t BaseUrl

333−-- -> Event t tag -> m (Event t (ReqResult tag NoContent))

334−-- performRequestNoBody reqMeth req reqHost trigger = do

335−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger

336−-- let decodeResp = const $ Right NoContent

337−-- return $ leftmost [ fmap (evalResponse decodeResp) resp

338−-- , fmap (uncurry RequestFailure) badReq

339−-- ]

340−

341−

342−-- performRequestCT

343−-- :: (SupportsServantReflex t m,

344−-- MimeUnrender ct a)

345−-- => Proxy ct

346−-- -> Text

347−-- -> Req t

348−-- -> Dynamic t BaseUrl

349−-- -> Event t tag

350−-- -> m (Event t (ReqResult tag a))

351−-- performRequestCT ct reqMeth req reqHost trigger = do

352−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger

353−-- let decodeResp x = first T.pack .

354−-- mimeUnrender ct .

355−-- BL.fromStrict .

356−-- TE.encodeUtf8 =<< note "No body text"

357−-- (_xhrResponse_responseText x)

358−

359−-- return $ leftmost [fmap (evalResponse decodeResp) resp

360−-- , fmap (uncurry RequestFailure) badReq

361−-- ]

362−

363346performRequestsCT

364347 :: (SupportsServantReflex t m,

365348 MimeUnrender ct a, Traversable f)

@@ -367,10 +350,11 @@ performRequestsCT

367350 -> Text

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

369352 -> Dynamic t BaseUrl

353+ -> ClientOptions

370354 -> Event t tag

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

372−performRequestsCT ct reqMeth reqs reqHost trigger = do

373− resps <- performRequests reqMeth reqs reqHost trigger

356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357+ resps <- performRequests reqMeth reqs reqHost opts trigger

374358 let decodeResp x = first T.pack

375359 . mimeUnrender ct

376360 . JS.textToJSString

@@ -389,10 +373,11 @@ performRequestsNoBody

389373 => Text

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

391375 -> Dynamic t BaseUrl

376+ -> ClientOptions

392377 -> Event t tag

393378 -> m (Event t (f (ReqResult tag NoContent)))

394−performRequestsNoBody reqMeth reqs reqHost trigger = do

395− resps <- performRequests reqMeth reqs reqHost trigger

379+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

380+ resps <- performRequests reqMeth reqs reqHost opts trigger

396381 let decodeResp = const $ Right NoContent

397382 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of

398383 Left e -> RequestFailure tag e

@@ -419,11 +404,6 @@ evalResponse decodeRes (tag, xhr) =

419404 in respPayld

420405

421406

422−

423−

424−note :: e -> Maybe a -> Either e a

425−note e = maybe (Left e) Right

426−

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

428408-- the second argument expects a JSString instead of ByteString.

429409-- This can lead to better performance ghcjs.

@@ -458,3 +438,17 @@ instance MimeUnrender OctetStream ByteString where

458438-- | @Right . toStrict@

459439instance MimeUnrender OctetStream BS.ByteString where

460440 mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString

441+

442+note :: e -> Maybe a -> Either e a

443+note e Nothing = Left e

444+note _ (Just a) = Right a

445+

446+fmapL :: (e -> e') -> Either e a -> Either e' a

447+fmapL _ (Right a) = Right a

448+fmapL f (Left e) = Left (f e)

449+

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

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

452+

453+escape :: T.Text -> T.Text

454+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece

src/Servant/Reflex.hs+106−59

@@ -1,24 +1,22 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# LANGUAGE MultiParamTypeClasses #-}

15−{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE PolyKinds #-}

17−{-# LANGUAGE ScopedTypeVariables #-}

18−{-# LANGUAGE TupleSections #-}

19−{-# LANGUAGE TypeFamilies #-}

20−{-# LANGUAGE TypeOperators #-}

21−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE InstanceSigs #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+

17+#if MIN_VERSION_base(4,9,0)

18+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

19+#endif

2220

2321-- #include "overlapping-compat.h"

2422-- | This module provides 'client' which can automatically generate

@@ -26,9 +24,13 @@

2624-- API.

2725module Servant.Reflex

2826 ( client

27+ , clientWithOpts

28+ , clientWithRoute

2929 , BuildHeaderKeysTo(..)

3030 , toHeaders

31− , HasClient(..)

31+ , HasClient

32+ , Client

33+ , withCredentials

3234 , module Servant.Common.Req

3335 , module Servant.Common.BaseUrl

3436 ) where

@@ -44,6 +46,7 @@ import Data.Proxy (Proxy (..))

4446import qualified Data.Map as Map

4547import Data.Text (Text)

4648import qualified Data.Text as T

49+import GHC.Exts (Constraint)

4750import GHC.TypeLits (KnownSymbol, symbolVal)

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

4952 BasicAuthData, BuildHeadersTo(..),

@@ -54,6 +57,7 @@ import Servant.API ((:<|>)(..),(:>), BasicAuth,

5457 QueryParams, Raw, ReflectMethod(..),

5558 RemoteHost, ReqBody,

5659 ToHttpApiData(..), Vault, Verb)

60+import qualified Servant.Auth as Auth

5761

5862import Reflex.Dom (Dynamic, Event, Reflex,

5963 XhrRequest(..),

@@ -65,8 +69,9 @@ import Reflex.Dom (Dynamic, Event, Reflex,

6569import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

6670 showBaseUrl,

6771 SupportsServantReflex)

68−import Servant.Common.Req (Req, ReqResult(..), QParam(..),

69− MimeUnrender,

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

73+ defaultClientOptions,

74+ Req, ReqResult(..), QParam(..),

7075 QueryPart(..), addHeader, authData,

7176 defReq, evalResponse, prependToPathParts,

7277 -- performRequestCT,

@@ -76,9 +81,10 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

7681 performSomeRequestsAsync,

7782 qParamToQueryPart, reqBody,

7883 reqSuccess, reqFailure,

79− reqMethod, respHeaders, response,

84+ reqMethod, respHeaders,

85+ response,

8086 reqTag,

81− qParams)

87+ qParams, withCredentials)

8288

8389

8490-- * Accessing APIs as a Client

@@ -96,9 +102,24 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

96102-- -> m (Event t (l, ReqResult Book)))

97103-- > (getAllBooks :<|> postNewBook) = client myApi host

98104-- > where host = constDyn $ BaseUrl Http "localhost" 8080

99−client :: (HasClient t m layout tag)

100− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag

101−client p q t baseurl = clientWithRoute p q t defReq baseurl

105+client

106+ :: (HasClient t m layout tag)

107+ => Proxy layout

108+ -> Proxy m

109+ -> Proxy tag

110+ -> Dynamic t BaseUrl

111+ -> Client t m layout tag

112+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions

113+

114+clientWithOpts

115+ :: (HasClient t m layout tag)

116+ => Proxy layout

117+ -> Proxy m

118+ -> Proxy tag

119+ -> Dynamic t BaseUrl

120+ -> ClientOptions

121+ -> Client t m layout tag

122+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

102123

103124

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

@@ -106,15 +127,15 @@ client p q t baseurl = clientWithRoute p q t defReq baseurl

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

107128class HasClient t m layout (tag :: *) where

108129 type Client t m layout tag :: *

109− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag

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

110131

111132

112133instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where

113134 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag

114135

115− clientWithRoute Proxy q pTag req baseurl =

116− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>

117− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl

136+ clientWithRoute Proxy q pTag req baseurl opts =

137+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>

138+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts

118139

119140

120141-- Capture. Example:

@@ -135,11 +156,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta

135156 type Client t m (Capture capture a :> sublayout) tag =

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

137158

138− clientWithRoute Proxy q t req baseurl val =

159+ clientWithRoute Proxy q t req baseurl opts val =

139160 clientWithRoute (Proxy :: Proxy sublayout)

140161 q t

141162 (prependToPathParts p req)

142− baseurl

163+ baseurl opts

143164 where p = (fmap . fmap) (toUrlPiece) val

144165

145166

@@ -152,9 +173,8 @@ instance {-# OVERLAPPABLE #-}

152173 Event t tag -> m (Event t (ReqResult tag a))

153174 -- TODO how to access input types here?

154175 -- ExceptT ServantError IO a

155− clientWithRoute Proxy _ _ req baseurl trigs =

156− -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs

157− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl trigs

176+ clientWithRoute Proxy _ _ req baseurl opts trigs =

177+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs

158178 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

159179 req' = req { reqMethod = method }

160180

@@ -167,8 +187,8 @@ instance {-# OVERLAPPING #-}

167187 Event t tag -> m (Event t (ReqResult tag NoContent))

168188 -- TODO: how to access input types here?

169189 -- ExceptT ServantError IO NoContent

170− clientWithRoute Proxy _ _ req baseurl =

171− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl

190+ clientWithRoute Proxy _ _ req baseurl opts =

191+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts

172192 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

173193

174194

@@ -204,9 +224,9 @@ instance {-# OVERLAPPABLE #-}

204224 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where

205225 type Client t m (Verb method status cts' (Headers ls a)) tag =

206226 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))

207− clientWithRoute Proxy _ _ req baseurl trigs = do

227+ clientWithRoute Proxy _ _ req baseurl opts trigs = do

208228 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

209− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs

229+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs

210230 return $ toHeaders <$> resp

211231 where req' = req { respHeaders =

212232 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

@@ -220,9 +240,9 @@ instance {-# OVERLAPPABLE #-}

220240 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where

221241 type Client t m (Verb method status cts (Headers ls NoContent)) tag

222242 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))

223− clientWithRoute Proxy _ _ req baseurl trigs = do

243+ clientWithRoute Proxy _ _ req baseurl opts trigs = do

224244 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

225− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs

245+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs

226246 return $ toHeaders <$> resp

227247 where req' = req {respHeaders =

228248 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

@@ -250,11 +270,11 @@ instance (KnownSymbol sym, ToHttpApiData a,

250270 type Client t m (Header sym a :> sublayout) tag =

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

252272

253− clientWithRoute Proxy q t req baseurl eVal =

273+ clientWithRoute Proxy q t req baseurl opts eVal =

254274 clientWithRoute (Proxy :: Proxy sublayout)

255275 q t

256276 (Servant.Common.Req.addHeader hname eVal req)

257− baseurl

277+ baseurl opts

258278 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

259279

260280

@@ -305,9 +325,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

305325 Dynamic t (QParam a) -> Client t m sublayout tag

306326

307327 -- if mparam = Nothing, we don't add it to the query string

308− clientWithRoute Proxy q t req baseurl mparam =

328+ clientWithRoute Proxy q t req baseurl opts mparam =

309329 clientWithRoute (Proxy :: Proxy sublayout) q t

310− (req {qParams = paramPair : qParams req}) baseurl

330+ (req {qParams = paramPair : qParams req}) baseurl opts

311331

312332 where pname = symbolVal (Proxy :: Proxy sym)

313333 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm

@@ -351,8 +371,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

351371 type Client t m (QueryParams sym a :> sublayout) tag =

352372 Dynamic t [a] -> Client t m sublayout tag

353373

354− clientWithRoute Proxy q t req baseurl paramlist =

355− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl

374+ clientWithRoute Proxy q t req baseurl opts paramlist =

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

356376

357377 where req' = req { qParams = (T.pack pname, params') : qParams req }

358378 pname = symbolVal (Proxy :: Proxy sym)

@@ -391,8 +411,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)

391411 type Client t m (QueryFlag sym :> sublayout) tag =

392412 Dynamic t Bool -> Client t m sublayout tag

393413

394− clientWithRoute Proxy q t req baseurl flag =

395− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl

414+ clientWithRoute Proxy q t req baseurl opts flag =

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

396416

397417 where req' = req { qParams = thisPair : qParams req }

398418 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)

@@ -406,7 +426,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

406426 -> Event t tag

407427 -> m (Event t (ReqResult tag ()))

408428

409− clientWithRoute _ _ _ _ baseurl xhrs triggers = do

429+ clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do

410430

411431 let xhrs' = liftA2 (\x path -> case x of

412432 Left e -> Left e

@@ -448,8 +468,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

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

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

450470

451− clientWithRoute Proxy q t req baseurl body =

452− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl

471+ clientWithRoute Proxy q t req baseurl opts body =

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

453473 where req' = req { reqBody = bodyBytesCT }

454474 ctProxy = Proxy :: Proxy ct

455475 ctString = T.pack $ show $ contentType ctProxy

@@ -463,9 +483,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

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

464484 type Client t m (path :> sublayout) tag = Client t m sublayout tag

465485

466− clientWithRoute Proxy q t req baseurl =

486+ clientWithRoute Proxy q t req baseurl opts =

467487 clientWithRoute (Proxy :: Proxy sublayout) q t

468− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl

488+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts

469489

470490 where p = symbolVal (Proxy :: Proxy path)

471491

@@ -498,8 +518,8 @@ instance (HasClient t m api tag, Reflex t)

498518 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)

499519 -> Client t m api tag

500520

501− clientWithRoute Proxy q t req baseurl authdata =

502− clientWithRoute (Proxy :: Proxy api) q t req' baseurl

521+ clientWithRoute Proxy q t req baseurl opts authdata =

522+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts

503523 where

504524 req' = req { authData = Just authdata }

505525

@@ -525,3 +545,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall

525545more specific. This in turn generally means adding yet another instance (one

526546for empty and one for non-empty lists).

527547-}

548+

549+

550+-- SUPPORT FOR servant-auth --

551+

552+-- For JavaScript clients we should be sending/storing JSON web tokens in a

553+-- way that is inaccessible to JavaScript.

554+--

555+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM

556+-- app this means the @servant-auth@ client should only verify that the API

557+-- supports Cookie-based authentication but do nothing with the token

558+-- directly.

559+

560+-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures

561+-- we're not trying to rely on cookies when the API does not use them.

562+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where

563+

564+ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag

565+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

566+

567+

568+type family HasCookieAuth xs :: Constraint where

569+ HasCookieAuth (Auth.Cookie ': xs) = ()

570+ HasCookieAuth (x ': xs) = HasCookieAuth xs

571+ HasCookieAuth '[] = CookieAuthNotEnabled

572+

573+class CookieAuthNotEnabled

574+

src/Servant/Reflex/Multi.hs+47−32

@@ -16,12 +16,15 @@

1616module Servant.Reflex.Multi (

1717 -- * Compute servant client functions

1818 clientA

19+ , clientWithOptsA

1920 , BaseUrl(..)

2021 , Scheme(..)

2122

2223 -- * Build QueryParam arguments

2324 , QParam(..)

2425

26+ -- * Access response data

27+ , withCredentials

2528

2629 -- * Access response data

2730 , ReqResult(..)

@@ -59,16 +62,18 @@ import Reflex.Dom (Dynamic, Event, Reflex,

5962------------------------------------------------------------------------------

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

6164 SupportsServantReflex)

62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,

63− MimeUnrender,

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

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

6467 ReqResult (..), addHeader, authData,

65− defReq, performRequestsCT,

68+ defReq,

69+ defaultClientOptions,

70+ performRequestsCT,

6671 performRequestsNoBody,

6772 performSomeRequestsAsync,

6873 prependToPathParts, qParamToQueryPart,

6974 qParams, reqBody, reqFailure,

7075 reqMethod, reqSuccess, reqSuccess',

71− respHeaders, response)

76+ respHeaders, response, withCredentials)

7277import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

7378

7479

@@ -78,14 +83,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

7883 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag

7984clientA p q f tag baseurl =

8085 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl

86+ defaultClientOptions

87+

8188

89+-- | A version of @client@ that sets the withCredentials flag

90+-- on requests. Use this function for clients of CORS API's

91+clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

92+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag

93+ -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag

94+clientWithOptsA p q f tag baseurl opts =

95+ clientWithRouteMulti p q f tag

96+ (constDyn (pure defReq)) baseurl opts

8297

8398------------------------------------------------------------------------------

8499class HasClientMulti t m layout f (tag :: *) where

85100 type ClientMulti t m layout f tag :: *

86101 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

87102 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

88− -> ClientMulti t m layout f tag

103+ -> ClientOptions -> ClientMulti t m layout f tag

89104

90105

91106------------------------------------------------------------------------------

@@ -93,9 +108,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>

93108 HasClientMulti t m (a :<|> b) f tag where

94109 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

95110 ClientMulti t m b f tag

96− clientWithRouteMulti Proxy q f tag reqs baseurl =

97− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>

98− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl

111+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =

112+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>

113+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts

99114

100115

101116------------------------------------------------------------------------------

@@ -108,8 +123,8 @@ instance (SupportsServantReflex t m,

108123 type ClientMulti t m (Capture capture a :> sublayout) f tag =

109124 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

110125

111− clientWithRouteMulti _ q f tag reqs baseurl vals =

112− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

126+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =

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

113128 where

114129 reqs' = (prependToPathParts <$> ps <*>) <$> reqs

115130 ps = (fmap . fmap . fmap) toUrlPiece vals

@@ -129,8 +144,8 @@ instance {-# OVERLAPPABLE #-}

129144 type ClientMulti t m (Verb method status cts' a) f tag =

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

131146

132− clientWithRouteMulti _ _ _ _ reqs baseurl =

133− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

147+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

148+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts

134149 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

135150 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

136151

@@ -144,8 +159,8 @@ instance {-# OVERLAPPING #-}

144159 Event t tag -> m (Event t (f (ReqResult tag NoContent)))

145160 -- TODO: how to access input types here?

146161 -- ExceptT ServantError IO NoContent

147− clientWithRouteMulti Proxy _ _ _ req baseurl =

148− performRequestsNoBody method req baseurl

162+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

163+ performRequestsNoBody method req baseurl opts

149164 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

150165

151166

@@ -159,9 +174,9 @@ instance {-# OVERLAPPABLE #-}

159174 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where

160175 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =

161176 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))

162− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

177+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

163178 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

164− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))

179+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))

165180 return $ fmap toHeaders <$> resp

166181 where

167182 reqs' = fmap (\r ->

@@ -182,9 +197,9 @@ instance {-# OVERLAPPABLE #-}

182197 cts (Headers ls NoContent)) f tag where

183198 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

184199 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))

185− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

200+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

186201 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

187− resp <- performRequestsNoBody method reqs' baseurl triggers

202+ resp <- performRequestsNoBody method reqs' baseurl opts triggers

188203 return $ fmap toHeaders <$> resp

189204 where reqs' = fmap (\req ->

190205 req {respHeaders = OnlyHeaders (Set.fromList

@@ -204,11 +219,11 @@ instance (KnownSymbol sym,

204219 type ClientMulti t m (Header sym a :> sublayout) f tag =

205220 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

206221

207− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

222+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =

208223 clientWithRouteMulti (Proxy :: Proxy sublayout) f

209224 q tag

210225 reqs'

211− baseurl

226+ baseurl opts

212227 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

213228 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

214229 <$> eVals <*>) <$> reqs

@@ -238,9 +253,9 @@ instance (KnownSymbol sym,

238253

239254 -- if mparam = Nothing, we don't add it to the query string

240255 -- TODO: Check the above comment

241− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

256+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

242257 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

243− reqs' baseurl

258+ reqs' baseurl opts

244259

245260 where pname = symbolVal (Proxy :: Proxy sym)

246261 p prm = QueryPartParam $ fmap qParamToQueryPart prm

@@ -261,8 +276,8 @@ instance (KnownSymbol sym,

261276 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

262277 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

263278

264− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

265− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

279+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

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

266281

267282 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

268283 pname = symbolVal (Proxy :: Proxy sym)

@@ -280,8 +295,8 @@ instance (KnownSymbol sym,

280295 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

281296 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

282297

283− clientWithRouteMulti Proxy q f' tag reqs baseurl flags =

284− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl

298+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

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

285300

286301 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

287302 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

@@ -295,10 +310,10 @@ instance (SupportsServantReflex t m,

295310 -> Event t tag

296311 -> m (Event t (f (ReqResult tag ())))

297312

298− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do

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

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

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

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

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

302317 return resps

303318 where

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

@@ -314,8 +329,8 @@ instance (MimeRender ct a,

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

315330 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag

316331

317− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

318− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

332+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

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

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

320335 ctProxy = Proxy :: Proxy ct

321336 ctString = T.pack $ show $ contentType ctProxy

@@ -366,8 +381,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

366381 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

367382 -> ClientMulti t m api f tag

368383

369− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

370− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl

384+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

385+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

371386 where

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

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

testserver/Main.hs+11−3

@@ -2,6 +2,7 @@

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE TypeOperators #-}

@@ -47,8 +48,10 @@ data App = App

4748-- that represents the API, are glued together using :<|>.

4849--

4950-- Each handler runs in the 'ExceptT ServantErr IO' monad.

50−server :: Server API (Handler App App)

51+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

52+server = return () :<|> return 100 :<|> sayhi :<|> dbl

53+ :<|> multi :<|> qna :<|> serveSecret

54+ :<|> serveDirectory "static"

5255 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

5356 sayhi nm greetings withGusto = case nm of

5457 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -69,11 +72,16 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>

6972 putStrLn $ "qna got: " ++ show q

7073 T.putStrLn $ unQuestion q

7174 return $ Answer $ unQuestion q

75+ serveSecret _ = do

76+ req <- getRequest

77+ liftIO $ putStrLn (show req)

78+ return 101

7279

7380-- Turn the server into a WAI app. 'serve' is provided by servant,

7481-- more precisely by the Servant.Server module.

7582test :: Handler App App ()

76−test = serveSnap testApi server

83+test = serveSnapWithContext testApi

84+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

7785

7886initApp :: SnapletInit App App

7987initApp = makeSnaplet "myapp" "example" Nothing $ do

testserver/testserver.cabal+6−6

@@ -19,13 +19,13 @@ executable back

1919 main-is: Main.hs

2020 -- other-modules:

2121 -- other-extensions:

22− build-depends: aeson >= 0.9 && < 1.1

23− , base >=4.8 && <4.10

24− , snap >= 1.0 && < 1.1

22+ build-depends: aeson >= 0.9 && < 1.4

23+ , base >=4.8 && <4.11

24+ , snap >= 1.0 && < 1.2

2525 , snap-server >= 1.0 && < 1.1

2626 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.8 && < 0.11

28− , servant-snap >= 0.7.2 && < 0.8

29− , text >= 1.2 && < 1.3

27+ , servant >= 0.8 && < 0.12

28+ , servant-snap >= 0.8 && < 0.9

29+ , text >= 1.0 && < 1.3

3030 -- hs-source-dirs:

3131 default-language: Haskell2010