Add support for full & deep query string capture in servant-server

Author: divarvel

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

@@ -23,6 +23,7 @@ module Servant.Client.Core.HasClient (
     (/:),
     foldMapUnion,
     matchUnion,
+    ToDeepQuery (..)
     ) where
 
 import           Prelude ()
@@ -46,6 +47,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,17 +72,17 @@ 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)
@@ -664,6 +666,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

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(..)

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,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
@@ -122,6 +125,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 +162,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 +202,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 +232,8 @@ getRoot
   :<|> getQueryParamBinary
   :<|> getQueryParams
   :<|> getQueryFlag
+  :<|> getQueryString
+  :<|> getDeepQuery
   :<|> getFragment
   :<|> getRawSuccess
   :<|> getRawSuccessPassHeaders
@@ -244,6 +272,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.hs

@@ -111,6 +111,9 @@ module Servant.Server
 
   , getAcceptHeader
 
+  -- * DeepQuery parsing
+  , FromDeepQuery (..)
+
   -- * Re-exports
   , Application
   , Tagged (..)