From cffa511df94fdf9b6f3228824b82a20db44b4f8e Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Mon, 30 Sep 2019 17:59:56 -0700 Subject: [PATCH] Add QueryParamForm for Client, Server, Internal, Foreign, and SafeLink --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Core.hs | 1 + .../src/Servant/Client/Core/HasClient.hs | 55 +++++++- .../src/Servant/Client/Core/Request.hs | 13 +- servant-docs/servant-docs.cabal | 2 + servant-docs/src/Servant/Docs/Internal.hs | 26 ++++ servant-docs/test/Servant/DocsSpec.hs | 35 ++++- .../src/Servant/Foreign/Internal.hs | 14 ++ servant-foreign/test/Servant/ForeignSpec.hs | 28 +++- .../test/Servant/ClientSpec.hs | 33 ++++- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server/Internal.hs | 71 +++++++++- servant-server/test/Servant/ServerSpec.hs | 127 +++++++++++++++++- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 3 +- servant/src/Servant/API/QueryParam.hs | 35 ++++- servant/src/Servant/API/TypeLevel.hs | 3 +- servant/src/Servant/Links.hs | 18 ++- servant/test/Servant/LinksSpec.hs | 24 ++++ 19 files changed, 469 insertions(+), 22 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 5789da60..55495411 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/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 diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index f18d327f..e23724b3 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -55,6 +55,7 @@ module Servant.Client.Core , addHeader , appendToQueryString , appendToPath + , concatQueryString , setRequestBodyLBS , setRequestBody ) where diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 78307244..5442fdee 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/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 diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index 73756e70..8b6fd992 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/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' diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 72896d72..8799b5d2 100644 --- a/servant-docs/servant-docs.cabal +++ b/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 diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index d5b51d93..14b534bb 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/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) _ = diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index bda291a6..72b18841 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/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) diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 0f3b1248..8941b19e 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/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 diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 2bfe0555..1f7096ab 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/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"] } + diff --git a/servant-http-streams/test/Servant/ClientSpec.hs b/servant-http-streams/test/Servant/ClientSpec.hs index aa0e0fb8..079f1559 100644 --- a/servant-http-streams/test/Servant/ClientSpec.hs +++ b/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 @@ -48,9 +48,9 @@ import Data.Semigroup ((<>)) 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 @@ -64,9 +64,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 @@ -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 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 1e81a47a..fe12cfdb 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -148,6 +148,7 @@ test-suite spec , base-compat , base64-bytestring , bytestring + , http-api-data , http-types , mtl , resourcet diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index b9a94035..2c428a99 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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: diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index ff87d04b..d28bf098 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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} + -- }}} diff --git a/servant/servant.cabal b/servant/servant.cabal index b44f9f48..2417e80d 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -161,6 +161,7 @@ test-suite spec , base-compat , aeson , bytestring + , http-api-data , http-media , mtl , servant diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 772a3887..d5dfbb34 100644 --- a/servant/src/Servant/API.hs +++ b/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 diff --git a/servant/src/Servant/API/QueryParam.hs b/servant/src/Servant/API/QueryParam.hs index 45d0e7ee..18e978c5 100644 --- a/servant/src/Servant/API/QueryParam.hs +++ b/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¶m2=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'. diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 188aa63d..a4e0c86a 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/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' diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 0d07c201..b58b5ea1 100644 --- a/servant/src/Servant/Links.hs +++ b/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 diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 1c448ba0..00b80039 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/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"]