9ca6a0f · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Release notes and cleanup

commit9ca6a0f3439d9f967eb95c19ad4c4c2d70eb55b3 authorGreg Hale <imalsogreg@gmail.com> dateSat 4 Mar 2017, 15:20 (10 years ago) parentf870bba

3 files changed+140−87

compare with master

unifiedsplit

changelog.md+32 src/Servant/Common/Req.hs+36−15 src/Servant/Reflex/Multi.hs+72−72

changelog.mdnew file+32

@@ -0,0 +1,32 @@

1+0.3

2+---

4+- **Addition of the 'Servant.Reflex.Multi' module** which allows the user

5+to choose some '(Applicative f, Traversable f) => f' for collecting

6+endpoint parameters. The traversable instance is used for passing

7+multiple 'XhrRequest's in response to a single event trigger. The

8+Applicative instance is used to combine parameters. For example,

9+'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'

10+will generate a client function:

11+`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->

12+ m (Event t (f (ReqResult tag Text)))`

13+Calling that function with 'f' chosen to be list ('[]'), this call

14+`clientFun

15+(constDyn ["Greg", "Bernie"])

16+(constDyn ["Greetings", "Hey"])

17+trigger`

18+would produce four XhrRequests per 'trigger' event, one for each

19+combination of possible parameters, and one response event

20+would carry a list of the four responses.

21+A 'zip-wise' combination of the parameters can be chosen with

22+a different applicative wrapper: 'ZipList'

23+

24+- **Event tags**. A new type parameter lets users choose a payload

25+value to attach to outgoing requests at the point of triggering,

26+and which is embedded in the response, allowing individual

27+request-response pairs to be followed. The response's tag has been

28+added to each constructor `ReqResult tag a` type.

29+

30+- **Improved Unicode support** Thanks to Schell Scivally

