QueryParamForm Revisited

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

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

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

@@ -75,9 +75,9 @@ import           Servant.API
                  FromSourceIO (..), Header', Headers (..), HttpVersion,
                  IsSecure, MimeRender (mimeRender),
                  MimeUnrender (mimeUnrender), NoContent (NoContent),
-                 NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
+                 NoContentVerb, QueryFlag, QueryParam', QueryParams, QueryParamForm', Raw,
                  ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
-                 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
+                 StreamBody', Summary, ToForm (..), ToHttpApiData, ToSourceIO (..), Vault,
                  Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
                  getResponse, toEncodedUrlPiece, toUrlPiece)
 import           Servant.API.ContentTypes
@@ -653,6 +653,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 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 (ToForm a, HasClient m api, SBoolI (FoldRequired mods))
+      => HasClient m (QueryParamForm' mods a :> api) where
+
+  type Client m (QueryParamForm' mods 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,7 +51,8 @@ import           Network.HTTP.Types
                  (Header, HeaderName, HttpVersion (..), Method, QueryItem,
                  http11, methodGet)
 import           Servant.API
-                 (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
+                 (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO,
+                 ToForm (..), toListStable)
 
 import Servant.Client.Core.Internal (mediaTypeRnf)
 
@@ -157,11 +159,21 @@ 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
+      queryEncoder = map (bimap encodeUtf8 (Just . encodeUtf8))
+      querySeq = Seq.fromList . queryEncoder . toListStable . toForm $ 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'
 -- constructor.
---
 -- @since 0.12
 --
 setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request

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

@@ -28,6 +28,7 @@ import           Control.Lens
                  (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
                  _1, (%~), (&), (.~), (<>~), (^.), (|>))
 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
@@ -1052,6 +1053,25 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
           paramP = Proxy :: Proxy (QueryFlag sym)
           action' = over params (|> toParam paramP) action
 
+-- | The docs for a @'QueryParamForm' a'@
+--   require a 'ToSample a' instance
+instance (ToForm a, ToSample a, HasDocs api)
+      => HasDocs (QueryParamForm' mods a :> api) where
+  docsFor Proxy (endpoint, action) =
+    docsFor subApiP (endpoint, action')
+
+    where subApiP = Proxy :: Proxy api
+          action' =
+            let (Just sampleForm) = toSample (Proxy :: Proxy a)
+                sampleEncoding = LBSC.unpack . urlEncodeAsForm . toForm $ sampleForm
+            in action & params <>~ [qParamMaker sampleEncoding]
+          qParamMaker formEncodedSample = DocQueryParam {
+            _paramName = "Collection of Parameters"
+            , _paramValues = [formEncodedSample]
+            , _paramDesc = "Query parameters"
+            , _paramKind = Normal
+          }
+
 instance (ToFragment (Fragment a), HasDocs api)
       => HasDocs (Fragment a :> api) where
 

servant-docs/test/Servant/DocsSpec.hs

@@ -52,6 +52,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
@@ -123,6 +125,12 @@ spec = describe "Servant.Docs" $ do
       md `shouldContain` "## POST"
       md `shouldContain` "## GET"
 
+    it "should mention the endpoints" $ do
+      md `shouldContain` "## POST /"
+      md `shouldContain` "## GET /qparam"
+      md `shouldContain` "## GET /qparamform"
+      md `shouldContain` "## PUT /"
+
     it "mentions headers" $ do
       md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
 
@@ -133,6 +141,12 @@ 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" $
+      md `shouldContain` "**Values**: *dt1field2=13&dt1field1=field%201*"
+
     it "does not generate any docs mentioning the 'empty-api' path" $
       md `shouldNotContain` "empty-api"
 
@@ -149,6 +163,7 @@ data Datatype1 = Datatype1 { dt1field1 :: String
                            } deriving (Eq, Show, Generic)
 
 instance ToJSON Datatype1
+instance ToForm Datatype1
 
 instance ToSample Datatype1 where
   toSamples _ = singleSample $ Datatype1 "field 1" 13
@@ -166,6 +181,9 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
            :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
            :<|> Header "X-Test" Int :> Put '[JSON] Int
            :<|> "empty-api" :> EmptyAPI
+           :<|> "qparam"     :> QueryParam "query" String       :> Get '[JSON] Datatype1
+           :<|> "qparamform" :> QueryParamForm Datatype1 :> Get '[JSON] Datatype1
+
 
 type TestApi2 = "duplicate-endpoint" :> Get '[JSON]      Datatype1
            :<|> "duplicate-endpoint" :> Get '[PlainText] Int

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

@@ -109,6 +109,7 @@ data ArgType
   = Normal
   | Flag
   | List
+  | Form
   deriving (Data, Eq, Show, Typeable)
 
 makePrisms ''ArgType
@@ -416,6 +417,18 @@ instance
         { _argName = PathSegment str
         , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
 
+instance (HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
+  => HasForeign lang ftype (QueryParamForm' mods a :> api) where
+  type Foreign ftype (QueryParamForm' mods 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
   (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)
   => HasForeign lang ftype (Fragment a :> api) where
@@ -426,6 +439,7 @@ instance
     where
       argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a))
 
+
 instance HasForeign lang ftype Raw where
   type Foreign ftype Raw = HTTP.Method -> Req ftype
 

servant-foreign/test/Servant/ForeignSpec.hs

@@ -66,9 +66,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 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]
@@ -80,9 +92,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,19 @@ 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 ]
+          Nothing
+      , _reqMethod     = "POST"
+      , _reqHeaders    = []
+      , _reqBody       = Nothing
+      , _reqReturnType = Just "voidX"
+      , _reqFuncName   = FunctionName ["post", "test"]
+      }
+
   it "collects all info for put request" $ do
     shouldBe putReq $ defReq
       { _reqUrl        = Url
@@ -151,3 +176,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
@@ -46,9 +46,9 @@ import           Data.Monoid ()
 import           Data.Proxy
 import           GHC.Generics
                  (Generic)
-import qualified Network.HTTP.Types                   as HTTP
+import qualified Network.HTTP.Types               as HTTP
 import           Network.Socket
-import qualified Network.Wai                          as Wai
+import qualified Network.Wai                      as Wai
 import           Network.Wai.Handler.Warp
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
@@ -62,9 +62,10 @@ 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)
-import qualified Servant.Client.Core.Auth    as Auth
-import qualified Servant.Client.Core.Request as Req
+                 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
 import           Servant.Server
 import           Servant.Server.Experimental.Auth
@@ -119,6 +120,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 Person :> Get '[JSON] [Person]
   :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
   :<|> "rawSuccess" :> Raw
   :<|> "rawFailure" :> Raw
@@ -144,6 +146,7 @@ getCaptureAll   :: [String] -> ClientM [Person]
 getBody         :: Person -> ClientM Person
 getQueryParam   :: Maybe String -> ClientM Person
 getQueryParams  :: [String] -> ClientM [Person]
+getQueryParamForm  :: Maybe Person -> ClientM [Person]
 getQueryFlag    :: Bool -> ClientM Bool
 getRawSuccess   :: HTTP.Method -> ClientM Response
 getRawFailure   :: HTTP.Method -> ClientM Response
@@ -161,6 +164,7 @@ getRoot
   :<|> getBody
   :<|> getQueryParam
   :<|> getQueryParams
+  :<|> getQueryParamForm
   :<|> getQueryFlag
   :<|> getRawSuccess
   :<|> getRawFailure
@@ -183,6 +187,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 _) -> return [alice, carol]
+                   Just (Left _) -> 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")
@@ -303,6 +311,11 @@ successSpec = 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 $ Person "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

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