5867eae · servant-reflex

git.iko.soy/servant-reflex

Add Multi interface for making batch requests

commit5867eaedd8e6a50fceb17b04958b505b4bfd84c9 authorGreg Hale <imalsogreg@gmail.com> dateSat 18 Feb 2017, 23:28 (10 years ago) parent183d8db

4 files changed+195−30

compare with master

unifiedsplit

exec/Example.hs+32−5 servant-reflex.cabal+2−1 src/Servant/Common/Req.hs+119−16 src/Servant/Reflex.hs+42−8

exec/Example.hs+32−5

@@ -6,25 +6,51 @@

77module Main where

9+------------------------------------------------------------------------------

910import Data.Bool

1011import Data.Maybe

1112import Control.Monad.Fix (MonadFix)

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

13+import Data.Monoid (First(..), (<>))

1314import Data.Text (Text)

1415import qualified Data.Text as T

1516import Servant.API

16−import Servant.Reflex

1717import API

1818import Data.Proxy

1919import Text.Read (readMaybe)

2020import Reflex.Dom

21+------------------------------------------------------------------------------

22+import Servant.Reflex

23+import Servant.Reflex.Multi

24+

2125

2226api :: Proxy API

2327api = Proxy

2428

2529main :: IO ()

26−main = mainWidget run

27−

30+main = mainWidget $ do

31+ divClass "example-base" run

32+ divClass "example-multi" runMulti

33+

34+

35+runMulti :: forall t m. (SupportsServantReflex t m,

36+ DomBuilder t m,

37+ DomBuilderSpace m ~ GhcjsDomSpace,

38+ MonadFix m,

39+ PostBuild t m,

40+ MonadHold t m) => m ()

41+runMulti = do

42+ url <- baseUrlWidget

43+ el "br" blank

44+ let (_ :<|> _ :<|> _ :<|> dbl :<|> _ :<|> _ ) =

45+ clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) url

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

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

48+ -- dynText =<< holdDyn "waiting" (T.pack . show <$> num)

49+ -- numLabeled :: Event t (First Int, Double) <- zipListWithEvent (,) (First . Just <$> [0..]) num

50+ b <- button "Run dbl multi"

51+ r <- dbl [num,num2] b

52+ dynText =<< holdDyn "Waiting" (T.pack . show . fmapMaybe reqSuccess <$> r)

53+ return ()

2854

2955run :: forall t m. (SupportsServantReflex t m,

3056 DomBuilder t m,

@@ -39,6 +65,7 @@ run = do

3965 url <- baseUrlWidget

4066 el "br" (return ())

4167 dynText $ showBaseUrl <$> url

68+

4269 el "br" (return ())

4370

4471 -- Name the computed API client functions

@@ -90,7 +117,7 @@ run = do

90117 text "A Double to double"

91118 el "br" $ return ()

92119 dblinp <- fmap value $ divClass "double-input" $ textInput def

93− dblBtn <- divClass "double-button" $ button "Double it"

120+ (dblBtn) <- divClass "double-button" $ button "Double it"

94121 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

95122 dblinp) dblBtn

96123 divClass "double-errors" $ dynText =<<

servant-reflex.cabal+2−1

@@ -1,5 +1,5 @@

11Name: servant-reflex

2−Version: 0.2

2+Version: 0.2.1

33Synopsis: Servant reflex API generator

44Description: Servant reflex API generator

55License: AllRightsReserved

@@ -14,6 +14,7 @@ Cabal-version: >=1.10

1414library

1515 exposed-modules:

1616 Servant.Reflex

17+ Servant.Reflex.Multi

1718

1819 other-modules:

1920 Servant.Common.BaseUrl

src/Servant/Common/Req.hs+119−16

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