31+(https://github.com/schell) for identifying and fixing a UTF-8

32+encoding bug!

src/Servant/Common/Req.hs+36−15

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

31{-# LANGUAGE CPP #-}

42{-# LANGUAGE FlexibleContexts #-}

53{-# LANGUAGE GADTs #-}

@@ -8,13 +6,11 @@

86{-# LANGUAGE ScopedTypeVariables #-}

97{-# LANGUAGE TupleSections #-}

108

11−{-# LANGUAGE EmptyCase #-}

129module Servant.Common.Req where

1310

1411-------------------------------------------------------------------------------

1512import Control.Concurrent

1613import Control.Applicative (liftA2, liftA3)

17−import Control.Arrow (second)

1814import Control.Monad (join)

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

2016import Data.Bifunctor (first)

@@ -27,44 +23,67 @@ import Data.Proxy (Proxy(..))

2723import Data.Text (Text)

2824import qualified Data.Text as T

2925import qualified Data.Text.Encoding as TE

30−import Data.Traversable

31−import Reflex.Dom

32−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)

26+import Data.Traversable (forM)

27+import Reflex.Dom hiding (tag)

28+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

29+ SupportsServantReflex)

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

3431import Web.HttpApiData (ToHttpApiData(..))

3532-------------------------------------------------------------------------------

3633import Servant.API.BasicAuth

3734

3835

36+------------------------------------------------------------------------------

37+-- | The result of a request event

38+data ReqResult tag a

39+ = ResponseSuccess tag a XhrResponse

40+ -- ^ The succesfully decoded response from a request tagged with 'tag'

41+ | ResponseFailure tag Text XhrResponse

42+ -- ^ The failure response, which may have failed decoding or had

43+ -- a non-successful response code

44+ | RequestFailure tag Text

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

3946

40−data ReqResult tag a = ResponseSuccess tag a XhrResponse

41− | ResponseFailure tag Text XhrResponse

42− | RequestFailure tag Text

43−

44−instance Functor (ReqResult tag) where

45− fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr

46− fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x

47− fmap _ (RequestFailure tag r) = RequestFailure tag r

4847

48+------------------------------------------------------------------------------

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

50+-- ignore the error case. For example:

51+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers

4952reqSuccess :: ReqResult tag a -> Maybe a

5053reqSuccess (ResponseSuccess _ x _) = Just x

5154reqSuccess _ = Nothing

5255

56+

57+------------------------------------------------------------------------------

58+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag

5359reqSuccess' :: ReqResult tag a -> Maybe (tag,a)

5460reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)

5561reqSuccess' _ = Nothing

5662

63+

64+------------------------------------------------------------------------------

65+-- | Simple filter/accessor for any failure case

5766reqFailure :: ReqResult tag a -> Maybe Text

5867reqFailure (ResponseFailure _ s _) = Just s

5968reqFailure (RequestFailure _ s) = Just s

6069reqFailure _ = Nothing

6170

71+

72+------------------------------------------------------------------------------

73+-- | Simple filter/accessor for the raw XHR response

6274response :: ReqResult tag a -> Maybe XhrResponse

6375response (ResponseSuccess _ _ x) = Just x

6476response (ResponseFailure _ _ x) = Just x

6577response _ = Nothing

6678

6779

80+------------------------------------------------------------------------------

81+instance Functor (ReqResult tag) where

82+ fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr

83+ fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x

84+ fmap _ (RequestFailure tag r) = RequestFailure tag r

85+

86+

6887-------------------------------------------------------------------------------

6988-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to

7089-- indicate whether the parameter is valid and present, validly absent, or

@@ -76,11 +95,13 @@ data QParam a = QParamSome a

7695 | QParamInvalid Text

7796 -- ^ Indication that your validation failed (the request isn't valid)

7897

98+

7999qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)

80100qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)

81101qParamToQueryPart QNone = Right Nothing

82102qParamToQueryPart (QParamInvalid e) = Left e

83103

104+

84105data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

85106 | QueryPartParams (Dynamic t [Text])

86107 | QueryPartFlag (Dynamic t Bool)

src/Servant/Reflex/Multi.hs+72−72

@@ -1,69 +1,74 @@

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE InstanceSigs #-}

147{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TupleSections #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+

16+module Servant.Reflex.Multi (

17+ -- * Compute servant client functions

18+ clientA

19+ , BaseUrl(..)

20+ , Scheme(..)

21+

22+ -- * Build QueryParam arguments

23+ , QParam(..)

24+

25+

26+ -- * Access response data

27+ , ReqResult(..)

28+ , reqSuccess

29+ , reqSuccess'

30+ , reqFailure

31+ , response

1532

16−module Servant.Reflex.Multi

17− ( clientA

1833 , HasClientMulti(..)

1934 ) where

2035

2136------------------------------------------------------------------------------

22−import Control.Applicative

23−import Control.Arrow (second)

24−import Data.Functor.Compose

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

26−import qualified Data.Set as Set

27−import qualified Data.Text.Encoding as E

28−import Data.CaseInsensitive (mk)

29−import Data.Proxy (Proxy (..))

30−import qualified Data.Map as Map

31−import Data.Text (Text)

32−import qualified Data.Text as T

33−import GHC.TypeLits (KnownSymbol, symbolVal)

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

35− BasicAuthData, BuildHeadersTo(..),

36− Capture, contentType, Header,

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

38− MimeRender(..), MimeUnrender,

39− NoContent, QueryFlag, QueryParam,

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

41− RemoteHost, ReqBody,

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

43−

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

45− XhrRequest(..),

46− XhrResponseHeaders(..),

47− XhrResponse(..), constDyn, ffor, fmapMaybe,

48− leftmost, performRequestAsync, attachPromptlyDynWith,

49− tagPromptlyDyn )

37+import Control.Applicative (liftA2)

38+import Data.Functor.Compose (Compose (..), getCompose)

39+import Data.Proxy (Proxy (..))

40+import qualified Data.Set as Set

41+import Data.Text (Text)

42+import qualified Data.Text as T

43+import qualified Data.Text.Encoding as E

44+import GHC.TypeLits (KnownSymbol, symbolVal)

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

46+ BasicAuthData, BuildHeadersTo (..),

47+ Capture, Header, Headers (..),

48+ HttpVersion, IsSecure, MimeRender (..),

49+ MimeUnrender, NoContent, QueryFlag,

50+ QueryParam, QueryParams, Raw,

51+ ReflectMethod (..), RemoteHost,

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

53+ Verb, contentType)

54+

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

56+ XhrRequest (..),

57+ XhrResponseHeaders (..),

58+ attachPromptlyDynWith, constDyn)

5059------------------------------------------------------------------------------

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

52− showBaseUrl,

53− SupportsServantReflex)

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

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

56− defReq, prependToPathParts,

57− -- performRequestCT,

58− performRequestsCT,

59− -- performRequestNoBody,

60− performRequestsNoBody,

61− performSomeRequestsAsync,

62− qParamToQueryPart, reqBody,

63− reqSuccess, reqFailure,

64− reqMethod, respHeaders, response,

65− qParams)

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

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

