eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source
This commit is contained in:
Erik Aker 2019-09-30 17:59:56 -07:00
parent 38f3da2499
commit cffa511df9
19 changed files with 469 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client-core/servant-client-core.cabal
View file

@ -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

1
servant-client-core/src/Servant/Client/Core.hs
View file

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

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

@ -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

13
servant-client-core/src/Servant/Client/Core/Request.hs
View file

@ -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'

2
servant-docs/servant-docs.cabal
View file

@ -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

26
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -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) _ =

35
servant-docs/test/Servant/DocsSpec.hs
View file

@ -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)

14
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -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

28
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -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"]
}

33
servant-http-streams/test/Servant/ClientSpec.hs
View file

@ -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

1
servant-server/servant-server.cabal
View file

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

71
servant-server/src/Servant/Server/Internal.hs
View file

@ -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:

127
servant-server/test/Servant/ServerSpec.hs
View file

@ -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}
-- }}}

1
servant/servant.cabal
View file

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

3
servant/src/Servant/API.hs
View file

@ -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

35
servant/src/Servant/API/QueryParam.hs
View file

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

3
servant/src/Servant/API/TypeLevel.hs
View file

@ -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'

18
servant/src/Servant/Links.hs
View file

@ -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

24
servant/test/Servant/LinksSpec.hs
View file

@ -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"]