diff --git a/changelog.d/1604 b/changelog.d/1604 new file mode 100644 index 000000000..b7b201652 --- /dev/null +++ b/changelog.d/1604 @@ -0,0 +1,10 @@ +synopsis: Full query string helpers +prs: #1604 + +description: { + This PR introduces `DeepQuery`, a route combinator that implements a pattern commonly known as deep objects. + It builds upon the convention of using `[]` for a list of parameters: + `books?filter[search]=value&filter[author][name]=value`. + The corresponding type would be `DeepQuery "filter" BookQuery :> Get '[JSON] [Book]`. + +} diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 5b64281a5..f087a58e8 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -22,7 +22,7 @@ module Servant.Client.Core.HasClient ( (//), (/:), foldMapUnion, - matchUnion, + matchUnion ) where import Prelude () @@ -46,6 +46,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 @@ -70,22 +71,23 @@ import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as H import Servant.API - ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, - BuildHeadersTo (..), Capture', CaptureAll, Description, - EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), - FromSourceIO (..), Header', Headers (..), HttpVersion, - IsSecure, MimeRender (mimeRender), - MimeUnrender (mimeUnrender), NoContent (NoContent), - NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM, - ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, - StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, - Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, - getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes) + ((:<|>) ((:<|>)), (:>), + BuildHeadersTo (..), + EmptyAPI, + FromSourceIO (..), + IsSecure, + MimeUnrender (mimeUnrender), + NoContentVerb, + ReflectMethod (..), + StreamBody', + Verb, + getResponse, AuthProtect, BasicAuth, BasicAuthData, Capture', CaptureAll, DeepQuery, Description, Fragment, FramingRender (..), FramingUnrender (..), Header', Headers (..), HttpVersion, MimeRender (mimeRender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, RemoteHost, ReqBody', SBoolI, Stream, Summary, ToHttpApiData, ToSourceIO (..), Vault, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, toEncodedUrlPiece, toUrlPiece, NamedRoutes) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi , GenericServant, toServant, fromServant) import Servant.API.ContentTypes (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) +import Servant.API.QueryString (ToDeepQuery(..), generateDeepParam) import Servant.API.Status (statusFromNat) import Servant.API.TypeLevel (FragmentUnique, AtMostOneFragment) @@ -664,6 +666,36 @@ 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) + +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/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index d00cd9950..1cba07e25 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, urlEncodeBuilder) import Servant.API (ToHttpApiData, toEncodedUrlPiece, toQueryParam, 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 diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 30cb6b105..1d6b57b19 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,18 +56,20 @@ 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.API.QueryString (FromDeepQuery(..), ToDeepQuery(..)) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server @@ -122,6 +126,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 @@ -140,6 +163,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 @@ -178,6 +203,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 @@ -206,6 +233,8 @@ getRoot :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag + :<|> getQueryString + :<|> getDeepQuery :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders @@ -244,6 +273,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 c86375716..643e62d29 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -110,6 +110,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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 5cc89b5b8..b0f36cd8e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -40,6 +40,7 @@ import Control.Monad.Trans import Control.Monad.Trans.Resource (runResourceT, ReleaseKey) import Data.Acquire +import Data.Bifunctor (first) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 @@ -49,6 +50,7 @@ import Data.Either (partitionEithers) import Data.Kind (Type) +import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import Data.String @@ -75,10 +77,10 @@ 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, Raw, RawM, ReflectMethod (reflectMethod), + QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod), RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext, WithResource, NamedRoutes) @@ -90,6 +92,7 @@ import Servant.API.ContentTypes import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) +import Servant.API.QueryString (FromDeepQuery(..)) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import Servant.API.Status @@ -627,6 +630,105 @@ 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) + +-- | 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 + -- | Just pass the request to the underlying application and serve its response. -- -- Example: diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 3df5c3e24..98537d1bf 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -16,7 +16,7 @@ import Prelude () import Prelude.Compat import Control.Monad - (forM_, unless, when) + (forM_, join, unless, when) import Control.Monad.Reader (runReaderT, ask) import Control.Monad.Error.Class (MonadError (..)) @@ -26,6 +26,7 @@ import Data.Aeson import Data.Acquire (Acquire, mkAcquire) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) @@ -57,8 +58,14 @@ import Servant.API Header, Header', Headers, HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, NoFraming, OctetStream, Optional, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM, + 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, addHeader') +import Servant.API.QueryString (FromDeepQuery(..)) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..), emptyServer, err401, err403, err404, hoistServer, respond, serve, @@ -71,6 +78,7 @@ import Test.Hspec.Wai (get, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) import qualified Test.Hspec.Wai as THW +import Text.Read (readMaybe) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) @@ -362,17 +370,33 @@ captureAllSpec = do -- * queryParamSpec {{{ ------------------------------------------------------------------------------ +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 . 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 @@ -385,6 +409,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 @@ -456,6 +489,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 diff --git a/servant/servant.cabal b/servant/servant.cabal index 0e2b271e9..76470ab70 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -47,6 +47,7 @@ library Servant.API.Modifiers Servant.API.NamedRoutes Servant.API.QueryParam + Servant.API.QueryString Servant.API.Raw Servant.API.RemoteHost Servant.API.ReqBody @@ -83,6 +84,7 @@ library base >= 4.9 && < 4.20 , bytestring >= 0.10.8.1 && < 0.13 , constraints >= 0.2 + , containers >= 0.6 && < 0.7 , mtl ^>= 2.2.2 || ^>= 2.3.1 , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.7 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 347f6d846..47fa1fadf 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, @@ -118,6 +120,8 @@ import Servant.API.NamedRoutes (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) +import Servant.API.QueryString + (QueryString, DeepQuery) import Servant.API.Raw (Raw, RawM) 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 000000000..837773ebc --- /dev/null +++ b/servant/src/Servant/API/QueryString.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} + +module Servant.API.QueryString (QueryString, DeepQuery, FromDeepQuery (..), ToDeepQuery (..), generateDeepParam) where + +import Data.Bifunctor (Bifunctor (first)) +#if MIN_VERSION_base(4,9,0) +import Data.Kind (Type) +#endif +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable + ( Typeable, + ) +import GHC.TypeLits + ( Symbol, + ) +import Web.HttpApiData (FromHttpApiData) +import Web.Internal.HttpApiData (FromHttpApiData (..)) + +-- | 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 :: Type) + deriving (Typeable) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Book +-- >>> data BookQuery +-- >>> instance ToJSON Book where { toJSON = undefined } + +-- | 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 :: [([Text], Maybe Text)] -> Either String a + +instance (FromHttpApiData a) => FromDeepQuery (Map 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 + +-- | Generate query parameters from an object, using the deep object syntax. +-- A result of @'(["a", "b", "c"], Just "d")'@ attributed to the @filter@ +-- parameter name will result in the following query parameter: +-- @filter[a][b][c]=d@ +class ToDeepQuery a where + toDeepQuery :: a -> [([Text], Maybe Text)] + +-- | Turn a nested path into a deep object query param +-- +-- >>> generateDeepParam "filter" (["a", "b", "c"], Just "d") +-- ("filter[a][b][c]",Just "d") +generateDeepParam :: Text -> ([Text], Maybe Text) -> (Text, Maybe Text) +generateDeepParam name (keys, value) = + let makeKeySegment key = "[" <> key <> "]" + in (name <> foldMap makeKeySegment keys, value)