61+ SupportsServantReflex)

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

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

64+ defReq, performRequestsCT,

65+ performRequestsNoBody,

66+ performSomeRequestsAsync,

67+ prependToPathParts, qParamToQueryPart,

68+ qParams, reqBody, reqFailure,

69+ reqMethod, reqSuccess, reqSuccess',

70+ respHeaders, response)

71+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

6772

6873

6974------------------------------------------------------------------------------

@@ -102,7 +107,8 @@ instance (SupportsServantReflex t m,

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

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

104109

105− clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

110+ clientWithRouteMulti _ q f tag reqs baseurl vals =

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

106112 where

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

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

@@ -122,7 +128,7 @@ instance {-# OVERLAPPABLE #-}

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

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

124130

125− clientWithRouteMulti _ _ f tag reqs baseurl =

131+ clientWithRouteMulti _ _ _ _ reqs baseurl =

126132 performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

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

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

@@ -137,7 +143,7 @@ instance {-# OVERLAPPING #-}

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

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

139145 -- ExceptT ServantError IO NoContent

140− clientWithRouteMulti Proxy _ _ tag req baseurl =

146+ clientWithRouteMulti Proxy _ _ _ req baseurl =

141147 performRequestsNoBody method req baseurl

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

143149

@@ -223,7 +229,6 @@ instance (KnownSymbol sym,

223229 ToHttpApiData a,

224230 HasClientMulti t m sublayout f tag,

225231 Reflex t,

226− Traversable f,

227232 Applicative f)

228233 => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where

229234

@@ -249,7 +254,6 @@ instance (KnownSymbol sym,

249254 ToHttpApiData a,

250255 HasClientMulti t m sublayout f tag,

251256 Reflex t,

252− Traversable f,

253257 Applicative f)

254258 => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

255259

@@ -264,21 +268,19 @@ instance (KnownSymbol sym,

264268 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

265269 l

266270 reqs' = liftA2 req' <$> paramlists <*> reqs

267− -- reqs' = req' <$> paramlists <*> reqs

268271

269272

270273instance (KnownSymbol sym,

271274 HasClientMulti t m sublayout f tag,

272275 Reflex t,

273− Traversable f,

274276 Applicative f)

275277 => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

276278

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

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

279281

280− clientWithRouteMulti Proxy q f tag reqs baseurl flags =

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

282+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =

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

282284

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

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

@@ -292,10 +294,9 @@ instance (SupportsServantReflex t m,

292294 -> Event t tag

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

294296

295− clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do

297+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do

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

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

298−-- resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''

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

300301 return resps

301302 where

@@ -306,7 +307,6 @@ instance (SupportsServantReflex t m,

306307instance (MimeRender ct a,

307308 HasClientMulti t m sublayout f tag,

308309 Reflex t,

309− Traversable f,

310310 Applicative f)

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

312312

@@ -359,7 +359,7 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f

359359 clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

360360

361361

362−instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)

362+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

363363 => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

364364

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