From cffa511df94fdf9b6f3228824b82a20db44b4f8e Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Mon, 30 Sep 2019 17:59:56 -0700 Subject: [PATCH 1/5] 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 5789da601..55495411b 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 f18d327f2..e23724b3d 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 783072443..5442fdee7 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 73756e702..8b6fd992b 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 72896d728..8799b5d24 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 d5b51d93a..14b534bb6 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 bda291a6a..72b18841f 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 0f3b1248e..8941b19ec 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 2bfe05553..1f7096ab2 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 aa0e0fb81..079f1559d 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 1e81a47a7..fe12cfdba 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 b9a940359..2c428a99b 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 ff87d04bf..d28bf098c 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 b44f9f482..2417e80d6 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 772a38878..d5dfbb34a 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 45d0e7ee3..18e978c55 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 188aa63d9..a4e0c86a5 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 0d07c201f..b58b5ea11 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 1c448ba0c..00b800390 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"] From 68014463d9c89ce84506d2a6df1f5b34dffc923e Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Wed, 2 Oct 2019 20:47:54 -0700 Subject: [PATCH 2/5] Rewrite client concatQueryString for client requests and pull extraneous data type for spec Remove symbol from QueryParamForm type args Remove the data instance for QueryParamForm in HasDocs --- .../src/Servant/Client/Core/HasClient.hs | 8 ++--- .../src/Servant/Client/Core/Request.hs | 10 +++--- servant-docs/src/Servant/Docs/Internal.hs | 22 +++++-------- servant-docs/test/Servant/DocsSpec.hs | 9 ++--- .../src/Servant/Foreign/Internal.hs | 8 ++--- servant-foreign/test/Servant/ForeignSpec.hs | 2 +- .../test/Servant/ClientSpec.hs | 18 +++------- servant-server/src/Servant/Server/Internal.hs | 27 +++++++-------- servant-server/test/Servant/ServerSpec.hs | 6 ++-- servant/src/Servant/API/QueryParam.hs | 8 ++--- servant/src/Servant/Links.hs | 12 +++---- servant/test/Servant/LinksSpec.hs | 33 ++++++++++++++----- 12 files changed, 82 insertions(+), 81 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 5442fdee7..7f9bc5f98 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -557,7 +557,7 @@ instance (KnownSymbol sym, HasClient m api) -- > } deriving (Eq, Show, Generic) -- > instance ToForm BookSearchParams -- --- > type MyApi = "books" :> QueryParamForm "searchQ" BookSearchParams :> Get '[JSON] [Book] +-- > type MyApi = "books" :> QueryParamForm BookSearchParams :> Get '[JSON] [Book] -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy @@ -567,10 +567,10 @@ instance (KnownSymbol sym, HasClient m api) -- > -- 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 +instance (ToForm a, HasClient m api, SBoolI (FoldRequired mods)) + => HasClient m (QueryParamForm' mods a :> api) where - type Client m (QueryParamForm' mods sym a :> api) = + 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 diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index 8b6fd992b..bd36b8958 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -51,11 +51,11 @@ import Network.HTTP.Media (MediaType) import Network.HTTP.Types (Header, HeaderName, HttpVersion (..), Method, QueryItem, - http11, methodGet, parseQuery) + http11, methodGet) import Servant.API (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO) import Web.FormUrlEncoded - (ToForm (..), urlEncodeAsForm) + (ToForm (..), toListStable) import Servant.Client.Core.Internal (mediaTypeRnf) @@ -143,14 +143,16 @@ concatQueryString :: ToForm a -> Request -> Request concatQueryString form req - = let querySeq = Seq.fromList . parseQuery . LBS.toStrict . urlEncodeAsForm $ form + = 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 diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 14b534bb6..54c16a834 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -32,8 +32,6 @@ 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 @@ -955,25 +953,23 @@ 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 - +-- | 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) - paramNames = constrFields (toConstr sampleForm) sampleEncoding = LBSC.unpack . urlEncodeAsForm . toForm $ sampleForm - in action & params <>~ (fmap (qParamMaker sampleEncoding) paramNames) - qParamMaker formEncodedSample pName = DocQueryParam { - _paramName = pName + in action & params <>~ [qParamMaker sampleEncoding] + qParamMaker formEncodedSample = DocQueryParam { + _paramName = "Collection of Parameters" , _paramValues = [formEncodedSample] - , _paramDesc = "Query parameter" + , _paramDesc = "Query parameters" , _paramKind = Normal } diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 72b18841f..32ffce115 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -58,7 +58,7 @@ instance ToParam (QueryParam' mods "bar" Int) where 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 + 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 @@ -143,10 +143,7 @@ spec = describe "Servant.Docs" $ do 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 + it "mentions optional query-param-form params from QueryParamForm" $ md `shouldContain` "- **Values**: *dt1field1=field%201&dt1field2=13*" it "does not generate any docs mentioning the 'empty-api' path" $ @@ -177,7 +174,7 @@ instance MimeRender PlainText Int where type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> "postJson" :> ReqBody '[JSON] String :> Post '[JSON] Datatype1 :<|> "qparam" :> QueryParam "query" String :> Get '[JSON] Datatype1 - :<|> "qparamform" :> QueryParamForm "form" Datatype1 :> Get '[JSON] Datatype1 + :<|> "qparamform" :> QueryParamForm Datatype1 :> Get '[JSON] Datatype1 :<|> "header" :> Header "X-Test" Int :> Put '[JSON] Int :<|> "empty-api" :> EmptyAPI diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 8941b19ec..771f44424 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -325,9 +325,9 @@ 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 +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) $ @@ -336,7 +336,7 @@ instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), 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 1f7096ab2..e25b61f3e 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -82,7 +82,7 @@ instance HasForeignType LangX String ContactForm where 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" :> 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] diff --git a/servant-http-streams/test/Servant/ClientSpec.hs b/servant-http-streams/test/Servant/ClientSpec.hs index 079f1559d..4ea340b9e 100644 --- a/servant-http-streams/test/Servant/ClientSpec.hs +++ b/servant-http-streams/test/Servant/ClientSpec.hs @@ -111,14 +111,6 @@ 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 = @@ -130,7 +122,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] + :<|> "paramform" :> QueryParamForm Person :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "rawSuccess" :> Raw :<|> "rawFailure" :> Raw @@ -156,7 +148,7 @@ getCaptureAll :: [String] -> ClientM [Person] getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person getQueryParams :: [String] -> ClientM [Person] -getQueryParamForm :: Maybe PersonSearch -> ClientM [Person] +getQueryParamForm :: Maybe Person -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool getRawSuccess :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response @@ -198,8 +190,8 @@ server = serve api ( 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" "" [] + 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") @@ -323,7 +315,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.QueryParam.QueryParamForm" $ \(_, baseUrl) -> do left show <$> runClient (getQueryParamForm Nothing) baseUrl `shouldReturn` Right [] - left show <$> runClient (getQueryParamForm (Just $ PersonSearch "a" 10)) baseUrl + left show <$> runClient (getQueryParamForm (Just $ Person "a" 10)) baseUrl `shouldReturn` Right [alice, carol] context "Servant.API.QueryParam.QueryFlag" $ diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 2c428a99b..8a3ac8d96 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -558,9 +558,9 @@ 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. +-- | If you define a custom record type, for example @BookSearchParams@, then you can use +-- @'QueryParamForm' 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)@. @@ -582,26 +582,24 @@ instance (KnownSymbol sym, HasServer api context) -- > , page :: Maybe Int -- > } deriving (Eq, Show, Generic) -- > instance FromForm BookSearchParams --- > type MyApi = "books" :> QueryParamForm "searchQ" BookSearchParams :> Get '[JSON] [Book] --- +-- > type MyApi = "books" :> QueryParamForm BookSearchParams :> Get '[JSON] [Book] +-- -- Example Handler Signature: -- Maybe (Either Text BookSearchParams) -> Handler [Book] instance - ( KnownSymbol sym, FromForm a, HasServer api context + (FromForm a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) ) - => HasServer (QueryParamForm' mods sym a :> api) context where + => HasServer (QueryParamForm' mods a :> api) context where ------ - type ServerT (QueryParamForm' mods sym a :> api) m = + type ServerT (QueryParamForm' mods 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) + route Proxy context subserver = - parseParamForm req = + let parseParamForm req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev where rawQS = rawQueryString req @@ -612,12 +610,11 @@ instance _ -> Just $ urlDecodeAsForm (BL.drop 1 . BL.fromStrict $ rawQS) errReq = delayedFailFatal err400 - { errBody = cs $ "Query parameter form " <> formName <> " is required" + { errBody = "Query parameter form is required" } errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter form " - <> formName <> " failed: " <> e + { errBody = cs $ "Error: parsing query parameter form failed. " <> e } delayed = addParameterCheck subserver . withRequest $ \req -> diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index d28bf098c..5f023363b 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -466,14 +466,14 @@ data AnimalSearch = AnimalSearch { instance FromForm AnimalSearch type QueryParamFormApi = - QueryParamForm "octopus" AnimalSearch :> Get '[JSON] Animal + QueryParamForm AnimalSearch :> Get '[JSON] Animal :<|> "before-param" :> QueryParam "before" Bool - :> QueryParamForm "before" AnimalSearch + :> QueryParamForm AnimalSearch :> Get '[JSON] Animal :<|> "mixed-param" :> QueryParam "before" Bool - :> QueryParamForm "multiple" AnimalSearch + :> QueryParamForm AnimalSearch :> QueryParam "after" Bool :> Get '[JSON] Animal diff --git a/servant/src/Servant/API/QueryParam.hs b/servant/src/Servant/API/QueryParam.hs index 18e978c55..adb5d35ac 100644 --- a/servant/src/Servant/API/QueryParam.hs +++ b/servant/src/Servant/API/QueryParam.hs @@ -50,7 +50,7 @@ data QueryParams (sym :: Symbol) (a :: *) -- 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 @@ -59,15 +59,15 @@ data QueryParams (sym :: Symbol) (a :: *) -- > , page :: Maybe Int -- > } deriving (Eq, Show, Generic) -- > instance FromForm BookSearchParams --- > type MyApi = "books" :> QueryParamForm "searchQ" BookSearchParams :> Get '[JSON] [Book] --- +-- > type MyApi = "books" :> QueryParamForm 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 :: *) +data QueryParamForm' (mods :: [*]) (a :: *) deriving Typeable diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index b58b5ea11..ba6e73a04 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -142,7 +142,7 @@ import Network.URI import Prelude () import Prelude.Compat import Web.FormUrlEncoded - (ToForm(..), urlEncodeAsFormStable) + (ToForm(..), urlEncodeAsForm) import Servant.API.Alternative ((:<|>) ((:<|>))) @@ -478,15 +478,15 @@ 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) +instance (ToForm v, HasLink sub, SBoolI (FoldRequired mods)) + => HasLink (QueryParamForm' mods v :> sub) where - type MkLink (QueryParamForm' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a + type MkLink (QueryParamForm' mods 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 + STrue -> (addQueryParam . FormParam . urlEncodeAsForm) mv l + SFalse -> maybe id (addQueryParam . FormParam . urlEncodeAsForm) mv l -- :<|> instance - Generate all links at once instance (HasLink a, HasLink b) => HasLink (a :<|> b) where diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 00b800390..f3940dc66 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -6,13 +6,15 @@ {-# LANGUAGE TypeOperators #-} module Servant.LinksSpec where + import Data.Proxy (Proxy (..)) import Data.String (fromString) +import qualified Data.Text as T import GHC.Generics import Test.Hspec - (Expectation, Spec, describe, it, shouldBe) + (Expectation, Spec, describe, it, shouldBe, shouldContain) import Web.FormUrlEncoded (ToForm(..)) @@ -25,8 +27,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 + :<|> "formR" :> QueryParamForm' '[Required, Strict] TestForm :> Delete '[JSON] NoContent + :<|> "form-opt" :> QueryParamForm TestForm :> Delete '[JSON] NoContent :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent -- Flags @@ -62,6 +64,10 @@ shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected = toUrlPiece link `shouldBe` fromString expected +linkShouldContain :: Link -> String -> Expectation +linkShouldContain link expected = + T.unpack (toUrlPiece link) `shouldContain` expected + spec :: Spec spec = describe "Servant.Links" $ do it "generates correct links for capture query params" $ do @@ -80,14 +86,25 @@ spec = describe "Servant.Links" $ do 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 + let l3 = Proxy :: Proxy ("formR" :> QueryParamForm' '[Required, Strict] 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 + let result3 = apiLink l3 (TestForm "sure" "später") + -- we can't guarantee the order of the params unless we switch to `urlEncodeAsFormStable`... + result3 `linkShouldContain` "formR?" + result3 `linkShouldContain` "&" + result3 `linkShouldContain` "time=sp%C3%A4ter" + result3 `linkShouldContain` "testing=sure" + + let l4 = Proxy :: Proxy ("form-opt" :> QueryParamForm TestForm :> Delete '[JSON] NoContent) - apiLink l4 (Just $ TestForm "sure" "später") `shouldBeLink` "form-opt?testing=sure&time=sp%C3%A4ter" + + let result4 = apiLink l4 (Just $ TestForm "sure" "später") + -- we can't guarantee the order of the params unless we switch to `urlEncodeAsFormStable`... + result4 `linkShouldContain` "form-opt?" + result4 `linkShouldContain` "&" + result4 `linkShouldContain` "time=sp%C3%A4ter" + result4 `linkShouldContain` "testing=sure" it "generates correct links for CaptureAll" $ do apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) From cee0763507ed51ff75307fef2c3881b0f2f2d9e4 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Thu, 16 Jan 2020 21:22:56 -0800 Subject: [PATCH 3/5] Add an illustrative test demonstrating single question mark result --- servant-docs/test/Servant/DocsSpec.hs | 4 +--- servant-server/src/Servant/Server/Internal.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 9 +++++++++ 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 4d18f7e2b..5c98ec323 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -22,8 +22,6 @@ 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 @@ -161,7 +159,7 @@ spec = describe "Servant.Docs" $ do data Datatype1 = Datatype1 { dt1field1 :: String , dt1field2 :: Int - } deriving (Eq, Show, Data, Generic) + } deriving (Eq, Show, Generic) instance ToJSON Datatype1 instance ToForm Datatype1 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 988e4ecbe..36f9f15ed 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -607,7 +607,7 @@ instance mev :: Maybe (Either T.Text a) mev = case B.length rawQS of 0 -> Nothing - _ -> Just $ urlDecodeAsForm (BL.drop 1 . BL.fromStrict $ rawQS) + _ -> Just $ urlDecodeAsForm $ BL.drop 1 $ BL.fromStrict rawQS errReq = delayedFailFatal err400 { errBody = "Query parameter form is required" diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e71c20157..265b2aa4a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -514,6 +514,15 @@ queryParamFormSpec = do } liftIO $ do decode' (simpleBody response1) `shouldBe` (Just $ Animal { species = "bimac", numberOfLegs = 7}) + it "Just a question mark will match but return a Left" $ + (flip runSession) (serve queryParamFormApi qpFormServer) $ do + let paramsQ = "?" + response1 <- Network.Wai.Test.request defaultRequest{ + rawQueryString = paramsQ, + queryString = parseQuery paramsQ + } + liftIO $ do + decode' (simpleBody response1) `shouldBe` (Just $ Animal { species = "broken", numberOfLegs = 0}) it "allows no query params at all" $ (flip runSession) (serve queryParamFormApi qpFormServer) $ do response1 <- Network.Wai.Test.request defaultRequest From 75da485e0ff5a60051a39602d90f5f5c442945d2 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Sat, 18 Jan 2020 22:04:24 -0800 Subject: [PATCH 4/5] Re-export Web.FormUrlEncoded from Servant.API --- servant-client-core/servant-client-core.cabal | 1 - servant-client-core/src/Servant/Client/Core/HasClient.hs | 4 +--- servant-client-core/src/Servant/Client/Core/Request.hs | 5 ++--- servant-docs/servant-docs.cabal | 2 -- servant-docs/src/Servant/Docs/Internal.hs | 2 -- servant-docs/test/Servant/DocsSpec.hs | 3 --- servant/src/Servant/API.hs | 5 +++++ 7 files changed, 8 insertions(+), 14 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index f7dcf4a86..3faf65bb4 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -79,7 +79,6 @@ 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/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 7f9bc5f98..e26c1cdca 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -49,7 +49,7 @@ import Servant.API IsSecure, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, QueryParamForm', Raw, ReflectMethod (..), RemoteHost, - ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, + ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToForm (..), ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext, contentType, getHeadersHList, getResponse, toQueryParam, toUrlPiece) @@ -57,8 +57,6 @@ 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 diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index 16568b802..ca5f855cf 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -53,9 +53,8 @@ import Network.HTTP.Types (Header, HeaderName, HttpVersion (..), Method, QueryItem, http11, methodGet) import Servant.API - (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO) -import Web.FormUrlEncoded - (ToForm (..), toListStable) + (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO, + ToForm (..), toListStable) import Servant.Client.Core.Internal (mediaTypeRnf) diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 8799b5d24..72896d728 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -62,7 +62,6 @@ 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 @@ -101,7 +100,6 @@ 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 bd4360c38..c2cca1ca2 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -64,8 +64,6 @@ 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 diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5c98ec323..d53f53dc0 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -36,8 +35,6 @@ import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit (Assertion, HasCallStack, assertFailure, testCase, (@?=)) -import Web.FormUrlEncoded - (ToForm) import Servant.API import Servant.Docs.Internal diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index d5dfbb34a..dcb0efac7 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -58,6 +58,9 @@ module Servant.API ( module Web.HttpApiData, -- | Classes and instances for types that can be converted to and from HTTP API data. + -- * ToForm and FromForm + module Web.FormUrlEncoded, + -- | Classes and instances for working with Forms -- * Experimental modules module Servant.API.Experimental.Auth, @@ -139,3 +142,5 @@ import Servant.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +import Web.FormUrlEncoded + (ToForm (..), urlEncodeAsForm, toListStable) \ No newline at end of file From 55a85e17d083676e8f939d923f326019bd53a036 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Wed, 17 Nov 2021 18:30:22 -0800 Subject: [PATCH 5/5] Making the diff smaller and fix the tests. --- servant-docs/src/Servant/Docs/Internal.hs | 3 ++- servant-docs/test/Servant/DocsSpec.hs | 15 ++++++++------- servant-foreign/test/Servant/ForeignSpec.hs | 2 ++ 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 9991aec50..9ff742d03 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -1074,13 +1074,14 @@ instance (ToForm a, ToSample a, HasDocs api) instance (ToFragment (Fragment a), HasDocs api) => HasDocs (Fragment a :> api) where + docsFor Proxy (endpoint, action) = docsFor subApiP (endpoint, action') + where subApiP = Proxy :: Proxy api fragmentP = Proxy :: Proxy (Fragment a) action' = set fragment (Just (toFragment fragmentP)) action - instance HasDocs Raw where docsFor _proxy (endpoint, action) _ = single endpoint action diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index f8a35ebb0..9b87c1ac0 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -82,7 +82,7 @@ spec = describe "Servant.Docs" $ do (defAction & notes <>~ [DocNote "Get an Integer" ["get an integer in Json or plain text"]]) <> extraInfo - (Proxy :: Proxy ("postJson" :> ReqBody '[JSON] String :> Post '[JSON] Datatype1)) + (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1)) tests1 md @@ -126,10 +126,10 @@ spec = describe "Servant.Docs" $ do md `shouldContain` "## GET" it "should mention the endpoints" $ do - md `shouldContain` "## POST /postJson" + md `shouldContain` "## POST /" md `shouldContain` "## GET /qparam" md `shouldContain` "## GET /qparamform" - md `shouldContain` "## PUT /header" + md `shouldContain` "## PUT /" it "mentions headers" $ do md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." @@ -145,7 +145,7 @@ spec = describe "Servant.Docs" $ do md `shouldContain` "### GET Parameters:" md `shouldContain` "- query" it "mentions optional query-param-form params from QueryParamForm" $ - md `shouldContain` "- **Values**: *dt1field1=field%201&dt1field2=13*" + md `shouldContain` "**Values**: *dt1field2=13&dt1field1=field%201*" it "does not generate any docs mentioning the 'empty-api' path" $ md `shouldNotContain` "empty-api" @@ -178,11 +178,12 @@ instance MimeRender PlainText Int where mimeRender _ = cs . show type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) - :<|> "postJson" :> ReqBody '[JSON] String :> Post '[JSON] Datatype1 + :<|> 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 - :<|> "header" :> Header "X-Test" Int :> Put '[JSON] Int - :<|> "empty-api" :> EmptyAPI + type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1 :<|> "duplicate-endpoint" :> Get '[PlainText] Int diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 3632c071d..fe65493a7 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -127,8 +127,10 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] [ QueryArg (Arg "" "maybe contactFormX") Form ] + Nothing , _reqMethod = "POST" , _reqHeaders = [] + , _reqBody = Nothing , _reqReturnType = Just "voidX" , _reqFuncName = FunctionName ["post", "test"] }