12{-# LANGUAGE DeriveDataTypeable #-}

23{-# LANGUAGE CPP #-}

34{-# LANGUAGE FlexibleContexts #-}

@@ -6,10 +7,14 @@

67{-# LANGUAGE LambdaCase #-}

78{-# LANGUAGE ScopedTypeVariables #-}

89{-# LANGUAGE TupleSections #-}

10+

11+{-# LANGUAGE EmptyCase #-}

912module Servant.Common.Req where

1013

1114-------------------------------------------------------------------------------

15+import Control.Concurrent

1216import Control.Applicative (liftA2, liftA3)

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

1318import qualified Data.ByteString.Lazy.Char8 as BL

1419import qualified Data.Map as Map

1520import Data.Maybe (catMaybes)

@@ -18,6 +23,7 @@ import Data.Proxy (Proxy(..))

1823import Data.Text (Text)

1924import qualified Data.Text as T

2025import qualified Data.Text.Encoding as TE

26+import Data.Traversable

2127import Reflex.Dom

2228import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)

2329import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

@@ -96,20 +102,13 @@ addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) ->

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

97103

98104

99−-- * performing requests

100−

101−displayHttpRequest :: Text -> Text

102−displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

103−

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

105−performRequest :: forall t m.(SupportsServantReflex t m)

106− => Text

107− -> Req t

108− -> Dynamic t BaseUrl

109− -> Event t ()

110− -> m (Event t XhrResponse, Event t Text)

111−performRequest reqMeth req reqHost trigger = do

112−

105+reqToReflexRequest

106+ :: forall t. Reflex t

107+ => Text

108+ -> Req t

109+ -> Dynamic t BaseUrl

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

111+reqToReflexRequest reqMeth req reqHost =

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

114113 t = sequence $ reverse $ reqPathParts req

115114

@@ -142,8 +141,8 @@ performRequest reqMeth req reqHost trigger = do

142141 queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])

143142 queryString :: Dynamic t (Either Text Text) =

144143 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

145−-- ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") (sequence qs)

146− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q) baseUrl urlPath queryString

144+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)

145+ baseUrl urlPath queryString

147146 where

148147 (</>) :: Text -> Text -> Text

149148 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

@@ -202,6 +201,71 @@ performRequest reqMeth req reqHost trigger = do

202201

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

204203

204+ in xhrReq

205+

206+-- * performing requests

207+

208+displayHttpRequest :: Text -> Text

209+displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

210+

211+-- | This function actually performs the request.

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

213+ => Text

214+ -> f (Req t)

215+ -> Dynamic t BaseUrl

216+ -> Event t ()

217+ -> m (Event t (f (Either Text XhrResponse)))

218+performRequests reqMeth rs reqHost trigger = do

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

220+ let reqs = tagPromptlyDyn xhrReqs trigger

221+ resps <- performSomeRequestsAsync reqs

222+ return resps

223+

224+-- | 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.

225+performSomeRequestsAsync

226+ :: (MonadIO (Performable m),

227+ HasWebView (Performable m),

228+ PerformEvent t m,

229+ TriggerEvent t m,

230+ Traversable f,

231+ IsXhrPayload a)

232+ => Event t (f (Either Text (XhrRequest a)))

233+ -> m (Event t (f (Either Text XhrResponse)))

234+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

235+

236+

237+------------------------------------------------------------------------------

238+-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

239+-- that accepts 'f (Either e (XhrRequestb))' events

240+performSomeRequestsAsync'

241+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

242+ => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)

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

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

245+ rs <- hrs

246+ resps <- forM rs $ \r -> case r of

247+ Left e -> do

248+ resp <- liftIO $ newMVar (Left e)

249+ return resp

250+ Right r' -> do

251+ resp <- liftIO newEmptyMVar

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

253+ return resp

254+ _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

255+ return ()

256+

257+

258+

259+-- | This function actually performs the request.

260+performRequest :: forall t m .(SupportsServantReflex t m)

261+ => Text

262+ -> (Req t)

263+ -> Dynamic t BaseUrl

264+ -> Event t ()

265+ -> m (Event t (XhrResponse), Event t Text)

266+performRequest reqMeth req reqHost trigger = do

267+

268+ let xhrReq = reqToReflexRequest reqMeth req reqHost

205269 let reqs = tagPromptlyDyn xhrReq trigger

206270 okReqs = fmapMaybe (either (const Nothing) Just) reqs

207271 badReqs = fmapMaybe (either Just (const Nothing)) reqs

@@ -210,6 +274,7 @@ performRequest reqMeth req reqHost trigger = do

210274

211275 return (resps, badReqs)

212276

277+

213278#ifdef ghcjs_HOST_OS

214279type XhrPayload = String

215280bytesToPayload :: BL.ByteString -> XhrPayload

@@ -229,6 +294,20 @@ performRequestNoBody reqMeth req reqHost trigger = do

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

230295 return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

231296

297+performRequestsNoBody :: forall t m f .(SupportsServantReflex t m, Traversable f)

298+ => Text

299+ -> f (Req t)

300+ -> Dynamic t BaseUrl

