diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,102 @@ +## Req 3.13.4 + +* Fixed empty ciphersuite list when compiling against `tls < 2.0.6` + (see [PR 175](https://github.com/mrkkrp/req/pull/175)). As a side effect, now + compatible with older versions of `crypton-connection` (>= 0.3). + +## Req 3.13.3 + +* Works with `crypton-connection-0.4` and newer. + +## Req 3.13.2 + +* Disable the problematic `httpbin-tests` test suite by default. Only enable + it when the `dev` flag is enabled. In that case it is expected that an + httpbin server is run locally at `localhost:1234`. + +## Req 3.13.1 + +* Switched the non-pure test suite to use https://httpbun.org instead of + https://httpbin.org since the latter proved to be highly unreliable + lately. + +* Switched from `connection` to `crypton-connection`. + +* Builds with GHC 9.6.1. + +## Req 3.13.0 + +* Add `headerRedacted` function to add header fields, which will be with + redacted values on print. + +## Req 3.12.0 + +* Add `isStatusCodeException` function. +* Add `instance HttpResponse (Network.HTTP.Client.Response ())`. + +## 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. + +## Req 3.9.2 + +* The test suite works with `aeson-2.x.x.x`. + +## Req 3.9.1 + +* Builds with GHC 9.0. + +## Req 3.9.0 + +* The `useHttpURI` and `useHttpsURI` functions now preserve trailing + slashes. + +## Req 3.8.0 + +* Adjusted the value of the `httpConfigRetryJudgeException` field of + `defaultHttpConfig` to retry on response timeouts and connection timeouts. + +## Req 3.7.0 + +* Added `reqCb`, a function that allows you to modify the `Request` object + but otherwise performs the requst for you. + +* Derived `MonadThrow`, `MonadCatch`, and `MonadMask` for the `Req` monad. + +## Req 3.6.0 + +* Added the `httpConfigBodyPreviewLength` configuration parameter to + `HttpConfig`. + +## Req 3.5.0 + +* Made `Req` an instance of `MonadUnliftIO`. [Issue + 100](https://github.com/mrkkrp/req/issues/100). + +## Req 3.4.0 + +* Requests using `DELETE` method can now have a body. [Issue + 89](https://github.com/mrkkrp/req/issues/89). + +* Added the `httpConfigRetryJudgeException` field to `HttpConfig` so that + requests that result in exceptions can be retried. [Issue + 93](https://github.com/mrkkrp/req/issues/93). + +* Added the function `renderUrl`. [Issue + 83](https://github.com/mrkkrp/req/issues/83). + +## Req 3.3.0 + +* Derived `Show` instances for response types `IgnoreResponse`, + `JsonResponse`, `BsResponse`, and `LbsResponse`. + ## Req 3.2.0 * Made the tests pass with `http-client-0.7` and later. diff --git a/Network/HTTP/Req.hs b/Network/HTTP/Req.hs --- a/Network/HTTP/Req.hs +++ b/Network/HTTP/Req.hs @@ -1,19 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,61 +19,40 @@ -- -- The documentation below is structured in such a way that the most -- important information is presented first: you learn how to do HTTP --- requests, how to embed them in any monad you have, and then it gives you +-- requests, how to embed them in the monad you have, and then it gives you -- details about less-common things you may want to know about. The -- documentation is written with sufficient coverage of details and -- examples, and it's designed to be a complete tutorial on its own. -- --- /(A modest intro goes here, click on 'req' to start making requests.)/ --- -- === About the library -- --- Req is an easy-to-use, type-safe, expandable, high-level HTTP client --- library that just works without any fooling around. --- --- What does the phrase “easy-to-use” mean? It means that the library is --- designed to be beginner-friendly so it's simple to add to your monad --- stack, intuitive to work with, well-documented, and does not get in your --- way. Doing HTTP requests is a common task and Haskell library for this --- should be very approachable and clear to beginners, thus certain --- compromises were made. For example, one cannot currently modify --- 'L.ManagerSettings' of the default manager because the library always --- uses the same implicit global manager for simplicity and maximal --- connection sharing. There is a way to use your own manager with different --- settings, but it requires a bit more typing. +-- Req is an HTTP client library that attempts to be easy-to-use, type-safe, +-- and expandable. -- --- “Type-safe” means that the library is protective and eliminates certain --- classes of errors. For example, we have correct-by-construction 'Url's, --- it's guaranteed that the user does not send the request body when using --- methods like 'GET' or 'OPTIONS', and the amount of implicit assumptions --- is minimized by making the user specify his\/her intentions in an --- explicit form (for example, it's not possible to avoid specifying the --- body or method of request). Authentication methods that assume HTTPS --- force the user to use HTTPS at the type level. The library also carefully --- hides underlying types from the lower-level @http-client@ package because --- those types are not safe enough (for example 'L.Request' is an instance --- of 'Data.String.IsString' and, if it's malformed, it will blow up at --- run-time). +-- “Easy-to-use” means that the library is designed to be beginner-friendly +-- so it's simple to add to your monad stack, intuitive to work with, +-- well-documented, and does not get in your way. Doing HTTP requests is a +-- common task and a Haskell library for this should be approachable and +-- clear to beginners, thus certain compromises were made. For example, one +-- cannot currently modify 'L.ManagerSettings' of the default manager +-- because the library always uses the same implicit global manager for +-- simplicity and maximal connection sharing. There is a way to use your own +-- manager with different settings, but it requires more typing. -- --- “Expandable” refers to the ability of the library to be expanded without --- having to resort to ugly hacking. For example, it's possible to define --- your own HTTP methods, create new ways to construct the body of a --- request, create new authorization options, perform a request in a --- different way, and create your own methods to parse and represent a --- response. As the user extends the library to satisfy his\/her special --- needs, the new solutions will work just like the built-ins. However, all --- of the common cases are also covered by the library out-of-the-box. +-- “Type-safe” means that the library tries to eliminate certain classes of +-- errors. For example, we have correct-by-construction URLs; it is +-- guaranteed that the user does not send the request body when using +-- methods like GET or OPTIONS, and the amount of implicit assumptions is +-- minimized by making the user specify their intentions in an explicit +-- form. For example, it's not possible to avoid specifying the body or the +-- method of a request. Authentication methods that assume HTTPS force the +-- user to use HTTPS at the type level. -- --- “High-level” means that there are less details to worry about. The --- library is a result of my experiences as a Haskell consultant. Working --- for several clients, who had very different projects, showed me that the --- library should adapt easily to any particular style of writing Haskell --- applications. For example, some people prefer throwing exceptions, while --- others are concerned with purity. Just define 'handleHttpException' --- accordingly when making your monad instance of 'MonadHttp' and it will --- play together seamlessly. Finally, the library cuts down boilerplate --- considerably, and helps you write concise, easy to read, and maintainable --- code. +-- “Expandable” refers to the ability to create new components without +-- having to resort to hacking. For example, it's possible to define your +-- own HTTP methods, create new ways to construct the body of a request, +-- create new authorization options, perform a request in a different way, +-- and create your own methods to parse a response. -- -- === Using with other libraries -- @@ -112,6 +81,7 @@ -- $making-a-request req, reqBr, + reqCb, req', withReqManager, @@ -149,6 +119,7 @@ useHttpsURI, useURI, urlQ, + renderUrl, -- ** Body -- $body @@ -173,11 +144,13 @@ -- $query-parameters (=:), queryFlag, + formToQuery, QueryParam (..), -- *** Headers header, attachHeader, + headerRedacted, -- *** Cookies -- $cookies @@ -224,56 +197,78 @@ -- * Other HttpException (..), + isStatusCodeException, CanHaveBody (..), Scheme (..), ) where -import qualified Blaze.ByteString.Builder as BB +import Blaze.ByteString.Builder qualified as BB import Control.Applicative import Control.Arrow (first, second) -import Control.Exception hiding (TypeError) +import Control.Exception hiding (Handler (..), TypeError) +import Control.Monad (guard, void, (>=>)) import Control.Monad.Base +import Control.Monad.Catch (Handler (..), MonadCatch, MonadMask, MonadThrow) import Control.Monad.IO.Class -import Control.Monad.Reader +import Control.Monad.IO.Unlift +import Control.Monad.Reader (ReaderT (ReaderT), ask, lift, runReaderT) +import Control.Monad.Trans.Accum (AccumT) +import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Control +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Identity (IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import Control.Monad.Trans.RWS.CPS qualified as RWS.CPS +import Control.Monad.Trans.RWS.Lazy qualified as RWS.Lazy +import Control.Monad.Trans.RWS.Strict qualified as RWS.Strict +import Control.Monad.Trans.Select (SelectT) +import Control.Monad.Trans.State.Lazy qualified as State.Lazy +import Control.Monad.Trans.State.Strict qualified as State.Strict +import Control.Monad.Trans.Writer.CPS qualified as Writer.CPS +import Control.Monad.Trans.Writer.Lazy qualified as Writer.Lazy +import Control.Monad.Trans.Writer.Strict qualified as Writer.Strict import Control.Retry import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.CaseInsensitive qualified as CI import Data.Data (Data) +import Data.Default.Class (def) import Data.Function (on) import Data.IORef import Data.Kind (Constraint, Type) import Data.List (foldl', nubBy) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Proxy -import Data.Semigroup hiding (Option, option) +import Data.Semigroup (Endo (..)) +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Typeable (Typeable, cast) import GHC.Generics import GHC.TypeLits -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Quote as TH -import qualified Language.Haskell.TH.Syntax as TH -import qualified Network.Connection as NC -import qualified Network.HTTP.Client as L -import qualified Network.HTTP.Client.Internal as LI -import qualified Network.HTTP.Client.MultipartFormData as LM -import qualified Network.HTTP.Client.TLS as L -import qualified Network.HTTP.Types as Y +import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Quote qualified as TH +import Language.Haskell.TH.Syntax qualified as TH +import Network.Connection qualified as NC +import Network.HTTP.Client qualified as L +import Network.HTTP.Client.Internal qualified as LI +import Network.HTTP.Client.MultipartFormData qualified as LM +import Network.HTTP.Client.TLS qualified as L +import Network.HTTP.Types qualified as Y import System.IO.Unsafe (unsafePerformIO) import Text.URI (URI) -import qualified Text.URI as URI -import qualified Text.URI.QQ as QQ -import qualified Web.Authenticate.OAuth as OAuth +import Text.URI qualified as URI +import Text.URI.QQ qualified as QQ +import Web.Authenticate.OAuth qualified as OAuth +import Web.FormUrlEncoded (FromForm (..), ToForm (..)) +import Web.FormUrlEncoded qualified as Form import Web.HttpApiData (ToHttpApiData (..)) ---------------------------------------------------------------------------- @@ -298,7 +293,7 @@ -- -- @body@ is a body option such as 'NoReqBody' or 'ReqBodyJson'. The -- tutorial has a section about HTTP bodies, but usage is very --- straightforward and should be clear from the examples below. +-- straightforward and should be clear from the examples. -- -- @response@ is a type hint how to make and interpret response of an HTTP -- request. Out-of-the-box it can be the following: @@ -426,12 +421,7 @@ -- | Response m response req method url body responseProxy options = - reqBr method url body (options <> extraOptions) getHttpResponse - where - extraOptions = - case acceptHeader responseProxy of - Nothing -> mempty - Just accept -> header "Accept" accept + reqCb method url body responseProxy options pure -- | A version of 'req' that does not use one of the predefined instances of -- 'HttpResponse' but instead allows the user to consume @'L.Response' @@ -456,7 +446,58 @@ (L.Response L.BodyReader -> IO a) -> -- | Result m a -reqBr method url body options consume = req' method url body options $ \request manager -> do +reqBr method url body options consume = + req' method url body options (reqHandler consume) + +-- | A version of 'req' that takes a callback to modify the 'L.Request', but +-- otherwise performs the request identically. +-- +-- @since 3.7.0 +reqCb :: + ( MonadHttp m, + HttpMethod method, + HttpBody body, + HttpResponse response, + HttpBodyAllowed (AllowsBody method) (ProvidesBody body) + ) => + -- | HTTP method + method -> + -- | 'Url'—location of resource + Url scheme -> + -- | Body of the request + body -> + -- | A hint how to interpret response + Proxy response -> + -- | Collection of optional parameters + Option scheme -> + -- | Callback to modify the request + (L.Request -> m L.Request) -> + -- | Response + m response +reqCb method url body responseProxy options adjustRequest = + req' method url body (options <> extraOptions) $ \request manager -> do + request' <- adjustRequest request + reqHandler getHttpResponse request' manager + where + extraOptions = + case acceptHeader responseProxy of + Nothing -> mempty + Just accept -> header "Accept" accept + +-- | The default handler function that the higher-level request functions +-- pass to 'req''. Internal function. +-- +-- @since 3.7.0 +reqHandler :: + (MonadHttp m) => + -- | How to get final result from a 'L.Response' + (L.Response L.BodyReader -> IO b) -> + -- | 'L.Request' to perform + L.Request -> + -- | 'L.Manager' to use + L.Manager -> + m b +reqHandler consume request manager = do HttpConfig {..} <- getHttpConfig let wrapVanilla = handle (throwIO . VanillaHttpException) wrapExc = handle (throwIO . LI.toHttpException request) @@ -472,12 +513,23 @@ r' <- L.responseOpen request manager writeIORef rref (Just r') return r' + exceptionRetryPolicies = + skipAsyncExceptions + ++ [ \retryStatus -> Handler $ \e -> + return $ httpConfigRetryJudgeException retryStatus e + ] r <- retrying httpConfigRetryPolicy - (\st r -> return $ httpConfigRetryJudge st r) - (const openResponse) - (preview, r') <- grabPreview bodyPreviewLength r + (\retryStatus r -> return $ httpConfigRetryJudge retryStatus r) + ( const + ( recovering + httpConfigRetryPolicy + exceptionRetryPolicies + (const openResponse) + ) + ) + (preview, r') <- grabPreview httpConfigBodyPreviewLength r mapM_ LI.throwHttp (httpConfigCheckResponse request r' preview) consume r' ) @@ -526,22 +578,22 @@ nubHeaders <> getRequestMod options <> getRequestMod config - <> getRequestMod (Womb body :: Womb "body" body) + <> getRequestMod (Tagged body :: Tagged "body" body) <> getRequestMod url - <> getRequestMod (Womb method :: Womb "method" method) + <> getRequestMod (Tagged method :: Tagged "method" method) request <- finalizeRequest options request' withReqManager (m request) -- | Perform an action using the global implicit 'L.Manager' that the rest -- of the library uses. This allows to reuse connections that the -- 'L.Manager' controls. -withReqManager :: MonadIO m => (L.Manager -> m a) -> m a +withReqManager :: (MonadIO m) => (L.Manager -> m a) -> m a withReqManager m = liftIO (readIORef globalManager) >>= m --- | Global 'L.Manager' that 'req' uses. Here we just go with the default --- settings, so users don't need to deal with this manager stuff at all, but --- when we create a request, instance 'HttpConfig' can affect the default --- settings via 'getHttpConfig'. +-- | The global 'L.Manager' that 'req' uses. Here we just go with the +-- default settings, so users don't need to deal with this manager stuff at +-- all, but when we create a request, instance 'HttpConfig' can affect the +-- default settings via 'getHttpConfig'. -- -- A note about safety, in case 'unsafePerformIO' looks suspicious to you. -- The value of 'globalManager' is named and lives on top level. This means @@ -555,7 +607,7 @@ let settings = L.mkManagerSettingsContext (Just context) - (NC.TLSSettingsSimple False False False) + def Nothing manager <- L.newManager settings newIORef manager @@ -572,13 +624,13 @@ -- When writing a library, keep your API polymorphic in terms of -- 'MonadHttp', only define instance of 'MonadHttp' in final application. -- Another option is to use a @newtype@-wrapped monad stack and define --- 'MonadHttp' for it. As of version /0.4.0/, the 'Req' monad that follows --- this strategy is provided out-of-the-box (see below). +-- 'MonadHttp' for it. As of the version /0.4.0/, the 'Req' monad that +-- follows this strategy is provided out-of-the-box (see below). -- | A type class for monads that support performing HTTP requests. -- Typically, you only need to define the 'handleHttpException' method -- unless you want to tweak 'HttpConfig'. -class MonadIO m => MonadHttp m where +class (MonadIO m) => MonadHttp m where -- | This method describes how to deal with 'HttpException' that was -- caught by the library. One option is to re-throw it if you are OK with -- exceptions, but if you prefer working with something like @@ -586,17 +638,16 @@ -- 'Control.Monad.Except.throwError'. handleHttpException :: HttpException -> m a - -- | Return 'HttpConfig' to be used when performing HTTP requests. Default - -- implementation returns its 'def' value, which is described in the - -- documentation for the type. Common usage pattern with manually defined - -- 'getHttpConfig' is to return some hard-coded value, or a value + -- | Return the 'HttpConfig' to be used when performing HTTP requests. + -- Default implementation returns its 'def' value, which is described in + -- the documentation for the type. Common usage pattern with manually + -- defined 'getHttpConfig' is to return some hard-coded value, or a value -- extracted from 'Control.Monad.Reader.MonadReader' if a more flexible -- approach to configuration is desirable. getHttpConfig :: m HttpConfig getHttpConfig = return defaultHttpConfig --- | 'HttpConfig' contains general and default settings to be used when --- making HTTP requests. +-- | 'HttpConfig' contains settings to be used when making HTTP requests. data HttpConfig = HttpConfig { -- | Proxy to use. By default values of @HTTP_PROXY@ and @HTTPS_PROXY@ -- environment variables are respected, this setting overwrites them. @@ -640,8 +691,8 @@ -- | The retry policy to use for request retrying. By default 'def' is -- used (see 'RetryPolicyM'). -- - -- __Note__: signature of this function was changed in the version - -- /1.0.0/. + -- __Note__: signature of this function was changed to disallow 'IO' in + -- version /1.0.0/ and then changed back to its current form in /3.1.0/. -- -- @since 0.3.0 httpConfigRetryPolicy :: RetryPolicyM IO, @@ -652,11 +703,22 @@ -- /1.0.0/. -- -- @since 0.3.0 - httpConfigRetryJudge :: forall b. RetryStatus -> L.Response b -> Bool + httpConfigRetryJudge :: forall b. RetryStatus -> L.Response b -> Bool, + -- | Similar to 'httpConfigRetryJudge', but is used to decide when to + -- retry requests that resulted in an exception. By default it retries + -- on response timeout and connection timeout (changed in version + -- /3.8.0/). + -- + -- @since 3.4.0 + httpConfigRetryJudgeException :: RetryStatus -> SomeException -> Bool, + -- | Max length of preview fragment of response body. + -- + -- @since 3.6.0 + httpConfigBodyPreviewLength :: forall a. (Num a) => a } deriving (Typeable) --- | Default value of 'HttpConfig'. +-- | The default value of 'HttpConfig'. -- -- @since 2.0.0 defaultHttpConfig :: HttpConfig @@ -678,7 +740,16 @@ 524, -- A timeout occurred 598, -- (Informal convention) Network read timeout error 599 -- (Informal convention) Network connect timeout error - ] + ], + httpConfigRetryJudgeException = \_ e -> + case fromException e of + Just (L.HttpExceptionRequest _ c) -> + case c of + L.ResponseTimeout -> True + L.ConnectionTimeout -> True + _ -> False + _ -> False, + httpConfigBodyPreviewLength = 1024 } where statusCode = Y.statusCode . L.responseStatus @@ -691,7 +762,7 @@ LI.requestManagerOverride = httpConfigAltManager } --- | A monad that allows to run 'req' in any 'IO'-enabled monad without +-- | A monad that allows us to run 'req' in any 'IO'-enabled monad without -- having to define new instances. -- -- @since 0.4.0 @@ -700,9 +771,19 @@ ( Functor, Applicative, Monad, - MonadIO + MonadIO, + MonadUnliftIO ) +-- | @since 3.7.0 +deriving instance MonadThrow Req + +-- | @since 3.7.0 +deriving instance MonadCatch Req + +-- | @since 3.7.0 +deriving instance MonadMask Req + instance MonadBase IO Req where liftBase = liftIO @@ -717,12 +798,87 @@ handleHttpException = Req . lift . throwIO getHttpConfig = Req ask +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (AccumT w m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (ContT r m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (ExceptT e m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (IdentityT m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (MaybeT m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (ReaderT r m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (RWS.CPS.RWST r w s m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (RWS.Lazy.RWST r w s m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (RWS.Strict.RWST r w s m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (SelectT r m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (State.Lazy.StateT s m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m) => MonadHttp (State.Strict.StateT s m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (Writer.CPS.WriterT w m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (Writer.Lazy.WriterT w m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + +-- | @since 3.10.0 +instance (MonadHttp m, Monoid w) => MonadHttp (Writer.Strict.WriterT w m) where + handleHttpException = lift . handleHttpException + getHttpConfig = lift getHttpConfig + -- | Run a computation in the 'Req' monad with the given 'HttpConfig'. In --- case of exceptional situation an 'HttpException' will be thrown. +-- the case of an exceptional situation an 'HttpException' will be thrown. -- -- @since 0.4.0 runReq :: - MonadIO m => + (MonadIO m) => -- | 'HttpConfig' to use HttpConfig -> -- | Computation to run @@ -770,14 +926,15 @@ type AllowsBody PUT = 'CanHaveBody httpMethodName Proxy = Y.methodPut --- | 'DELETE' method. This data type does not allow having request body with --- 'DELETE' requests, as it should be. However some APIs may expect 'DELETE' --- requests to have bodies, in that case define your own variation of --- 'DELETE' method and allow it to have a body. +-- | 'DELETE' method. RFC 7231 allows a payload in DELETE but without +-- semantics. +-- +-- __Note__: before version /3.4.0/ this method did not allow request +-- bodies. data DELETE = DELETE instance HttpMethod DELETE where - type AllowsBody DELETE = 'NoBody + type AllowsBody DELETE = 'CanHaveBody httpMethodName Proxy = Y.methodDelete -- | 'TRACE' method. @@ -826,7 +983,7 @@ -- | Return name of the method as a 'ByteString'. httpMethodName :: Proxy a -> ByteString -instance HttpMethod method => RequestComponent (Womb "method" method) where +instance (HttpMethod method) => RequestComponent (Tagged "method" method) where getRequestMod _ = Endo $ \x -> x {L.method = httpMethodName (Proxy :: Proxy method)} @@ -873,18 +1030,15 @@ type role Url nominal -- With template-haskell >=2.15 and text >=1.2.4 Lift can be derived, however --- the derived lift forgets the type of scheme. -instance Typeable scheme => TH.Lift (Url scheme) where +-- the derived lift forgets the type of the scheme. +instance (Typeable scheme) => TH.Lift (Url scheme) where lift url = TH.dataToExpQ (fmap liftText . cast) url `TH.sigE` case url of Url Http _ -> [t|Url 'Http|] Url Https _ -> [t|Url 'Https|] where liftText t = TH.AppE (TH.VarE 'T.pack) <$> TH.lift (T.unpack t) - -#if MIN_VERSION_template_haskell(2,16,0) - liftTyped url = TH.TExp <$> TH.lift url -#endif + liftTyped = TH.Code . TH.unsafeTExpCoerce . TH.lift -- | Given host name, produce a 'Url' which has “http” as its scheme and -- empty path. This also sets port to @80@. @@ -896,20 +1050,33 @@ https :: Text -> Url 'Https https = Url Https . pure --- | Grow given 'Url' appending a single path segment to it. Note that the +-- | Grow a given 'Url' appending a single path segment to it. Note that the -- path segment can be of any type that is an instance of 'ToHttpApiData'. infixl 5 /~ -(/~) :: ToHttpApiData a => Url scheme -> a -> Url scheme +(/~) :: (ToHttpApiData a) => Url scheme -> a -> Url scheme Url secure path /~ segment = Url secure (NE.cons (toUrlPiece segment) path) --- | Type-constrained version of @('/~')@ to remove ambiguity in the cases +-- | A type-constrained version of @('/~')@ to remove ambiguity in the cases -- when next URL piece is a 'Data.Text.Text' literal. infixl 5 /: (/:) :: Url scheme -> Text -> Url scheme (/:) = (/~) +-- | Render a 'Url' as 'Text'. +-- +-- @since 3.4.0 +renderUrl :: Url scheme -> Text +renderUrl = \case + Url Https parts -> + "https://" <> renderParts parts + Url Http parts -> + "http://" <> renderParts parts + where + renderParts parts = + T.intercalate "/" (reverse $ NE.toList parts) + -- | The 'useHttpURI' function provides an alternative method to get 'Url' -- (possibly with some 'Option's) from a 'URI'. This is useful when you are -- given a URL to query dynamically and don't know it beforehand. @@ -923,8 +1090,7 @@ urlHead <- http <$> uriHost uri let url = case URI.uriPath uri of Nothing -> urlHead - Just (_, xs) -> - foldl' (/:) urlHead (URI.unRText <$> NE.toList xs) + Just uriPath -> uriPathToUrl uriPath urlHead return (url, uriOptions uri) -- | Just like 'useHttpURI', but expects the “https” scheme. @@ -936,10 +1102,21 @@ urlHead <- https <$> uriHost uri let url = case URI.uriPath uri of Nothing -> urlHead - Just (_, xs) -> - foldl' (/:) urlHead (URI.unRText <$> NE.toList xs) + Just uriPath -> uriPathToUrl uriPath urlHead return (url, uriOptions uri) +-- | Convert URI path to a 'Url'. Internal. +-- +-- @since 3.9.0 +uriPathToUrl :: + (Bool, NonEmpty (URI.RText 'URI.PathPiece)) -> + Url scheme -> + Url scheme +uriPathToUrl (trailingSlash, xs) urlHead = + if trailingSlash then path /: T.empty else path + where + path = foldl' (/:) urlHead (URI.unRText <$> NE.toList xs) + -- | A combination of 'useHttpURI' and 'useHttpsURI' for cases when scheme -- is not known in advance. -- @@ -1056,21 +1233,21 @@ instance HttpBody NoReqBody where getRequestBody NoReqBody = L.RequestBodyBS B.empty --- | This body option allows to use a JSON object as request body—probably --- the most popular format right now. Just wrap a data type that is an --- instance of 'ToJSON' type class and you are done: it will be converted to --- JSON and inserted as request body. +-- | This body option allows us to use a JSON object as the request +-- body—probably the most popular format right now. Just wrap a data type +-- that is an instance of 'ToJSON' type class and you are done: it will be +-- converted to JSON and inserted as request body. -- -- This body option sets the @Content-Type@ header to @\"application/json; -- charset=utf-8\"@ value. newtype ReqBodyJson a = ReqBodyJson a -instance ToJSON a => HttpBody (ReqBodyJson a) where +instance (ToJSON a) => HttpBody (ReqBodyJson a) where getRequestBody (ReqBodyJson a) = L.RequestBodyLBS (A.encode a) getRequestContentType _ = pure "application/json; charset=utf-8" -- | This body option streams request body from a file. It is expected that --- the file size does not change during the streaming. +-- the file size does not change during streaming. -- -- Using of this body option does not set the @Content-Type@ header. newtype ReqBodyFile = ReqBodyFile FilePath @@ -1095,12 +1272,11 @@ instance HttpBody ReqBodyLbs where getRequestBody (ReqBodyLbs bs) = L.RequestBodyLBS bs --- | Form URL-encoded body. This can hold a collection of parameters which --- are encoded similarly to query parameters at the end of query string, --- with the only difference that they are stored in request body. The --- similarity is reflected in the API as well, as you can use the same --- combinators you would use to add query parameters: @('=:')@ and --- 'queryFlag'. +-- | URL-encoded body. This can hold a collection of parameters which are +-- encoded similarly to query parameters at the end of query string, with +-- the only difference that they are stored in request body. The similarity +-- is reflected in the API as well, as you can use the same combinators you +-- would use to add query parameters: @('=:')@ and 'queryFlag'. -- -- This body option sets the @Content-Type@ header to -- @\"application/x-www-form-urlencoded\"@ value. @@ -1119,7 +1295,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 @@ -1158,7 +1341,7 @@ -- | Create 'ReqBodyMultipart' request body from a collection of 'LM.Part's. -- -- @since 0.2.0 -reqBodyMultipart :: MonadIO m => [LM.Part] -> m ReqBodyMultipart +reqBodyMultipart :: (MonadIO m) => [LM.Part] -> m ReqBodyMultipart reqBodyMultipart parts = liftIO $ do boundary <- LM.webkitBoundary body <- LM.renderParts boundary parts @@ -1186,9 +1369,6 @@ -- | This type function allows any HTTP body if method says it -- 'CanHaveBody'. When the method says it should have 'NoBody', the only -- body option to use is 'NoReqBody'. --- --- __Note__: users of GHC 8.0.1 and later will see a slightly more friendly --- error message when method does not allow a body and body is provided. type family HttpBodyAllowed (allowsBody :: CanHaveBody) @@ -1201,8 +1381,8 @@ TypeError ('Text "This HTTP method does not allow attaching a request body.") -instance HttpBody body => RequestComponent (Womb "body" body) where - getRequestMod (Womb body) = Endo $ \x -> +instance (HttpBody body) => RequestComponent (Tagged "body" body) where + getRequestMod (Tagged body) = Endo $ \x -> x { L.requestBody = getRequestBody body, L.requestHeaders = @@ -1231,8 +1411,8 @@ = Option (Endo (Y.QueryText, L.Request)) (Maybe (L.Request -> IO L.Request)) -- NOTE 'QueryText' is just [(Text, Maybe Text)], we keep it along with --- Request to avoid appending to existing query string in request every --- time new parameter is added. Additional Maybe (L.Request -> IO +-- Request to avoid appending to an existing query string in request every +-- time new parameter is added. The additional Maybe (L.Request -> IO -- L.Request) is a finalizer that will be applied after all other -- transformations. This is for authentication methods that sign requests -- based on data in Request. @@ -1247,6 +1427,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 @@ -1265,7 +1451,7 @@ -- | Finalize given 'L.Request' by applying a finalizer from the given -- 'Option' (if it has any). -finalizeRequest :: MonadIO m => Option scheme -> L.Request -> m L.Request +finalizeRequest :: (MonadIO m) => Option scheme -> L.Request -> m L.Request finalizeRequest (Option _ mfinalizer) = liftIO . fromMaybe pure mfinalizer ---------------------------------------------------------------------------- @@ -1289,7 +1475,7 @@ (=:) :: (QueryParam param, ToHttpApiData a) => Text -> a -> param name =: value = queryParam name (pure value) --- | Construct a flag, that is, valueless query parameter. For example, in +-- | Construct a flag, that is, a valueless query parameter. For example, in -- the following URL @\"a\"@ is a flag, while @\"b\"@ is a query parameter -- with a value: -- @@ -1298,9 +1484,27 @@ -- This operator is defined in terms of 'queryParam': -- -- > queryFlag name = queryParam name (Nothing :: Maybe ()) -queryFlag :: QueryParam param => Text -> param +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. @@ -1310,11 +1514,17 @@ -- 'Nothing', it won't be included at all (i.e. you create a flag this -- way). It's recommended to use @('=:')@ and 'queryFlag' instead of this -- method, because they are easier to read. - queryParam :: ToHttpApiData a => Text -> Maybe a -> param + 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 @@ -1338,6 +1548,14 @@ attachHeader name value x = x {L.requestHeaders = (CI.mk name, value) : L.requestHeaders x} +-- | Same as 'header', but with redacted values on print. +-- +-- @since 3.13.0 +headerRedacted :: ByteString -> ByteString -> Option scheme +headerRedacted name value = withRequest $ \x -> + let y = attachHeader name value x + in y {L.redactHeaders = CI.mk name `S.insert` L.redactHeaders y} + ---------------------------------------------------------------------------- -- Request—Optional parameters—Cookies @@ -1479,7 +1697,7 @@ -- | Specify the port to connect to explicitly. Normally, 'Url' you use -- determines the default port: @80@ for HTTP and @443@ for HTTPS. This --- 'Option' allows to choose an arbitrary port overwriting the defaults. +-- 'Option' allows us to choose an arbitrary port overwriting the defaults. port :: Int -> Option scheme port n = withRequest $ \x -> x {L.port = n} @@ -1494,8 +1712,8 @@ -- -- > decompress (const True) decompress :: - -- | Predicate that is given MIME type, it - -- returns 'True' when content should be decompressed on the fly. + -- | Predicate that is given MIME type, it returns 'True' when content + -- should be decompressed on the fly. (ByteString -> Bool) -> Option scheme decompress f = withRequest $ \x -> @@ -1526,6 +1744,7 @@ -- | Make a request and ignore the body of the response. newtype IgnoreResponse = IgnoreResponse (L.Response ()) + deriving (Show) instance HttpResponse IgnoreResponse where type HttpResponseBody IgnoreResponse = () @@ -1542,8 +1761,9 @@ -- monad in which you use 'req' will determine what to do in the case when -- parsing fails (the 'JsonHttpException' constructor will be used). newtype JsonResponse a = JsonResponse (L.Response a) + deriving (Show) -instance FromJSON a => HttpResponse (JsonResponse a) where +instance (FromJSON a) => HttpResponse (JsonResponse a) where type HttpResponseBody (JsonResponse a) = a toVanillaResponse (JsonResponse r) = r getHttpResponse r = do @@ -1561,6 +1781,7 @@ -- | Make a request and interpret the body of the response as a strict -- 'ByteString'. newtype BsResponse = BsResponse (L.Response ByteString) + deriving (Show) instance HttpResponse BsResponse where type HttpResponseBody BsResponse = ByteString @@ -1577,6 +1798,7 @@ -- | Make a request and interpret the body of the response as a lazy -- 'BL.ByteString'. newtype LbsResponse = LbsResponse (L.Response BL.ByteString) + deriving (Show) instance HttpResponse LbsResponse where type HttpResponseBody LbsResponse = BL.ByteString @@ -1593,7 +1815,7 @@ ---------------------------------------------------------------------------- -- Helpers for response interpretations --- | Fetch beginning of response and return it together with new +-- | Fetch beginning of the response and return it together with a new -- @'L.Response' 'L.BodyReader'@ that can be passed to 'getHttpResponse' and -- such. grabPreview :: @@ -1657,14 +1879,14 @@ -- | Get the response body. responseBody :: - HttpResponse response => + (HttpResponse response) => response -> HttpResponseBody response responseBody = L.responseBody . toVanillaResponse -- | Get the response status code. responseStatusCode :: - HttpResponse response => + (HttpResponse response) => response -> Int responseStatusCode = @@ -1672,7 +1894,7 @@ -- | Get the response status message. responseStatusMessage :: - HttpResponse response => + (HttpResponse response) => response -> ByteString responseStatusMessage = @@ -1680,7 +1902,7 @@ -- | Lookup a particular header from a response. responseHeader :: - HttpResponse response => + (HttpResponse response) => -- | Response interpretation response -> -- | Header to lookup @@ -1692,7 +1914,7 @@ -- | Get the response 'L.CookieJar'. responseCookieJar :: - HttpResponse response => + (HttpResponse response) => response -> L.CookieJar responseCookieJar = L.responseCookieJar . toVanillaResponse @@ -1705,9 +1927,9 @@ -- To create a new response interpretation you just need to make your data -- type an instance of the 'HttpResponse' type class. --- | A type class for response interpretations. It allows to describe how to --- consume response from a @'L.Response' 'L.BodyReader'@ and produce the --- final result that is to be returned to the user. +-- | A type class for response interpretations. It allows us to describe how +-- to consume the response from a @'L.Response' 'L.BodyReader'@ and produce +-- the final result that is to be returned to the user. class HttpResponse response where -- | The associated type is the type of body that can be extracted from an -- instance of 'HttpResponse'. @@ -1746,6 +1968,16 @@ acceptHeader :: Proxy response -> Maybe ByteString acceptHeader Proxy = Nothing +-- | This instance has been added to make it easier to inspect 'L.Response' +-- using Req's functions like 'responseStatusCode', 'responseStatusMessage', +-- etc. +-- +-- @since 3.12.0 +instance HttpResponse (L.Response ()) where + type HttpResponseBody (L.Response ()) = () + toVanillaResponse = id + getHttpResponse = return . void + ---------------------------------------------------------------------------- -- Other @@ -1771,7 +2003,7 @@ -- method@ and @'HttpBody' body => 'RequestComponent' body@ when it decides -- which instance to use (i.e. the constraints are taken into account later, -- when instance is already chosen). -newtype Womb (tag :: Symbol) a = Womb a +newtype Tagged (tag :: Symbol) a = Tagged a -- | Exceptions that this library throws. data HttpException @@ -1784,6 +2016,20 @@ instance Exception HttpException +-- | Return 'Just' if the given 'HttpException' is wrapping a http-client's +-- 'L.StatusCodeException'. Otherwise, return 'Nothing'. +-- +-- @since 3.12.0 +isStatusCodeException :: HttpException -> Maybe (L.Response ()) +isStatusCodeException + ( VanillaHttpException + ( L.HttpExceptionRequest + _ + (L.StatusCodeException r _) + ) + ) = Just r +isStatusCodeException _ = Nothing + -- | A simple type isomorphic to 'Bool' that we only have for better error -- messages. We use it as a kind and its data constructors as type-level -- tags. @@ -1804,10 +2050,3 @@ | -- | HTTPS Https deriving (Eq, Ord, Show, Data, Typeable, Generic, TH.Lift) - ----------------------------------------------------------------------------- --- Constants - --- | Max length of preview fragment of response body. -bodyPreviewLength :: Num a => a -bodyPreviewLength = 1024 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,10 +4,8 @@ [![Hackage](https://img.shields.io/hackage/v/req.svg?style=flat)](https://hackage.haskell.org/package/req) [![Stackage Nightly](http://stackage.org/package/req/badge/nightly)](http://stackage.org/nightly/package/req) [![Stackage LTS](http://stackage.org/package/req/badge/lts)](http://stackage.org/lts/package/req) -[![Build Status](https://travis-ci.org/mrkkrp/req.svg?branch=master)](https://travis-ci.org/mrkkrp/req) +![CI](https://github.com/mrkkrp/req/workflows/CI/badge.svg?branch=master) -* [Motivation and Req vs other libraries](#motivation-and-req-vs-other-libraries) -* [Unsolved problems](#unsolved-problems) * [Related packages](#related-packages) * [Blog posts](#blog-posts) * [Contribution](#contribution) @@ -43,49 +41,33 @@ liftIO $ print (responseBody r :: Value) ``` -Req is an easy-to-use, type-safe, expandable, high-level HTTP client library -that just works without any fooling around. +Req is an HTTP client library that attempts to be easy-to-use, type-safe, +and expandable. -What does the phrase “easy-to-use” mean? It means that the library is -designed to be beginner-friendly so it's simple to add to your monad stack, -intuitive to work with, well-documented, and does not get in your way. Doing -HTTP requests is a common task and Haskell library for this should be very -approachable and clear to beginners, thus certain compromises were made. For -example, one cannot currently modify `ManagerSettings` of the default -manager because the library always uses the same implicit global manager for -simplicity and maximal connection sharing. There is a way to use your own -manager with different settings, but it requires a bit more typing. +“Easy-to-use” means that the library is designed to be beginner-friendly so +it's simple to add to your monad stack, intuitive to work with, +well-documented, and does not get in your way. Doing HTTP requests is a +common task and a Haskell library for this should be approachable and clear +to beginners, thus certain compromises were made. For example, one cannot +currently modify `ManagerSettings` of the default manager because the +library always uses the same implicit global manager for simplicity and +maximal connection sharing. There is a way to use your own manager with +different settings, but it requires more typing. -“Type-safe” means that the library is protective and eliminates certain -classes of errors. For example, we have correct-by-construction URLs, it's -guaranteed that the user does not send the request body when using methods -like GET or OPTIONS, and the amount of implicit assumptions is minimized by -making the user specify his/her intentions in an explicit form (for example, -it's not possible to avoid specifying the body or method of request). +“Type-safe” means that the library tries to eliminate certain classes of +errors. For example, we have correct-by-construction URLs; it is guaranteed +that the user does not send the request body when using methods like GET or +OPTIONS, and the amount of implicit assumptions is minimized by making the +user specify their intentions in an explicit form. For example, it's not +possible to avoid specifying the body or the method of a request. Authentication methods that assume HTTPS force the user to use HTTPS at the -type level. The library also carefully hides underlying types from the -lower-level `http-client` package because those types are not safe enough -(for example `Request` is an instance of `IsString` and, if it's malformed, -it will blow up at run-time). - -“Expandable” refers to the ability to create new components for dealing with -HTTP without having to resort to ugly hacking. For example, it's possible to -define your own HTTP methods, create new ways to construct the body of a -request, create new authorization options, perform a request in a different -way, and create your own methods to parse and represent a response. As the -user extends the library to satisfy his/her special needs, the new solutions -will work just like the built-ins. However, all of the common cases are also -covered by the library out-of-the-box. +type level. -“High-level” means that there are less details to worry about. The library -is a result of my experiences as a Haskell consultant. Working for several -clients, who had very different projects, showed me that the library should -adapt easily to any particular style of writing Haskell applications. For -example, some people prefer throwing exceptions, while others are concerned -with purity. Just define `handleHttpException` accordingly when making your -monad instance of `MonadHttp` and it will play together seamlessly. Finally, -the library cuts down boilerplate considerably, and helps you write concise, -easy to read, and maintainable code. +“Expandable” refers to the ability to create new components without having +to resort to hacking. For example, it's possible to define your own HTTP +methods, create new ways to construct the body of a request, create new +authorization options, perform a request in a different way, and create your +own methods to parse a response. The library uses the following mature packages under the hood to guarantee you the best experience: @@ -95,88 +77,10 @@ * [`http-client-tls`](https://hackage.haskell.org/package/http-client-tls)—TLS (HTTPS) support for `http-client`. -It's important to note that since we leverage well-known libraries that the +It is important to note that since we leverage well-known libraries that the whole Haskell ecosystem uses, there is no risk in using Req. The machinery for performing requests is the same as with `http-conduit` and Wreq. The only difference is the API. - -## Motivation and Req vs other libraries - -*This section is my opinion and it contains criticisms of other well-known -libraries. If you're a user/fan of one of these libraries, please remember -not to react aggressively and respect the fact that I may have different -views on API design from yours.* - -I have spent time to write the library because sending HTTP requests is a -common need, but there is no high-level library for that in Haskell that I -could use with pleasure. I'll explain why. - -First of all, there is `http-client` and `http-client-tls`. They just work. -I have no issues with the libraries except that they are too low-level for -my taste. Indeed, even the docs say that they are low-level and “intended as -a base layer for more user-friendly packages”. This is exactly how I use -them in Req, as base level. Req is nothing but a different API to -`http-client`, so it only works because of the hard work put into -`http-client`. - -`http-conduit` definitely has its place. For one thing it allows you to -stream request and response bodies in constant memory, what other library -allows you to do that? On the other hand if you take a look at -`Network.HTTP.Simple`, then although it's said that it's a “higher level -API”, it's mostly the same as vanilla `http-client` in spirit/approach and -just adds `conduit`-powered functions to perform requests and allows to use -global implicit `Manager` (Req does the same). If I tried to frame what -exactly I don't like about `http-conduit` in words, then it would be “the -way requests are constructed”. You *set* parameters instead of *being -forced* to declare necessary bits and *being allowed* to declare optional -bits in a way that their combination is valid. Also, with `http-conduit` you -parse request from a string without the protection of TH that otherwise -saves the day as in Yesod. - -Then there is Wreq. `wreq` [doesn't see much development -lately](https://github.com/bos/wreq/issues/93). `wreq` is by itself a weird -library, IMO. You have functions per method—not very good, as there may be -new methods, like PATCH which is not new but still missing (well, you have -`customMethod`, but what is the point of having per-method functions if you -have a more general way to use any method? you should be able to just insert -methods in the “argument slot” of `customMethod` and end up with a more -general solution). Now, every method function has a companion that takes -`Options` (like you have `get` and `getWith`). Why the duplication? Where is -generality and flexibility? This is not all though, because you cannot -really use `get` you see in the main module, because you want to have -connection sharing. Wreq's author does not take the gift of automatic -connection re-use `Manager` from `http-client` provides, he invents the -whole new thing of “sessions”. Only inside a session your connections will -be shared and re-used. However with the session stuff you have yet another -set of per-method functions like `get` and `getWith`—these are different -ones, to be used with sessions! Now if you have a multi-threaded app, here -is a surprise for you: you can't share connections between threads as -connections are shared only inside of the `withSession` friend and “session -will no longer be valid after that function returns”. There are valid uses -for sessions, but the point is that they are just too inconvenient for -common tasks. - -I used `servant-client` a couple of times but the amount of boilerplate it -requires is frightening. If you have several query parameters, and you use -just one of them, you'll have to pass lots of `Nothing`s. - -## Unsolved problems - -AWS request signing is problematic because request body can be in the form -of an action to execute (and all that “popper” stuff for streaming), not -just a `ByteString` and so getting its digest (hash) is not trivial without -running the action and consuming body in its entirety before the request in -made. In Wreq the author chose to just use `error` when body is not a -(strict or lazy) `ByteString`. Maybe it's OK for Wreq, but I don't consider -this a proper solution for Req as we support full variety of body options. -For example, what if I want to upload 1 Gb file to S3? I want to stream it -in constant memory but at the same time I need to calculate its hash before -I start streaming. One solution to the problem seems to be in taking the -hash explicitly (as an argument of the hypothetical `awsAuth`) and making it -a responsibility of the user to calculate the hash correctly. I don't like -this because it's not user-friendly. So the question stays open, for now -there is no AWS signing functionality provided out-of-the-box. The best -solution for talking to AWS is the `amazonka` package so far. ## Related packages diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain 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 @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -8,53 +8,55 @@ module Network.HTTP.ReqSpec (spec) where import Control.Exception -import Control.Monad.Reader +import Control.Monad (forM_) import Control.Monad.Trans.Control -import Data.Aeson ((.=), ToJSON (..), Value (..), object) -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HM +import Data.Aeson (ToJSON (..), Value (..), object, (.=)) +import Data.Aeson qualified as A +import Data.Aeson.KeyMap qualified as Aeson.KeyMap +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.Functor.Identity (runIdentity) +import Data.Maybe (fromJust) import Data.Proxy import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as TIO -import qualified Network.HTTP.Client as L -import qualified Network.HTTP.Client.MultipartFormData as LM -import Network.HTTP.Req -import qualified Network.HTTP.Types as Y +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.IO qualified as TIO +import Network.HTTP.Client qualified as L +import Network.HTTP.Client.MultipartFormData qualified as LM +import Network.HTTP.Req hiding (req) +import Network.HTTP.Req qualified as Req +import Network.HTTP.Types qualified as Y import Test.Hspec import Test.QuickCheck -#if !MIN_VERSION_base(4,13,0) -import Data.Semigroup ((<>)) -#endif - spec :: Spec spec = do - describe "exception throwing on non-2xx status codes" - $ it "throws indeed for non-2xx" - $ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty - `shouldThrow` selector404 - - describe "exception throwing on non-2xx status codes (Req monad)" - $ it "throws indeed for non-2xx" - $ asIO . runReq defaultHttpConfig - $ liftBaseWith - $ \run -> - run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty) + describe "exception throwing on non-2xx status codes" $ + it "throws indeed for non-2xx" $ + req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty `shouldThrow` selector404 - describe "response check via httpConfigCheckResponse" - $ context "if it's set to always throw" - $ it "throws indeed" - $ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty) - `shouldThrow` anyException + describe "exception throwing on non-2xx status codes (Req monad)" $ + it "throws indeed for non-2xx" $ + asIO . runReq defaultHttpConfig $ + liftBaseWith $ \run -> + run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty) + `shouldThrow` selector404 - describe "receiving user-agent header back" - $ it "works" - $ do + describe "response check via httpConfigCheckResponse" $ + context "if it's set to always throw" $ + it "throws indeed" $ + blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty) + `shouldThrow` anyException + + describe "isStatusCodeException" $ + it "extracts non-2xx response" $ + req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty + `shouldThrow` selector404ByStatusCodeException + + describe "receiving user-agent header back" $ + it "works" $ do r <- req GET @@ -68,9 +70,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving request headers back" - $ it "works" - $ do + describe "receiving request headers back" $ + it "works" $ do r <- req GET @@ -84,34 +85,30 @@ .= object [ "Accept-Encoding" .= ("gzip" :: Text), "Foo" .= ("bar" :: Text), - "Baz" .= ("quux" :: Text), - "Host" .= ("httpbin.org" :: Text) + "Baz" .= ("quux" :: Text) ] ] responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving GET data back" - $ it "works" - $ do + describe "receiving GET data back" $ + it "works" $ do r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object [ "args" .= emptyObject, - "url" .= ("https://httpbin.org/get" :: Text), + "url" .= ("http://localhost:1234/get" :: Text), "headers" .= object - [ "Accept-Encoding" .= ("gzip" :: Text), - "Host" .= ("httpbin.org" :: Text) + [ "Accept-Encoding" .= ("gzip" :: Text) ] ] responseHeader r "Content-Type" `shouldBe` return "application/json" responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving POST JSON data back" - $ it "works" - $ do + describe "receiving POST JSON data back" $ + it "works" $ do let text = "foo" :: Text reflected = reflectJSON text r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty @@ -120,12 +117,11 @@ [ "args" .= emptyObject, "json" .= text, "data" .= reflected, - "url" .= ("https://httpbin.org/post" :: Text), + "url" .= ("http://localhost:1234/post" :: Text), "headers" .= object [ "Content-Type" .= ("application/json; charset=utf-8" :: Text), "Accept-Encoding" .= ("gzip" :: Text), - "Host" .= ("httpbin.org" :: Text), "Content-Length" .= show (T.length reflected) ], "files" .= emptyObject, @@ -135,27 +131,25 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving POST data back (multipart form data)" - $ it "works" - $ do + describe "receiving POST data back (multipart form data)" $ + it "works" $ do body <- reqBodyMultipart [ LM.partBS "foo" "foo data!", 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, "json" .= Null, "data" .= ("" :: Text), - "url" .= ("https://httpbin.org/post" :: Text), + "url" .= ("http://localhost:1234/post" :: Text), "headers" .= object [ "Content-Type" .= T.decodeUtf8 contentType, "Accept-Encoding" .= ("gzip" :: Text), - "Host" .= ("httpbin.org" :: Text), "Content-Length" .= ("242" :: Text) ], "files" .= emptyObject, @@ -169,9 +163,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving PATCHed file back" - $ it "works" - $ do + describe "receiving PATCHed file back" $ + it "works" $ do let file :: FilePath file = "httpbin-data/robots.txt" contents <- TIO.readFile file @@ -181,11 +174,10 @@ [ "args" .= emptyObject, "json" .= Null, "data" .= contents, - "url" .= ("https://httpbin.org/patch" :: Text), + "url" .= ("http://localhost:1234/patch" :: Text), "headers" .= object [ "Accept-Encoding" .= ("gzip" :: Text), - "Host" .= ("httpbin.org" :: Text), "Content-Length" .= show (T.length contents) ], "files" .= emptyObject, @@ -195,9 +187,8 @@ responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - describe "receiving PUT form URL-encoded data back" - $ it "works" - $ do + describe "receiving PUT form URL-encoded data back" $ + it "works" $ do let params = "foo" =: ("bar" :: Text) <> "baz" =: (5 :: Int) @@ -208,12 +199,11 @@ [ "args" .= emptyObject, "json" .= Null, "data" .= ("" :: Text), - "url" .= ("https://httpbin.org/put" :: Text), + "url" .= ("http://localhost:1234/put" :: Text), "headers" .= object [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text), "Accept-Encoding" .= ("gzip" :: Text), - "Host" .= ("httpbin.org" :: Text), "Content-Length" .= ("18" :: Text) ], "files" .= emptyObject, @@ -230,9 +220,8 @@ -- TODO /delete - describe "receiving UTF-8 encoded Unicode data" - $ it "works" - $ do + describe "receiving UTF-8 encoded Unicode data" $ + it "works" $ do r <- req GET @@ -248,9 +237,8 @@ -- TODO /gzip -- TODO /deflate - describe "retrying" - $ it "retries as many times as specified" - $ do + describe "retrying" $ + it "retries as many times as specified" $ do -- FIXME We no longer can count retries because all the functions -- responsible for controlling retrying are pure now. let status = 408 :: Int @@ -273,9 +261,8 @@ -- TODO /response-headers -- TODO /redirect - describe "redirects" - $ it "follows redirects" - $ do + describe "redirects" $ + it "follows redirects" $ do r <- req GET @@ -294,9 +281,8 @@ let user, password :: Text user = "Scooby" password = "Doo" - context "when we do not send appropriate basic auth data" - $ it "fails with 401" - $ do + context "when we do not send appropriate basic auth data" $ + it "fails with 401" $ do r <- prepareForShit $ req @@ -307,16 +293,15 @@ mempty responseStatusCode r `shouldBe` 401 responseStatusMessage r `shouldBe` "UNAUTHORIZED" - context "when we provide appropriate basic auth data" - $ it "succeeds" - $ do + context "when we provide appropriate basic auth data" $ + it "succeeds" $ do r <- req GET (httpbin /: "basic-auth" /~ user /~ password) NoReqBody ignoreResponse - (basicAuth (T.encodeUtf8 user) (T.encodeUtf8 password)) + (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password)) responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" @@ -328,9 +313,8 @@ -- TODO /range -- TODO /html - describe "robots.txt" - $ it "works" - $ do + describe "robots.txt" $ + it "works" $ do r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty robots <- B.readFile "httpbin-data/robots.txt" responseBody r `shouldBe` robots @@ -341,9 +325,8 @@ -- TODO /cache describe "getting random bytes" $ do - it "works" - $ property - $ \n' -> do + it "works" $ + property $ \n' -> do let n :: Word n = getSmall n' r <- @@ -356,9 +339,8 @@ responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length) responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - context "when we try to interpret 1000 random bytes as JSON" - $ it "throws correct exception" - $ do + context "when we try to interpret 1000 random bytes as JSON" $ + it "throws correct exception" $ do let selector :: HttpException -> Bool selector (JsonHttpException _) = True selector _ = False @@ -372,22 +354,21 @@ mempty `shouldThrow` selector - describe "streaming random bytes" - $ it "works" - $ property - $ \n' -> do - let n :: Word - n = getSmall n' - r <- - req - GET - (httpbin /: "stream-bytes" /~ n) - NoReqBody - bsResponse - mempty - responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length) - responseStatusCode r `shouldBe` 200 - responseStatusMessage r `shouldBe` "OK" + describe "streaming random bytes" $ + it "works" $ + property $ \n' -> do + let n :: Word + n = getSmall n' + r <- + req + GET + (httpbin /: "stream-bytes" /~ n) + NoReqBody + bsResponse + mempty + responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length) + responseStatusCode r `shouldBe` 200 + responseStatusMessage r `shouldBe` "OK" -- TODO /links -- TODO /image @@ -407,52 +388,87 @@ ---------------------------------------------------------------------------- -- Helpers --- | Run request with such settings that it does not signal error on adverse --- response status codes. +-- | Run a request with such settings that it does not signal errors. prepareForShit :: Req a -> IO a prepareForShit = runReq defaultHttpConfig {httpConfigCheckResponse = noNoise} where noNoise _ _ _ = Nothing --- | Run request with such settings that it throws on any response. +-- | Run a request with such settings that it throws on any response. blindlyThrowing :: Req a -> IO a blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit} where doit _ _ = error "Oops!" -- | 'Url' representing . -httpbin :: Url 'Https -httpbin = https "httpbin.org" +httpbin :: Url 'Http +httpbin = http "localhost" +req :: + ( MonadHttp m, + HttpMethod method, + HttpBody body, + HttpResponse response, + HttpBodyAllowed (AllowsBody method) (ProvidesBody body) + ) => + method -> + Url scheme -> + body -> + Proxy response -> + Option scheme -> + m response +req method url body responseProxy options = + Req.req method url body responseProxy (options <> defaultOptions) + +-- | Options to apply by default. +defaultOptions :: Option scheme +defaultOptions = port 1234 + -- | Remove “origin” field from JSON value. Origin may change, we don't want -- to depend on that. stripOrigin :: Value -> Value -stripOrigin (Object m) = Object (HM.delete "origin" m) +stripOrigin (Object m) = Object (Aeson.KeyMap.delete "origin" m) stripOrigin value = value -- | Remove funny headers that might break the tests. stripFunnyHeaders :: Value -> Value -stripFunnyHeaders (Object m) = - let f (Object p) = Object $ HM.filterWithKey (\k _ -> k `elem` hs) p - f value = value - hs = - [ "Content-Type", - "Accept-Encoding", - "Host", - "Content-Length", - "Foo", - "Baz" - ] - in Object (HM.adjust f "headers" m) -stripFunnyHeaders value = value +stripFunnyHeaders = \case + Object m -> + Object + ( runIdentity + ( Aeson.KeyMap.alterF + (pure . fmap stripFunnyHeaders') + "headers" + m + ) + ) + value -> value +-- | Similar to 'stripFunnyHeaders', but acts directly on the argument +-- without trying to access its "headers" field. +stripFunnyHeaders' :: Value -> Value +stripFunnyHeaders' = \case + Object p -> + Object $ + Aeson.KeyMap.filterWithKey + (\k _ -> k `elem` whitelistedHeaders) + p + value -> value + where + whitelistedHeaders = + [ "Content-Type", + "Accept-Encoding", + "Content-Length", + "Foo", + "Baz" + ] + -- | This is a complete test case that makes use of to -- get various response status codes. checkStatusCode :: Int -> SpecWith () checkStatusCode code = - describe ("receiving status code " ++ show code) - $ it "works" - $ do + describe ("receiving status code " ++ show code) $ + it "works" $ do r <- prepareForShit $ req @@ -475,12 +491,19 @@ L.responseStatus response == Y.status404 && not (B.null chunk) selector404 _ = False --- | Empty JSON 'Object'. +-- | Same as 'selector404' except that it uses 'isStatusCodeException'. +selector404ByStatusCodeException :: HttpException -> Bool +selector404ByStatusCodeException e = + case isStatusCodeException e of + Nothing -> False + Just r -> responseStatusCode r == 404 + +-- | The empty JSON 'Object'. emptyObject :: Value -emptyObject = Object HM.empty +emptyObject = Object Aeson.KeyMap.empty --- | Get rendered JSON value as 'Text'. -reflectJSON :: ToJSON a => a -> Text +-- | Get a rendered JSON value as 'Text'. +reflectJSON :: (ToJSON a) => a -> Text reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode -- | Clarify to the type checker that the inner computation is in the 'IO' 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,53 +13,50 @@ module Network.HTTP.ReqSpec (spec) where -import qualified Blaze.ByteString.Builder as BB +import Blaze.ByteString.Builder qualified as BB import Control.Exception (throwIO) import Control.Monad import Control.Retry import Data.Aeson (ToJSON (..)) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy qualified as BL +import Data.CaseInsensitive qualified as CI import Data.Either (isRight) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.Proxy import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified 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 -import qualified Network.HTTP.Client as L +import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Quote qualified as TH +import Network.HTTP.Client qualified as L import Network.HTTP.Req -import qualified Network.HTTP.Types as Y -import qualified Network.HTTP.Types.Header as Y +import Network.HTTP.Types qualified as Y +import Network.HTTP.Types.Header qualified as Y import Test.Hspec import Test.Hspec.Core.Spec (SpecM) import Test.QuickCheck import Text.URI (URI) -import qualified Text.URI as URI -import qualified Text.URI.QQ as QQ - -#if !MIN_VERSION_base(4,13,0) -import Data.Semigroup ((<>)) -#endif +import Text.URI qualified as URI +import Text.URI.QQ qualified as QQ +import Web.FormUrlEncoded qualified as F spec :: Spec spec = do - describe "config" - $ it "getHttpConfig has effect on resulting request" - $ property - $ \config -> do - request <- runReq config (req_ GET url NoReqBody mempty) - L.proxy request `shouldBe` httpConfigProxy config - L.redirectCount request `shouldBe` httpConfigRedirectCount config + describe "config" $ + it "getHttpConfig has effect on resulting request" $ + property $ \config -> do + request <- runReq config (req_ GET url NoReqBody mempty) + L.proxy request `shouldBe` httpConfigProxy config + L.redirectCount request `shouldBe` httpConfigRedirectCount config describe "methods" $ do let mnth :: @@ -72,9 +68,8 @@ SpecM () () mnth method = do let name = httpMethodName (Proxy :: Proxy method) - describe (B8.unpack name) - $ it "affects name of HTTP method" - $ do + describe (B8.unpack name) $ + it "affects name of HTTP method" $ do request <- req_ method url NoReqBody mempty L.method request `shouldBe` name mnth GET @@ -88,48 +83,42 @@ mnth PATCH describe "urls" $ do - describe "http" - $ it "sets all the params correctly" - $ property - $ \host -> do - request <- req_ GET (http host) NoReqBody mempty - L.secure request `shouldBe` False - L.port request `shouldBe` 80 - L.host request `shouldBe` urlEncode host - describe "https" - $ it "sets all the params correctly" - $ property - $ \host -> do - request <- req_ GET (https host) NoReqBody mempty - L.secure request `shouldBe` True - L.port request `shouldBe` 443 - L.host request `shouldBe` urlEncode host - describe "(/~)" - $ it "attaches a path piece that is URL-encoded" - $ property - $ \host pieces -> do - let url' = foldl (/~) (https host) pieces - request <- req_ GET url' NoReqBody mempty - L.host request `shouldBe` urlEncode host - L.path request `shouldBe` encodePathPieces pieces - describe "(/:)" - $ it "attaches a path piece that is URL-encoded" - $ property - $ \host pieces -> do - let url' = foldl (/:) (https host) pieces - request <- req_ GET url' NoReqBody mempty - L.host request `shouldBe` urlEncode host - L.path request `shouldBe` encodePathPieces pieces + describe "http" $ + it "sets all the params correctly" $ + property $ \host -> do + request <- req_ GET (http host) NoReqBody mempty + L.secure request `shouldBe` False + L.port request `shouldBe` 80 + L.host request `shouldBe` urlEncode host + describe "https" $ + it "sets all the params correctly" $ + property $ \host -> do + request <- req_ GET (https host) NoReqBody mempty + L.secure request `shouldBe` True + L.port request `shouldBe` 443 + L.host request `shouldBe` urlEncode host + describe "(/~)" $ + it "attaches a path piece that is URL-encoded" $ + property $ \host pieces -> do + let url' = foldl (/~) (https host) pieces + request <- req_ GET url' NoReqBody mempty + L.host request `shouldBe` urlEncode host + L.path request `shouldBe` encodePathPieces pieces + describe "(/:)" $ + it "attaches a path piece that is URL-encoded" $ + property $ \host pieces -> do + let url' = foldl (/:) (https host) pieces + request <- req_ GET url' NoReqBody mempty + L.host request `shouldBe` urlEncode host + L.path request `shouldBe` encodePathPieces pieces describe "useHttpURI" $ do - it "does not recognize non-http schemes" - $ property - $ \uri -> + it "does not recognize non-http schemes" $ + property $ \uri -> when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $ useHttpURI uri `shouldSatisfy` isNothing - it "accepts correct URLs" - $ property - $ \uri' -> do + it "accepts correct URLs" $ + property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard let uri = uri' {URI.uriScheme = Just [QQ.scheme|http|]} (url', options) = fromJust (useHttpURI uri) @@ -141,14 +130,12 @@ lookup "Authorization" (L.requestHeaders request) `shouldBe` uriBasicAuth uri describe "useHttpsURI" $ do - it "does not recognize non-https schemes" - $ property - $ \uri -> + it "does not recognize non-https schemes" $ + property $ \uri -> when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $ useHttpsURI uri `shouldSatisfy` isNothing - it "parses correct URLs" - $ property - $ \uri' -> do + it "parses correct URLs" $ + property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard let uri = uri' {URI.uriScheme = Just [QQ.scheme|https|]} (url', options) = fromJust (useHttpsURI uri) @@ -160,27 +147,27 @@ lookup "Authorization" (L.requestHeaders request) `shouldBe` uriBasicAuth uri describe "useURI" $ do - it "does not recognize non-http and non-https schemes" - $ property - $ \uri -> + it "does not recognize non-http and non-https schemes" $ + property $ \uri -> when ( ( URI.uriScheme uri /= Just [QQ.scheme|http|] && (URI.uriScheme uri /= Just [QQ.scheme|https|]) ) ) $ useURI uri `shouldSatisfy` isNothing - it "parses correct URLs" - $ property - $ \uri' -> do + it "parses correct URLs" $ + property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard 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 @@ -194,57 +181,83 @@ lookup "Authorization" (L.requestHeaders requestHttps) `shouldBe` uriBasicAuth uriHttps + describe "renderUrl" $ do + context "http" $ do + context "empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|http://httpbin.org|] + renderUrl uriHttp `shouldBe` "http://httpbin.org" + context "non-empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|http://httpbin.org/here/we/go|] + renderUrl uriHttp `shouldBe` "http://httpbin.org/here/we/go" + context "http" $ do + context "empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|https://httpbin.org|] + renderUrl uriHttp `shouldBe` "https://httpbin.org" + context "non-empty path" $ + it "renders correctly" $ do + let (uriHttp, _) = [urlQ|https://httpbin.org/here/we/go|] + renderUrl uriHttp `shouldBe` "https://httpbin.org/here/we/go" + describe "bodies" $ do - describe "NoReqBody" - $ it "sets body to empty byte string" - $ do + describe "NoReqBody" $ + it "sets body to empty byte string" $ do request <- req_ POST url NoReqBody mempty case L.requestBody request of L.RequestBodyBS x -> x `shouldBe` B.empty _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyJson" - $ it "sets body to correct lazy byte string" - $ property - $ \thing -> do - request <- req_ POST url (ReqBodyJson thing) mempty - case L.requestBody request of - L.RequestBodyLBS x -> x `shouldBe` A.encode (thing :: Thing) - _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyBs" - $ it "sets body to specified strict byte string" - $ property - $ \bs -> do - request <- req_ POST url (ReqBodyBs bs) mempty - case L.requestBody request of - L.RequestBodyBS x -> x `shouldBe` bs - _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyLbs" - $ it "sets body to specified lazy byte string" - $ property - $ \lbs -> do - request <- req_ POST url (ReqBodyLbs lbs) mempty - case L.requestBody request of - L.RequestBodyLBS x -> x `shouldBe` lbs - _ -> expectationFailure "Wrong request body constructor." - describe "ReqBodyUrlEnc" - $ it "sets body to correct lazy byte string" - $ property - $ \params -> do - request <- req_ POST url (ReqBodyUrlEnc (formUrlEnc params)) mempty - case L.requestBody request of - L.RequestBodyLBS x -> x `shouldBe` renderQuery params - _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyJson" $ + it "sets body to correct lazy byte string" $ + property $ \thing -> do + request <- req_ POST url (ReqBodyJson thing) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` A.encode (thing :: Thing) + _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyBs" $ + it "sets body to specified strict byte string" $ + property $ \bs -> do + request <- req_ POST url (ReqBodyBs bs) mempty + case L.requestBody request of + L.RequestBodyBS x -> x `shouldBe` bs + _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyLbs" $ + it "sets body to specified lazy byte string" $ + property $ \lbs -> do + request <- req_ POST url (ReqBodyLbs lbs) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` lbs + _ -> expectationFailure "Wrong request body constructor." + describe "ReqBodyUrlEnc" $ + it "sets body to correct lazy byte string" $ + property $ \params -> do + request <- req_ POST url (ReqBodyUrlEnc (formUrlEnc params)) mempty + case L.requestBody request of + 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" - $ property - $ \name value -> do + it "sets specified header value" $ + property $ \name value -> do request <- req_ GET url NoReqBody (header name value) lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value - it "left header wins" - $ property - $ \name value0 value1 -> do + it "left header wins" $ + property $ \name value0 value1 -> do request <- req_ GET @@ -252,9 +265,8 @@ NoReqBody (header name value0 <> header name value1) lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value0 - it "overwrites headers set by other parts of the lib" - $ property - $ \value -> do + it "overwrites headers set by other parts of the lib" $ + property $ \value -> do request <- req_ POST @@ -262,26 +274,19 @@ (ReqBodyUrlEnc mempty) (header "Content-Type" value) lookup "Content-Type" (L.requestHeaders request) `shouldBe` pure value - describe "cookieJar" - $ it "cookie jar is set without modifications" - $ property - $ \cjar -> do - request <- req_ GET url NoReqBody (cookieJar cjar) -#if MIN_VERSION_http_client(0,7,0) - L.cookieJar request `shouldSatisfy` (maybe False (L.equalCookieJar cjar)) -#else - L.cookieJar request `shouldBe` Just cjar -#endif + describe "cookieJar" $ + it "cookie jar is set without modifications" $ + property $ \cjar -> do + request <- req_ GET url NoReqBody (cookieJar cjar) + L.cookieJar request `shouldSatisfy` (maybe False (L.equalCookieJar cjar)) describe "basicAuth" $ do - it "sets Authorization header to correct value" - $ property - $ \username password -> do + it "sets Authorization header to correct value" $ + property $ \username password -> do request <- req_ GET url NoReqBody (basicAuth username password) lookup "Authorization" (L.requestHeaders request) `shouldBe` Just (basicAuthHeader username password) - it "overwrites manual setting of header" - $ property - $ \username password value -> do + it "overwrites manual setting of header" $ + property $ \username password value -> do request0 <- req_ GET @@ -297,9 +302,8 @@ let result = Just (basicAuthHeader username password) lookup "Authorization" (L.requestHeaders request0) `shouldBe` result lookup "Authorization" (L.requestHeaders request1) `shouldBe` result - it "left auth option wins" - $ property - $ \username0 password0 username1 password1 -> do + it "left auth option wins" $ + property $ \username0 password0 username1 password1 -> do request <- req_ GET @@ -309,15 +313,13 @@ lookup "Authorization" (L.requestHeaders request) `shouldBe` Just (basicAuthHeader username0 password0) describe "oAuth2Bearer" $ do - it "sets Authorization header to correct value" - $ property - $ \token -> do + it "sets Authorization header to correct value" $ + property $ \token -> do request <- req_ GET url NoReqBody (oAuth2Bearer token) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("Bearer " <> token) - it "overwrites manual setting of header" - $ property - $ \token value -> do + it "overwrites manual setting of header" $ + property $ \token value -> do request0 <- req_ GET @@ -335,9 +337,8 @@ `shouldBe` pure result lookup "Authorization" (L.requestHeaders request1) `shouldBe` pure result - it "left auth option wins" - $ property - $ \token0 token1 -> do + it "left auth option wins" $ + property $ \token0 token1 -> do request <- req_ GET @@ -346,23 +347,20 @@ (oAuth2Bearer token0 <> oAuth2Bearer token1) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("Bearer " <> token0) - describe "ProxyAuthorization" - $ it "sets Authorization header to correct value" - $ property - $ \username password -> do - request <- req_ GET url NoReqBody (basicProxyAuth username password) - lookup "Proxy-Authorization" (L.requestHeaders request) - `shouldBe` pure (basicProxyAuthHeader username password) + describe "ProxyAuthorization" $ + it "sets Authorization header to correct value" $ + property $ \username password -> do + request <- req_ GET url NoReqBody (basicProxyAuth username password) + lookup "Proxy-Authorization" (L.requestHeaders request) + `shouldBe` pure (basicProxyAuthHeader username password) describe "oAuth2Token" $ do - it "sets Authorization header to correct value" - $ property - $ \token -> do + it "sets Authorization header to correct value" $ + property $ \token -> do request <- req_ GET url NoReqBody (oAuth2Token token) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("token " <> token) - it "overwrites manual setting of header" - $ property - $ \token value -> do + it "overwrites manual setting of header" $ + property $ \token value -> do request0 <- req_ GET @@ -380,9 +378,8 @@ `shouldBe` pure result lookup "Authorization" (L.requestHeaders request1) `shouldBe` pure result - it "left auth option wins" - $ property - $ \token0 token1 -> do + it "left auth option wins" $ + property $ \token0 token1 -> do request <- req_ GET @@ -391,27 +388,24 @@ (oAuth2Token token0 <> oAuth2Token token1) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("token " <> token0) - describe "port" - $ it "sets port overwriting the defaults" - $ property - $ \n -> do - request <- req_ GET url NoReqBody (port n) - L.port request `shouldBe` n - describe "decompress" - $ it "sets decompress function overwriting the defaults" - $ property - $ \token -> do - request <- req_ GET url NoReqBody (decompress (/= token)) - L.decompress request token `shouldBe` False + describe "port" $ + it "sets port overwriting the defaults" $ + property $ \n -> do + request <- req_ GET url NoReqBody (port n) + L.port request `shouldBe` n + describe "decompress" $ + it "sets decompress function overwriting the defaults" $ + property $ \token -> do + request <- req_ GET url NoReqBody (decompress (/= token)) + L.decompress request token `shouldBe` False -- FIXME Can't really test responseTimeout right new because the -- ResponseTimeout data type does not implement Eq and its constructors -- are also not exported. Sent a PR. - describe "httpVersion" - $ it "sets HTTP version overwriting the defaults" - $ property - $ \major minor -> do - request <- req_ GET url NoReqBody (httpVersion major minor) - L.requestVersion request `shouldBe` Y.HttpVersion major minor + describe "httpVersion" $ + it "sets HTTP version overwriting the defaults" $ + property $ \major minor -> do + request <- req_ GET url NoReqBody (httpVersion major minor) + L.requestVersion request `shouldBe` Y.HttpVersion major minor describe "quasiquoter" $ do it "works for valid urls" $ @@ -419,12 +413,12 @@ -- 'Https, Option _) type checks, so we can catch if the type of scheme -- is unspecified. let testTypeOfQuoterResult :: - forall a s. Typeable a => (a, Option s) -> Bool + forall a s. (Typeable a) => (a, Option s) -> Bool testTypeOfQuoterResult _ = isJust $ eqT @a @(Url 'Https) in property $ testTypeOfQuoterResult [urlQ|https://example.org/|] - it "doesn't work for invalid urls" - $ property - $ TH.runQ (TH.quoteExp urlQ "not a url") `shouldThrow` anyIOException + it "doesn't work for invalid urls" $ + property $ + TH.runQ (TH.quoteExp urlQ "not a url") `shouldThrow` anyIOException ---------------------------------------------------------------------------- -- Instances @@ -440,6 +434,8 @@ httpConfigCheckResponse _ _ _ = Nothing httpConfigRetryPolicy = retryPolicyDefault httpConfigRetryJudge _ _ = False + httpConfigRetryJudgeException _ _ = False + httpConfigBodyPreviewLength = 1024 return HttpConfig {..} instance Show HttpConfig where @@ -507,6 +503,9 @@ instance Arbitrary DiffTime where arbitrary = secondsToDiffTime <$> arbitrary +instance Arbitrary F.Form where + arbitrary = (F.Form . fromList) <$> arbitrary + ---------------------------------------------------------------------------- -- Helper types @@ -574,13 +573,14 @@ maybe def (fromIntegral) $ either (const Nothing) Just (URI.uriAuthority uri) >>= URI.authPort --- | Get path from 'URI'. +-- | Get the path from a 'URI'. uriPath :: URI -> ByteString uriPath uri = fromMaybe "" $ do - (_, xs) <- URI.uriPath uri - (return . encodePathPieces . fmap URI.unRText . NE.toList) xs + (trailingSlash, xs) <- URI.uriPath uri + let pref = (encodePathPieces . fmap URI.unRText . NE.toList) xs + return $ if trailingSlash then pref <> "/" else pref --- | Get query string from 'URI'. +-- | Get the query string from a 'URI'. uriQuery :: URI -> ByteString uriQuery uri = do let liftQueryParam = \case @@ -618,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,19 +1,15 @@ -cabal-version: 1.18 +cabal-version: 2.4 name: req -version: 3.2.0 -license: BSD3 +version: 3.13.4 +license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov author: Mark Karpov -tested-with: ghc ==8.6.5 ghc ==8.8.3 ghc ==8.10.1 +tested-with: ghc ==9.6.3 ghc ==9.8.2 ghc ==9.10.1 homepage: https://github.com/mrkkrp/req bug-reports: https://github.com/mrkkrp/req/issues -synopsis: - Easy-to-use, type-safe, expandable, high-level HTTP client library - -description: - Easy-to-use, type-safe, expandable, high-level HTTP client library. - +synopsis: HTTP client library +description: HTTP client library. category: Network, Web build-type: Simple data-files: @@ -35,95 +31,97 @@ library exposed-modules: Network.HTTP.Req - default-language: Haskell2010 + default-language: GHC2021 build-depends: - aeson >=0.9 && <1.6, - authenticate-oauth >=1.5 && <1.7, - base >=4.12 && <5.0, + aeson >=0.9 && <3, + authenticate-oauth >=1.5 && <1.8, + base >=4.15 && <5, blaze-builder >=0.3 && <0.5, - bytestring >=0.10.8 && <0.11, + bytestring >=0.10.8 && <0.13, case-insensitive >=0.2 && <1.3, - connection >=0.2.2 && <0.4, - http-api-data >=0.2 && <0.5, - http-client >=0.5 && <0.8, + containers >=0.5 && <0.7, + crypton-connection >=0.3 && <0.5, + data-default-class, + exceptions >=0.6 && <0.11, + http-api-data >=0.2 && <0.7, + http-client >=0.7.13.1 && <0.8, http-client-tls >=0.3.2 && <0.4, - http-types >=0.8 && <10.0, + http-types >=0.8 && <10, modern-uri >=0.3 && <0.4, monad-control >=1.0 && <1.1, mtl >=2.0 && <3.0, - retry >=0.8 && <0.9, - template-haskell >=2.14 && <2.17, - text >=0.2 && <1.3, - time >=1.2 && <1.10, - transformers >=0.4 && <0.6, - transformers-base -any + retry >=0.8 && <0.10, + template-haskell >=2.19 && <2.23, + text >=0.2 && <2.2, + transformers >=0.5.3.0 && <0.7, + transformers-base, + unliftio-core >=0.1.1 && <0.3 if flag(dev) - ghc-options: -O0 -Wall -Werror + ghc-options: + -Wall -Werror -Wpartial-fields -Wunused-packages + -Wno-unused-imports else ghc-options: -O2 -Wall - if flag(dev) - ghc-options: - -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - test-suite pure-tests - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-tools: hspec-discover >=2.0 && <3.0 - hs-source-dirs: pure-tests - other-modules: Network.HTTP.ReqSpec - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + hs-source-dirs: pure-tests + other-modules: Network.HTTP.ReqSpec + default-language: GHC2021 build-depends: - QuickCheck >=2.7 && <3.0, - aeson >=0.9 && <1.6, - base >=4.12 && <5.0, + QuickCheck >=2.7 && <3, + aeson >=0.9 && <3, + base >=4.15 && <5.0, blaze-builder >=0.3 && <0.5, - bytestring >=0.10.8 && <0.11, + bytestring >=0.10.8 && <0.13, case-insensitive >=0.2 && <1.3, - hspec >=2.0 && <3.0, - hspec-core >=2.0 && <3.0, - http-client >=0.5 && <0.8, - http-types >=0.8 && <10.0, + hspec >=2.0 && <3, + hspec-core >=2.0 && <3, + http-api-data >=0.2 && <0.7, + http-client >=0.7 && <0.8, + http-types >=0.8 && <10, modern-uri >=0.3 && <0.4, - mtl >=2.0 && <3.0, - req -any, - retry >=0.8 && <0.9, - template-haskell >=2.14 && <2.17, - text >=0.2 && <1.3, - time >=1.2 && <1.10 + req, + retry >=0.8 && <0.10, + template-haskell >=2.19 && <2.23, + text >=0.2 && <2.2, + time >=1.2 && <1.13 if flag(dev) - ghc-options: -O0 -Wall -Werror + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages else ghc-options: -O2 -Wall test-suite httpbin-tests - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-tools: hspec-discover >=2.0 && <3.0 - hs-source-dirs: httpbin-tests - other-modules: Network.HTTP.ReqSpec - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + hs-source-dirs: httpbin-tests + other-modules: Network.HTTP.ReqSpec + default-language: GHC2021 build-depends: - QuickCheck >=2.7 && <3.0, - aeson >=0.9 && <1.6, - base >=4.12 && <5.0, - bytestring >=0.10.8 && <0.11, + QuickCheck >=2.7 && <3, + aeson >=2 && <3, + base >=4.15 && <5, + bytestring >=0.10.8 && <0.13, hspec >=2.0 && <3.0, - http-client >=0.5 && <0.8, - http-types >=0.8 && <10.0, + http-client >=0.7 && <0.8, + http-types >=0.8 && <10, monad-control >=1.0 && <1.1, - mtl >=2.0 && <3.0, - req -any, - text >=0.2 && <1.3, - unordered-containers >=0.2.5 && <0.2.11 + req, + text >=0.2 && <2.2 if flag(dev) - ghc-options: -O0 -Wall -Werror + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages else - ghc-options: -O2 -Wall + buildable: False