Merge pull request #1604 from divarvel/full-query-string-helpers

Full query string helpers

Author: tchoutri

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]`.
+
+}

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

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

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"))

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
 

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: