Add QueryParamForm for Client, Server, Internal, Foreign, and SafeLink

servant-client-core/servant-client-core.cabal

@@ -79,6 +79,7 @@ library
     , base64-bytestring     >= 1.0.0.1  && < 1.1
     , exceptions            >= 0.10.0   && < 0.11
     , free                  >= 5.1      && < 5.2
+    , http-api-data         >= 0.4      && < 0.4.2
     , http-media            >= 0.7.1.3  && < 0.9
     , http-types            >= 0.12.2   && < 0.13
     , network-uri           >= 2.6.1.0  && < 2.7

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

@@ -55,6 +55,7 @@ module Servant.Client.Core
   , addHeader
   , appendToQueryString
   , appendToPath
+  , concatQueryString
   , setRequestBodyLBS
   , setRequestBody
   ) where

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

@@ -48,7 +48,7 @@ import           Servant.API
                  FromSourceIO (..), Header', Headers (..), HttpVersion,
                  IsSecure, MimeRender (mimeRender),
                  MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
-                 QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
+                 QueryParam', QueryParams, QueryParamForm', Raw, ReflectMethod (..), RemoteHost,
                  ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
                  ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
                  contentType, getHeadersHList, getResponse, toQueryParam,
@@ -57,6 +57,8 @@ import           Servant.API.ContentTypes
                  (contentTypes)
 import           Servant.API.Modifiers
                  (FoldRequired, RequiredArgument, foldRequiredArgument)
+import           Web.FormUrlEncoded
+                 (ToForm (..))
 
 import           Servant.Client.Core.Auth
 import           Servant.Client.Core.BasicAuth
@@ -534,6 +536,55 @@ instance (KnownSymbol sym, HasClient m api)
   hoistClientMonad pm _ f cl = \b ->
     hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
 
