Skip to content

Commit bcbd3d2

Browse files
divarveldivarvel
committed
Add support for full & deep query string capture in servant-server
1 parent a5357ea commit bcbd3d2

File tree

9 files changed

+349
-20
lines changed

9 files changed

+349
-20
lines changed

‎servant-client-core/src/Servant/Client/Core/HasClient.hs

+44-12
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ module Servant.Client.Core.HasClient (
2222
(//),
2323
(/:),
2424
foldMapUnion,
25-
matchUnion,
25+
matchUnion
2626
) where
2727

2828
import Prelude ()
@@ -46,6 +46,7 @@ import Data.List
4646
import Data.Sequence
4747
(fromList)
4848
import qualified Data.Text as T
49+
import Data.Text.Encoding (encodeUtf8)
4950
import Network.HTTP.Media
5051
(MediaType, matches, parseAccept)
5152
import qualified Network.HTTP.Media as Media
@@ -70,22 +71,23 @@ import Network.HTTP.Types
7071
(Status)
7172
import qualified Network.HTTP.Types as H
7273
import Servant.API
73-
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
74-
BuildHeadersTo (..), Capture', CaptureAll, Description,
75-
EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
76-
FromSourceIO (..), Header', Headers (..), HttpVersion,
77-
IsSecure, MimeRender (mimeRender),
78-
MimeUnrender (mimeUnrender), NoContent (NoContent),
79-
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
80-
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
81-
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
82-
Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
83-
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
74+
((:<|>) ((:<|>)), (:>),
75+
BuildHeadersTo (..),
76+
EmptyAPI,
77+
FromSourceIO (..),
78+
IsSecure,
79+
MimeUnrender (mimeUnrender),
80+
NoContentVerb,
81+
ReflectMethod (..),
82+
StreamBody',
83+
Verb,
84+
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)
8485
import Servant.API.Generic
8586
(GenericMode(..), ToServant, ToServantApi
8687
, GenericServant, toServant, fromServant)
8788
import Servant.API.ContentTypes
8889
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
90+
import Servant.API.QueryString (ToDeepQuery(..), generateDeepParam)
8991
import Servant.API.Status
9092
(statusFromNat)
9193
import Servant.API.TypeLevel (FragmentUnique, AtMostOneFragment)
@@ -664,6 +666,36 @@ instance (KnownSymbol sym, HasClient m api)
664666
hoistClientMonad pm _ f cl = \b ->
665667
hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
666668

669+
instance (HasClient m api)
670+
=> HasClient m (QueryString :> api) where
671+
type Client m (QueryString :> api) =
672+
H.Query -> Client m api
673+
674+
clientWithRoute pm Proxy req query =
675+
clientWithRoute pm (Proxy :: Proxy api)
676+
(setQueryString query req)
677+
678+
hoistClientMonad pm _ f cl = \b ->
679+
hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
680+
681+
instance (KnownSymbol sym, ToDeepQuery a, HasClient m api)
682+
=> HasClient m (DeepQuery sym a :> api) where
683+
type Client m (DeepQuery sym a :> api) =
684+
a -> Client m api
685+
686+
clientWithRoute pm Proxy req deepObject =
687+
let params = toDeepQuery deepObject
688+
withParams = foldl' addDeepParam req params
689+
addDeepParam r' kv =
690+
let (k, textV) = generateDeepParam paramname kv
691+
in appendToQueryString k (encodeUtf8 <$> textV) r'
692+
paramname = pack $ symbolVal (Proxy :: Proxy sym)
693+
in clientWithRoute pm (Proxy :: Proxy api)
694+
withParams
695+
696+
hoistClientMonad pm _ f cl = \b ->
697+
hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
698+
667699
-- | Pick a 'Method' and specify where the server you want to query is. You get
668700
-- back the full `Response`.
669701
instance RunClient m => HasClient m Raw where

‎servant-client-core/src/Servant/Client/Core/Request.hs

+8-1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ module Servant.Client.Core.Request (
1818
appendToPath,
1919
appendToQueryString,
2020
encodeQueryParamValue,
21+
setQueryString,
2122
setRequestBody,
2223
setRequestBodyLBS,
2324
) where
@@ -50,7 +51,7 @@ import GHC.Generics
5051
import Network.HTTP.Media
5152
(MediaType)
5253
import Network.HTTP.Types
53-
(Header, HeaderName, HttpVersion (..), Method, QueryItem,
54+
(Header, HeaderName, HttpVersion (..), Method, Query, QueryItem,
5455
http11, methodGet, urlEncodeBuilder)
5556
import Servant.API
5657
(ToHttpApiData, toEncodedUrlPiece, toQueryParam, toHeader, SourceIO)
@@ -162,6 +163,12 @@ appendToQueryString pname pvalue req
162163
= req { requestQueryString = requestQueryString req
163164
Seq.|> (encodeUtf8 pname, pvalue)}
164165

166+
setQueryString :: Query
167+
-> Request
168+
-> Request
169+
setQueryString query req
170+
= req { requestQueryString = Seq.fromList query }
171+
165172
-- | Encode a query parameter value.
166173
--
167174
encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

‎servant-client/test/Servant/ClientTestUtils.hs

+40-3
Original file line numberDiff line numberDiff line change
@@ -31,11 +31,13 @@ import Control.Monad.Error.Class
3131
import Data.Aeson
3232
import Data.ByteString
3333
(ByteString)
34+
import qualified Data.ByteString.Char8 as C8
3435
import Data.ByteString.Builder
3536
(byteString)
3637
import qualified Data.ByteString.Lazy as LazyByteString
3738
import Data.Char
3839
(chr, isPrint)
40+
import Data.Maybe (fromMaybe)
3941
import Data.Monoid ()
4042
import Data.Proxy
4143
import Data.SOP
@@ -54,18 +56,20 @@ import Network.Wai.Handler.Warp
5456
import System.IO.Unsafe
5557
(unsafePerformIO)
5658
import Test.QuickCheck
59+
import Text.Read (readMaybe)
5760
import Web.FormUrlEncoded
5861
(FromForm, ToForm)
5962

6063
import Servant.API
6164
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
62-
BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
65+
BasicAuthData (..), Capture, CaptureAll, DeepQuery, DeleteNoContent,
6366
EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers,
6467
JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
6568
NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
66-
QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
67-
Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
69+
QueryParams, QueryString, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..),
70+
UVerb, Union, Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
6871
import Servant.API.Generic ((:-))
72+
import Servant.API.QueryString (FromDeepQuery(..), ToDeepQuery(..))
6973
import Servant.Client
7074
import qualified Servant.Client.Core.Auth as Auth
7175
import Servant.Server
@@ -122,6 +126,25 @@ data OtherRoutes mode = OtherRoutes
122126
-- Get for HTTP 307 Temporary Redirect
123127
type Get307 = Verb 'GET 307
124128

129+
data Filter = Filter
130+
{ ageFilter :: Integer
131+
, nameFilter :: String
132+
}
133+
deriving Show
134+
135+
instance FromDeepQuery Filter where
136+
fromDeepQuery params = do
137+
let maybeToRight l = maybe (Left l) Right
138+
age' <- maybeToRight "missing age" $ readMaybe . Text.unpack =<< join (lookup ["age"] params)
139+
name' <- maybeToRight "missing name" $ join $ lookup ["name"] params
140+
return $ Filter age' (Text.unpack name')
141+
142+
instance ToDeepQuery Filter where
143+
toDeepQuery (Filter age' name') =
144+
[ (["age"], Just (Text.pack $ show age'))
145+
, (["name"], Just (Text.pack name'))
146+
]
147+
125148
type Api =
126149
Get '[JSON] Person
127150
:<|> "get" :> Get '[JSON] Person
@@ -140,6 +163,8 @@ type Api =
140163
:<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw
141164
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
142165
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
166+
:<|> "query-string" :> QueryString :> Get '[JSON] Person
167+
:<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person
143168
:<|> "fragment" :> Fragment String :> Get '[JSON] Person
144169
:<|> "rawSuccess" :> Raw
145170
:<|> "rawSuccessPassHeaders" :> Raw
@@ -178,6 +203,8 @@ getQueryParam :: Maybe String -> ClientM Person
178203
getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response
179204
getQueryParams :: [String] -> ClientM [Person]
180205
getQueryFlag :: Bool -> ClientM Bool
206+
getQueryString :: [(ByteString, Maybe ByteString)] -> ClientM Person
207+
getDeepQuery :: Filter -> ClientM Person
181208
getFragment :: ClientM Person
182209
getRawSuccess :: HTTP.Method -> ClientM Response
183210
getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
@@ -206,6 +233,8 @@ getRoot
206233
:<|> getQueryParamBinary
207234
:<|> getQueryParams
208235
:<|> getQueryFlag
236+
:<|> getQueryString
237+
:<|> getDeepQuery
209238
:<|> getFragment
210239
:<|> getRawSuccess
211240
:<|> getRawSuccessPassHeaders
@@ -244,6 +273,14 @@ server = serve api (
244273
)
245274
:<|> (\ names -> return (zipWith Person names [0..]))
246275
:<|> return
276+
:<|> (\ q -> return alice { _name = maybe mempty C8.unpack $ join (lookup "name" q)
277+
, _age = fromMaybe 0 (readMaybe . C8.unpack =<< join (lookup "age" q))
278+
}
279+
)
280+
:<|> (\ filter' -> return alice { _name = nameFilter filter'
281+
, _age = ageFilter filter'
282+
}
283+
)
247284
:<|> return alice
248285
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
249286
:<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))

‎servant-client/test/Servant/SuccessSpec.hs

+7
Original file line numberDiff line numberDiff line change
@@ -110,6 +110,13 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
110110
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
111111
left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
112112

113+
it "Servant.API.QueryParam.QueryString" $ \(_, baseUrl) -> do
114+
let qs = [("name", Just "bob"), ("age", Just "1")]
115+
left show <$> runClient (getQueryString qs) baseUrl `shouldReturn` (Right (Person "bob" 1))
116+
117+
it "Servant.API.QueryParam.DeepQuery" $ \(_, baseUrl) -> do
118+
left show <$> runClient (getDeepQuery $ Filter 1 "bob") baseUrl `shouldReturn` (Right (Person "bob" 1))
119+
113120
it "Servant.API.Fragment" $ \(_, baseUrl) -> do
114121
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
115122

‎servant-server/src/Servant/Server/Internal.hs

+104-2
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ import Control.Monad.Trans
4040
import Control.Monad.Trans.Resource
4141
(runResourceT, ReleaseKey)
4242
import Data.Acquire
43+
import Data.Bifunctor (first)
4344
import qualified Data.ByteString as B
4445
import qualified Data.ByteString.Builder as BB
4546
import qualified Data.ByteString.Char8 as BC8
@@ -49,6 +50,7 @@ import Data.Either
4950
(partitionEithers)
5051
import Data.Kind
5152
(Type)
53+
import qualified Data.Map.Strict as Map
5254
import Data.Maybe
5355
(fromMaybe, isNothing, mapMaybe, maybeToList)
5456
import Data.String
@@ -75,10 +77,10 @@ import Prelude ()
7577
import Prelude.Compat
7678
import Servant.API
7779
((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
78-
CaptureAll, Description, EmptyAPI, Fragment,
80+
CaptureAll, DeepQuery, Description, EmptyAPI, Fragment,
7981
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
8082
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
81-
QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
83+
QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod),
8284
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
8385
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
8486
WithNamedContext, WithResource, NamedRoutes)
@@ -90,6 +92,7 @@ import Servant.API.ContentTypes
9092
import Servant.API.Modifiers
9193
(FoldLenient, FoldRequired, RequestArgument,
9294
unfoldRequestArgument)
95+
import Servant.API.QueryString (FromDeepQuery(..))
9396
import Servant.API.ResponseHeaders
9497
(GetHeaders, Headers, getHeaders, getResponse)
9598
import Servant.API.Status
@@ -627,6 +630,105 @@ instance (KnownSymbol sym, HasServer api context)
627630
examine v | v == "true" || v == "1" || v == "" = True
628631
| otherwise = False
629632

633+
-- | If you use @'QueryString'@ in one of the endpoints for your API,
634+
-- this automatically requires your server-side handler to be a function
635+
-- that takes an argument of type @Query@ (@[('ByteString', 'Maybe' 'ByteString')]@).
636+
--
637+
-- This lets you extract the whole query string. This is useful when the query string
638+
-- can contain parameters with dynamic names, that you can't access with @'QueryParam'@.
639+
--
640+
-- Example:
641+
--
642+
-- > type MyApi = "books" :> QueryString :> Get '[JSON] [Book]
643+
-- >
644+
-- > server :: Server MyApi
645+
-- > server = getBooksBy
646+
-- > where getBooksBy :: Query -> Handler [Book]
647+
-- > getBooksBy filters = ...filter books based on the dynamic filters provided...
648+
instance
649+
( HasServer api context
650+
)
651+
=> HasServer (QueryString :> api) context where
652+
------
653+
type ServerT (QueryString :> api) m =
654+
Query -> ServerT api m
655+
656+
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
657+
658+
route Proxy context subserver =
659+
route (Proxy :: Proxy api) context (passToServer subserver queryString)
660+
661+
-- | If you use @'DeepQuery' "symbol" a@ in one of the endpoints for your API,
662+
-- this automatically requires your server-side handler to be a function
663+
-- that takes an argument of type @a@.
664+
--
665+
-- This lets you extract an object from multiple parameters in the query string,
666+
-- with its fields enclosed in brackets: `/books?filter[author][name]=value`. When
667+
-- all the fields are known in advance, it can be done with @'QueryParam'@ (it can
668+
-- still be tedious if you the object has many fields). When some fields are dynamic,
669+
-- it cannot be done with @'QueryParam'.
670+
--
671+
-- The way the object is constructed from the extracted fields can be controlled by
672+
-- providing an instance on @'FromDeepQuery'@
673+
--
674+
-- Example:
675+
--
676+
-- > type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]
677+
-- >
678+
-- > server :: Server MyApi
679+
-- > server = getBooksBy
680+
-- > where getBooksBy :: BookQuery -> Handler [Book]
681+
-- > getBooksBy query = ...filter books based on the dynamic filters provided...
682+
instance
683+
( KnownSymbol sym, FromDeepQuery a, HasServer api context
684+
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
685+
)
686+
=> HasServer (DeepQuery sym a :> api) context where
687+
------
688+
type ServerT (DeepQuery sym a :> api) m =
689+
a -> ServerT api m
690+
691+
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
692+
693+
route Proxy context subserver = route (Proxy :: Proxy api) context $
694+
subserver `addParameterCheck` withRequest paramsCheck
695+
where
696+
rep = typeRep (Proxy :: Proxy DeepQuery)
697+
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
698+
699+
paramname = cs $ symbolVal (Proxy :: Proxy sym)
700+
paramsCheck req =
701+
let relevantParams :: [(T.Text, Maybe T.Text)]
702+
relevantParams = mapMaybe isRelevantParam
703+
. queryToQueryText
704+
. queryString
705+
$ req
706+
isRelevantParam (name, value) = (, value) <$>
707+
case T.stripPrefix paramname name of
708+
Just "" -> Just ""
709+
Just x | "[" `T.isPrefixOf` x -> Just x
710+
_ -> Nothing
711+
in case fromDeepQuery =<< traverse parseDeepParam relevantParams of
712+
Left e -> delayedFailFatal $ formatError rep req
713+
$ cs $ "Error parsing deep query parameter(s) "
714+
<> paramname <> T.pack " failed: "
715+
<> T.pack e
716+
Right parsed -> return parsed
717+
718+
parseDeepParam :: (T.Text, Maybe T.Text) -> Either String ([T.Text], Maybe T.Text)
719+
parseDeepParam (paramname, value) =
720+
let parseParam "" = return []
721+
parseParam n = reverse <$> go [] n
722+
go parsed remaining = case T.take 1 remaining of
723+
"[" -> case T.breakOn "]" remaining of
724+
(_ , "") -> Left $ "Error parsing deep param, missing closing ']': " <> T.unpack remaining
725+
(name, "]") -> return $ T.drop 1 name : parsed
726+
(name, remaining') -> case T.take 2 remaining' of
727+
"][" -> go (T.drop 1 name : parsed) (T.drop 1 remaining')
728+
_ -> Left $ "Error parsing deep param, incorrect brackets: " <> T.unpack remaining
729+
_ -> Left $ "Error parsing deep param, missing opening '[': " <> T.unpack remaining
730+
in (, value) <$> parseParam paramname
731+
630732
-- | Just pass the request to the underlying application and serve its response.
631733
--
632734
-- Example:

0 commit comments

Comments
 (0)