diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Req 3.11.0 + +* Add the `queryParamToList` method to the `QueryParam` type class. +* Add the `formToQuery` function. [Issue 126](https://github.com/mrkkrp/req/issues/126). +* Add `FromForm` instances (in the `Web.FormUrlEncoded` module) to the + `Option` and `FormUrlEncodedParam` types. + ## Req 3.10.0 * Add `MonadHttp` instances for `transformers` types. diff --git a/Network/HTTP/Req.hs b/Network/HTTP/Req.hs --- a/Network/HTTP/Req.hs +++ b/Network/HTTP/Req.hs @@ -155,6 +155,7 @@ -- $query-parameters (=:), queryFlag, + formToQuery, QueryParam (..), -- *** Headers @@ -251,7 +252,7 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.Proxy -import Data.Semigroup hiding (Option, option) +import Data.Semigroup (Endo (..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -272,6 +273,8 @@ import qualified Text.URI as URI import qualified Text.URI.QQ as QQ import qualified Web.Authenticate.OAuth as OAuth +import Web.FormUrlEncoded (FromForm (..), ToForm (..)) +import qualified Web.FormUrlEncoded as Form import Web.HttpApiData (ToHttpApiData (..)) ---------------------------------------------------------------------------- @@ -1303,7 +1306,14 @@ instance QueryParam FormUrlEncodedParam where queryParam name mvalue = FormUrlEncodedParam [(name, toQueryParam <$> mvalue)] + queryParamToList (FormUrlEncodedParam p) = p +-- | Use 'formToQuery'. +-- +-- @since 3.11.0 +instance FromForm FormUrlEncodedParam where + fromForm = Right . formToQuery + -- | Multipart form data. Please consult the -- "Network.HTTP.Client.MultipartFormData" module for how to construct -- parts, then use 'reqBodyMultipart' to create actual request body from the @@ -1428,6 +1438,12 @@ mempty = Option mempty Nothing mappend = (<>) +-- | Use 'formToQuery'. +-- +-- @since 3.11.0 +instance FromForm (Option scheme) where + fromForm = Right . formToQuery + -- | A helper to create an 'Option' that modifies only collection of query -- parameters. This helper is not a part of the public API. withQueryParams :: (Y.QueryText -> Y.QueryText) -> Option scheme @@ -1482,6 +1498,24 @@ queryFlag :: QueryParam param => Text -> param queryFlag name = queryParam name (Nothing :: Maybe ()) +-- | Construct query parameters from a 'ToForm' instance. This function +-- produces the same query params as 'Form.urlEncodeAsFormStable'. +-- +-- Note that 'Form.Form' doesn't have the concept of parameters with the +-- empty value (i.e. what you can get by @key =: ""@). If the value is +-- empty, it will be encoded as a valueless parameter (i.e. what you can get +-- by @queryFlag key@). +-- +-- @since 3.11.0 +formToQuery :: (QueryParam param, Monoid param, ToForm f) => f -> param +formToQuery f = mconcat . fmap toParam . Form.toListStable $ toForm f + where + toParam (key, val) = + queryParam key $ + if val == "" + then Nothing + else Just val + -- | A type class for query-parameter-like things. The reason to have an -- overloaded 'queryParam' is to be able to use it as an 'Option' and as a -- 'FormUrlEncodedParam' when constructing form URL encoded request bodies. @@ -1493,9 +1527,15 @@ -- method, because they are easier to read. queryParam :: ToHttpApiData a => Text -> Maybe a -> param + -- | Get the query parameter names and values set by 'queryParam'. + -- + -- @since 3.11.0 + queryParamToList :: param -> [(Text, Maybe Text)] + instance QueryParam (Option scheme) where queryParam name mvalue = withQueryParams ((:) (name, toQueryParam <$> mvalue)) + queryParamToList (Option f _) = fst $ appEndo f ([], L.defaultRequest) ---------------------------------------------------------------------------- -- Request—Optional parameters—Headers diff --git a/httpbin-tests/Network/HTTP/ReqSpec.hs b/httpbin-tests/Network/HTTP/ReqSpec.hs --- a/httpbin-tests/Network/HTTP/ReqSpec.hs +++ b/httpbin-tests/Network/HTTP/ReqSpec.hs @@ -16,6 +16,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Functor.Identity (runIdentity) +import Data.Maybe (fromJust) import Data.Proxy import Data.Text (Text) import qualified Data.Text as T @@ -135,7 +136,7 @@ LM.partBS "bar" "bar data!" ] r <- req POST (httpbin /: "post") body jsonResponse mempty - let Just contentType = getRequestContentType body + let contentType = fromJust (getRequestContentType body) (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object [ "args" .= emptyObject, @@ -260,21 +261,17 @@ -- TODO /response-headers -- TODO /redirect - -- FIXME Redirects test is temporarily disabled due to - -- - -- https://github.com/postmanlabs/httpbin/issues/617 - - -- describe "redirects" $ - -- it "follows redirects" $ do - -- r <- - -- req - -- GET - -- (httpbin /: "redirect-to") - -- NoReqBody - -- ignoreResponse - -- ("url" =: ("https://httpbin.org" :: Text)) - -- responseStatusCode r `shouldBe` 200 - -- responseStatusMessage r `shouldBe` "OK" + describe "redirects" $ + it "follows redirects" $ do + r <- + req + GET + (httpbin /: "redirect-to") + NoReqBody + ignoreResponse + ("url" =: ("https://httpbin.org" :: Text)) + responseStatusCode r `shouldBe` 200 + responseStatusMessage r `shouldBe` "OK" -- TODO /relative-redicet -- TODO /absolute-redirect diff --git a/pure-tests/Network/HTTP/ReqSpec.hs b/pure-tests/Network/HTTP/ReqSpec.hs --- a/pure-tests/Network/HTTP/ReqSpec.hs +++ b/pure-tests/Network/HTTP/ReqSpec.hs @@ -33,6 +33,7 @@ import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable (Typeable, eqT) +import GHC.Exts (IsList (..)) import GHC.Generics import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH @@ -46,6 +47,7 @@ import Text.URI (URI) import qualified Text.URI as URI import qualified Text.URI.QQ as QQ +import qualified Web.FormUrlEncoded as F spec :: Spec spec = do @@ -159,11 +161,13 @@ let uriHttp = uri' {URI.uriScheme = Just [QQ.scheme|http|]} uriHttps = uri' {URI.uriScheme = Just [QQ.scheme|https|]} requestHttp <- - let Left (url', options) = fromJust (useURI uriHttp) - in req_ GET url' NoReqBody options + case fromJust (useURI uriHttp) of + Left (url', options) -> req_ GET url' NoReqBody options + _ -> error "(useURI uriHttp) should have returned Left" requestHttps <- - let Right (url', options) = fromJust (useURI uriHttps) - in req_ GET url' NoReqBody options + case fromJust (useURI uriHttps) of + Right (url', options) -> req_ GET url' NoReqBody options + _ -> error "(useURI uriHttps) should have returned Right" L.host requestHttp `shouldBe` uriHost uriHttp L.host requestHttps `shouldBe` uriHost uriHttps L.port requestHttp `shouldBe` uriPort 80 uriHttp @@ -233,6 +237,19 @@ L.RequestBodyLBS x -> x `shouldBe` renderQuery params _ -> expectationFailure "Wrong request body constructor." + describe "query params" $ do + describe "FormUrlEncodedParam" $ do + describe "formToQuery" $ do + it "should produce the same parameters as F.urlEncodeFormStable" $ + property $ \form -> do + request <- req_ POST url (ReqBodyUrlEnc $ formToQuery form) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` F.urlEncodeFormStable form + _ -> expectationFailure "Wrong request body constructor" + specParamToList (Proxy :: Proxy FormUrlEncodedParam) + describe "Option" $ do + specParamToList (Proxy :: Proxy (Option 'Http)) + describe "optional parameters" $ do describe "header" $ do it "sets specified header value" $ @@ -486,6 +503,9 @@ instance Arbitrary DiffTime where arbitrary = secondsToDiffTime <$> arbitrary +instance Arbitrary F.Form where + arbitrary = (F.Form . fromList) <$> arbitrary + ---------------------------------------------------------------------------- -- Helper types @@ -598,3 +618,15 @@ basicProxyAuthHeader username password = fromJust . lookup Y.hProxyAuthorization . L.requestHeaders $ L.applyBasicProxyAuth username password L.defaultRequest + +-- | Spec about 'paramToList' for the type @p@. +specParamToList :: (QueryParam p, Monoid p) => Proxy p -> Spec +specParamToList typeProxy = do + describe "paramToList" $ do + it "should reproduce the parameters given by queryParam" $ + property $ \(QueryParams params) -> do + let queryParam0 = + (mconcat $ fmap (uncurry queryParam) params) + `asProxyTypeOf` typeProxy + got = queryParamToList queryParam0 + got `shouldBe` params diff --git a/req.cabal b/req.cabal --- a/req.cabal +++ b/req.cabal @@ -1,11 +1,11 @@ -cabal-version: 1.18 +cabal-version: 2.4 name: req -version: 3.10.0 -license: BSD3 +version: 3.11.0 +license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov author: Mark Karpov -tested-with: ghc ==8.8.4 ghc ==8.10.5 ghc ==9.0.1 +tested-with: ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.1 homepage: https://github.com/mrkkrp/req bug-reports: https://github.com/mrkkrp/req/issues synopsis: HTTP client library @@ -49,8 +49,8 @@ monad-control >=1.0 && <1.1, mtl >=2.0 && <3.0, retry >=0.8 && <0.10, - template-haskell >=2.14 && <2.18, - text >=0.2 && <1.3, + template-haskell >=2.14 && <2.19, + text >=0.2 && <2.1, time >=1.2 && <1.13, transformers >=0.5.3.0 && <0.6, transformers-base, @@ -83,14 +83,15 @@ case-insensitive >=0.2 && <1.3, hspec >=2.0 && <3.0, hspec-core >=2.0 && <3.0, + http-api-data >=0.2 && <0.5, http-client >=0.7 && <0.8, http-types >=0.8 && <10.0, modern-uri >=0.3 && <0.4, mtl >=2.0 && <3.0, req, retry >=0.8 && <0.10, - template-haskell >=2.14 && <2.18, - text >=0.2 && <1.3, + template-haskell >=2.14 && <2.19, + text >=0.2 && <2.1, time >=1.2 && <1.13 if flag(dev) @@ -117,7 +118,7 @@ monad-control >=1.0 && <1.1, mtl >=2.0 && <3.0, req, - text >=0.2 && <1.3 + text >=0.2 && <2.1 if flag(dev) ghc-options: -O0 -Wall -Werror