+-- | If you use a 'QueryParamForm' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'QueryParamForm',
+-- enclosed in Maybe.
+--
+-- If you give Nothing, nothing will be added to the query string.
+--
+-- If you give a non-'Nothing' value, this function will take care
+-- of inserting a textual representation of your form in the query string.
+--
+-- You can control how values for your type are turned into
+-- text by specifying a 'ToForm' instance for your type.
+-- Example:
+--
+-- > data BookSearchParams = BookSearchParams
+-- >   { title :: Text
+-- >   , authors :: [Text]
+-- >   , page :: Maybe Int
+-- >   } deriving (Eq, Show, Generic)
+-- > instance ToForm BookSearchParams
+--
+-- > type MyApi = "books" :> QueryParamForm "searchQ" BookSearchParams :> Get '[JSON] [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooks :: Bool -> ClientM [Book]
+-- > getBooks = client myApi
+-- > -- then you can just use "getBooks" to query that endpoint.
+-- > -- 'getBooksBy Nothing' for all books
+-- > -- 'getBooksBy (Just $ BookSearchParams "white noise" ["DeLillo"] Nothing)'
+instance (KnownSymbol sym, ToForm a, HasClient m api, SBoolI (FoldRequired mods))
+      => HasClient m (QueryParamForm' mods sym a :> api) where
+
+  type Client m (QueryParamForm' mods sym a :> api) =
+    RequiredArgument mods a -> Client m api
+
+  -- if mparam = Nothing, we don't add it to the query string
+  clientWithRoute pm Proxy req mparam =
+    clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
+      (Proxy :: Proxy mods) add (maybe req add) mparam
+    where
+      add :: ToForm a => a -> Request
+      add qForm = concatQueryString qForm req
+
+  hoistClientMonad pm _ f cl = \arg ->
+    hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
+
+
 -- | 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

@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (
     addHeader,
     appendToPath,
     appendToQueryString,
+    concatQueryString,
     setRequestBody,
     setRequestBodyLBS,
     ) where
@@ -50,9 +51,11 @@ import           Network.HTTP.Media
                  (MediaType)
 import           Network.HTTP.Types
                  (Header, HeaderName, HttpVersion (..), Method, QueryItem,
-                 http11, methodGet)
+                 http11, methodGet, parseQuery)
 import           Servant.API
                  (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
+import           Web.FormUrlEncoded
+                 (ToForm (..), urlEncodeAsForm)
 
 import Servant.Client.Core.Internal (mediaTypeRnf)
 
@@ -135,6 +138,14 @@ addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
 addHeader name val req
   = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
 
+concatQueryString :: ToForm a
+                  => a
+                  -> Request
+                  -> Request
+concatQueryString form req
+  = let querySeq = Seq.fromList . parseQuery . LBS.toStrict . urlEncodeAsForm $ form
+    in req { requestQueryString = requestQueryString req Seq.>< querySeq }
+
 -- | Set body and media type of the request being constructed.
 --
 -- The body is set to the given bytestring using the 'RequestBodyLBS'

servant-docs/servant-docs.cabal

@@ -62,6 +62,7 @@ library
     , base-compat          >= 0.10.5   && < 0.12
     , case-insensitive     >= 1.2.0.11 && < 1.3
     , hashable             >= 1.2.7.0  && < 1.4
+    , http-api-data        >= 0.4      && < 0.4.2
     , http-media           >= 0.7.1.3  && < 0.9
     , http-types           >= 0.12.2   && < 0.13
     , lens                 >= 4.17     && < 4.19
@@ -100,6 +101,7 @@ test-suite spec
       base
     , base-compat
     , aeson
+    , http-api-data
     , lens
     , servant
     , servant-docs

servant-docs/src/Servant/Docs/Internal.hs

@@ -28,9 +28,12 @@ import           Control.Lens
                  (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
                  (<>~), (^.), (|>))
 import qualified Data.ByteString.Char8      as BSC
+import qualified Data.ByteString.Lazy.Char8 as LBSC
 import           Data.ByteString.Lazy.Char8
                  (ByteString)
 import qualified Data.CaseInsensitive       as CI
+import           Data.Data
+                 (Data, toConstr, constrFields)
 import           Data.Foldable
                  (toList)
 import           Data.Foldable
@@ -63,6 +66,8 @@ import           GHC.TypeLits
 import           Servant.API
 import           Servant.API.ContentTypes
 import           Servant.API.TypeLevel
+import           Web.FormUrlEncoded
+                 (ToForm(..), urlEncodeAsForm)
 
 import qualified Data.Universe.Helpers as U
 
@@ -950,6 +955,27 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
           paramP = Proxy :: Proxy (QueryFlag sym)
           action' = over params (|> toParam paramP) action
 
+-- | The docs for a @'QueryParamForm' sym a'@
+--   require the following instances for the `a`:
+--   'Data', 'ToSample'
+instance (KnownSymbol sym, Data a, ToForm a, ToSample a, HasDocs api)
+      => HasDocs (QueryParamForm' mods sym a :> api) where
+    
+  docsFor Proxy (endpoint, action) =
+    docsFor subApiP (endpoint, action')
+
+    where subApiP = Proxy :: Proxy api
+          action' =
+            let (Just sampleForm) = toSample (Proxy :: Proxy a)
+                paramNames = constrFields (toConstr sampleForm)
+                sampleEncoding = LBSC.unpack . urlEncodeAsForm . toForm $ sampleForm
+            in action & params <>~ (fmap (qParamMaker sampleEncoding) paramNames)
+          qParamMaker formEncodedSample pName = DocQueryParam {
+            _paramName = pName
+            , _paramValues = [formEncodedSample]
+            , _paramDesc = "Query parameter"
+            , _paramKind = Normal
+          }
 
 instance HasDocs Raw where
   docsFor _proxy (endpoint, action) _ =

servant-docs/test/Servant/DocsSpec.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE FlexibleContexts           #-}
@@ -21,6 +22,8 @@ import           Control.Monad
 import           Control.Monad.Trans.Writer
                  (Writer, runWriter, tell)
 import           Data.Aeson
+import           Data.Data
+                 (Data)
 import           Data.List
                  (isInfixOf)
 import           Data.Proxy
@@ -35,6 +38,8 @@ import           Test.Tasty.Golden
                  (goldenVsString)
 import           Test.Tasty.HUnit
                  (Assertion, HasCallStack, assertFailure, testCase, (@?=))
+import           Web.FormUrlEncoded
+                 (ToForm)
 
 import           Servant.API
 import           Servant.Docs.Internal
@@ -52,6 +57,8 @@ instance ToParam (QueryParam' mods "bar" Int) where
   toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal
 instance ToParam (QueryParams "foo" Int) where
   toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List
+instance ToParam (QueryParam "query" String) where
+    toParam _ = DocQueryParam "query" ["a","b","c"] "QueryParams String" Normal  
 instance ToParam (QueryFlag "foo") where
   toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag
 instance ToCapture (Capture "foo" Int) where
@@ -76,7 +83,7 @@ spec = describe "Servant.Docs" $ do
               (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]])
               <>
               extraInfo
-              (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
+              (Proxy :: Proxy ("postJson" :> ReqBody '[JSON] String :> Post '[JSON] Datatype1))
               (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
       md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
     tests md
@@ -119,6 +126,12 @@ spec = describe "Servant.Docs" $ do
       md `shouldContain` "## POST"
       md `shouldContain` "## GET"
 
+    it "should mention the endpoints" $ do
+      md `shouldContain` "## POST /postJson"
+      md `shouldContain` "## GET /qparam"
+      md `shouldContain` "## GET /qparamform"
+      md `shouldContain` "## PUT /header"
+
     it "mentions headers" $ do
       md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
 
@@ -127,6 +140,15 @@ spec = describe "Servant.Docs" $ do
     it "contains request body samples" $
       md `shouldContain` "17"
 
+    it "mentions optional query-param" $ do
+      md `shouldContain` "### GET Parameters:"
+      md `shouldContain` "- query"
+    it "mentions optional query-param-form params from QueryParamForm" $ do
+      md `shouldContain` "- dt1field1"
+      md `shouldContain` "- dt1field2"
+      -- contains sample url-encoded form
+      md `shouldContain` "- **Values**: *dt1field1=field%201&dt1field2=13*"
+
     it "does not generate any docs mentioning the 'empty-api' path" $
       md `shouldNotContain` "empty-api"
 
@@ -135,9 +157,10 @@ spec = describe "Servant.Docs" $ do
 
 data Datatype1 = Datatype1 { dt1field1 :: String
                            , dt1field2 :: Int
-                           } deriving (Eq, Show, Generic)
+                           } deriving (Eq, Show, Data, Generic)
 
 instance ToJSON Datatype1
+instance ToForm Datatype1
 
 instance ToSample Datatype1 where
   toSamples _ = singleSample $ Datatype1 "field 1" 13
@@ -152,8 +175,10 @@ instance MimeRender PlainText Int where
   mimeRender _ = cs . show
 
 type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
-           :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
+           :<|> "postJson"   :> ReqBody '[JSON] String          :> Post '[JSON] Datatype1
-           :<|> Header "X-Test" Int :> Put '[JSON] Int
+           :<|> "qparam"     :> QueryParam "query" String       :> Get '[JSON] Datatype1
+           :<|> "qparamform" :> QueryParamForm "form" Datatype1 :> Get '[JSON] Datatype1
+           :<|> "header"     :> Header "X-Test" Int             :> Put '[JSON] Int
            :<|> "empty-api"                                     :> EmptyAPI
 
 data TT = TT1 | TT2 deriving (Show, Eq)

servant-foreign/src/Servant/Foreign/Internal.hs

@@ -88,6 +88,7 @@ data ArgType
   = Normal
   | Flag
   | List
+  | Form
   deriving (Data, Eq, Show, Typeable)
 
 makePrisms ''ArgType
@@ -324,6 +325,19 @@ instance
         { _argName = PathSegment str
         , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
 
+instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
+  => HasForeign lang ftype (QueryParamForm' mods sym a :> api) where
+  type Foreign ftype (QueryParamForm' mods sym a :> api) = Foreign ftype api
+
+  foreignFor lang Proxy Proxy req =
+    foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
+      req & reqUrl.queryStr <>~ [QueryArg arg Form]
+    where
+      arg = Arg
+        { _argName = PathSegment ""
+        , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) }
+      
+
 instance HasForeign lang ftype Raw where
   type Foreign ftype Raw = HTTP.Method -> Req ftype
 

servant-foreign/test/Servant/ForeignSpec.hs

@@ -68,9 +68,21 @@ instance {-# OVERLAPPABLE #-} HasForeignType LangX String a => HasForeignType La
 instance (HasForeignType LangX String a) => HasForeignType LangX String (Maybe a) where
   typeFor lang ftype _ = "maybe " <> typeFor lang ftype (Proxy :: Proxy a)
 
+data ContactForm = ContactForm {
+  name      :: String
+  , message :: String
+  , email   :: String
+} deriving (Eq, Show)
+
+instance HasForeignType LangX String ContactForm where
+  typeFor _ _ _ = "contactFormX"
+
+
+
 type TestApi
     = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int
  :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent
+ :<|> "test" :> QueryParamForm "contact" ContactForm :> Post '[JSON] NoContent
  :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent
  :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent
  :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]
@@ -82,9 +94,9 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: P
 listFromAPISpec :: Spec
 listFromAPISpec = describe "listFromAPI" $ do
   it "generates 5 endpoints for TestApi" $ do
-    length testApi `shouldBe` 5
+    length testApi `shouldBe` 6
 
-  let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi
+  let [getReq, postReq, contactReq, putReq, deleteReq, captureAllReq] = testApi
 
   it "collects all info for get request" $ do
     shouldBe getReq $ defReq
@@ -110,6 +122,17 @@ listFromAPISpec = describe "listFromAPI" $ do
       , _reqFuncName   = FunctionName ["post", "test"]
       }
 
+  it "collects all info for a queryparamform" $ do
+    shouldBe contactReq $ defReq
+      { _reqUrl        = Url
+          [ Segment $ Static "test" ]
+          [ QueryArg (Arg "" "maybe contactFormX") Form ]
+      , _reqMethod     = "POST"
+      , _reqHeaders    = []
+      , _reqReturnType = Just "voidX"
+      , _reqFuncName   = FunctionName ["post", "test"]
+      }
+
   it "collects all info for put request" $ do
     shouldBe putReq $ defReq
       { _reqUrl        = Url
@@ -148,3 +171,4 @@ listFromAPISpec = describe "listFromAPI" $ do
       , _reqReturnType = Just "listX of intX"
       , _reqFuncName   = FunctionName ["get", "test", "by", "ids"]
       }
+

servant-http-streams/test/Servant/ClientSpec.hs

@@ -32,7 +32,7 @@ import           Control.Concurrent
 import           Control.DeepSeq
                  (NFData (..))
 import           Control.Exception
-                 (bracket, fromException, IOException)
+                 (IOException, bracket, fromException)
 import           Control.Monad.Error.Class
                  (throwError)
 import           Data.Aeson
@@ -64,7 +64,8 @@ import           Servant.API
                  BasicAuthData (..), Capture, CaptureAll, Delete,
                  DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
                  Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
-                 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
+                 QueryParam, QueryParamForm, QueryParams, Raw, ReqBody,
+                 addHeader, getHeaders)
 import qualified Servant.Client.Core.Auth         as Auth
 import qualified Servant.Client.Core.Request      as Req
 import           Servant.HttpStreams
@@ -110,6 +111,14 @@ alice = Person "Alice" 42
 carol :: Person
 carol = Person "Carol" 17
 
+data PersonSearch = PersonSearch
+  { nameStartsWith :: String
+  , ageGreaterThan :: Integer
+  } deriving (Eq, Show, Generic)
+
+instance ToForm PersonSearch
+instance FromForm PersonSearch
+
 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
 
 type Api =
@@ -121,6 +130,7 @@ type Api =
   :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
   :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
   :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
+  :<|> "paramform" :> QueryParamForm "names" PersonSearch :> Get '[JSON] [Person]
   :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
   :<|> "rawSuccess" :> Raw
   :<|> "rawFailure" :> Raw
@@ -146,6 +156,7 @@ getCaptureAll   :: [String] -> ClientM [Person]
 getBody         :: Person -> ClientM Person
 getQueryParam   :: Maybe String -> ClientM Person
 getQueryParams  :: [String] -> ClientM [Person]
+getQueryParamForm  :: Maybe PersonSearch -> ClientM [Person]
 getQueryFlag    :: Bool -> ClientM Bool
 getRawSuccess   :: HTTP.Method -> ClientM Response
 getRawFailure   :: HTTP.Method -> ClientM Response
@@ -163,6 +174,7 @@ getRoot
   :<|> getBody
   :<|> getQueryParam
   :<|> getQueryParams
+  :<|> getQueryParamForm
   :<|> getQueryFlag
   :<|> getRawSuccess
   :<|> getRawFailure
@@ -185,6 +197,10 @@ server = serve api (
                    Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
                    Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
+  :<|> (\ psearch -> case psearch of
+                   Just (Right psearch) -> return [alice, carol]
+                   Just (Left err) -> throwError $ ServerError 400 "failed to decode form" "" []
+                   Nothing -> return [])
   :<|> return
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
@@ -305,6 +321,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
       left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
         `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
 
+    it "Servant.API.QueryParam.QueryParamForm" $ \(_, baseUrl) -> do
+      left show <$> runClient (getQueryParamForm Nothing) baseUrl `shouldReturn` Right []
+      left show <$> runClient (getQueryParamForm (Just $ PersonSearch "a" 10)) baseUrl
+        `shouldReturn` Right [alice, carol]
+
     context "Servant.API.QueryParam.QueryFlag" $
       forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
         left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag

servant-server/servant-server.cabal

@@ -148,6 +148,7 @@ test-suite spec
     , base-compat
     , base64-bytestring
     , bytestring
+    , http-api-data
     , http-types
     , mtl
     , resourcet

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

@@ -72,7 +72,7 @@ import           Servant.API
                  ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
                  CaptureAll, Description, EmptyAPI, FramingRender (..),
                  FramingUnrender (..), FromSourceIO (..), Header', If,
-                 IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
+                 IsSecure (..), QueryFlag, QueryParam', QueryParamForm', QueryParams, Raw,
                  ReflectMethod (reflectMethod), RemoteHost, ReqBody',
                  SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
                  Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
@@ -86,6 +86,8 @@ import           Servant.API.Modifiers
                  unfoldRequestArgument)
 import           Servant.API.ResponseHeaders
                  (GetHeaders, Headers, getHeaders, getResponse)
+import           Web.FormUrlEncoded
+                 (FromForm(..), urlDecodeAsForm)
 import qualified Servant.Types.SourceT                      as S
 import           Web.HttpApiData
                  (FromHttpApiData, parseHeader, parseQueryParam,
@@ -556,6 +558,73 @@ instance (KnownSymbol sym, HasServer api context)
           examine v | v == "true" || v == "1" || v == "" = True
                     | otherwise = False
 
+-- | If you define a custom record type, for example @BookSearchParams@, then you can use 
+-- @'QueryParamForm' "formName" BookSearchParams@ in one of the endpoints for your API
+-- to translate a collection of query-string parameters into a value of your record type. 
+--
+-- Your server-side handler must be a function that takes an argument of type
+-- @'Maybe' ('Either' BookSearchParams)@.
+--
+-- You can control how the individual values are converted from the query string
+-- into a value of your type by simply providing an instance of 'FromForm' for your type.
+-- All of the record's values utilize 'FromHttpApiData'.
+--
+-- Note: anytime you use a 'QueryParamForm', your server will assume it's present
+-- if the query-string is non-empty. This modifier does not check if any specific
+-- keys from the record are present: it just attempts to 'urlDecodeAsForm' the whole query
+-- string if any query-string parameters have been provided.
+--
+-- Example:
+--
+-- > data BookSearchParams = BookSearchParams
+-- >   { title :: Text
+-- >   , authors :: [Text]
+-- >   , page :: Maybe Int
+-- >   } deriving (Eq, Show, Generic)
+-- > instance FromForm BookSearchParams
+-- > type MyApi = "books" :> QueryParamForm "searchQ" BookSearchParams :> Get '[JSON] [Book]
+-- 
+-- Example Handler Signature:
+-- Maybe (Either Text BookSearchParams) -> Handler [Book]
+instance
+  ( KnownSymbol sym, FromForm a, HasServer api context
+  , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
+  )
+  => HasServer (QueryParamForm' mods sym a :> api) context where
+------
+  type ServerT (QueryParamForm' mods sym a :> api) m =
+    RequestArgument mods a -> ServerT api m
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
+
+  route Proxy context subserver = 
+    
+    let formName = cs $ symbolVal (Proxy :: Proxy sym)
+
+        parseParamForm req =
+            unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
+          where
+            rawQS = rawQueryString req
+
+            mev :: Maybe (Either T.Text a)
+            mev = case B.length rawQS of
+              0 -> Nothing
+              _ -> Just $ urlDecodeAsForm (BL.drop 1 . BL.fromStrict $ rawQS)
+
+            errReq = delayedFailFatal err400
+              { errBody = cs $ "Query parameter form " <> formName <> " is required"
+              }
+
+            errSt e = delayedFailFatal err400
+              { errBody = cs $ "Error parsing query parameter form "
+                                <> formName <> " failed: " <> e
+              }
+
+        delayed = addParameterCheck subserver . withRequest $ \req ->
+          parseParamForm req
+
+    in route (Proxy :: Proxy api) context delayed
+
 -- | Just pass the request to the underlying application and serve its response.
 --
 -- Example:

servant-server/test/Servant/ServerSpec.hs

@@ -49,7 +49,7 @@ import           Servant.API
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Lenient, Strict, Delete,
                  EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
                  JSON, NoContent (..), NoFraming, OctetStream, Patch,
-                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
+                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw,
                  RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
                  NoContentVerb, addHeader)
 import           Servant.Server
@@ -63,6 +63,8 @@ import           Test.Hspec.Wai
                  (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
                  with, (<:>))
 import qualified Test.Hspec.Wai                    as THW
+import           Web.FormUrlEncoded
+                 (FromForm)
 
 import           Servant.Server.Experimental.Auth
                  (AuthHandler, AuthServerData, mkAuthHandler)
@@ -88,6 +90,7 @@ spec = do
   captureSpec
   captureAllSpec
   queryParamSpec
+  queryParamFormSpec
   reqBodySpec
   headerSpec
   rawSpec
@@ -451,6 +454,124 @@ queryParamSpec = do
               name = "Alice"
              }
 
+------------------------------------------------------------------------------
+-- * queryParamFormSpec {{{
+------------------------------------------------------------------------------
+
+data AnimalSearch = AnimalSearch {
+  sName       :: String
+  , sLegs       :: Integer
+} deriving (Eq, Show, Generic)
+
+instance FromForm AnimalSearch
+
+type QueryParamFormApi =
+  QueryParamForm "octopus" AnimalSearch :> Get '[JSON] Animal
+  :<|> "before-param"
+        :> QueryParam "before" Bool
+        :> QueryParamForm "before" AnimalSearch
+        :> Get '[JSON] Animal
+  :<|> "mixed-param"
+        :> QueryParam "before" Bool
+        :> QueryParamForm "multiple" AnimalSearch
+        :> QueryParam "after" Bool
+        :> Get '[JSON] Animal
+
+queryParamFormApi :: Proxy QueryParamFormApi
+queryParamFormApi = Proxy
+
+qpFormServer :: Server QueryParamFormApi
+qpFormServer = searchAnimal :<|> searchWithBeforeParms :<|> searchWithAroundParms
+
+  where searchAnimal (Just (Right search)) = return $ Animal { species = sName search, numberOfLegs = sLegs search}
+        searchAnimal (Just (Left _))       = return $ Animal { species = "broken", numberOfLegs = 0}
+        searchAnimal Nothing       = return bimac
+
+        searchWithBeforeParms (Just _) (Just (Right search)) = return $ Animal { species = sName search, numberOfLegs = sLegs search}
+        searchWithBeforeParms _ _ = return bimac
+
+        searchWithAroundParms (Just _) (Just (Right search)) (Just True) = return $ Animal { species = sName search, numberOfLegs = sLegs search}
+        searchWithAroundParms _ _ _ = return bimac
+
+
+queryParamFormSpec :: Spec
+queryParamFormSpec = do
+  describe "Servant.API.QueryParamForm" $ do
+      it "allows query params into form" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          let params1 = "?sName=bimac&sLegs=7"
+          response1 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params1,
+            queryString = parseQuery params1
+           }
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` (Just $ Animal { species = "bimac", numberOfLegs = 7})
+      it "allows no query params at all" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          response1 <- Network.Wai.Test.request defaultRequest
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` Just bimac
+      it "does not generate an error for incomplete form" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          let paramsBork = "?sName=bimac"
+          responseBork <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = paramsBork,
+            queryString = parseQuery paramsBork
+           }
+          liftIO $ do
+            decode' (simpleBody responseBork) `shouldBe`  (Just $ Animal { species = "broken", numberOfLegs = 0})
+          return ()
+      it "does not generate an error for duplicated keys" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          let paramsBork = "?sName=bimac&sName=dup&sLegs=12"
+          responseBork <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = paramsBork,
+            queryString = parseQuery paramsBork
+            }
+          liftIO $ do
+            decode' (simpleBody responseBork) `shouldBe`  (Just $ Animal { species = "broken", numberOfLegs = 0})
+          return ()
+      it "does not generate an error for form with bad input types" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          let paramsBork = "?sName=bimac&sLegs=ocean"
+          responseBork <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = paramsBork,
+            queryString = parseQuery paramsBork
+            }
+          liftIO $ do
+            decode' (simpleBody responseBork) `shouldBe`  (Just $ Animal { species = "broken", numberOfLegs = 0})
+          return ()
+
+      it "allows query params into form even with other params" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          let params1 = "?before=true&sName=bimac&sLegs=6"
+          response1 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params1,
+            queryString = parseQuery params1,
+            pathInfo = ["before-param"]
+            }
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` (Just $ Animal { species = "bimac", numberOfLegs = 6})
+
+          let params2 = "?sName=bimac&before=true&sLegs=5"
+          response2 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params2,
+            queryString = parseQuery params2,
+            pathInfo = ["before-param"]
+            }
+          liftIO $ do
+            decode' (simpleBody response2) `shouldBe` (Just $ Animal { species = "bimac", numberOfLegs = 5})
+      it "allows completely mixed up params with QueryParamForm" $
+        (flip runSession) (serve queryParamFormApi qpFormServer) $ do
+          let params1 = "?sLegs=1&before=true&sName=bimac&after=true&unknown=ignoreThis"
+          response1 <- Network.Wai.Test.request defaultRequest{
+            rawQueryString = params1,
+            queryString = parseQuery params1,
+            pathInfo = ["mixed-param"]
+            }
+          liftIO $ do
+            decode' (simpleBody response1) `shouldBe` (Just $ Animal { species = "bimac", numberOfLegs = 1})
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * reqBodySpec {{{
@@ -811,4 +932,8 @@ chimera = Animal "Chimera" (-1)
 
 beholder :: Animal
 beholder = Animal "Beholder" 0
+
+bimac :: Animal
+bimac = Animal { species = "Octopus bimaculoides" , numberOfLegs = 8}
+
 -- }}}

servant/servant.cabal

@@ -161,6 +161,7 @@ test-suite spec
     , base-compat
     , aeson
     , bytestring
+    , http-api-data
     , http-media
     , mtl
     , servant

servant/src/Servant/API.hs

@@ -101,7 +101,8 @@ import           Servant.API.IsSecure
 import           Servant.API.Modifiers
                  (Lenient, Optional, Required, Strict)
 import           Servant.API.QueryParam
-                 (QueryFlag, QueryParam, QueryParam', QueryParams)
+                 (QueryFlag, QueryParam, QueryParam', QueryParams,
+                 QueryParamForm, QueryParamForm')
 import           Servant.API.Raw
                  (Raw)
 import           Servant.API.RemoteHost

servant/src/Servant/API/QueryParam.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE PolyKinds          #-}
 {-# LANGUAGE TypeOperators      #-}
 {-# OPTIONS_HADDOCK not-home    #-}
-module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where
+module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams, QueryParamForm, QueryParamForm') where
 
 import           Data.Typeable
                  (Typeable)
@@ -38,6 +38,39 @@ data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)
 data QueryParams (sym :: Symbol) (a :: *)
     deriving Typeable
 
+-- | Lookup the values associated with a collection of query string parameters
+-- and try to extract them as a value of type @a@. This is typically
+-- meant to query string parameters of the form
+-- @param1=val1&param2=val2@ and so on into a custom type represented by the form.
+--
+-- Note: Unlike with 'QueryParam', by default 'QueryParamForm' is parsed in a
+-- 'Lenient' way, because it's difficult to know if it should be parsed
+-- or not (when other 'QueryParam's are present). As a result, most users
+-- of 'QueryParamForm' are going to implement handlers that take a value
+-- of type (Maybe (Either Text a)). This also means that in a server implementation
+-- if there as a query string of any length (even just a "?"), we'll try to parse
+-- the 'QueryParamForm' into the custom type specified.
+-- 
+-- Example:
+--
+-- > data BookSearchParams = BookSearchParams
+-- >   { title :: Text
+-- >   , authors :: [Text]
+-- >   , page :: Maybe Int
+-- >   } deriving (Eq, Show, Generic)
+-- > instance FromForm BookSearchParams
+-- > type MyApi = "books" :> QueryParamForm "searchQ" BookSearchParams :> Get '[JSON] [Book]
+-- 
+-- Example Handler Signature:
+-- Maybe (Either Text BookSearchParams) -> Handler [Book]
+
+type QueryParamForm = QueryParamForm' '[Optional, Lenient]
+
+-- | 'QueryParamForm' which can be 'Required', 'Lenient', or modified otherwise.
+data QueryParamForm' (mods :: [*]) (sym :: Symbol) (a :: *)
+    deriving Typeable
+
+
 -- | Lookup a potentially value-less query string parameter
 -- with boolean semantics. If the param @sym@ is there without any value,
 -- or if it's there with value "true" or "1", it's interpreted as 'True'.

servant/src/Servant/API/TypeLevel.hs

@@ -53,7 +53,7 @@ import           Servant.API.Capture
 import           Servant.API.Header
                  (Header)
 import           Servant.API.QueryParam
-                 (QueryFlag, QueryParam, QueryParams)
+                 (QueryFlag, QueryParam, QueryParams, QueryParamForm)
 import           Servant.API.ReqBody
                  (ReqBody)
 import           Servant.API.Sub
@@ -127,6 +127,7 @@ type family IsElem endpoint api :: Constraint where
                                           = IsElem sa sb
   IsElem sa (QueryParam x y :> sb)        = IsElem sa sb
   IsElem sa (QueryParams x y :> sb)       = IsElem sa sb
+  IsElem sa (QueryParamForm x :> sb)      = IsElem sa sb
   IsElem sa (QueryFlag x :> sb)           = IsElem sa sb
   IsElem (Verb m s ct typ) (Verb m s ct' typ)
                                           = IsSubList ct ct'

servant/src/Servant/Links.hs

@@ -122,6 +122,8 @@ module Servant.Links (
   , linkQueryParams
 ) where
 
+import qualified Data.ByteString.Lazy         as LBS
+import qualified Data.ByteString.Lazy.Char8   as LBSC
 import           Data.List
 import           Data.Proxy
                  (Proxy (..))
@@ -139,6 +141,8 @@ import           Network.URI
                  (URI (..), escapeURIString, isUnreserved)
 import           Prelude ()
 import           Prelude.Compat
+import           Web.FormUrlEncoded
+                 (ToForm(..), urlEncodeAsFormStable)
 
 import           Servant.API.Alternative
                  ((:<|>) ((:<|>)))
@@ -162,7 +166,7 @@ import           Servant.API.IsSecure
 import           Servant.API.Modifiers
                  (FoldRequired)
 import           Servant.API.QueryParam
-                 (QueryFlag, QueryParam', QueryParams)
+                 (QueryFlag, QueryParam', QueryParams, QueryParamForm')
 import           Servant.API.Raw
                  (Raw)
 import           Servant.API.RemoteHost
@@ -219,6 +223,7 @@ data Param
     = SingleParam    String Text.Text
     | ArrayElemParam String Text.Text
     | FlagParam      String
+    | FormParam      LBS.ByteString
   deriving Show
 
 addSegment :: Escaped -> Link -> Link
@@ -284,6 +289,7 @@ linkURI' addBrackets (Link segments q_params) =
     makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
     makeQuery (SingleParam k v)    = escape k <> "=" <> escape (Text.unpack v)
     makeQuery (FlagParam k)        = escape k
+    makeQuery (FormParam f)        = LBSC.unpack f
 
     style = case addBrackets of
         LinkArrayElementBracket -> "[]="
@@ -472,6 +478,16 @@ instance (KnownSymbol sym, HasLink sub)
       where
         k = symbolVal (Proxy :: Proxy sym)
 
+instance (KnownSymbol sym, ToForm v, HasLink sub, SBoolI (FoldRequired mods))
+    => HasLink (QueryParamForm' mods sym v :> sub)
+  where
+    type MkLink (QueryParamForm' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
+    toLink toA _ l mv =
+        toLink toA (Proxy :: Proxy sub) $
+            case sbool :: SBool (FoldRequired mods) of
+                STrue  -> (addQueryParam . FormParam . urlEncodeAsFormStable) mv l
+                SFalse -> maybe id (addQueryParam . FormParam . urlEncodeAsFormStable) mv l
+
 -- :<|> instance - Generate all links at once
 instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
     type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r

servant/test/Servant/LinksSpec.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE ConstraintKinds     #-}
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators       #-}
@@ -9,8 +10,11 @@ import           Data.Proxy
                  (Proxy (..))
 import           Data.String
                  (fromString)
+import           GHC.Generics
 import           Test.Hspec
                  (Expectation, Spec, describe, it, shouldBe)
+import           Web.FormUrlEncoded
+                 (ToForm(..))
 
 import           Servant.API
 import           Servant.Test.ComprehensiveAPI
@@ -21,6 +25,8 @@ type TestApi =
   -- Capture and query params
        "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent
   :<|> "hi"    :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent
+  :<|> "formR" :> QueryParamForm'  '[Required, Strict] "someform" TestForm :> Delete '[JSON] NoContent
+  :<|> "form-opt" :> QueryParamForm  "someform" TestForm :> Delete '[JSON] NoContent
   :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent
 
   -- Flags
@@ -43,6 +49,13 @@ apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
          => Proxy endpoint -> MkLink endpoint Link
 apiLink = safeLink (Proxy :: Proxy TestApi)
 
+data TestForm = TestForm {
+    testing :: String
+    , time :: String
+} deriving (Eq, Generic)
+
+instance ToForm TestForm
+
 -- | Convert a link to a URI and ensure that this maps to the given string
 -- given string
 shouldBeLink :: Link -> String -> Expectation
@@ -65,6 +78,17 @@ spec = describe "Servant.Links" $ do
                                       :> Delete '[JSON] NoContent)
         apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false"
 
+    it "generates query param form links" $ do
+        -- most who use QueryParamForm are not going to use it Required, Strict, so we'll test it both ways
+        let l3 = Proxy :: Proxy ("formR" :> QueryParamForm'  '[Required, Strict] "someform" TestForm
+                                         :> Delete '[JSON] NoContent)
+        -- We allow `urlEncodeAsFormStable` to uri Escape for us. Validating that assumption here:
+        apiLink l3 (TestForm "sure" "später") `shouldBeLink` "formR?testing=sure&time=sp%C3%A4ter"
+
+        let l4 = Proxy :: Proxy ("form-opt" :> QueryParamForm  "someform" TestForm
+                                            :> Delete '[JSON] NoContent)
+        apiLink l4 (Just $ TestForm "sure" "später") `shouldBeLink` "form-opt?testing=sure&time=sp%C3%A4ter"
+
     it "generates correct links for CaptureAll" $ do
         apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
           ["roads", "lead", "to", "rome"]