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

Author: erewok

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
@@ -710,4 +761,4 @@ decodedAs response ct = do
     Left err -> throwClientError $ DecodeFailure (T.pack err) response
     Right val -> return val
   where
-    accept = toList $ contentTypes ct 
+    accept = toList $ contentTypes ct

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,9 +175,11 @@ instance MimeRender PlainText Int where
   mimeRender _ = cs . show
 
 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
+           :<|> "postJson"   :> ReqBody '[JSON] String          :> Post '[JSON] Datatype1
+           :<|> "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)
 data UT = UT1 | UT2 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"]
       }
+