9ca6a0f · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

Release notes and cleanup

9ca6a0fGreg Hale10 years ago

changelog.mdnew file+32

compare with master

unifiedsplit

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

3{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

4{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

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

8{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE EmptyCase #-}

12module Servant.Common.Req where

9module Servant.Common.Req where

14-------------------------------------------------------------------------------

11-------------------------------------------------------------------------------

15import Control.Concurrent

12import Control.Concurrent

16import Control.Applicative (liftA2, liftA3)

13import Control.Applicative (liftA2, liftA3)

17−import Control.Arrow (second)

18import Control.Monad (join)

14import Control.Monad (join)

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

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

20import Data.Bifunctor (first)

16import Data.Bifunctor (first)

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

27import Data.Text (Text)

23import Data.Text (Text)

28import qualified Data.Text as T

24import qualified Data.Text as T

29import qualified Data.Text.Encoding as TE

25import qualified Data.Text.Encoding as TE

30−import Data.Traversable

26+import Data.Traversable (forM)

31−import Reflex.Dom

27+import Reflex.Dom hiding (tag)

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

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

29+ SupportsServantReflex)

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

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

34import Web.HttpApiData (ToHttpApiData(..))

31import Web.HttpApiData (ToHttpApiData(..))

35-------------------------------------------------------------------------------

32-------------------------------------------------------------------------------

36import Servant.API.BasicAuth

33import Servant.API.BasicAuth

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

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

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

49reqSuccess :: ReqResult tag a -> Maybe a

52reqSuccess :: ReqResult tag a -> Maybe a

50reqSuccess (ResponseSuccess _ x _) = Just x

53reqSuccess (ResponseSuccess _ x _) = Just x

51reqSuccess _ = Nothing

54reqSuccess _ = Nothing

56+

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

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

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

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

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

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

55reqSuccess' _ = Nothing

61reqSuccess' _ = Nothing

63+

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

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

57reqFailure :: ReqResult tag a -> Maybe Text

66reqFailure :: ReqResult tag a -> Maybe Text

58reqFailure (ResponseFailure _ s _) = Just s

67reqFailure (ResponseFailure _ s _) = Just s

59reqFailure (RequestFailure _ s) = Just s

68reqFailure (RequestFailure _ s) = Just s

60reqFailure _ = Nothing

69reqFailure _ = Nothing

71+

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

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

62response :: ReqResult tag a -> Maybe XhrResponse

74response :: ReqResult tag a -> Maybe XhrResponse

63response (ResponseSuccess _ _ x) = Just x

75response (ResponseSuccess _ _ x) = Just x

64response (ResponseFailure _ _ x) = Just x

76response (ResponseFailure _ _ x) = Just x

65response _ = Nothing

77response _ = Nothing

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+

68-------------------------------------------------------------------------------

87-------------------------------------------------------------------------------

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

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

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

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

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

76 | QParamInvalid Text

95 | QParamInvalid Text

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

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

98+

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

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

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

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

81qParamToQueryPart QNone = Right Nothing

101qParamToQueryPart QNone = Right Nothing

82qParamToQueryPart (QParamInvalid e) = Left e

102qParamToQueryPart (QParamInvalid e) = Left e

103

104+

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

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

85 | QueryPartParams (Dynamic t [Text])

106 | QueryPartParams (Dynamic t [Text])

86 | QueryPartFlag (Dynamic t Bool)

107 | QueryPartFlag (Dynamic t Bool)

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

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE InstanceSigs #-}

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

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

16−module Servant.Reflex.Multi

17− ( clientA

18 , HasClientMulti(..)

33 , HasClientMulti(..)

19 ) where

34 ) where

21------------------------------------------------------------------------------

36------------------------------------------------------------------------------

22−import Control.Applicative

37+import Control.Applicative (liftA2)

23−import Control.Arrow (second)

24−import Data.Functor.Compose

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

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

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

26−import qualified Data.Set as Set

40+import qualified Data.Set as Set

41+import Data.Text (Text)

42+import qualified Data.Text as T

27−import qualified Data.Text.Encoding as E

43+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)

44+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

35− BasicAuthData, BuildHeadersTo(..),