301+ -> Event t () -> m (Event t (f (ReqResult NoContent)))

302+performRequestsNoBody reqMeth reqs reqHost trigger = do

303+ resp <- performRequests reqMeth reqs reqHost trigger

304+ return $ (fmap . fmap) aux resp

305+ where

306+ aux (Right x) = ResponseSuccess NoContent x

307+ aux (Left e) = RequestFailure e

308+ -- return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

309+

310+

232311

233312performRequestCT :: (SupportsServantReflex t m,

234313 MimeUnrender ct a)

@@ -244,5 +323,29 @@ performRequestCT ct reqMeth req reqHost trigger = do

244323 (Left e, r) -> ResponseFailure (T.pack e) r

245324 return $ leftmost [reqs, fmap RequestFailure badReq]

246325

326+performRequestsCT

327+ :: (SupportsServantReflex t m,

328+ MimeUnrender ct a, Traversable f)

329+ => Proxy ct

330+ -> Text

331+ -> f (Req t)

332+ -> Dynamic t BaseUrl

333+ -> Event t ()

334+ -> m (Event t (f (ReqResult a)))

335+performRequestsCT ct reqMeth reqs reqHost trigger = do

336+ resps <- performRequests reqMeth reqs reqHost trigger

337+ return $ ffor resps $ \eithXhrs -> ffor eithXhrs $ \eithXhr -> case eithXhr of

338+ Left e -> RequestFailure e

339+ Right x -> case _xhrResponse_responseText x of

340+ Nothing -> ResponseFailure "No body text" x

341+ Just bod -> case mimeUnrender ct . BL.fromStrict . TE.encodeUtf8 $ bod of

342+ Left e -> ResponseFailure (T.pack e) x

343+ Right a -> ResponseSuccess a x

344+

345+

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

248347note e = maybe (Left e) Right

348+

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

350+fmapL _ (Right a) = Right a

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

src/Servant/Reflex.hs+42−8

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

12{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleContexts #-}

@@ -18,12 +19,14 @@

1819-- API.

1920module Servant.Reflex

2021 ( client

22+ , BuildHeaderKeysTo(..)

23+ , toHeaders

2124 , HasClient(..)

2225 , module Servant.Common.Req

2326 , module Servant.Common.BaseUrl

2427 ) where

2528

26−-------------------------------------------------------------------------------

29+------------------------------------------------------------------------------

2730import Control.Applicative

2831import Data.Monoid ((<>))

2932import qualified Data.Set as Set

@@ -43,6 +46,14 @@ import Servant.API ((:<|>)(..),(:>), BasicAuth,

4346 QueryParams, Raw, ReflectMethod(..),

4447 RemoteHost, ReqBody,

4548 ToHttpApiData(..), Vault, Verb)

49+

50+import Reflex.Dom (Dynamic, Event, Reflex,

51+ XhrRequest(..),

52+ XhrResponseHeaders(..),

53+ XhrResponse(..), ffor, fmapMaybe,

54+ leftmost, performRequestAsync,

55+ tagPromptlyDyn )

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

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

4758 showBaseUrl,

4859 SupportsServantReflex)

@@ -50,17 +61,14 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

5061 QueryPart(..), addHeader, authData,

5162 defReq, prependToPathParts,

5263 performRequestCT,

64+ performRequestsCT,

5365 performRequestNoBody,

66+ performRequestsNoBody,

67+ performSomeRequestsAsync,

5468 qParamToQueryPart, reqBody,

5569 reqSuccess, reqFailure,

5670 reqMethod, respHeaders, response,

5771 qParams)

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

59− XhrRequest(..),

60− XhrResponseHeaders(..),

61− XhrResponse(..), ffor, fmapMaybe,

62− leftmost, performRequestAsync,

63− tagPromptlyDyn )

6472

6573-- * Accessing APIs as a Client

6674

@@ -81,6 +89,7 @@ client :: (HasClient t m layout)

8189 => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

8290client p q baseurl = clientWithRoute p q defReq baseurl

8391

92+

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

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

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

@@ -91,10 +100,12 @@ class HasClient t m layout where

91100

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

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

103+

94104 clientWithRoute Proxy q req baseurl =

95105 clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>

96106 clientWithRoute (Proxy :: Proxy b) q req baseurl

97107

108+

98109-- Capture. Example:

99110-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

100111-- >

@@ -106,6 +117,7 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

106117-- -> Event t ()

