From 3c13cb8e5a690bc98a57c7722fc3480261259d8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Wed, 24 Aug 2022 15:17:04 +0200 Subject: [PATCH 1/7] Add support for full query string capture in servant-server --- servant-server/src/Servant/Server/Internal.hs | 30 +++++++++++++- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 4 ++ servant/src/Servant/API/QueryString.hs | 39 +++++++++++++++++++ 4 files changed, 73 insertions(+), 1 deletion(-) create mode 100644 servant/src/Servant/API/QueryString.hs diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a4d74564..63857ded 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -74,7 +74,7 @@ import Servant.API CaptureAll, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), NoContentVerb, QueryFlag, - QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), + QueryParam', QueryParams, QueryString, Raw, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext, NamedRoutes) @@ -585,6 +585,34 @@ instance (KnownSymbol sym, HasServer api context) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False +-- | If you use @'QueryString'@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @Query@ (@[('ByteString', 'Maybe' 'ByteString')]@). +-- +-- This lets you extract the whole query string. This is useful when the query string +-- can contain parameters with dynamic names, that you can't access with @'QueryParam'@. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryString :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: Query -> Handler [Book] +-- > getBooksBy filters = ...filter books based on the dynamic filters provided... +instance + ( HasServer api context + ) + => HasServer (QueryString :> api) context where +------ + type ServerT (QueryString :> api) m = + Query -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver queryString) + -- | Just pass the request to the underlying application and serve its response. -- -- Example: diff --git a/servant/servant.cabal b/servant/servant.cabal index a3dc401d..27874ecd 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -48,6 +48,7 @@ library Servant.API.Modifiers Servant.API.NamedRoutes Servant.API.QueryParam + Servant.API.QueryString Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 22309dce..cf50d46b 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -19,6 +19,8 @@ module Servant.API ( -- | Retrieving the HTTP version of the request module Servant.API.QueryParam, -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ + module Servant.API.QueryString, + -- | Retrieving the complete query string of the 'URI': @'QueryString'@ module Servant.API.Fragment, -- | Documenting the fragment of the 'URI': @'Fragment'@ module Servant.API.ReqBody, @@ -114,6 +116,8 @@ import Servant.API.Modifiers (Lenient, Optional, Required, Strict) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) +import Servant.API.QueryString + (QueryString) import Servant.API.Raw (Raw) import Servant.API.RemoteHost diff --git a/servant/src/Servant/API/QueryString.hs b/servant/src/Servant/API/QueryString.hs new file mode 100644 index 00000000..138ffeec --- /dev/null +++ b/servant/src/Servant/API/QueryString.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.QueryString (QueryString, DeepQuery) where + +import Data.Typeable + (Typeable) +import GHC.TypeLits + (Symbol) + +-- | Extract the whole query string from a request. This is useful for query strings +-- containing dynamic parameter names. For query strings with static parameter names, +-- 'QueryParam' is more suited. +-- +-- Example: +-- +-- >>> -- /books?author=&year= +-- >>> type MyApi = "books" :> QueryString :> Get '[JSON] [Book] +data QueryString + deriving Typeable + +-- | Extract an deep object from a query string. +-- +-- Example: +-- +-- >>> -- /books?filter[author][name]=&filter[year]= +-- >>> type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book] +data DeepQuery (sym :: Symbol) (a :: *) + deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> data BookQuery +-- >>> instance ToJSON Book where { toJSON = undefined } From 024def921777695f87476db3a7193186212d8161 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Wed, 24 Aug 2022 16:16:09 +0200 Subject: [PATCH 2/7] Parse deep objects from query string --- servant-server/src/Servant/Server.hs | 3 + servant-server/src/Servant/Server/Internal.hs | 91 ++++++++++++++++++- servant/src/Servant/API.hs | 2 +- 3 files changed, 94 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 79d092b9..aa58a88e 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -110,6 +110,9 @@ module Servant.Server , getAcceptHeader + -- * DeepQuery parsing + , FromDeepQuery (..) + -- * Re-exports , Application , Tagged (..) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 63857ded..04a185d8 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -38,6 +38,7 @@ import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Resource (runResourceT) +import Data.Bifunctor (first) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 @@ -45,6 +46,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Constraint (Constraint, Dict(..)) import Data.Either (partitionEithers) +import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.String @@ -71,7 +73,7 @@ import Prelude () import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', - CaptureAll, Description, EmptyAPI, Fragment, + CaptureAll, DeepQuery, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', If, IsSecure (..), NoContentVerb, QueryFlag, QueryParam', QueryParams, QueryString, Raw, ReflectMethod (reflectMethod), @@ -613,6 +615,93 @@ instance route Proxy context subserver = route (Proxy :: Proxy api) context (passToServer subserver queryString) +-- | If you use @'DeepQuery' "symbol" a@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @a@. +-- +-- This lets you extract an object from multiple parameters in the query string, +-- with its fields enclosed in brackets: `/books?filter[author][name]=value`. When +-- all the fields are known in advance, it can be done with @'QueryParam'@ (it can +-- still be tedious if you the object has many fields). When some fields are dynamic, +-- it cannot be done with @'QueryParam'. +-- +-- The way the object is constructed from the extracted fields can be controlled by +-- providing an instance on @'FromDeepQuery'@ +-- +-- Example: +-- +-- > type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: BookQuery -> Handler [Book] +-- > getBooksBy query = ...filter books based on the dynamic filters provided... +instance + ( KnownSymbol sym, FromDeepQuery a, HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) + => HasServer (DeepQuery sym a :> api) context where +------ + type ServerT (DeepQuery sym a :> api) m = + a -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver = route (Proxy :: Proxy api) context $ + subserver `addParameterCheck` withRequest paramsCheck + where + rep = typeRep (Proxy :: Proxy DeepQuery) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + + paramname = cs $ symbolVal (Proxy :: Proxy sym) + paramsCheck req = + let relevantParams :: [(T.Text, Maybe T.Text)] + relevantParams = mapMaybe isRelevantParam + . queryToQueryText + . queryString + $ req + isRelevantParam (name, value) = (, value) <$> + case T.stripPrefix paramname name of + Just "" -> Just "" + Just x | "[" `T.isPrefixOf` x -> Just x + _ -> Nothing + in case fromDeepQuery =<< traverse parseDeepParam relevantParams of + Left e -> delayedFailFatal $ formatError rep req + $ cs $ "Error parsing deep query parameter(s) " + <> paramname <> T.pack " failed: " + <> T.pack e + Right parsed -> return parsed + +parseDeepParam :: (T.Text, Maybe T.Text) -> Either String ([T.Text], Maybe T.Text) +parseDeepParam (paramname, value) = + let parseParam "" = return [] + parseParam n = reverse <$> go [] n + go parsed remaining = case T.take 1 remaining of + "[" -> case T.breakOn "]" remaining of + (_ , "") -> Left $ "Error parsing deep param, missing closing ']': " <> T.unpack remaining + (name, "]") -> return $ T.drop 1 name : parsed + (name, remaining') -> case T.take 2 remaining' of + "][" -> go (T.drop 1 name : parsed) (T.drop 1 remaining') + _ -> Left $ "Error parsing deep param, incorrect brackets: " <> T.unpack remaining + _ -> Left $ "Error parsing deep param, missing opening '[': " <> T.unpack remaining + in (, value) <$> parseParam paramname + +-- | Extract a deep object from (possibly nested) query parameters. +-- a param like @filter[a][b][c]=d@ will be represented as +-- @'(["a", "b", "c"], Just "d")'@. Note that a parameter with no +-- nested field is possible: @filter=a@ will be represented as +-- @'([], Just "a")'@ +class FromDeepQuery a where + fromDeepQuery :: [([T.Text], Maybe T.Text)] -> Either String a + +instance FromHttpApiData a => FromDeepQuery (Map.Map T.Text a) where + fromDeepQuery params = + let parseParam ([k], Just rawV) = (k,) <$> first T.unpack (parseQueryParam rawV) + parseParam (_, Nothing) = Left "Empty map value" + parseParam ([], _) = Left "Empty map parameter" + parseParam (_ , Just _) = Left "Nested map values" + in Map.fromList <$> traverse parseParam params + -- | Just pass the request to the underlying application and serve its response. -- -- Example: diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index cf50d46b..37fb796f 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -117,7 +117,7 @@ import Servant.API.Modifiers import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) import Servant.API.QueryString - (QueryString) + (QueryString, DeepQuery) import Servant.API.Raw (Raw) import Servant.API.RemoteHost From bf477e3954b1f8711537a402568d41b3f66faee4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Fri, 14 Oct 2022 15:04:36 +0200 Subject: [PATCH 3/7] Generate query strings from complete maps or deep objects --- .../src/Servant/Client/Core/HasClient.hs | 44 ++++++++++++++++++- .../src/Servant/Client/Core/Reexport.hs | 3 ++ .../src/Servant/Client/Core/Request.hs | 9 +++- 3 files changed, 53 insertions(+), 3 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index fe2a15f8..3d62172b 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -23,6 +23,7 @@ module Servant.Client.Core.HasClient ( (/:), foldMapUnion, matchUnion, + ToDeepQuery (..) ) where import Prelude () @@ -44,6 +45,7 @@ import Data.List import Data.Sequence (fromList) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Media (MediaType, matches, parseAccept) import qualified Network.HTTP.Media as Media @@ -69,12 +71,12 @@ import Network.HTTP.Types import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, - BuildHeadersTo (..), Capture', CaptureAll, Description, + BuildHeadersTo (..), Capture', CaptureAll, DeepQuery, Description, EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), - NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, + NoContentVerb, QueryFlag, QueryParam', QueryParams, QueryString, Raw, ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList, @@ -662,6 +664,44 @@ instance (KnownSymbol sym, HasClient m api) hoistClientMonad pm _ f cl = \b -> hoistClientMonad pm (Proxy :: Proxy api) f (cl b) +instance (HasClient m api) + => HasClient m (QueryString :> api) where + type Client m (QueryString :> api) = + H.Query -> Client m api + + clientWithRoute pm Proxy req query = + clientWithRoute pm (Proxy :: Proxy api) + (setQueryString query req) + + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) + +class ToDeepQuery a where + toDeepQuery :: a -> [([T.Text], Maybe T.Text)] + +generateDeepParam :: T.Text -> ([T.Text], Maybe T.Text) -> (T.Text, Maybe T.Text) +generateDeepParam name (keys, value) = + let makeKeySegment key = "[" <> key <> "]" + in (name <> foldMap makeKeySegment keys, value) + +instance (KnownSymbol sym, ToDeepQuery a, HasClient m api) + => HasClient m (DeepQuery sym a :> api) where + type Client m (DeepQuery sym a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req deepObject = + let params = toDeepQuery deepObject + withParams = foldl' addDeepParam req params + addDeepParam r' kv = + let (k, textV) = generateDeepParam paramname kv + in appendToQueryString k (encodeUtf8 <$> textV) r' + paramname = pack $ symbolVal (Proxy :: Proxy sym) + in clientWithRoute pm (Proxy :: Proxy api) + withParams + + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) + -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance RunClient m => HasClient m Raw where diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index e7f43f71..f574031d 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -20,6 +20,9 @@ module Servant.Client.Core.Reexport , ClientError(..) , EmptyClient(..) + -- * DeepQuery + , ToDeepQuery(..) + -- * BaseUrl , BaseUrl(..) , Scheme(..) diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index 431b1f07..acbb6407 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -18,6 +18,7 @@ module Servant.Client.Core.Request ( appendToPath, appendToQueryString, encodeQueryParamValue, + setQueryString, setRequestBody, setRequestBodyLBS, ) where @@ -50,7 +51,7 @@ import GHC.Generics import Network.HTTP.Media (MediaType) import Network.HTTP.Types - (Header, HeaderName, HttpVersion (..), Method, QueryItem, + (Header, HeaderName, HttpVersion (..), Method, Query, QueryItem, http11, methodGet) import Servant.API (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO) @@ -162,6 +163,12 @@ appendToQueryString pname pvalue req = req { requestQueryString = requestQueryString req Seq.|> (encodeUtf8 pname, pvalue)} +setQueryString :: Query + -> Request + -> Request +setQueryString query req + = req { requestQueryString = Seq.fromList query } + -- | Encode a query parameter value. -- encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString From 7b0479079620a3c20eb864d389f81df1a32aebf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Tue, 6 Dec 2022 16:31:20 +0100 Subject: [PATCH 4/7] servant-server: add spec for QueryString and DeepQuery --- servant-server/test/Servant/ServerSpec.hs | 60 ++++++++++++++++++++--- 1 file changed, 53 insertions(+), 7 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4..cc5994a8 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -12,16 +12,19 @@ module Servant.ServerSpec where +import Debug.Trace + import Prelude () import Prelude.Compat import Control.Monad - (forM_, unless, when) + (forM_, join, unless, when) import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) @@ -49,14 +52,15 @@ import Network.Wai.Test import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, - Headers, HttpVersion, IsSecure (..), JSON, Lenient, - NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, - PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, + DeepQuery, Delete, EmptyAPI, Fragment, Get, + HasStatus (StatusOf), Header, Headers, HttpVersion, + IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, + NoFraming, OctetStream, Patch, PlainText, Post, Put, + QueryFlag, QueryParam, QueryParams, QueryString, Raw, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, UVerb, Union, Verb, WithStatus (..), addHeader) import Servant.Server - (Context ((:.), EmptyContext), Handler, Server, Tagged (..), + (Context ((:.), EmptyContext), FromDeepQuery (..), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, respond, serve, serveWithContext) import Servant.Test.ComprehensiveAPI @@ -67,6 +71,7 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) import qualified Test.Hspec.Wai as THW +import Text.Read (readMaybe) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) @@ -320,17 +325,33 @@ captureAllSpec = do -- * queryParamSpec {{{ ------------------------------------------------------------------------------ +data Filter = Filter + { ageFilter :: Integer + , nameFilter :: String + } + deriving Show + +instance FromDeepQuery Filter where + fromDeepQuery params = traceShowId $ do + let maybeToRight l = maybe (Left l) Right + age' <- maybeToRight "missing age" $ readMaybe . T.unpack =<< join (lookup ["age"] params) + name' <- maybeToRight "missing name" $ join $ lookup ["name"] params + return $ Filter age' (T.unpack name') + + type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person :<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person :<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person + :<|> "raw-query-string" :> QueryString :> Get '[JSON] Person + :<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy qpServer :: Server QueryParamApi -qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges +qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges :<|> qpRaw :<|> qpDeep where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice @@ -343,6 +364,15 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAge qpAges ages = return alice{ age = sum ages} + qpRaw q = return alice { name = maybe mempty C8.unpack $ join (lookup "name" q) + , age = fromMaybe 0 (readMaybe . C8.unpack =<< join (lookup "age" q)) + } + + qpDeep filter' = + return alice { name = nameFilter filter' + , age = ageFilter filter' + } + queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice @@ -414,6 +444,22 @@ queryParamSpec = do { name = "Alice" } + it "allows retrieving a full query string" $ + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?age=32&name=john" ["raw-query-string"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { name = "john" + , age = 32 + } + + it "allows retrieving a query string deep object" $ + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?filter[age]=32&filter[name]=john" ["deep-query"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { name = "john" + , age = 32 + } + describe "Uses queryString instead of rawQueryString" $ do -- test query parameters rewriter let queryRewriter :: Middleware From 35ac209c91b27a836a71b5f09cc1c49bc8f69eaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 15 Dec 2022 16:30:55 +0100 Subject: [PATCH 5/7] fixup! servant-server: add spec for QueryString and DeepQuery --- servant-server/test/Servant/ServerSpec.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index cc5994a8..81d47804 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -12,8 +12,6 @@ module Servant.ServerSpec where -import Debug.Trace - import Prelude () import Prelude.Compat From c45002a021247147b4348d60454c441ff4e24733 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 15 Dec 2022 16:30:55 +0100 Subject: [PATCH 6/7] fixup! servant-server: add spec for QueryString and DeepQuery --- servant-server/test/Servant/ServerSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 81d47804..50e1527a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -330,7 +330,7 @@ data Filter = Filter deriving Show instance FromDeepQuery Filter where - fromDeepQuery params = traceShowId $ do + fromDeepQuery params = do let maybeToRight l = maybe (Left l) Right age' <- maybeToRight "missing age" $ readMaybe . T.unpack =<< join (lookup ["age"] params) name' <- maybeToRight "missing name" $ join $ lookup ["name"] params From 1ae85d1ee9c2c58c9440203ca629dcd009af2269 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Delafargue?= Date: Thu, 15 Dec 2022 16:30:10 +0100 Subject: [PATCH 7/7] servant-client: add spec for QueryString and DeepQuery --- .../test/Servant/ClientTestUtils.hs | 42 +++++++++++++++++-- servant-client/test/Servant/SuccessSpec.hs | 7 ++++ 2 files changed, 46 insertions(+), 3 deletions(-) diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index b548c40f..8f98984f 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -31,11 +31,13 @@ import Control.Monad.Error.Class import Data.Aeson import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) +import Data.Maybe (fromMaybe) import Data.Monoid () import Data.Proxy import Data.SOP @@ -54,17 +56,18 @@ import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck +import Text.Read (readMaybe) import Web.FormUrlEncoded (FromForm, ToForm) import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, - BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, + BasicAuthData (..), Capture, CaptureAll, DeepQuery, DeleteNoContent, EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers, JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, - QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, - Verb, WithStatus (WithStatus), NamedRoutes, addHeader) + QueryParams, QueryString, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), + UVerb, Union, Verb, WithStatus (WithStatus), NamedRoutes, addHeader) import Servant.API.Generic ((:-)) import Servant.Client import qualified Servant.Client.Core.Auth as Auth @@ -121,6 +124,25 @@ data OtherRoutes mode = OtherRoutes -- Get for HTTP 307 Temporary Redirect type Get307 = Verb 'GET 307 +data Filter = Filter + { ageFilter :: Integer + , nameFilter :: String + } + deriving Show + +instance FromDeepQuery Filter where + fromDeepQuery params = do + let maybeToRight l = maybe (Left l) Right + age' <- maybeToRight "missing age" $ readMaybe . Text.unpack =<< join (lookup ["age"] params) + name' <- maybeToRight "missing name" $ join $ lookup ["name"] params + return $ Filter age' (Text.unpack name') + +instance ToDeepQuery Filter where + toDeepQuery (Filter age' name') = + [ (["age"], Just (Text.pack $ show age')) + , (["name"], Just (Text.pack name')) + ] + type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person @@ -139,6 +161,8 @@ type Api = :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool + :<|> "query-string" :> QueryString :> Get '[JSON] Person + :<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person :<|> "fragment" :> Fragment String :> Get '[JSON] Person :<|> "rawSuccess" :> Raw :<|> "rawSuccessPassHeaders" :> Raw @@ -176,6 +200,8 @@ getQueryParam :: Maybe String -> ClientM Person getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool +getQueryString :: [(ByteString, Maybe ByteString)] -> ClientM Person +getDeepQuery :: Filter -> ClientM Person getFragment :: ClientM Person getRawSuccess :: HTTP.Method -> ClientM Response getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response @@ -203,6 +229,8 @@ getRoot :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag + :<|> getQueryString + :<|> getDeepQuery :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders @@ -240,6 +268,14 @@ server = serve api ( ) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return + :<|> (\ q -> return alice { _name = maybe mempty C8.unpack $ join (lookup "name" q) + , _age = fromMaybe 0 (readMaybe . C8.unpack =<< join (lookup "age" q)) + } + ) + :<|> (\ filter' -> return alice { _name = nameFilter filter' + , _age = ageFilter filter' + } + ) :<|> return alice :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")) diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 06437ca6..28009f89 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -115,6 +115,13 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag + it "Servant.API.QueryParam.QueryString" $ \(_, baseUrl) -> do + let qs = [("name", Just "bob"), ("age", Just "1")] + left show <$> runClient (getQueryString qs) baseUrl `shouldReturn` (Right (Person "bob" 1)) + + it "Servant.API.QueryParam.DeepQuery" $ \(_, baseUrl) -> do + left show <$> runClient (getDeepQuery $ Filter 1 "bob") baseUrl `shouldReturn` (Right (Person "bob" 1)) + it "Servant.API.Fragment" $ \(_, baseUrl) -> do left id <$> runClient getFragment baseUrl `shouldReturn` Right alice