46+ BasicAuthData, BuildHeadersTo (..),

36− Capture, contentType, Header,

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

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

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

38− MimeRender(..), MimeUnrender,

39− NoContent, QueryFlag, QueryParam,

49+ MimeUnrender, NoContent, QueryFlag,

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

50+ QueryParam, QueryParams, Raw,

41− RemoteHost, ReqBody,

51+ ReflectMethod (..), RemoteHost,

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

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

43−

53+ Verb, contentType)

54+

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

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

45− XhrRequest(..),

56+ XhrRequest (..),

46− XhrResponseHeaders(..),

57+ XhrResponseHeaders (..),

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

48− leftmost, performRequestAsync, attachPromptlyDynWith,

58+ attachPromptlyDynWith, constDyn)

49− tagPromptlyDyn )

50------------------------------------------------------------------------------

59------------------------------------------------------------------------------

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

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

52− showBaseUrl,

53− SupportsServantReflex)

61+ SupportsServantReflex)

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

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

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

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

56− defReq, prependToPathParts,

57− -- performRequestCT,

58− performRequestsCT,

64+ defReq, performRequestsCT,

59− -- performRequestNoBody,

60− performRequestsNoBody,

65+ performRequestsNoBody,

61− performSomeRequestsAsync,

66+ performSomeRequestsAsync,

62− qParamToQueryPart, reqBody,

67+ prependToPathParts, qParamToQueryPart,

63− reqSuccess, reqFailure,

68+ qParams, reqBody, reqFailure,

69+ reqMethod, reqSuccess, reqSuccess',

64− reqMethod, respHeaders, response,

70+ respHeaders, response)

65− qParams)

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

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

69------------------------------------------------------------------------------

74------------------------------------------------------------------------------

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

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

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

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

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

104

109

110+ clientWithRouteMulti _ q f tag reqs baseurl vals =

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

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

106 where

112 where

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

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

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

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

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

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

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

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

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

124

130

125− clientWithRouteMulti _ _ f tag reqs baseurl =

131+ clientWithRouteMulti _ _ _ _ reqs baseurl =

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

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

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

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

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

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

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

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

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

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

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

139 -- ExceptT ServantError IO NoContent

145 -- ExceptT ServantError IO NoContent

140− clientWithRouteMulti Proxy _ _ tag req baseurl =

146+ clientWithRouteMulti Proxy _ _ _ req baseurl =

141 performRequestsNoBody method req baseurl

147 performRequestsNoBody method req baseurl

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

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

143

149

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

223 ToHttpApiData a,

229 ToHttpApiData a,

224 HasClientMulti t m sublayout f tag,

230 HasClientMulti t m sublayout f tag,

225 Reflex t,

231 Reflex t,

226− Traversable f,

227 Applicative f)

232 Applicative f)

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

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

229

234

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

249 ToHttpApiData a,

254 ToHttpApiData a,

250 HasClientMulti t m sublayout f tag,

255 HasClientMulti t m sublayout f tag,

251 Reflex t,

256 Reflex t,

252− Traversable f,

253 Applicative f)

257 Applicative f)

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

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

255

259

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

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

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

265 l

269 l

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

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

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

268

271

269

272

270instance (KnownSymbol sym,

273instance (KnownSymbol sym,

271 HasClientMulti t m sublayout f tag,

274 HasClientMulti t m sublayout f tag,

272 Reflex t,

275 Reflex t,

273− Traversable f,

274 Applicative f)

276 Applicative f)

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

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

276

278

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

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

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

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

279

281

280− clientWithRouteMulti Proxy q f tag reqs baseurl flags =

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

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

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

282

284

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

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

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

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

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

292 -> Event t tag

294 -> Event t tag

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

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

294

296

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

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

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

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

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

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

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

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

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

300 return resps

301 return resps

301 where

302 where

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

306instance (MimeRender ct a,

307instance (MimeRender ct a,

307 HasClientMulti t m sublayout f tag,

308 HasClientMulti t m sublayout f tag,

308 Reflex t,

309 Reflex t,

309− Traversable f,

310 Applicative f)

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

312

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

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

360

361

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)

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

364

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