107118-- -> m (Event t (Either XhrError (Text, Book)))

108119-- > getBook = client myApi (constDyn host)

120+

109121instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

110122 => HasClient t m (Capture capture a :> sublayout) where

111123

@@ -117,9 +129,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

117129 q

118130 (prependToPathParts p req)

119131 baseurl

120−

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

122133

134+

123135-- VERB (Returning content) --

124136instance {-# OVERLAPPABLE #-}

125137 -- Note [Non-Empty Content Types]

@@ -134,6 +146,9 @@ instance {-# OVERLAPPABLE #-}

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

135147 req' = req { reqMethod = method }

136148

149+

150+

151+

137152-- -- VERB (No content) --

138153instance {-# OVERLAPPING #-}

139154 (ReflectMethod method, SupportsServantReflex t m) =>

@@ -146,6 +161,7 @@ instance {-# OVERLAPPING #-}

146161 performRequestNoBody method req baseurl

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

148163

164+

149165toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)

150166toHeaders r =

151167 let toBS = E.encodeUtf8

@@ -186,6 +202,7 @@ instance {-# OVERLAPPABLE #-}

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

187203 }

188204

205+

189206-- HEADERS Verb (No content) --

190207instance {-# OVERLAPPABLE #-}

191208 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

@@ -202,6 +219,7 @@ instance {-# OVERLAPPABLE #-}

202219 }

203220

204221

222+

205223-- HEADER

206224-- > newtype Referer = Referer { referrer :: Text }

207225-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)

@@ -229,6 +247,9 @@ instance (KnownSymbol sym, ToHttpApiData a,

229247 baseurl

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

231249

250+

251+

252+

232253-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

233254-- functions.

234255instance HasClient t m sublayout

@@ -241,6 +262,7 @@ instance HasClient t m sublayout

241262 clientWithRoute (Proxy :: Proxy sublayout) q

242263

243264

265+

244266-- | If you use a 'QueryParam' in one of your endpoints in your API,

245267-- the corresponding querying function will automatically take

246268-- an additional argument of the type specified by your 'QueryParam',

@@ -284,6 +306,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

284306 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm

285307 paramPair = (T.pack pname, p mparam)

286308

309+

310+

287311-- | If you use a 'QueryParams' in one of your endpoints in your API,

288312-- the corresponding querying function will automatically take

289313-- an additional argument, a list of values of the type specified

@@ -327,6 +351,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

327351 paramlist

328352

329353

354+

330355-- | If you use a 'QueryFlag' in one of your endpoints in your API,

331356-- the corresponding querying function will automatically take

332357-- an additional 'Bool' argument.

@@ -365,6 +390,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

365390 pName = symbolVal (Proxy :: Proxy sym)

366391

367392

393+

368394-- | Pick a 'Method' and specify where the server you want to query is. You get

369395-- back the full `Response`.

370396-- TODO redo

@@ -389,6 +415,7 @@ instance SupportsServantReflex t m => HasClient t m Raw where

389415 ,fmap RequestFailure badReq]

390416

391417

418+

392419hush :: Either e a -> Maybe a

393420hush = either (const Nothing) Just

394421

@@ -430,6 +457,8 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

430457 (\b -> (mimeRender ctProxy b, ctString))

431458 body

432459

460+

461+

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

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

435464 type Client t m (path :> sublayout) = Client t m sublayout

@@ -441,24 +470,29 @@ instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m

441470

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

443472

473+

444474instance HasClient t m api => HasClient t m (Vault :> api) where

445475 type Client t m (Vault :> api) = Client t m api

446476

447477 clientWithRoute Proxy q req baseurl =

448478 clientWithRoute (Proxy :: Proxy api) q req baseurl

449479

480+

450481instance HasClient t m api => HasClient t m (RemoteHost :> api) where

451482 type Client t m (RemoteHost :> api) = Client t m api

452483

453484 clientWithRoute Proxy q req baseurl =

454485 clientWithRoute (Proxy :: Proxy api) q req baseurl

455486

487+

488+

456489instance HasClient t m api => HasClient t m (IsSecure :> api) where

457490 type Client t m (IsSecure :> api) = Client t m api

458491

459492 clientWithRoute Proxy q req baseurl =

460493 clientWithRoute (Proxy :: Proxy api) q req baseurl

461494

495+

462496instance (HasClient t m api, Reflex t)

463497 => HasClient t m (BasicAuth realm usr :> api) where

464498