mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
Release notes and cleanup
This commit is contained in:
parent
f870bbaa85
commit
9ca6a0f343
32
changelog.md
Normal file
32
changelog.md
Normal file
@ -0,0 +1,32 @@
|
||||
0.3
|
||||
---
|
||||
|
||||
- **Addition of the 'Servant.Reflex.Multi' module** which allows the user
|
||||
to choose some '(Applicative f, Traversable f) => f' for collecting
|
||||
endpoint parameters. The traversable instance is used for passing
|
||||
multiple 'XhrRequest's in response to a single event trigger. The
|
||||
Applicative instance is used to combine parameters. For example,
|
||||
'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'
|
||||
will generate a client function:
|
||||
`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->
|
||||
m (Event t (f (ReqResult tag Text)))`
|
||||
Calling that function with 'f' chosen to be list ('[]'), this call
|
||||
`clientFun
|
||||
(constDyn ["Greg", "Bernie"])
|
||||
(constDyn ["Greetings", "Hey"])
|
||||
trigger`
|
||||
would produce four XhrRequests per 'trigger' event, one for each
|
||||
combination of possible parameters, and one response event
|
||||
would carry a list of the four responses.
|
||||
A 'zip-wise' combination of the parameters can be chosen with
|
||||
a different applicative wrapper: 'ZipList'
|
||||
|
||||
- **Event tags**. A new type parameter lets users choose a payload
|
||||
value to attach to outgoing requests at the point of triggering,
|
||||
and which is embedded in the response, allowing individual
|
||||
request-response pairs to be followed. The response's tag has been
|
||||
added to each constructor `ReqResult tag a` type.
|
||||
|
||||
- **Improved Unicode support** Thanks to Schell Scivally
|
||||
(https://github.com/schell) for identifying and fixing a UTF-8
|
||||
encoding bug!
|
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
@ -8,13 +6,11 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{-# LANGUAGE EmptyCase #-}
|
||||
module Servant.Common.Req where
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
import Control.Concurrent
|
||||
import Control.Applicative (liftA2, liftA3)
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Bifunctor (first)
|
||||
@ -27,44 +23,67 @@ import Data.Proxy (Proxy(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Traversable
|
||||
import Reflex.Dom
|
||||
import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)
|
||||
import Data.Traversable (forM)
|
||||
import Reflex.Dom hiding (tag)
|
||||
import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
|
||||
SupportsServantReflex)
|
||||
import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
|
||||
import Web.HttpApiData (ToHttpApiData(..))
|
||||
-------------------------------------------------------------------------------
|
||||
import Servant.API.BasicAuth
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The result of a request event
|
||||
data ReqResult tag a
|
||||
= ResponseSuccess tag a XhrResponse
|
||||
-- ^ The succesfully decoded response from a request tagged with 'tag'
|
||||
| ResponseFailure tag Text XhrResponse
|
||||
-- ^ The failure response, which may have failed decoding or had
|
||||
-- a non-successful response code
|
||||
| RequestFailure tag Text
|
||||
-- ^ A failure to construct the request tagged with 'tag' at trigger time
|
||||
|
||||
data ReqResult tag a = ResponseSuccess tag a XhrResponse
|
||||
| ResponseFailure tag Text XhrResponse
|
||||
| RequestFailure tag Text
|
||||
|
||||
instance Functor (ReqResult tag) where
|
||||
fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr
|
||||
fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x
|
||||
fmap _ (RequestFailure tag r) = RequestFailure tag r
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Simple filter/accessor for successful responses, when you want to
|
||||
-- ignore the error case. For example:
|
||||
-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers
|
||||
reqSuccess :: ReqResult tag a -> Maybe a
|
||||
reqSuccess (ResponseSuccess _ x _) = Just x
|
||||
reqSuccess _ = Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
|
||||
reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
|
||||
reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
|
||||
reqSuccess' _ = Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Simple filter/accessor for any failure case
|
||||
reqFailure :: ReqResult tag a -> Maybe Text
|
||||
reqFailure (ResponseFailure _ s _) = Just s
|
||||
reqFailure (RequestFailure _ s) = Just s
|
||||
reqFailure _ = Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Simple filter/accessor for the raw XHR response
|
||||
response :: ReqResult tag a -> Maybe XhrResponse
|
||||
response (ResponseSuccess _ _ x) = Just x
|
||||
response (ResponseFailure _ _ x) = Just x
|
||||
response _ = Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
instance Functor (ReqResult tag) where
|
||||
fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr
|
||||
fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x
|
||||
fmap _ (RequestFailure tag r) = RequestFailure tag r
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
|
||||
-- indicate whether the parameter is valid and present, validly absent, or
|
||||
@ -76,11 +95,13 @@ data QParam a = QParamSome a
|
||||
| QParamInvalid Text
|
||||
-- ^ Indication that your validation failed (the request isn't valid)
|
||||
|
||||
|
||||
qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
|
||||
qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
|
||||
qParamToQueryPart QNone = Right Nothing
|
||||
qParamToQueryPart (QParamInvalid e) = Left e
|
||||
|
||||
|
||||
data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
|
||||
| QueryPartParams (Dynamic t [Text])
|
||||
| QueryPartFlag (Dynamic t Bool)
|
||||
|
@ -1,69 +1,74 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Reflex.Multi (
|
||||
-- * Compute servant client functions
|
||||
clientA
|
||||
, BaseUrl(..)
|
||||
, Scheme(..)
|
||||
|
||||
-- * Build QueryParam arguments
|
||||
, QParam(..)
|
||||
|
||||
|
||||
-- * Access response data
|
||||
, ReqResult(..)
|
||||
, reqSuccess
|
||||
, reqSuccess'
|
||||
, reqFailure
|
||||
, response
|
||||
|
||||
module Servant.Reflex.Multi
|
||||
( clientA
|
||||
, HasClientMulti(..)
|
||||
) where
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
import Control.Applicative
|
||||
import Control.Arrow (second)
|
||||
import Data.Functor.Compose
|
||||
import Data.Monoid ((<>))
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.CaseInsensitive (mk)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Servant.API ((:<|>)(..),(:>), BasicAuth,
|
||||
BasicAuthData, BuildHeadersTo(..),
|
||||
Capture, contentType, Header,
|
||||
Headers(..), HttpVersion, IsSecure,
|
||||
MimeRender(..), MimeUnrender,
|
||||
NoContent, QueryFlag, QueryParam,
|
||||
QueryParams, Raw, ReflectMethod(..),
|
||||
RemoteHost, ReqBody,
|
||||
ToHttpApiData(..), Vault, Verb)
|
||||
import Control.Applicative (liftA2)
|
||||
import Data.Functor.Compose (Compose (..), getCompose)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Servant.API ((:<|>) (..), (:>), BasicAuth,
|
||||
BasicAuthData, BuildHeadersTo (..),
|
||||
Capture, Header, Headers (..),
|
||||
HttpVersion, IsSecure, MimeRender (..),
|
||||
MimeUnrender, NoContent, QueryFlag,
|
||||
QueryParam, QueryParams, Raw,
|
||||
ReflectMethod (..), RemoteHost,
|
||||
ReqBody, ToHttpApiData (..), Vault,
|
||||
Verb, contentType)
|
||||
|
||||
import Reflex.Dom (Dynamic, Event, Reflex,
|
||||
XhrRequest(..),
|
||||
XhrResponseHeaders(..),
|
||||
XhrResponse(..), constDyn, ffor, fmapMaybe,
|
||||
leftmost, performRequestAsync, attachPromptlyDynWith,
|
||||
tagPromptlyDyn )
|
||||
import Reflex.Dom (Dynamic, Event, Reflex,
|
||||
XhrRequest (..),
|
||||
XhrResponseHeaders (..),
|
||||
attachPromptlyDynWith, constDyn)
|
||||
------------------------------------------------------------------------------
|
||||
import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
|
||||
showBaseUrl,
|
||||
SupportsServantReflex)
|
||||
import Servant.Common.Req (Req, ReqResult(..), QParam(..),
|
||||
QueryPart(..), addHeader, authData,
|
||||
defReq, prependToPathParts,
|
||||
-- performRequestCT,
|
||||
performRequestsCT,
|
||||
-- performRequestNoBody,
|
||||
performRequestsNoBody,
|
||||
performSomeRequestsAsync,
|
||||
qParamToQueryPart, reqBody,
|
||||
reqSuccess, reqFailure,
|
||||
reqMethod, respHeaders, response,
|
||||
qParams)
|
||||
import Servant.Reflex (BuildHeaderKeysTo(..), toHeaders)
|
||||
import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
|
||||
SupportsServantReflex)
|
||||
import Servant.Common.Req (QParam (..), QueryPart (..), Req,
|
||||
ReqResult (..), addHeader, authData,
|
||||
defReq, performRequestsCT,
|
||||
performRequestsNoBody,
|
||||
performSomeRequestsAsync,
|
||||
prependToPathParts, qParamToQueryPart,
|
||||
qParams, reqBody, reqFailure,
|
||||
reqMethod, reqSuccess, reqSuccess',
|
||||
respHeaders, response)
|
||||
import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -102,7 +107,8 @@ instance (SupportsServantReflex t m,
|
||||
type ClientMulti t m (Capture capture a :> sublayout) f tag =
|
||||
f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
|
||||
|
||||
clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
|
||||
clientWithRouteMulti _ q f tag reqs baseurl vals =
|
||||
clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
|
||||
where
|
||||
reqs' = (prependToPathParts <$> ps <*>) <$> reqs
|
||||
ps = (fmap . fmap . fmap) toUrlPiece vals
|
||||
@ -122,7 +128,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
type ClientMulti t m (Verb method status cts' a) f tag =
|
||||
Event t tag -> m (Event t (f (ReqResult tag a)))
|
||||
|
||||
clientWithRouteMulti _ _ f tag reqs baseurl =
|
||||
clientWithRouteMulti _ _ _ _ reqs baseurl =
|
||||
performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
|
||||
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
|
||||
reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
|
||||
@ -137,7 +143,7 @@ instance {-# OVERLAPPING #-}
|
||||
Event t tag -> m (Event t (f (ReqResult tag NoContent)))
|
||||
-- TODO: how to access input types here?
|
||||
-- ExceptT ServantError IO NoContent
|
||||
clientWithRouteMulti Proxy _ _ tag req baseurl =
|
||||
clientWithRouteMulti Proxy _ _ _ req baseurl =
|
||||
performRequestsNoBody method req baseurl
|
||||
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
@ -223,7 +229,6 @@ instance (KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
HasClientMulti t m sublayout f tag,
|
||||
Reflex t,
|
||||
Traversable f,
|
||||
Applicative f)
|
||||
=> HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
|
||||
|
||||
@ -249,7 +254,6 @@ instance (KnownSymbol sym,
|
||||
ToHttpApiData a,
|
||||
HasClientMulti t m sublayout f tag,
|
||||
Reflex t,
|
||||
Traversable f,
|
||||
Applicative f)
|
||||
=> HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
|
||||
|
||||
@ -264,21 +268,19 @@ instance (KnownSymbol sym,
|
||||
params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
|
||||
l
|
||||
reqs' = liftA2 req' <$> paramlists <*> reqs
|
||||
-- reqs' = req' <$> paramlists <*> reqs
|
||||
|
||||
|
||||
instance (KnownSymbol sym,
|
||||
HasClientMulti t m sublayout f tag,
|
||||
Reflex t,
|
||||
Traversable f,
|
||||
Applicative f)
|
||||
=> HasClientMulti t m (QueryFlag sym :> sublayout) f tag where
|
||||
|
||||
type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
|
||||
Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
|
||||
|
||||
clientWithRouteMulti Proxy q f tag reqs baseurl flags =
|
||||
clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
|
||||
clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
|
||||
clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
|
||||
|
||||
where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
|
||||
thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
|
||||
@ -292,10 +294,9 @@ instance (SupportsServantReflex t m,
|
||||
-> Event t tag
|
||||
-> m (Event t (f (ReqResult tag ())))
|
||||
|
||||
clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do
|
||||
clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
|
||||
let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
|
||||
rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
|
||||
-- resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''
|
||||
resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
|
||||
return resps
|
||||
where
|
||||
@ -306,7 +307,6 @@ instance (SupportsServantReflex t m,
|
||||
instance (MimeRender ct a,
|
||||
HasClientMulti t m sublayout f tag,
|
||||
Reflex t,
|
||||
Traversable f,
|
||||
Applicative f)
|
||||
=> HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
|
||||
|
||||
@ -359,7 +359,7 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f
|
||||
clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
|
||||
|
||||
|
||||
instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)
|
||||
instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
|
||||
=> HasClientMulti t m (BasicAuth realm usr :> api) f tag where
|
||||
|
||||
type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
|
||||
|
Loading…
Reference in New Issue
Block a user