diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,142 @@ +## 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. + +* Added a quasiquoter for URL creation, `urlQ`. + +## Req 3.1.0 + +* Changed signature of `httpConfigRetryPolicy` to `RetryPolicyM IO`. + +## Req 3.0.0 + +* Dropped functions `parseUrlHttp`, `parseUrlHttps`, and `parseUrl`. Instead + we now have `useHttpURI`, `useHttpsURI`, and `useURI` take `URI`s from + `modern-uri` as their argument. You first parse your URL with the + `modern-uri` package and then pass it to those functions. This allows us + to work with typed URI representations and seamlessly convert them to + something `req` can work with. As a side effect basic auth from the `URI`s + is now taken into consideration. In the future we may also start to + respect fragments if `http-client` starts to support this. + +* Dropped support for GHC 8.2 and older. + +## Req 2.1.0 + +* Dropped support for GHC 7.10. + +* Added the new `acceptHeader` method to the `HttpResponse` type class. + Notably, the `jsonResponse` method now sets `"Accept"` header to + `"application/json"`. + +## Req 2.0.1 + +* Fixed the `httpbin` tests (they changed something on the server again). + +## Req 2.0.0 + +* Got rid of `data-default-class` dependency, now we export + `defaultHttpConfig` instead. + ## Req 1.2.1 * Fixed a typo in the type signature of `parseUrl`. diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2016–2018 Mark Karpov +Copyright © 2016–present Mark Karpov All rights reserved. diff --git a/Network/HTTP/Req.hs b/Network/HTTP/Req.hs --- a/Network/HTTP/Req.hs +++ b/Network/HTTP/Req.hs @@ -1,1714 +1,2052 @@ --- | --- Module : Network.HTTP.Req --- Copyright : © 2016–2018 Mark Karpov --- License : BSD 3 clause --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- 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 --- 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 a 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. --- --- “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 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 'L.Request' is an instance --- of 'Data.String.IsString' and, if it's malformed, it will blow up at --- run-time). --- --- “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 a 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. --- --- “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 boilerplate down --- considerably, and helps you write concise, easy to read, and maintainable --- code. --- --- === Using with other libraries --- --- * You won't need the low-level interface of @http-client@ most of the --- time, but when you do, it's better to do a qualified import, --- because @http-client@ has naming conflicts with @req@. --- * For streaming of large request bodies see the companion package --- @req-conduit@: . --- --- === Lightweight, no risk solution --- --- The library uses the following mature packages under the hood to --- guarantee you the best experience: --- --- * —low level HTTP --- client used everywhere in Haskell. --- * —TLS (HTTPS) --- support for @http-client@. --- --- It's 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. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -#if MIN_VERSION_base(4,9,0) -{-# LANGUAGE UndecidableInstances #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif - -module Network.HTTP.Req - ( -- * Making a request - -- $making-a-request - req - , reqBr - , req' - , withReqManager - -- * Embedding requests into your monad - -- $embedding-requests - , MonadHttp (..) - , HttpConfig (..) - , Req - , runReq - -- * Request - -- ** Method - -- $method - , GET (..) - , POST (..) - , HEAD (..) - , PUT (..) - , DELETE (..) - , TRACE (..) - , CONNECT (..) - , OPTIONS (..) - , PATCH (..) - , HttpMethod (..) - -- ** URL - -- $url - , Url - , http - , https - , (/~) - , (/:) - , parseUrlHttp - , parseUrlHttps - , parseUrl - -- ** Body - -- $body - , NoReqBody (..) - , ReqBodyJson (..) - , ReqBodyFile (..) - , ReqBodyBs (..) - , ReqBodyLbs (..) - , ReqBodyUrlEnc (..) - , FormUrlEncodedParam - , ReqBodyMultipart - , reqBodyMultipart - , HttpBody (..) - , ProvidesBody - , HttpBodyAllowed - -- ** Optional parameters - -- $optional-parameters - , Option - -- *** Query parameters - -- $query-parameters - , (=:) - , queryFlag - , QueryParam (..) - -- *** Headers - , header - , attachHeader - -- *** Cookies - -- $cookies - , cookieJar - -- *** Authentication - -- $authentication - , basicAuth - , basicAuthUnsafe - , basicProxyAuth - , oAuth1 - , oAuth2Bearer - , oAuth2Token - , customAuth - -- *** Other - , port - , decompress - , responseTimeout - , httpVersion - -- * Response - -- ** Response interpretations - , IgnoreResponse - , ignoreResponse - , JsonResponse - , jsonResponse - , BsResponse - , bsResponse - , LbsResponse - , lbsResponse - -- ** Inspecting a response - , responseBody - , responseStatusCode - , responseStatusMessage - , responseHeader - , responseCookieJar - -- ** Defining your own interpretation - -- $new-response-interpretation - , HttpResponse (..) - -- * Other - , HttpException (..) - , CanHaveBody (..) - , Scheme (..) ) -where - -import Control.Applicative -import Control.Arrow (first, second) -import Control.Monad.Base -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.Trans.Control -import Control.Retry -import Data.Aeson (ToJSON (..), FromJSON (..)) -import Data.ByteString (ByteString) -import Data.Data (Data) -import Data.Default.Class -import Data.Function (on) -import Data.IORef -import Data.List (nubBy) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe) -import Data.Proxy -import Data.Semigroup hiding (Option, option) -import Data.Text (Text) -import Data.Typeable (Typeable) -import GHC.Generics -import GHC.TypeLits -import System.IO.Unsafe (unsafePerformIO) -import Web.HttpApiData (ToHttpApiData (..)) -import qualified Blaze.ByteString.Builder as BB -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Read as TR -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 qualified Web.Authenticate.OAuth as OAuth - -#if MIN_VERSION_base(4,9,0) -import Control.Exception hiding (TypeError) -import Data.Kind (Constraint) -#else -import Control.Exception -import GHC.Exts (Constraint) -#endif - ----------------------------------------------------------------------------- --- Making a request - --- $making-a-request --- --- To make an HTTP request you normally need only one function: 'req'. - --- | Make an HTTP request. The function takes 5 arguments, 4 of which --- specify required parameters and the final 'Option' argument is a --- collection of optional parameters. --- --- Let's go through all the arguments first: @req method url body response --- options@. --- --- @method@ is an HTTP method such as 'GET' or 'POST'. The documentation has --- a dedicated section about HTTP methods below. --- --- @url@ is a 'Url' that describes location of resource you want to interact --- with. --- --- @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. --- --- @response@ is a type hint how to make and interpret response of an HTTP --- request. Out-of-the-box it can be the following: --- --- * 'ignoreResponse' --- * 'jsonResponse' --- * 'bsResponse' (to get a strict 'ByteString') --- * 'lbsResponse' (to get a lazy 'BL.ByteString') --- --- Finally, @options@ is a 'Monoid' that holds a composite 'Option' for all --- other optional settings like query parameters, headers, non-standard port --- number, etc. There are quite a few things you can put there, see the --- corresponding section in the documentation. If you don't need anything at --- all, pass 'mempty'. --- --- __Note__ that if you use 'req' to do all your requests, connection --- sharing and reuse is done for you automatically. --- --- See the examples below to get on the speed quickly. --- --- ==== __Examples__ --- --- First, this is a piece of boilerplate that should be in place before you --- try the examples: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > module Main (main) where --- > --- > import Control.Monad --- > import Control.Monad.IO.Class --- > import Data.Aeson --- > import Data.Default.Class --- > import Data.Maybe (fromJust) --- > import Data.Monoid ((<>)) --- > import Data.Text (Text) --- > import GHC.Generics --- > import Network.HTTP.Req --- > import qualified Data.ByteString.Char8 as B --- --- We will be making requests against the service. --- --- Make a GET request, grab 5 random bytes: --- --- > main :: IO () --- > main = runReq def $ do --- > let n :: Int --- > n = 5 --- > bs <- req GET (https "httpbin.org" /: "bytes" /~ n) NoReqBody bsResponse mempty --- > liftIO $ B.putStrLn (responseBody bs) --- --- The same, but now we use a query parameter named @\"seed\"@ to control --- seed of the generator: --- --- > main :: IO () --- > main = runReq def $ do --- > let n, seed :: Int --- > n = 5 --- > seed = 100 --- > bs <- req GET (https "httpbin.org" /: "bytes" /~ n) NoReqBody bsResponse $ --- > "seed" =: seed --- > liftIO $ B.putStrLn (responseBody bs) --- --- POST JSON data and get some info about the POST request: --- --- > data MyData = MyData --- > { size :: Int --- > , color :: Text --- > } deriving (Show, Generic) --- > --- > instance ToJSON MyData --- > instance FromJSON MyData --- > --- > main :: IO () --- > main = runReq def $ do --- > let myData = MyData --- > { size = 6 --- > , color = "Green" } --- > v <- req POST (https "httpbin.org" /: "post") (ReqBodyJson myData) jsonResponse mempty --- > liftIO $ print (responseBody v :: Value) --- --- Sending URL-encoded body: --- --- > main :: IO () --- > main = runReq def $ do --- > let params = --- > "foo" =: ("bar" :: Text) <> --- > queryFlag "baz" --- > response <- req POST (https "httpbin.org" /: "post") (ReqBodyUrlEnc params) jsonResponse mempty --- > liftIO $ print (responseBody response :: Value) --- --- Using various optional parameters and URL that is not known in advance: --- --- > main :: IO () --- > main = runReq def $ do --- > -- This is an example of what to do when URL is given dynamically. Of --- > -- course in a real application you may not want to use 'fromJust'. --- > let (url, options) = fromJust (parseUrlHttps "https://httpbin.org/get?foo=bar") --- > response <- req GET url NoReqBody jsonResponse $ --- > "from" =: (15 :: Int) <> --- > "to" =: (67 :: Int) <> --- > basicAuth "username" "password" <> --- > options <> -- contains the ?foo=bar part --- > port 443 -- here you can put any port of course --- > liftIO $ print (responseBody response :: Value) - -req - :: ( MonadHttp m - , HttpMethod method - , HttpBody body - , HttpResponse response - , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) - => method -- ^ HTTP method - -> Url scheme -- ^ 'Url'—location of resource - -> body -- ^ Body of the request - -> Proxy response -- ^ A hint how to interpret response - -> Option scheme -- ^ Collection of optional parameters - -> m response -- ^ Response -req method url body Proxy options = - reqBr method url body options getHttpResponse - --- | A version of 'req' that does not use one of the predefined instances of --- 'HttpResponse' but instead allows the user to consume @'L.Response' --- 'L.BodyReader'@ manually, in a custom way. --- --- @since 1.0.0 - -reqBr - :: ( MonadHttp m - , HttpMethod method - , HttpBody body - , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) - => method -- ^ HTTP method - -> Url scheme -- ^ 'Url'—location of resource - -> body -- ^ Body of the request - -> Option scheme -- ^ Collection of optional parameters - -> (L.Response L.BodyReader -> IO a) -- ^ How to consume response - -> m a -- ^ Result -reqBr method url body options consume = req' method url body options $ \request manager -> do - HttpConfig {..} <- getHttpConfig - let wrapVanilla = handle (throwIO . VanillaHttpException) - wrapExc = handle (throwIO . LI.toHttpException request) - withRRef = bracket - (newIORef Nothing) - (readIORef >=> mapM_ L.responseClose) - (liftIO . try . wrapVanilla . wrapExc) (withRRef $ \rref -> do - let openResponse = mask_ $ do - r <- readIORef rref - mapM_ L.responseClose r - r' <- L.responseOpen request manager - writeIORef rref (Just r') - return r' - r <- retrying - httpConfigRetryPolicy - (\st r -> return $ httpConfigRetryJudge st r) - (const openResponse) - (preview, r') <- grabPreview bodyPreviewLength r - mapM_ LI.throwHttp (httpConfigCheckResponse request r' preview) - consume r') - >>= either handleHttpException return - --- | Mostly like 'req' with respect to its arguments, but accepts a callback --- that allows to perform a request in arbitrary fashion. --- --- This function /does not/ perform handling\/wrapping exceptions, checking --- response (with 'httpConfigCheckResponse'), and retrying. It only prepares --- 'L.Request' and allows you to use it. --- --- @since 0.3.0 - -req' - :: forall m method body scheme a. - ( MonadHttp m - , HttpMethod method - , HttpBody body - , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) - => method -- ^ HTTP method - -> Url scheme -- ^ 'Url'—location of resource - -> body -- ^ Body of the request - -> Option scheme -- ^ Collection of optional parameters - -> (L.Request -> L.Manager -> m a) -- ^ How to perform request - -> m a -- ^ Result -req' method url body options m = do - config@HttpConfig {..} <- getHttpConfig - let -- NOTE First appearance of any given header wins. This allows to - -- “overwrite” headers when we construct a request by cons-ing. - nubHeaders = Endo $ \x -> - x { L.requestHeaders = nubBy ((==) `on` fst) (L.requestHeaders x) } - request' = flip appEndo L.defaultRequest $ - -- NOTE The order of 'mappend's matters, here method is overwritten - -- first and 'options' take effect last. In particular, this means - -- that 'options' can overwrite things set by other request - -- components, which is useful for setting port number, - -- "Content-Type" header, etc. - nubHeaders <> - getRequestMod options <> - getRequestMod config <> - getRequestMod (Womb body :: Womb "body" body) <> - getRequestMod url <> - getRequestMod (Womb method :: Womb "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 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'. --- --- A note about safety, in case 'unsafePerformIO' looks suspicious to you. --- The value of 'globalManager' is named and lives on top level. This means --- it will be shared, i.e. computed only once on the first use of the --- manager. From that moment on the 'IORef' will be just reused—exactly the --- behavior we want here in order to maximize connection sharing. GHC could --- spoil the plan by inlining the definition, hence the @NOINLINE@ pragma. - -globalManager :: IORef L.Manager -globalManager = unsafePerformIO $ do - context <- NC.initConnectionContext - let settings = L.mkManagerSettingsContext (Just context) def Nothing - manager <- L.newManager settings - newIORef manager -{-# NOINLINE globalManager #-} - ----------------------------------------------------------------------------- --- Embedding requests into your monad - --- $embedding-requests --- --- To use 'req' in your monad, all you need to do is to make the monad an --- instance of the 'MonadHttp' type class. --- --- 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 @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). - --- | 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 - - -- | 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 - -- 'Control.Monad.Except.MonadError', this is the right place to pass it to - -- '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 - -- extracted from 'Control.Monad.Reader.MonadReader' if a more flexible - -- approach to configuration is desirable. - - getHttpConfig :: m HttpConfig - getHttpConfig = return def - --- | 'HttpConfig' contains general and default settings to be used when --- making HTTP requests. - -data HttpConfig = HttpConfig - { httpConfigProxy :: Maybe L.Proxy - -- ^ Proxy to use. By default values of @HTTP_PROXY@ and @HTTPS_PROXY@ - -- environment variables are respected, this setting overwrites them. - -- Default value: 'Nothing'. - , httpConfigRedirectCount :: Int - -- ^ How many redirects to follow when getting a resource. Default - -- value: 10. - , httpConfigAltManager :: Maybe L.Manager - -- ^ Alternative 'L.Manager' to use. 'Nothing' (default value) means - -- that the default implicit manager will be used (that's what you want - -- in 99% of cases). - , httpConfigCheckResponse - :: forall b. - L.Request - -> L.Response b - -> ByteString - -> Maybe L.HttpExceptionContent - -- ^ Function to check the response immediately after receiving the - -- status and headers, before streaming of response body. The third - -- argument is the beginning of response body (typically first 1024 - -- bytes). This is used for throwing exceptions on non-success status - -- codes by default (set to @\\_ _ _ -> Nothing@ if this behavior is not - -- desirable). - -- - -- When the value this function returns is 'Nothing', nothing will - -- happen. When it there is 'L.HttpExceptionContent' inside 'Just', it - -- will be thrown. - -- - -- Throwing is better then just returning a request with non-2xx status - -- code because in that case something is wrong and we need a way to - -- short-cut execution (also remember that Req retries automatically on - -- request timeouts and such, so when your request fails, it's certainly - -- something exceptional). The thrown exception is caught by the library - -- though and is available in 'handleHttpException'. - -- - -- __Note__: signature of this function was changed in the version - -- /1.0.0/. - -- - -- @since 0.3.0 - , httpConfigRetryPolicy :: RetryPolicy - -- ^ 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/. - -- - -- @since 0.3.0 - , httpConfigRetryJudge :: forall b. RetryStatus -> L.Response b -> Bool - -- ^ The function is used to decide whether to retry a request. 'True' - -- means that the request should be retried. - -- - -- __Note__: signature of this function was changed in the version - -- /1.0.0/. - -- - -- @since 0.3.0 - } deriving Typeable - -instance Default HttpConfig where - def = HttpConfig - { httpConfigProxy = Nothing - , httpConfigRedirectCount = 10 - , httpConfigAltManager = Nothing - , httpConfigCheckResponse = \_ response preview -> - let scode = statusCode response - in if 200 <= scode && scode < 300 - then Nothing - else Just (L.StatusCodeException (void response) preview) - , httpConfigRetryPolicy = def - , httpConfigRetryJudge = \_ response -> - statusCode response `elem` - [ 408 -- Request timeout - , 504 -- Gateway timeout - , 524 -- A timeout occurred - , 598 -- (Informal convention) Network read timeout error - , 599 -- (Informal convention) Network connect timeout error - ] - } - where - statusCode = Y.statusCode . L.responseStatus - -instance RequestComponent HttpConfig where - getRequestMod HttpConfig {..} = Endo $ \x -> - x { L.proxy = httpConfigProxy - , L.redirectCount = httpConfigRedirectCount - , LI.requestManagerOverride = httpConfigAltManager } - --- | A monad that allows to run 'req' in any 'IO'-enabled monad without --- having to define new instances. --- --- @since 0.4.0 - -newtype Req a = Req (ReaderT HttpConfig IO a) - deriving ( Functor - , Applicative - , Monad - , MonadIO ) - -instance MonadBase IO Req where - liftBase = liftIO - -instance MonadBaseControl IO Req where - type StM Req a = a - liftBaseWith f = Req . ReaderT $ \r -> f (runReq r) - {-# INLINEABLE liftBaseWith #-} - restoreM = Req . ReaderT . const . return - {-# INLINEABLE restoreM #-} - -instance MonadHttp Req where - handleHttpException = Req . lift . throwIO - getHttpConfig = Req ask - --- | Run a computation in the 'Req' monad with the given 'HttpConfig'. In --- case of exceptional situation an 'HttpException' will be thrown. --- --- @since 0.4.0 - -runReq :: MonadIO m - => HttpConfig -- ^ 'HttpConfig' to use - -> Req a -- ^ Computation to run - -> m a -runReq config (Req m) = liftIO (runReaderT m config) - ----------------------------------------------------------------------------- --- Request—Method - --- $method --- --- The package supports all methods as defined by RFC 2616, and 'PATCH' --- which is defined by RFC 5789—that should be enough to talk to RESTful --- APIs. In some cases, however, you may want to add more methods (e.g. you --- work with WebDAV ); no need to --- compromise on type safety and hack, it only takes a couple of seconds to --- define a new method that will works seamlessly, see 'HttpMethod'. - --- | 'GET' method. - -data GET = GET - -instance HttpMethod GET where - type AllowsBody GET = 'NoBody - httpMethodName Proxy = Y.methodGet - --- | 'POST' method. - -data POST = POST - -instance HttpMethod POST where - type AllowsBody POST = 'CanHaveBody - httpMethodName Proxy = Y.methodPost - --- | 'HEAD' method. - -data HEAD = HEAD - -instance HttpMethod HEAD where - type AllowsBody HEAD = 'NoBody - httpMethodName Proxy = Y.methodHead - --- | 'PUT' method. - -data PUT = PUT - -instance HttpMethod PUT where - 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. - -data DELETE = DELETE - -instance HttpMethod DELETE where - type AllowsBody DELETE = 'NoBody - httpMethodName Proxy = Y.methodDelete - --- | 'TRACE' method. - -data TRACE = TRACE - -instance HttpMethod TRACE where - type AllowsBody TRACE = 'CanHaveBody - httpMethodName Proxy = Y.methodTrace - --- | 'CONNECT' method. - -data CONNECT = CONNECT - -instance HttpMethod CONNECT where - type AllowsBody CONNECT = 'CanHaveBody - httpMethodName Proxy = Y.methodConnect - --- | 'OPTIONS' method. - -data OPTIONS = OPTIONS - -instance HttpMethod OPTIONS where - type AllowsBody OPTIONS = 'NoBody - httpMethodName Proxy = Y.methodOptions - --- | 'PATCH' method. - -data PATCH = PATCH - -instance HttpMethod PATCH where - type AllowsBody PATCH = 'CanHaveBody - httpMethodName Proxy = Y.methodPatch - --- | A type class for types that can be used as an HTTP method. To define a --- non-standard method, follow this example that defines @COPY@: --- --- > data COPY = COPY --- > --- > instance HttpMethod COPY where --- > type AllowsBody COPY = 'CanHaveBody --- > httpMethodName Proxy = "COPY" - -class HttpMethod a where - - -- | Type function 'AllowsBody' returns a type of kind 'CanHaveBody' which - -- tells the rest of the library whether the method can have a body or - -- not. We use the special type 'CanHaveBody' lifted to the kind level - -- instead of 'Bool' to get more user-friendly compiler messages. - - type AllowsBody a :: CanHaveBody - - -- | Return name of the method as a 'ByteString'. - - httpMethodName :: Proxy a -> ByteString - -instance HttpMethod method => RequestComponent (Womb "method" method) where - getRequestMod _ = Endo $ \x -> - x { L.method = httpMethodName (Proxy :: Proxy method) } - ----------------------------------------------------------------------------- --- Request—URL - --- $url --- --- We use 'Url's which are correct by construction, see 'Url'. To build a --- 'Url' from a 'ByteString', use 'parseUrlHttp', 'parseUrlHttps', or --- generic 'parseUrl'. - --- | Request's 'Url'. Start constructing your 'Url' with 'http' or 'https' --- specifying the scheme and host at the same time. Then use the @('/~')@ --- and @('/:')@ operators to grow the path one piece at a time. Every single --- piece of path will be url(percent)-encoded, so using @('/~')@ and --- @('/:')@ is the only way to have forward slashes between path segments. --- This approach makes working with dynamic path segments easy and safe. See --- examples below how to represent various 'Url's (make sure the --- @OverloadedStrings@ language extension is enabled). --- --- ==== __Examples__ --- --- > http "httpbin.org" --- > -- http://httpbin.org --- --- > https "httpbin.org" --- > -- https://httpbin.org --- --- > https "httpbin.org" /: "encoding" /: "utf8" --- > -- https://httpbin.org/encoding/utf8 --- --- > https "httpbin.org" /: "foo" /: "bar/baz" --- > -- https://httpbin.org/foo/bar%2Fbaz --- --- > https "httpbin.org" /: "bytes" /~ (10 :: Int) --- > -- https://httpbin.org/bytes/10 --- --- > https "юникод.рф" --- > -- https://%D1%8E%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4.%D1%80%D1%84 - -data Url (scheme :: Scheme) = Url Scheme (NonEmpty Text) - -- NOTE The second value is the path segments in reversed order. - deriving (Eq, Ord, Show, Data, Typeable, Generic) - --- | Given host name, produce a 'Url' which have “http” as its scheme and --- empty path. This also sets port to @80@. - -http :: Text -> Url 'Http -http = Url Http . pure - --- | Given host name, produce a 'Url' which have “https” as its scheme and --- empty path. This also sets port to @443@. - -https :: Text -> Url 'Https -https = Url Https . pure - --- | Grow 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 -Url secure path /~ segment = Url secure (NE.cons (toUrlPiece segment) path) - --- | Type-constrained version of @('/~')@ to remove ambiguity in the cases --- when next URL piece is a 'Text' literal. - -infixl 5 /: -(/:) :: Url scheme -> Text -> Url scheme -(/:) = (/~) - --- | The 'parseUrlHttp' function provides an alternative method to get 'Url' --- (possibly with some 'Option's) from a 'ByteString'. This is useful when --- you are given a URL to query dynamically and don't know it beforehand. --- The function parses 'ByteString' because it's the correct type to --- represent a URL, as 'Url' cannot contain characters outside of ASCII --- range, thus we can consider every character a 'Data.Word.Word8' value. --- --- This function only parses 'Url' (scheme, host, path) and optional query --- parameters that are returned as 'Option'. It does not parse method name --- or authentication info from given 'ByteString'. - -parseUrlHttp :: ByteString -> Maybe (Url 'Http, Option scheme) -parseUrlHttp url' = do - url <- B.stripPrefix "http://" url' - (host :| path, option) <- parseUrlHelper url - return (foldl (/:) (http host) path, option) - --- | Just like 'parseUrlHttp', but expects “https” scheme. - -parseUrlHttps :: ByteString -> Maybe (Url 'Https, Option scheme) -parseUrlHttps url' = do - url <- B.stripPrefix "https://" url' - (host :| path, option) <- parseUrlHelper url - return (foldl (/:) (https host) path, option) - --- | A more general URI parsing function that can be used when scheme is not --- known beforehand. --- --- @since 1.2.1 - -parseUrl - :: ByteString - -> Maybe (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1)) -parseUrl url = Left <$> parseUrlHttp url <|> Right <$> parseUrlHttps url - --- | Get host\/collection of path pieces and possibly query parameters --- already converted to 'Option'. This function is not public. - -parseUrlHelper :: ByteString -> Maybe (NonEmpty Text, Option scheme) -parseUrlHelper url = do - let (path', query') = B.break (== 0x3f) url - query = mconcat (uncurry queryParam <$> Y.parseQueryText query') - p' :| ps <- NE.nonEmpty (Y.decodePathSegments path') - (p, port') <- - case T.break (== ':') p' of - (x, "") -> return (x, mempty) - (x, prt) -> - case TR.decimal (T.drop 1 prt) of - Right (prt',"") -> return (x, port prt') - _ -> Nothing - return (p :| ps, query <> port') - -instance RequestComponent (Url scheme) where - getRequestMod (Url scheme segments) = Endo $ \x -> - let (host :| path) = NE.reverse segments in - x { L.secure = case scheme of - Http -> False - Https -> True - , L.port = case scheme of - Http -> 80 - Https -> 443 - , L.host = Y.urlEncode False (T.encodeUtf8 host) - , L.path = - (BL.toStrict . BB.toLazyByteString . Y.encodePathSegments) path } - ----------------------------------------------------------------------------- --- Request—Body - --- $body --- --- A number of options for request bodies are available. The @Content-Type@ --- header is set for you automatically according to the body option you use --- (it's always specified in documentation for a given body option). To add --- your own way to represent request body, define an instance of 'HttpBody'. - --- | This data type represents empty body of an HTTP request. This is the --- data type to use with 'HttpMethod's that cannot have a body, as it's the --- only type for which 'ProvidesBody' returns 'NoBody'. --- --- Using of this body option does not set the @Content-Type@ header. - -data NoReqBody = NoReqBody - -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 sets the @Content-Type@ header to @\"application/json; --- charset=utf-8\"@ value. - -newtype ReqBodyJson a = ReqBodyJson a - -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. --- --- Using of this body option does not set the @Content-Type@ header. - -newtype ReqBodyFile = ReqBodyFile FilePath - -instance HttpBody ReqBodyFile where - getRequestBody (ReqBodyFile path) = - LI.RequestBodyIO (L.streamFile path) - --- | HTTP request body represented by a strict 'ByteString'. --- --- Using of this body option does not set the @Content-Type@ header. - -newtype ReqBodyBs = ReqBodyBs ByteString - -instance HttpBody ReqBodyBs where - getRequestBody (ReqBodyBs bs) = L.RequestBodyBS bs - --- | HTTP request body represented by a lazy 'BL.ByteString'. --- --- Using of this body option does not set the @Content-Type@ header. - -newtype ReqBodyLbs = ReqBodyLbs BL.ByteString - -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'. --- --- This body option sets the @Content-Type@ header to --- @\"application/x-www-form-urlencoded\"@ value. - -newtype ReqBodyUrlEnc = ReqBodyUrlEnc FormUrlEncodedParam - -instance HttpBody ReqBodyUrlEnc where - getRequestBody (ReqBodyUrlEnc (FormUrlEncodedParam params)) = - (L.RequestBodyLBS . BB.toLazyByteString) (Y.renderQueryText False params) - getRequestContentType _ = pure "application/x-www-form-urlencoded" - --- | An opaque monoidal value that allows to collect URL-encoded parameters --- to be wrapped in 'ReqBodyUrlEnc'. - -newtype FormUrlEncodedParam = FormUrlEncodedParam [(Text, Maybe Text)] - deriving (Semigroup, Monoid) - -instance QueryParam FormUrlEncodedParam where - queryParam name mvalue = - FormUrlEncodedParam [(name, toQueryParam <$> mvalue)] - --- | 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 --- parts. 'reqBodyMultipart' is the only way to get a value of the type --- 'ReqBodyMultipart', as its constructor is not exported on purpose. --- --- @since 0.2.0 --- --- ==== __Examples__ --- --- > import Control.Monad.IO.Class --- > import Data.Default.Class --- > import Network.HTTP.Req --- > import qualified Network.HTTP.Client.MultipartFormData as LM --- > --- > main :: IO () --- > main = runReq def $ do --- > body <- --- > reqBodyMultipart --- > [ LM.partBS "title" "My Image" --- > , LM.partFileSource "file1" "/tmp/image.jpg" --- > ] --- > response <- --- > req POST (http "example.com" /: "post") --- > body --- > bsResponse --- > mempty --- > liftIO $ print (responseBody response) - -data ReqBodyMultipart = ReqBodyMultipart ByteString LI.RequestBody - -instance HttpBody ReqBodyMultipart where - getRequestBody (ReqBodyMultipart _ body) = body - getRequestContentType (ReqBodyMultipart boundary _) = - pure ("multipart/form-data; boundary=" <> boundary) - --- | Create 'ReqBodyMultipart' request body from a collection of 'LM.Part's. --- --- @since 0.2.0 - -reqBodyMultipart :: MonadIO m => [LM.Part] -> m ReqBodyMultipart -reqBodyMultipart parts = liftIO $ do - boundary <- LM.webkitBoundary - body <- LM.renderParts boundary parts - return (ReqBodyMultipart boundary body) - --- | A type class for things that can be interpreted as an HTTP --- 'L.RequestBody'. - -class HttpBody body where - - -- | How to get actual 'L.RequestBody'. - - getRequestBody :: body -> L.RequestBody - - -- | This method allows to optionally specify value of @Content-Type@ - -- header that should be used with particular body option. By default it - -- returns 'Nothing' and so @Content-Type@ is not set. - - getRequestContentType :: body -> Maybe ByteString - getRequestContentType = const Nothing - --- | The type function recognizes 'NoReqBody' as having 'NoBody', while any --- other body option 'CanHaveBody'. This forces user to use 'NoReqBody' with --- 'GET' method and other methods that should not send a body. - -type family ProvidesBody body :: CanHaveBody where - ProvidesBody NoReqBody = 'NoBody - ProvidesBody body = 'CanHaveBody - --- | 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) - (providesBody :: CanHaveBody) :: Constraint where - HttpBodyAllowed 'NoBody 'NoBody = () - HttpBodyAllowed 'CanHaveBody body = () -#if MIN_VERSION_base(4,9,0) - HttpBodyAllowed 'NoBody 'CanHaveBody = TypeError - ('Text "This HTTP method does not allow attaching a request body.") -#endif - -instance HttpBody body => RequestComponent (Womb "body" body) where - getRequestMod (Womb body) = Endo $ \x -> - x { L.requestBody = getRequestBody body - , L.requestHeaders = - let old = L.requestHeaders x in - case getRequestContentType body of - Nothing -> old - Just contentType -> - (Y.hContentType, contentType) : old } - ----------------------------------------------------------------------------- --- Request—Optional parameters - --- $optional-parameters --- --- Optional parameters to a request include things like query parameters, --- headers, port number, etc. All optional parameters have the type --- 'Option', which is a 'Monoid'. This means that you can use 'mempty' as --- the last argument of 'req' to specify no optional parameters, or combine --- 'Option's using 'mappend' or @('<>')@ to have several of them at once. - --- | The opaque 'Option' type is a 'Monoid' you can use to pack collection --- of optional parameters like query parameters and headers. See sections --- below to learn which 'Option' primitives are available. - -data Option (scheme :: Scheme) = - 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 - -- 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. - -instance Semigroup (Option scheme) where - Option er0 mr0 <> Option er1 mr1 = Option - (er0 <> er1) (mr0 <|> mr1) - -instance Monoid (Option scheme) where - mempty = Option mempty Nothing - mappend = (<>) - --- | 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 -withQueryParams f = Option (Endo (first f)) Nothing - --- | A helper to create an 'Option' that modifies only 'L.Request'. This --- helper is not a part of public API. - -withRequest :: (L.Request -> L.Request) -> Option scheme -withRequest f = Option (Endo (second f)) Nothing - -instance RequestComponent (Option scheme) where - getRequestMod (Option f _) = Endo $ \x -> - let (qparams, x') = appEndo f ([], x) - query = Y.renderQuery True (Y.queryTextToQuery qparams) - in x' { L.queryString = query } - --- | 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 (Option _ mfinalizer) = liftIO . fromMaybe pure mfinalizer - ----------------------------------------------------------------------------- --- Request—Optional parameters—Query Parameters - --- $query-parameters --- --- This section describes a polymorphic interface that can be used to --- construct query parameters (of the type 'Option') and form URL-encoded --- bodies (of the type 'FormUrlEncodedParam'). - --- | This operator builds a query parameter that will be included in URL of --- your request after the question sign @?@. This is the same syntax you use --- with form URL encoded request bodies. --- --- This operator is defined in terms of 'queryParam': --- --- > name =: value = queryParam name (pure value) - -infix 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 --- the following URL @\"a\"@ is a flag, while @\"b\"@ is a query parameter --- with a value: --- --- > https://httpbin.org/foo/bar?a&b=10 --- --- This operator is defined in terms of 'queryParam': --- --- > queryFlag name = queryParam name (Nothing :: Maybe ()) - -queryFlag :: QueryParam param => Text -> param -queryFlag name = queryParam name (Nothing :: Maybe ()) - --- | 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. --- Having the same syntax for these cases seems natural and user-friendly. - -class QueryParam param where - - -- | Create a query parameter with given name and value. If value is - -- '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 - -instance QueryParam (Option scheme) where - queryParam name mvalue = - withQueryParams ((:) (name, toQueryParam <$> mvalue)) - ----------------------------------------------------------------------------- --- Request—Optional parameters—Headers - --- | Create an 'Option' that adds a header. Note that if you 'mappend' two --- headers with the same names the leftmost header will win. This means, in --- particular, that you cannot create a request with several headers of the --- same name. - -header - :: ByteString -- ^ Header name - -> ByteString -- ^ Header value - -> Option scheme -header name value = withRequest (attachHeader name value) - --- | A non-public helper that attaches a header with given name and content --- to a 'L.Request'. --- --- @since 1.1.0 - -attachHeader :: ByteString -> ByteString -> L.Request -> L.Request -attachHeader name value x = - x { L.requestHeaders = (CI.mk name, value) : L.requestHeaders x } - ----------------------------------------------------------------------------- --- Request—Optional parameters—Cookies - --- $cookies --- --- Support for cookies is quite minimalistic at the moment. It's possible to --- specify which cookies to send using 'cookieJar' and inspect 'L.Response' --- to extract 'L.CookieJar' from it (see 'responseCookieJar'). - --- | Use the given 'L.CookieJar'. A 'L.CookieJar' can be obtained from a --- 'L.Response' record. - -cookieJar :: L.CookieJar -> Option scheme -cookieJar jar = withRequest $ \x -> - x { L.cookieJar = Just jar } - ----------------------------------------------------------------------------- --- Request—Optional parameters—Authentication - --- $authentication --- --- This section provides the common authentication helpers in the form of --- 'Option's. You should always prefer the provided authentication 'Option's --- to manual construction of headers because it ensures that you only use --- one authentication method at a time (they overwrite each other) and --- provides additional type safety that prevents leaking of credentials in --- the cases when authentication relies on HTTPS for encrypting sensitive --- data. - --- | The 'Option' adds basic authentication. --- --- See also: . - -basicAuth - :: ByteString -- ^ Username - -> ByteString -- ^ Password - -> Option 'Https -- ^ Auth 'Option' -basicAuth = basicAuthUnsafe - --- | An alternative to 'basicAuth' which works for any scheme. Note that --- using basic access authentication without SSL/TLS is vulnerable to --- attacks. Use 'basicAuth' instead unless you know what you are doing. --- --- @since 0.3.1 - -basicAuthUnsafe - :: ByteString -- ^ Username - -> ByteString -- ^ Password - -> Option scheme -- ^ Auth 'Option' -basicAuthUnsafe username password = customAuth - (pure . L.applyBasicAuth username password) - --- | The 'Option' set basic proxy authentication header. --- --- @since 1.1.0 - -basicProxyAuth - :: ByteString -- ^ Username - -> ByteString -- ^ Password - -> Option scheme -- ^ Auth 'Option' -basicProxyAuth username password = - withRequest (L.applyBasicProxyAuth username password) - --- | The 'Option' adds OAuth1 authentication. --- --- @since 0.2.0 - -oAuth1 - :: ByteString -- ^ Consumer token - -> ByteString -- ^ Consumer secret - -> ByteString -- ^ OAuth token - -> ByteString -- ^ OAuth token secret - -> Option scheme -- ^ Auth 'Option' -oAuth1 consumerToken consumerSecret token tokenSecret = - customAuth (OAuth.signOAuth app creds) - where - app = OAuth.newOAuth - { OAuth.oauthConsumerKey = consumerToken - , OAuth.oauthConsumerSecret = consumerSecret } - creds = OAuth.newCredential token tokenSecret - --- | The 'Option' adds an OAuth2 bearer token. This is treated by many --- services as the equivalent of a username and password. --- --- The 'Option' is defined as: --- --- > oAuth2Bearer token = header "Authorization" ("Bearer " <> token) --- --- See also: . - -oAuth2Bearer - :: ByteString -- ^ Token - -> Option 'Https -- ^ Auth 'Option' -oAuth2Bearer token = customAuth - (pure . attachHeader "Authorization" ("Bearer " <> token)) - --- | The 'Option' adds a not-quite-standard OAuth2 bearer token (that seems --- to be used only by GitHub). This will be treated by whatever services --- accept it as the equivalent of a username and password. --- --- The 'Option' is defined as: --- --- > oAuth2Token token = header "Authorization" ("token" <> token) --- --- See also: . - -oAuth2Token - :: ByteString -- ^ Token - -> Option 'Https -- ^ Auth 'Option' -oAuth2Token token = customAuth - (pure . attachHeader "Authorization" ("token " <> token)) - --- | A helper to create custom authentication 'Option's. The given --- 'IO'-enabled request transformation is applied after all other --- modifications when constructing a request. Use wisely. --- --- @since 1.1.0 - -customAuth :: (L.Request -> IO L.Request) -> Option scheme -customAuth = Option mempty . pure - ----------------------------------------------------------------------------- --- Request—Optional parameters—Other - --- | 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. - -port :: Int -> Option scheme -port n = withRequest $ \x -> - x { L.port = n } - --- | This 'Option' controls whether gzipped data should be decompressed on --- the fly. By default everything except for @\"application\/x-tar\"@ is --- decompressed, i.e. we have: --- --- > decompress (/= "application/x-tar") --- --- You can also choose to decompress everything like this: --- --- > decompress (const True) - -decompress - :: (ByteString -> Bool) -- ^ Predicate that is given MIME type, it - -- returns 'True' when content should be decompressed on the fly. - -> Option scheme -decompress f = withRequest $ \x -> - x { L.decompress = f } - --- | Specify the number of microseconds to wait for response. The default --- value is 30 seconds (defined in 'L.ManagerSettings' of connection --- 'L.Manager'). - -responseTimeout - :: Int -- ^ Number of microseconds to wait - -> Option scheme -responseTimeout n = withRequest $ \x -> - x { L.responseTimeout = LI.ResponseTimeoutMicro n } - --- | HTTP version to send to the server, the default is HTTP 1.1. - -httpVersion - :: Int -- ^ Major version number - -> Int -- ^ Minor version number - -> Option scheme -httpVersion major minor = withRequest $ \x -> - x { L.requestVersion = Y.HttpVersion major minor } - ----------------------------------------------------------------------------- --- Response interpretations - --- | Make a request and ignore the body of the response. - -newtype IgnoreResponse = IgnoreResponse (L.Response ()) - -instance HttpResponse IgnoreResponse where - type HttpResponseBody IgnoreResponse = () - toVanillaResponse (IgnoreResponse r) = r - getHttpResponse r = return $ IgnoreResponse (void r) - --- | Use this as the fourth argument of 'req' to specify that you want it to --- ignore the response body. - -ignoreResponse :: Proxy IgnoreResponse -ignoreResponse = Proxy - --- | Make a request and interpret the body of the response as JSON. The --- 'handleHttpException' method of 'MonadHttp' instance corresponding to --- 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) - -instance FromJSON a => HttpResponse (JsonResponse a) where - type HttpResponseBody (JsonResponse a) = a - toVanillaResponse (JsonResponse r) = r - getHttpResponse r = do - chunks <- L.brConsume (L.responseBody r) - case A.eitherDecode (BL.fromChunks chunks) of - Left e -> throwIO (JsonHttpException e) - Right x -> return $ JsonResponse (x <$ r) - --- | Use this as the fourth argument of 'req' to specify that you want it to --- return the 'JsonResponse' interpretation. - -jsonResponse :: Proxy (JsonResponse a) -jsonResponse = Proxy - --- | Make a request and interpret the body of the response as a strict --- 'ByteString'. - -newtype BsResponse = BsResponse (L.Response ByteString) - -instance HttpResponse BsResponse where - type HttpResponseBody BsResponse = ByteString - toVanillaResponse (BsResponse r) = r - getHttpResponse r = do - chunks <- L.brConsume (L.responseBody r) - return $ BsResponse (B.concat chunks <$ r) - --- | Use this as the fourth argument of 'req' to specify that you want to --- interpret the response body as a strict 'ByteString'. - -bsResponse :: Proxy BsResponse -bsResponse = Proxy - --- | Make a request and interpret the body of the response as a lazy --- 'BL.ByteString'. - -newtype LbsResponse = LbsResponse (L.Response BL.ByteString) - -instance HttpResponse LbsResponse where - type HttpResponseBody LbsResponse = BL.ByteString - toVanillaResponse (LbsResponse r) = r - getHttpResponse r = do - chunks <- L.brConsume (L.responseBody r) - return $ LbsResponse (BL.fromChunks chunks <$ r) - --- | Use this as the fourth argument of 'req' to specify that you want to --- interpret the response body as a lazy 'BL.ByteString'. - -lbsResponse :: Proxy LbsResponse -lbsResponse = Proxy - ----------------------------------------------------------------------------- --- Helpers for response interpretations - --- | Fetch beginning of response and return it together with new --- @'L.Response' 'L.BodyReader'@ that can be passed to 'getHttpResponse' and --- such. - -grabPreview - :: Int - -- ^ How many bytes to fetch - -> L.Response L.BodyReader - -- ^ Response with body reader inside - -> IO (ByteString, L.Response L.BodyReader) - -- ^ Preview 'ByteString' and new response with body reader inside -grabPreview nbytes r = do - let br = L.responseBody r - (target, leftover, done) <- brReadN br nbytes - nref <- newIORef (0 :: Int) - let br' = do - n <- readIORef nref - let incn = modifyIORef' nref (+ 1) - case n of - 0 -> do - incn - if B.null target - then br' - else return target - 1 -> do - incn - if B.null leftover - then br' - else return leftover - _ -> - if done - then return B.empty - else br - return (target, r { L.responseBody = br' }) - --- | Consume N bytes from 'L.BodyReader', return the target chunk, the --- leftover (may be empty), and whether we're done consuming the body. - -brReadN - :: L.BodyReader - -- ^ Body reader to stream from - -> Int - -- ^ How many bytes to consume - -> IO (ByteString, ByteString, Bool) - -- ^ Target chunk, the leftover, whether we're done -brReadN br n = go 0 id id - where - go !tlen t l = do - chunk <- br - if B.null chunk - then return (r t, r l, True) - else do - let (target, leftover) = B.splitAt (n - tlen) chunk - tlen' = B.length target - t' = t . (target:) - l' = l . (leftover:) - if tlen + tlen' < n - then go (tlen + tlen') t' l' - else return (r t', r l', False) - r f = B.concat (f []) - ----------------------------------------------------------------------------- --- Inspecting a response - --- | Get the response body. - -responseBody - :: HttpResponse response - => response - -> HttpResponseBody response -responseBody = L.responseBody . toVanillaResponse - --- | Get the response status code. - -responseStatusCode - :: HttpResponse response - => response - -> Int -responseStatusCode = - Y.statusCode . L.responseStatus . toVanillaResponse - --- | Get the response status message. - -responseStatusMessage - :: HttpResponse response - => response - -> ByteString -responseStatusMessage = - Y.statusMessage . L.responseStatus . toVanillaResponse - --- | Lookup a particular header from a response. - -responseHeader - :: HttpResponse response - => response -- ^ Response interpretation - -> ByteString -- ^ Header to lookup - -> Maybe ByteString -- ^ Header value if found -responseHeader r h = - (lookup (CI.mk h) . L.responseHeaders . toVanillaResponse) r - --- | Get the response 'L.CookieJar'. - -responseCookieJar - :: HttpResponse response - => response - -> L.CookieJar -responseCookieJar = L.responseCookieJar . toVanillaResponse - ----------------------------------------------------------------------------- --- Response—Defining your own interpretation - --- $new-response-interpretation --- --- 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. - -class HttpResponse response where - - -- | The associated type is the type of body that can be extracted from an - -- instance of 'HttpResponse'. - - type HttpResponseBody response :: * - - -- | The method describes how to get the underlying 'L.Response' record. - - toVanillaResponse :: response -> L.Response (HttpResponseBody response) - - -- | This method describes how to consume response body and, more - -- generally, obtain @response@ value from @'L.Response' 'L.BodyReader'@. - -- - -- __Note__: 'L.BodyReader' is nothing but @'IO' 'ByteString'@. You should - -- call this action repeatedly until it yields the empty 'ByteString'. In - -- that case streaming of response is finished (which apparently leads to - -- closing of the connection, so don't call the reader after it has - -- returned the empty 'ByteString' once) and you can concatenate the - -- chunks to obtain the final result. (Of course you could as well stream - -- the contents to a file or do whatever you want.) - -- - -- __Note__: signature of this function was changed in the version - -- /1.0.0/. - - getHttpResponse - :: L.Response L.BodyReader - -- ^ Response with body reader inside - -> IO response - -- ^ The final result - ----------------------------------------------------------------------------- --- Other - --- | The main class for things that are “parts” of 'L.Request' in the sense --- that if we have a 'L.Request', then we know how to apply an instance of --- 'RequestComponent' changing\/overwriting something in it. 'Endo' is a --- monoid of endomorphisms under composition, it's used to chain different --- request components easier using @('<>')@. --- --- __Note__: this type class is not a part of the public API. - -class RequestComponent a where - - -- | Get a function that takes a 'L.Request' and changes it somehow - -- returning another 'L.Request'. For example, the 'HttpMethod' instance - -- of 'RequestComponent' just overwrites method. The function is wrapped - -- in 'Endo' so it's easier to chain such “modifying applications” - -- together building bigger and bigger 'RequestComponent's. - - getRequestMod :: a -> Endo L.Request - --- | This wrapper is only used to attach a type-level tag to a given type. --- This is necessary to define instances of 'RequestComponent' for any thing --- that implements 'HttpMethod' or 'HttpBody'. Without the tag, GHC can't --- see the difference between @'HttpMethod' method => 'RequestComponent' --- 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 - --- | Exceptions that this library throws. - -data HttpException - = VanillaHttpException L.HttpException - -- ^ A wrapper with an 'L.HttpException' from "Network.HTTP.Client" - | JsonHttpException String - -- ^ A wrapper with Aeson-produced 'String' describing why decoding - -- failed - deriving (Show, Typeable, Generic) - -instance Exception HttpException - --- | 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. --- --- See also: 'HttpMethod' and 'HttpBody'. - -data CanHaveBody - = CanHaveBody -- ^ Indeed can have a body - | NoBody -- ^ Should not have a body - --- | A type-level tag that specifies URL scheme used (and thus if HTTPS is --- enabled). This is used to force TLS requirement for some authentication --- 'Option's. - -data Scheme - = Http -- ^ HTTP - | Https -- ^ HTTPS - deriving (Eq, Ord, Show, Data, Typeable, Generic) - ----------------------------------------------------------------------------- --- Constants - --- | Max length of preview fragment of response body. - -bodyPreviewLength :: Num a => a -bodyPreviewLength = 1024 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Network.HTTP.Req +-- Copyright : © 2016–present Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- 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 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. +-- +-- === About the library +-- +-- Req is an HTTP client library that attempts to be easy-to-use, type-safe, +-- and expandable. +-- +-- “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. +-- +-- “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. +-- +-- “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 +-- +-- * You won't need the low-level interface of @http-client@ most of the +-- time, but when you do, it's better to do a qualified import, +-- because @http-client@ has naming conflicts with @req@. +-- * For streaming of large request bodies see the companion package +-- @req-conduit@: . +-- +-- === Lightweight, no risk solution +-- +-- The library uses the following mature packages under the hood to +-- guarantee you the best experience: +-- +-- * —low level HTTP +-- client used everywhere in Haskell. +-- * —TLS (HTTPS) +-- support for @http-client@. +-- +-- It's 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. +module Network.HTTP.Req + ( -- * Making a request + -- $making-a-request + req, + reqBr, + reqCb, + req', + withReqManager, + + -- * Embedding requests in your monad + -- $embedding-requests + MonadHttp (..), + HttpConfig (..), + defaultHttpConfig, + Req, + runReq, + + -- * Request + + -- ** Method + -- $method + GET (..), + POST (..), + HEAD (..), + PUT (..), + DELETE (..), + TRACE (..), + CONNECT (..), + OPTIONS (..), + PATCH (..), + HttpMethod (..), + + -- ** URL + -- $url + Url, + http, + https, + (/~), + (/:), + useHttpURI, + useHttpsURI, + useURI, + urlQ, + renderUrl, + + -- ** Body + -- $body + NoReqBody (..), + ReqBodyJson (..), + ReqBodyFile (..), + ReqBodyBs (..), + ReqBodyLbs (..), + ReqBodyUrlEnc (..), + FormUrlEncodedParam, + ReqBodyMultipart, + reqBodyMultipart, + HttpBody (..), + ProvidesBody, + HttpBodyAllowed, + + -- ** Optional parameters + -- $optional-parameters + Option, + + -- *** Query parameters + -- $query-parameters + (=:), + queryFlag, + formToQuery, + QueryParam (..), + + -- *** Headers + header, + attachHeader, + headerRedacted, + + -- *** Cookies + -- $cookies + cookieJar, + + -- *** Authentication + -- $authentication + basicAuth, + basicAuthUnsafe, + basicProxyAuth, + oAuth1, + oAuth2Bearer, + oAuth2Token, + customAuth, + + -- *** Other + port, + decompress, + responseTimeout, + httpVersion, + + -- * Response + + -- ** Response interpretations + IgnoreResponse, + ignoreResponse, + JsonResponse, + jsonResponse, + BsResponse, + bsResponse, + LbsResponse, + lbsResponse, + + -- ** Inspecting a response + responseBody, + responseStatusCode, + responseStatusMessage, + responseHeader, + responseCookieJar, + + -- ** Defining your own interpretation + -- $new-response-interpretation + HttpResponse (..), + + -- * Other + HttpException (..), + isStatusCodeException, + CanHaveBody (..), + Scheme (..), + ) +where + +import Blaze.ByteString.Builder qualified as BB +import Control.Applicative +import Control.Arrow (first, second) +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.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 Data.Aeson qualified as A +import Data.ByteString (ByteString) +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 Data.List.NonEmpty qualified as NE +import Data.Maybe (fromMaybe) +import Data.Proxy +import Data.Semigroup (Endo (..)) +import Data.Set qualified as S +import Data.Text (Text) +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 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 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 (..)) + +---------------------------------------------------------------------------- +-- Making a request + +-- $making-a-request +-- +-- To make an HTTP request you normally need only one function: 'req'. + +-- | Make an HTTP request. The function takes 5 arguments, 4 of which +-- specify required parameters and the final 'Option' argument is a +-- collection of optional parameters. +-- +-- Let's go through all the arguments first: @req method url body response +-- options@. +-- +-- @method@ is an HTTP method such as 'GET' or 'POST'. The documentation has +-- a dedicated section about HTTP methods below. +-- +-- @url@ is a 'Url' that describes location of resource you want to interact +-- with. +-- +-- @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. +-- +-- @response@ is a type hint how to make and interpret response of an HTTP +-- request. Out-of-the-box it can be the following: +-- +-- * 'ignoreResponse' +-- * 'jsonResponse' +-- * 'bsResponse' (to get a strict 'ByteString') +-- * 'lbsResponse' (to get a lazy 'BL.ByteString') +-- +-- Finally, @options@ is a 'Monoid' that holds a composite 'Option' for all +-- other optional settings like query parameters, headers, non-standard port +-- number, etc. There are quite a few things you can put there, see the +-- corresponding section in the documentation. If you don't need anything at +-- all, pass 'mempty'. +-- +-- __Note__ that if you use 'req' to do all your requests, connection +-- sharing and reuse is done for you automatically. +-- +-- See the examples below to get on the speed quickly. +-- +-- ==== __Examples__ +-- +-- First, this is a piece of boilerplate that should be in place before you +-- try the examples: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import Control.Monad +-- > import Control.Monad.IO.Class +-- > import Data.Aeson +-- > import Data.Maybe (fromJust) +-- > import Data.Monoid ((<>)) +-- > import Data.Text (Text) +-- > import GHC.Generics +-- > import Network.HTTP.Req +-- > import qualified Data.ByteString.Char8 as B +-- > import qualified Text.URI as URI +-- +-- We will be making requests against the service. +-- +-- Make a GET request, grab 5 random bytes: +-- +-- > main :: IO () +-- > main = runReq defaultHttpConfig $ do +-- > let n :: Int +-- > n = 5 +-- > bs <- req GET (https "httpbin.org" /: "bytes" /~ n) NoReqBody bsResponse mempty +-- > liftIO $ B.putStrLn (responseBody bs) +-- +-- The same, but now we use a query parameter named @\"seed\"@ to control +-- seed of the generator: +-- +-- > main :: IO () +-- > main = runReq defaultHttpConfig $ do +-- > let n, seed :: Int +-- > n = 5 +-- > seed = 100 +-- > bs <- req GET (https "httpbin.org" /: "bytes" /~ n) NoReqBody bsResponse $ +-- > "seed" =: seed +-- > liftIO $ B.putStrLn (responseBody bs) +-- +-- POST JSON data and get some info about the POST request: +-- +-- > data MyData = MyData +-- > { size :: Int +-- > , color :: Text +-- > } deriving (Show, Generic) +-- > +-- > instance ToJSON MyData +-- > instance FromJSON MyData +-- > +-- > main :: IO () +-- > main = runReq defaultHttpConfig $ do +-- > let myData = MyData +-- > { size = 6 +-- > , color = "Green" } +-- > v <- req POST (https "httpbin.org" /: "post") (ReqBodyJson myData) jsonResponse mempty +-- > liftIO $ print (responseBody v :: Value) +-- +-- Sending URL-encoded body: +-- +-- > main :: IO () +-- > main = runReq defaultHttpConfig $ do +-- > let params = +-- > "foo" =: ("bar" :: Text) <> +-- > queryFlag "baz" +-- > response <- req POST (https "httpbin.org" /: "post") (ReqBodyUrlEnc params) jsonResponse mempty +-- > liftIO $ print (responseBody response :: Value) +-- +-- Using various optional parameters and URL that is not known in advance: +-- +-- > main :: IO () +-- > main = runReq defaultHttpConfig $ do +-- > -- This is an example of what to do when URL is given dynamically. Of +-- > -- course in a real application you may not want to use 'fromJust'. +-- > uri <- URI.mkURI "https://httpbin.org/get?foo=bar" +-- > let (url, options) = fromJust (useHttpsURI uri) +-- > response <- req GET url NoReqBody jsonResponse $ +-- > "from" =: (15 :: Int) <> +-- > "to" =: (67 :: Int) <> +-- > basicAuth "username" "password" <> +-- > options <> -- contains the ?foo=bar part +-- > port 443 -- here you can put any port of course +-- > liftIO $ print (responseBody response :: Value) +req :: + ( 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 -> + -- | Response + m response +req method url body responseProxy options = + 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' +-- 'L.BodyReader'@ manually, in a custom way. +-- +-- @since 1.0.0 +reqBr :: + ( MonadHttp m, + HttpMethod method, + HttpBody body, + HttpBodyAllowed (AllowsBody method) (ProvidesBody body) + ) => + -- | HTTP method + method -> + -- | 'Url'—location of resource + Url scheme -> + -- | Body of the request + body -> + -- | Collection of optional parameters + Option scheme -> + -- | How to consume response + (L.Response L.BodyReader -> IO a) -> + -- | Result + m a +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) + withRRef = + bracket + (newIORef Nothing) + (readIORef >=> mapM_ L.responseClose) + (liftIO . try . wrapVanilla . wrapExc) + ( withRRef $ \rref -> do + let openResponse = mask_ $ do + r <- readIORef rref + mapM_ L.responseClose r + r' <- L.responseOpen request manager + writeIORef rref (Just r') + return r' + exceptionRetryPolicies = + skipAsyncExceptions + ++ [ \retryStatus -> Handler $ \e -> + return $ httpConfigRetryJudgeException retryStatus e + ] + r <- + retrying + httpConfigRetryPolicy + (\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' + ) + >>= either handleHttpException return + +-- | Mostly like 'req' with respect to its arguments, but accepts a callback +-- that allows to perform a request in arbitrary fashion. +-- +-- This function /does not/ perform handling\/wrapping exceptions, checking +-- response (with 'httpConfigCheckResponse'), and retrying. It only prepares +-- 'L.Request' and allows you to use it. +-- +-- @since 0.3.0 +req' :: + forall m method body scheme a. + ( MonadHttp m, + HttpMethod method, + HttpBody body, + HttpBodyAllowed (AllowsBody method) (ProvidesBody body) + ) => + -- | HTTP method + method -> + -- | 'Url'—location of resource + Url scheme -> + -- | Body of the request + body -> + -- | Collection of optional parameters + Option scheme -> + -- | How to perform request + (L.Request -> L.Manager -> m a) -> + -- | Result + m a +req' method url body options m = do + config <- getHttpConfig + let -- NOTE First appearance of any given header wins. This allows to + -- “overwrite” headers when we construct a request by cons-ing. + nubHeaders = Endo $ \x -> + x {L.requestHeaders = nubBy ((==) `on` fst) (L.requestHeaders x)} + request' = + flip appEndo L.defaultRequest $ + -- NOTE The order of 'mappend's matters, here method is overwritten + -- first and 'options' take effect last. In particular, this means + -- that 'options' can overwrite things set by other request + -- components, which is useful for setting port number, + -- "Content-Type" header, etc. + nubHeaders + <> getRequestMod options + <> getRequestMod config + <> getRequestMod (Tagged body :: Tagged "body" body) + <> getRequestMod url + <> 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 m = liftIO (readIORef globalManager) >>= m + +-- | 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 +-- it will be shared, i.e. computed only once on the first use of the +-- manager. From that moment on the 'IORef' will be just reused—exactly the +-- behavior we want here in order to maximize connection sharing. GHC could +-- spoil the plan by inlining the definition, hence the @NOINLINE@ pragma. +globalManager :: IORef L.Manager +globalManager = unsafePerformIO $ do + context <- NC.initConnectionContext + let settings = + L.mkManagerSettingsContext + (Just context) + def + Nothing + manager <- L.newManager settings + newIORef manager +{-# NOINLINE globalManager #-} + +---------------------------------------------------------------------------- +-- Embedding requests in your monad + +-- $embedding-requests +-- +-- To use 'req' in your monad, all you need to do is to make the monad an +-- instance of the 'MonadHttp' type class. +-- +-- 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 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 + -- | 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 + -- 'Control.Monad.Except.MonadError', this is the right place to pass it to + -- 'Control.Monad.Except.throwError'. + handleHttpException :: HttpException -> m a + + -- | 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 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. + -- Default value: 'Nothing'. + httpConfigProxy :: Maybe L.Proxy, + -- | How many redirects to follow when getting a resource. Default + -- value: 10. + httpConfigRedirectCount :: Int, + -- | Alternative 'L.Manager' to use. 'Nothing' (default value) means + -- that the default implicit manager will be used (that's what you want + -- in 99% of cases). + httpConfigAltManager :: Maybe L.Manager, + -- | Function to check the response immediately after receiving the + -- status and headers, before streaming of response body. The third + -- argument is the beginning of response body (typically first 1024 + -- bytes). This is used for throwing exceptions on non-success status + -- codes by default (set to @\\_ _ _ -> Nothing@ if this behavior is not + -- desirable). + -- + -- When the value this function returns is 'Nothing', nothing will + -- happen. When it there is 'L.HttpExceptionContent' inside 'Just', it + -- will be thrown. + -- + -- Throwing is better then just returning a request with non-2xx status + -- code because in that case something is wrong and we need a way to + -- short-cut execution (also remember that Req retries automatically on + -- request timeouts and such, so when your request fails, it's certainly + -- something exceptional). The thrown exception is caught by the library + -- though and is available in 'handleHttpException'. + -- + -- __Note__: signature of this function was changed in the version + -- /1.0.0/. + -- + -- @since 0.3.0 + httpConfigCheckResponse :: + forall b. + L.Request -> + L.Response b -> + ByteString -> + Maybe L.HttpExceptionContent, + -- | The retry policy to use for request retrying. By default 'def' is + -- used (see 'RetryPolicyM'). + -- + -- __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, + -- | The function is used to decide whether to retry a request. 'True' + -- means that the request should be retried. + -- + -- __Note__: signature of this function was changed in the version + -- /1.0.0/. + -- + -- @since 0.3.0 + 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) + +-- | The default value of 'HttpConfig'. +-- +-- @since 2.0.0 +defaultHttpConfig :: HttpConfig +defaultHttpConfig = + HttpConfig + { httpConfigProxy = Nothing, + httpConfigRedirectCount = 10, + httpConfigAltManager = Nothing, + httpConfigCheckResponse = \_ response preview -> + let scode = statusCode response + in if 200 <= scode && scode < 300 + then Nothing + else Just (L.StatusCodeException (void response) preview), + httpConfigRetryPolicy = retryPolicyDefault, + httpConfigRetryJudge = \_ response -> + statusCode response + `elem` [ 408, -- Request timeout + 504, -- Gateway timeout + 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 + +instance RequestComponent HttpConfig where + getRequestMod HttpConfig {..} = Endo $ \x -> + x + { L.proxy = httpConfigProxy, + L.redirectCount = httpConfigRedirectCount, + LI.requestManagerOverride = httpConfigAltManager + } + +-- | A monad that allows us to run 'req' in any 'IO'-enabled monad without +-- having to define new instances. +-- +-- @since 0.4.0 +newtype Req a = Req (ReaderT HttpConfig IO a) + deriving + ( Functor, + Applicative, + Monad, + 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 + +instance MonadBaseControl IO Req where + type StM Req a = a + liftBaseWith f = Req . ReaderT $ \r -> f (runReq r) + {-# INLINEABLE liftBaseWith #-} + restoreM = Req . ReaderT . const . return + {-# INLINEABLE restoreM #-} + +instance MonadHttp Req where + 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 +-- the case of an exceptional situation an 'HttpException' will be thrown. +-- +-- @since 0.4.0 +runReq :: + (MonadIO m) => + -- | 'HttpConfig' to use + HttpConfig -> + -- | Computation to run + Req a -> + m a +runReq config (Req m) = liftIO (runReaderT m config) + +---------------------------------------------------------------------------- +-- Request—Method + +-- $method +-- +-- The package supports all methods as defined by RFC 2616, and 'PATCH' +-- which is defined by RFC 5789—that should be enough to talk to RESTful +-- APIs. In some cases, however, you may want to add more methods (e.g. you +-- work with WebDAV ); no need to +-- compromise on type safety and hack, it only takes a couple of seconds to +-- define a new method that will works seamlessly, see 'HttpMethod'. + +-- | 'GET' method. +data GET = GET + +instance HttpMethod GET where + type AllowsBody GET = 'NoBody + httpMethodName Proxy = Y.methodGet + +-- | 'POST' method. +data POST = POST + +instance HttpMethod POST where + type AllowsBody POST = 'CanHaveBody + httpMethodName Proxy = Y.methodPost + +-- | 'HEAD' method. +data HEAD = HEAD + +instance HttpMethod HEAD where + type AllowsBody HEAD = 'NoBody + httpMethodName Proxy = Y.methodHead + +-- | 'PUT' method. +data PUT = PUT + +instance HttpMethod PUT where + type AllowsBody PUT = 'CanHaveBody + httpMethodName Proxy = Y.methodPut + +-- | '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 = 'CanHaveBody + httpMethodName Proxy = Y.methodDelete + +-- | 'TRACE' method. +data TRACE = TRACE + +instance HttpMethod TRACE where + type AllowsBody TRACE = 'CanHaveBody + httpMethodName Proxy = Y.methodTrace + +-- | 'CONNECT' method. +data CONNECT = CONNECT + +instance HttpMethod CONNECT where + type AllowsBody CONNECT = 'CanHaveBody + httpMethodName Proxy = Y.methodConnect + +-- | 'OPTIONS' method. +data OPTIONS = OPTIONS + +instance HttpMethod OPTIONS where + type AllowsBody OPTIONS = 'NoBody + httpMethodName Proxy = Y.methodOptions + +-- | 'PATCH' method. +data PATCH = PATCH + +instance HttpMethod PATCH where + type AllowsBody PATCH = 'CanHaveBody + httpMethodName Proxy = Y.methodPatch + +-- | A type class for types that can be used as an HTTP method. To define a +-- non-standard method, follow this example that defines @COPY@: +-- +-- > data COPY = COPY +-- > +-- > instance HttpMethod COPY where +-- > type AllowsBody COPY = 'CanHaveBody +-- > httpMethodName Proxy = "COPY" +class HttpMethod a where + -- | Type function 'AllowsBody' returns a type of kind 'CanHaveBody' which + -- tells the rest of the library whether the method can have body or not. + -- We use the special type 'CanHaveBody' lifted to the kind level instead + -- of 'Bool' to get more user-friendly compiler messages. + type AllowsBody a :: CanHaveBody + + -- | Return name of the method as a 'ByteString'. + httpMethodName :: Proxy a -> ByteString + +instance (HttpMethod method) => RequestComponent (Tagged "method" method) where + getRequestMod _ = Endo $ \x -> + x {L.method = httpMethodName (Proxy :: Proxy method)} + +---------------------------------------------------------------------------- +-- Request—URL + +-- $url +-- +-- We use 'Url's which are correct by construction, see 'Url'. To build a +-- 'Url' from a 'URI', use 'useHttpURI', 'useHttpsURI', or generic 'useURI'. + +-- | Request's 'Url'. Start constructing your 'Url' with 'http' or 'https' +-- specifying the scheme and host at the same time. Then use the @('/~')@ +-- and @('/:')@ operators to grow the path one piece at a time. Every single +-- piece of path will be url(percent)-encoded, so using @('/~')@ and +-- @('/:')@ is the only way to have forward slashes between path segments. +-- This approach makes working with dynamic path segments easy and safe. See +-- examples below how to represent various 'Url's (make sure the +-- @OverloadedStrings@ language extension is enabled). +-- +-- ==== __Examples__ +-- +-- > http "httpbin.org" +-- > -- http://httpbin.org +-- +-- > https "httpbin.org" +-- > -- https://httpbin.org +-- +-- > https "httpbin.org" /: "encoding" /: "utf8" +-- > -- https://httpbin.org/encoding/utf8 +-- +-- > https "httpbin.org" /: "foo" /: "bar/baz" +-- > -- https://httpbin.org/foo/bar%2Fbaz +-- +-- > https "httpbin.org" /: "bytes" /~ (10 :: Int) +-- > -- https://httpbin.org/bytes/10 +-- +-- > https "юникод.рф" +-- > -- https://%D1%8E%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4.%D1%80%D1%84 +data Url (scheme :: Scheme) = Url Scheme (NonEmpty Text) + -- NOTE The second value is the path segments in reversed order. + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +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 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) + 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@. +http :: Text -> Url 'Http +http = Url Http . pure + +-- | Given host name, produce a 'Url' which has “https” as its scheme and +-- empty path. This also sets port to @443@. +https :: Text -> Url 'Https +https = Url Https . pure + +-- | 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 +Url secure path /~ segment = Url secure (NE.cons (toUrlPiece segment) path) + +-- | 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. +-- +-- This function expects the scheme to be “http” and host to be present. +-- +-- @since 3.0.0 +useHttpURI :: URI -> Maybe (Url 'Http, Option scheme) +useHttpURI uri = do + guard (URI.uriScheme uri == Just [QQ.scheme|http|]) + urlHead <- http <$> uriHost uri + let url = case URI.uriPath uri of + Nothing -> urlHead + Just uriPath -> uriPathToUrl uriPath urlHead + return (url, uriOptions uri) + +-- | Just like 'useHttpURI', but expects the “https” scheme. +-- +-- @since 3.0.0 +useHttpsURI :: URI -> Maybe (Url 'Https, Option scheme) +useHttpsURI uri = do + guard (URI.uriScheme uri == Just [QQ.scheme|https|]) + urlHead <- https <$> uriHost uri + let url = case URI.uriPath uri of + Nothing -> urlHead + 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. +-- +-- @since 3.0.0 +useURI :: + URI -> + Maybe + ( Either + (Url 'Http, Option scheme0) + (Url 'Https, Option scheme1) + ) +useURI uri = + (Left <$> useHttpURI uri) <|> (Right <$> useHttpsURI uri) + +-- | An internal helper function to extract host from a 'URI'. +uriHost :: URI -> Maybe Text +uriHost uri = case URI.uriAuthority uri of + Left _ -> Nothing + Right URI.Authority {..} -> + Just (URI.unRText authHost) + +-- | A quasiquoter to build an 'Url' and 'Option' tuple. The type of the +-- generated expression is @('Url' scheme0, 'Option' scheme1)@ with +-- @scheme0@ being either 'Http' or 'Https' depending on the input. +-- +-- @since 3.2.0 +urlQ :: TH.QuasiQuoter +urlQ = + TH.QuasiQuoter + { quoteExp = \str -> + case URI.mkURI (T.pack str) of + Left err -> fail (displayException err) + Right uri -> case useURI uri of + Nothing -> fail "Not a HTTP or HTTPS URL" + Just eurl -> + TH.tupE + [ either (TH.lift . fst) (TH.lift . fst) eurl, + [|uriOptions uri|] + ], + quotePat = error "This usage is not supported", + quoteType = error "This usage is not supported", + quoteDec = error "This usage is not supported" + } + +-- | An internal helper function to extract 'Option's from a 'URI'. +uriOptions :: forall scheme. URI -> Option scheme +uriOptions uri = + mconcat + [ auth, + query, + port' + -- , fragment' + ] + where + (auth, port') = + case URI.uriAuthority uri of + Left _ -> (mempty, mempty) + Right URI.Authority {..} -> + let auth0 = case authUserInfo of + Nothing -> mempty + Just URI.UserInfo {..} -> + let username = T.encodeUtf8 (URI.unRText uiUsername) + password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword + in basicAuthUnsafe username password + port0 = case authPort of + Nothing -> mempty + Just port'' -> port (fromIntegral port'') + in (auth0, port0) + query = + let liftQueryParam = \case + URI.QueryFlag t -> queryFlag (URI.unRText t) + URI.QueryParam k v -> URI.unRText k =: URI.unRText v + in mconcat (liftQueryParam <$> URI.uriQuery uri) + +-- TODO Blocked on upstream: https://github.com/snoyberg/http-client/issues/424 +-- fragment' = +-- case URI.uriFragment uri of +-- Nothing -> mempty +-- Just fragment'' -> fragment (URI.unRText fragment'') + +instance RequestComponent (Url scheme) where + getRequestMod (Url scheme segments) = Endo $ \x -> + let (host :| path) = NE.reverse segments + in x + { L.secure = case scheme of + Http -> False + Https -> True, + L.port = case scheme of + Http -> 80 + Https -> 443, + L.host = Y.urlEncode False (T.encodeUtf8 host), + L.path = + (BL.toStrict . BB.toLazyByteString . Y.encodePathSegments) path + } + +---------------------------------------------------------------------------- +-- Request—Body + +-- $body +-- +-- A number of options for request bodies are available. The @Content-Type@ +-- header is set for you automatically according to the body option you use +-- (it's always specified in the documentation for a given body option). To +-- add your own way to represent request body, define an instance of +-- 'HttpBody'. + +-- | This data type represents empty body of an HTTP request. This is the +-- data type to use with 'HttpMethod's that cannot have a body, as it's the +-- only type for which 'ProvidesBody' returns 'NoBody'. +-- +-- Using of this body option does not set the @Content-Type@ header. +data NoReqBody = NoReqBody + +instance HttpBody NoReqBody where + getRequestBody NoReqBody = L.RequestBodyBS B.empty + +-- | 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 + 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 streaming. +-- +-- Using of this body option does not set the @Content-Type@ header. +newtype ReqBodyFile = ReqBodyFile FilePath + +instance HttpBody ReqBodyFile where + getRequestBody (ReqBodyFile path) = + LI.RequestBodyIO (L.streamFile path) + +-- | HTTP request body represented by a strict 'ByteString'. +-- +-- Using of this body option does not set the @Content-Type@ header. +newtype ReqBodyBs = ReqBodyBs ByteString + +instance HttpBody ReqBodyBs where + getRequestBody (ReqBodyBs bs) = L.RequestBodyBS bs + +-- | HTTP request body represented by a lazy 'BL.ByteString'. +-- +-- Using of this body option does not set the @Content-Type@ header. +newtype ReqBodyLbs = ReqBodyLbs BL.ByteString + +instance HttpBody ReqBodyLbs where + getRequestBody (ReqBodyLbs bs) = L.RequestBodyLBS bs + +-- | 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. +newtype ReqBodyUrlEnc = ReqBodyUrlEnc FormUrlEncodedParam + +instance HttpBody ReqBodyUrlEnc where + getRequestBody (ReqBodyUrlEnc (FormUrlEncodedParam params)) = + (L.RequestBodyLBS . BB.toLazyByteString) (Y.renderQueryText False params) + getRequestContentType _ = pure "application/x-www-form-urlencoded" + +-- | An opaque monoidal value that allows to collect URL-encoded parameters +-- to be wrapped in 'ReqBodyUrlEnc'. +newtype FormUrlEncodedParam = FormUrlEncodedParam [(Text, Maybe Text)] + deriving (Semigroup, Monoid) + +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 +-- parts. 'reqBodyMultipart' is the only way to get a value of the type +-- 'ReqBodyMultipart', as its constructor is not exported on purpose. +-- +-- @since 0.2.0 +-- +-- ==== __Examples__ +-- +-- > import Control.Monad.IO.Class +-- > import Data.Default.Class +-- > import Network.HTTP.Req +-- > import qualified Network.HTTP.Client.MultipartFormData as LM +-- > +-- > main :: IO () +-- > main = runReq def $ do +-- > body <- +-- > reqBodyMultipart +-- > [ LM.partBS "title" "My Image" +-- > , LM.partFileSource "file1" "/tmp/image.jpg" +-- > ] +-- > response <- +-- > req POST (http "example.com" /: "post") +-- > body +-- > bsResponse +-- > mempty +-- > liftIO $ print (responseBody response) +data ReqBodyMultipart = ReqBodyMultipart ByteString LI.RequestBody + +instance HttpBody ReqBodyMultipart where + getRequestBody (ReqBodyMultipart _ body) = body + getRequestContentType (ReqBodyMultipart boundary _) = + pure ("multipart/form-data; boundary=" <> boundary) + +-- | Create 'ReqBodyMultipart' request body from a collection of 'LM.Part's. +-- +-- @since 0.2.0 +reqBodyMultipart :: (MonadIO m) => [LM.Part] -> m ReqBodyMultipart +reqBodyMultipart parts = liftIO $ do + boundary <- LM.webkitBoundary + body <- LM.renderParts boundary parts + return (ReqBodyMultipart boundary body) + +-- | A type class for things that can be interpreted as an HTTP +-- 'L.RequestBody'. +class HttpBody body where + -- | How to get actual 'L.RequestBody'. + getRequestBody :: body -> L.RequestBody + + -- | This method allows us to optionally specify the value of + -- @Content-Type@ header that should be used with particular body option. + -- By default it returns 'Nothing' and so @Content-Type@ is not set. + getRequestContentType :: body -> Maybe ByteString + getRequestContentType = const Nothing + +-- | The type function recognizes 'NoReqBody' as having 'NoBody', while any +-- other body option 'CanHaveBody'. This forces the user to use 'NoReqBody' +-- with 'GET' method and other methods that should not have body. +type family ProvidesBody body :: CanHaveBody where + ProvidesBody NoReqBody = 'NoBody + ProvidesBody body = 'CanHaveBody + +-- | 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'. +type family + HttpBodyAllowed + (allowsBody :: CanHaveBody) + (providesBody :: CanHaveBody) :: + Constraint + where + HttpBodyAllowed 'NoBody 'NoBody = () + HttpBodyAllowed 'CanHaveBody body = () + HttpBodyAllowed 'NoBody 'CanHaveBody = + TypeError + ('Text "This HTTP method does not allow attaching a request body.") + +instance (HttpBody body) => RequestComponent (Tagged "body" body) where + getRequestMod (Tagged body) = Endo $ \x -> + x + { L.requestBody = getRequestBody body, + L.requestHeaders = + let old = L.requestHeaders x + in case getRequestContentType body of + Nothing -> old + Just contentType -> + (Y.hContentType, contentType) : old + } + +---------------------------------------------------------------------------- +-- Request—Optional parameters + +-- $optional-parameters +-- +-- Optional parameters of request include things like query parameters, +-- headers, port number, etc. All optional parameters have the type +-- 'Option', which is a 'Monoid'. This means that you can use 'mempty' as +-- the last argument of 'req' to specify no optional parameters, or combine +-- 'Option's using 'mappend' or @('<>')@ to have several of them at once. + +-- | The opaque 'Option' type is a 'Monoid' you can use to pack collection +-- of optional parameters like query parameters and headers. See sections +-- below to learn which 'Option' primitives are available. +data Option (scheme :: Scheme) + = 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 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. + +instance Semigroup (Option scheme) where + Option er0 mr0 <> Option er1 mr1 = + Option + (er0 <> er1) + (mr0 <|> mr1) + +instance Monoid (Option scheme) where + 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 +withQueryParams f = Option (Endo (first f)) Nothing + +-- | A helper to create an 'Option' that modifies only 'L.Request'. This +-- helper is not a part of public API. +withRequest :: (L.Request -> L.Request) -> Option scheme +withRequest f = Option (Endo (second f)) Nothing + +instance RequestComponent (Option scheme) where + getRequestMod (Option f _) = Endo $ \x -> + let (qparams, x') = appEndo f ([], x) + query = Y.renderQuery True (Y.queryTextToQuery qparams) + in x' {L.queryString = query} + +-- | 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 (Option _ mfinalizer) = liftIO . fromMaybe pure mfinalizer + +---------------------------------------------------------------------------- +-- Request—Optional parameters—Query Parameters + +-- $query-parameters +-- +-- This section describes a polymorphic interface that can be used to +-- construct query parameters (of the type 'Option') and form URL-encoded +-- bodies (of the type 'FormUrlEncodedParam'). + +-- | This operator builds a query parameter that will be included in URL of +-- your request after the question sign @?@. This is the same syntax you use +-- with form URL encoded request bodies. +-- +-- This operator is defined in terms of 'queryParam': +-- +-- > name =: value = queryParam name (pure value) +infix 7 =: + +(=:) :: (QueryParam param, ToHttpApiData a) => Text -> a -> param +name =: value = queryParam name (pure value) + +-- | 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: +-- +-- > https://httpbin.org/foo/bar?a&b=10 +-- +-- This operator is defined in terms of 'queryParam': +-- +-- > queryFlag name = queryParam name (Nothing :: Maybe ()) +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. +-- Having the same syntax for these cases seems natural and user-friendly. +class QueryParam param where + -- | Create a query parameter with given name and value. If value is + -- '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 + + -- | 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 + +-- | Create an 'Option' that adds a header. Note that if you 'mappend' two +-- headers with the same names the leftmost header will win. This means, in +-- particular, that you cannot create a request with several headers of the +-- same name. +header :: + -- | Header name + ByteString -> + -- | Header value + ByteString -> + Option scheme +header name value = withRequest (attachHeader name value) + +-- | Attach a header with given name and content to a 'L.Request'. +-- +-- @since 1.1.0 +attachHeader :: ByteString -> ByteString -> L.Request -> L.Request +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 + +-- $cookies +-- +-- Support for cookies is quite minimalistic at the moment. It's possible to +-- specify which cookies to send using 'cookieJar' and inspect 'L.Response' +-- to extract 'L.CookieJar' from it (see 'responseCookieJar'). + +-- | Use the given 'L.CookieJar'. A 'L.CookieJar' can be obtained from a +-- 'L.Response' record. +cookieJar :: L.CookieJar -> Option scheme +cookieJar jar = withRequest $ \x -> + x {L.cookieJar = Just jar} + +---------------------------------------------------------------------------- +-- Request—Optional parameters—Authentication + +-- $authentication +-- +-- This section provides the common authentication helpers in the form of +-- 'Option's. You should always prefer the provided authentication 'Option's +-- to manual construction of headers because it ensures that you only use +-- one authentication method at a time (they overwrite each other) and +-- provides additional type safety that prevents leaking of credentials in +-- the cases when authentication relies on HTTPS for encrypting sensitive +-- data. + +-- | The 'Option' adds basic authentication. +-- +-- See also: . +basicAuth :: + -- | Username + ByteString -> + -- | Password + ByteString -> + -- | Auth 'Option' + Option 'Https +basicAuth = basicAuthUnsafe + +-- | An alternative to 'basicAuth' which works for any scheme. Note that +-- using basic access authentication without SSL\/TLS is vulnerable to +-- attacks. Use 'basicAuth' instead unless you know what you are doing. +-- +-- @since 0.3.1 +basicAuthUnsafe :: + -- | Username + ByteString -> + -- | Password + ByteString -> + -- | Auth 'Option' + Option scheme +basicAuthUnsafe username password = + customAuth + (pure . L.applyBasicAuth username password) + +-- | The 'Option' set basic proxy authentication header. +-- +-- @since 1.1.0 +basicProxyAuth :: + -- | Username + ByteString -> + -- | Password + ByteString -> + -- | Auth 'Option' + Option scheme +basicProxyAuth username password = + withRequest (L.applyBasicProxyAuth username password) + +-- | The 'Option' adds OAuth1 authentication. +-- +-- @since 0.2.0 +oAuth1 :: + -- | Consumer token + ByteString -> + -- | Consumer secret + ByteString -> + -- | OAuth token + ByteString -> + -- | OAuth token secret + ByteString -> + -- | Auth 'Option' + Option scheme +oAuth1 consumerToken consumerSecret token tokenSecret = + customAuth (OAuth.signOAuth app creds) + where + app = + OAuth.newOAuth + { OAuth.oauthConsumerKey = consumerToken, + OAuth.oauthConsumerSecret = consumerSecret + } + creds = OAuth.newCredential token tokenSecret + +-- | The 'Option' adds an OAuth2 bearer token. This is treated by many +-- services as the equivalent of a username and password. +-- +-- The 'Option' is defined as: +-- +-- > oAuth2Bearer token = header "Authorization" ("Bearer " <> token) +-- +-- See also: . +oAuth2Bearer :: + -- | Token + ByteString -> + -- | Auth 'Option' + Option 'Https +oAuth2Bearer token = + customAuth + (pure . attachHeader "Authorization" ("Bearer " <> token)) + +-- | The 'Option' adds a not-quite-standard OAuth2 bearer token (that seems +-- to be used only by GitHub). This will be treated by whatever services +-- accept it as the equivalent of a username and password. +-- +-- The 'Option' is defined as: +-- +-- > oAuth2Token token = header "Authorization" ("token" <> token) +-- +-- See also: . +oAuth2Token :: + -- | Token + ByteString -> + -- | Auth 'Option' + Option 'Https +oAuth2Token token = + customAuth + (pure . attachHeader "Authorization" ("token " <> token)) + +-- | A helper to create custom authentication 'Option's. The given +-- 'IO'-enabled request transformation is applied after all other +-- modifications when constructing a request. Use wisely. +-- +-- @since 1.1.0 +customAuth :: (L.Request -> IO L.Request) -> Option scheme +customAuth = Option mempty . pure + +---------------------------------------------------------------------------- +-- Request—Optional parameters—Other + +-- | 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 us to choose an arbitrary port overwriting the defaults. +port :: Int -> Option scheme +port n = withRequest $ \x -> + x {L.port = n} + +-- | This 'Option' controls whether gzipped data should be decompressed on +-- the fly. By default everything except for @\"application\/x-tar\"@ is +-- decompressed, i.e. we have: +-- +-- > decompress (/= "application/x-tar") +-- +-- You can also choose to decompress everything like this: +-- +-- > decompress (const True) +decompress :: + -- | 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 -> + x {L.decompress = f} + +-- | Specify the number of microseconds to wait for response. The default +-- value is 30 seconds (defined in 'L.ManagerSettings' of connection +-- 'L.Manager'). +responseTimeout :: + -- | Number of microseconds to wait + Int -> + Option scheme +responseTimeout n = withRequest $ \x -> + x {L.responseTimeout = LI.ResponseTimeoutMicro n} + +-- | HTTP version to send to the server, the default is HTTP 1.1. +httpVersion :: + -- | Major version number + Int -> + -- | Minor version number + Int -> + Option scheme +httpVersion major minor = withRequest $ \x -> + x {L.requestVersion = Y.HttpVersion major minor} + +---------------------------------------------------------------------------- +-- Response interpretations + +-- | Make a request and ignore the body of the response. +newtype IgnoreResponse = IgnoreResponse (L.Response ()) + deriving (Show) + +instance HttpResponse IgnoreResponse where + type HttpResponseBody IgnoreResponse = () + toVanillaResponse (IgnoreResponse r) = r + getHttpResponse r = return $ IgnoreResponse (void r) + +-- | Use this as the fourth argument of 'req' to specify that you want it to +-- ignore the response body. +ignoreResponse :: Proxy IgnoreResponse +ignoreResponse = Proxy + +-- | Make a request and interpret the body of the response as JSON. The +-- 'handleHttpException' method of 'MonadHttp' instance corresponding to +-- 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 + type HttpResponseBody (JsonResponse a) = a + toVanillaResponse (JsonResponse r) = r + getHttpResponse r = do + chunks <- L.brConsume (L.responseBody r) + case A.eitherDecode (BL.fromChunks chunks) of + Left e -> throwIO (JsonHttpException e) + Right x -> return $ JsonResponse (x <$ r) + acceptHeader Proxy = Just "application/json" + +-- | Use this as the fourth argument of 'req' to specify that you want it to +-- return the 'JsonResponse' interpretation. +jsonResponse :: Proxy (JsonResponse a) +jsonResponse = Proxy + +-- | 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 + toVanillaResponse (BsResponse r) = r + getHttpResponse r = do + chunks <- L.brConsume (L.responseBody r) + return $ BsResponse (B.concat chunks <$ r) + +-- | Use this as the fourth argument of 'req' to specify that you want to +-- interpret the response body as a strict 'ByteString'. +bsResponse :: Proxy BsResponse +bsResponse = Proxy + +-- | 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 + toVanillaResponse (LbsResponse r) = r + getHttpResponse r = do + chunks <- L.brConsume (L.responseBody r) + return $ LbsResponse (BL.fromChunks chunks <$ r) + +-- | Use this as the fourth argument of 'req' to specify that you want to +-- interpret the response body as a lazy 'BL.ByteString'. +lbsResponse :: Proxy LbsResponse +lbsResponse = Proxy + +---------------------------------------------------------------------------- +-- Helpers for response interpretations + +-- | 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 :: + -- | How many bytes to fetch + Int -> + -- | Response with body reader inside + L.Response L.BodyReader -> + -- | Preview 'ByteString' and new response with body reader inside + IO (ByteString, L.Response L.BodyReader) +grabPreview nbytes r = do + let br = L.responseBody r + (target, leftover, done) <- brReadN br nbytes + nref <- newIORef (0 :: Int) + let br' = do + n <- readIORef nref + let incn = modifyIORef' nref (+ 1) + case n of + 0 -> do + incn + if B.null target + then br' + else return target + 1 -> do + incn + if B.null leftover + then br' + else return leftover + _ -> + if done + then return B.empty + else br + return (target, r {L.responseBody = br'}) + +-- | Consume N bytes from 'L.BodyReader', return the target chunk, the +-- leftover (may be empty), and whether we're done consuming the body. +brReadN :: + -- | Body reader to stream from + L.BodyReader -> + -- | How many bytes to consume + Int -> + -- | Target chunk, the leftover, whether we're done + IO (ByteString, ByteString, Bool) +brReadN br n = go 0 id id + where + go !tlen t l = do + chunk <- br + if B.null chunk + then return (r t, r l, True) + else do + let (target, leftover) = B.splitAt (n - tlen) chunk + tlen' = B.length target + t' = t . (target :) + l' = l . (leftover :) + if tlen + tlen' < n + then go (tlen + tlen') t' l' + else return (r t', r l', False) + r f = B.concat (f []) + +---------------------------------------------------------------------------- +-- Inspecting a response + +-- | Get the response body. +responseBody :: + (HttpResponse response) => + response -> + HttpResponseBody response +responseBody = L.responseBody . toVanillaResponse + +-- | Get the response status code. +responseStatusCode :: + (HttpResponse response) => + response -> + Int +responseStatusCode = + Y.statusCode . L.responseStatus . toVanillaResponse + +-- | Get the response status message. +responseStatusMessage :: + (HttpResponse response) => + response -> + ByteString +responseStatusMessage = + Y.statusMessage . L.responseStatus . toVanillaResponse + +-- | Lookup a particular header from a response. +responseHeader :: + (HttpResponse response) => + -- | Response interpretation + response -> + -- | Header to lookup + ByteString -> + -- | Header value if found + Maybe ByteString +responseHeader r h = + (lookup (CI.mk h) . L.responseHeaders . toVanillaResponse) r + +-- | Get the response 'L.CookieJar'. +responseCookieJar :: + (HttpResponse response) => + response -> + L.CookieJar +responseCookieJar = L.responseCookieJar . toVanillaResponse + +---------------------------------------------------------------------------- +-- Response—Defining your own interpretation + +-- $new-response-interpretation +-- +-- 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 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'. + type HttpResponseBody response :: Type + + -- | The method describes how to get the underlying 'L.Response' record. + toVanillaResponse :: response -> L.Response (HttpResponseBody response) + + -- | This method describes how to consume response body and, more + -- generally, obtain @response@ value from @'L.Response' 'L.BodyReader'@. + -- + -- __Note__: 'L.BodyReader' is nothing but @'IO' 'ByteString'@. You should + -- call this action repeatedly until it yields the empty 'ByteString'. In + -- that case streaming of response is finished (which apparently leads to + -- closing of the connection, so don't call the reader after it has + -- returned the empty 'ByteString' once) and you can concatenate the + -- chunks to obtain the final result. (Of course you could as well stream + -- the contents to a file or do whatever you want.) + -- + -- __Note__: signature of this function was changed in the version + -- /1.0.0/. + getHttpResponse :: + -- | Response with body reader inside + L.Response L.BodyReader -> + -- | The final result + IO response + + -- | The value of @\"Accept\"@ header. This is useful, for example, if a + -- website supports both @XML@ and @JSON@ responses, and decides what to + -- reply with based on what @Accept@ headers you have sent. + -- + -- __Note__: manually specified 'Options' that set the @\"Accept\"@ header + -- will take precedence. + -- + -- @since 2.1.0 + 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 + +-- | The main class for things that are “parts” of 'L.Request' in the sense +-- that if we have a 'L.Request', then we know how to apply an instance of +-- 'RequestComponent' changing\/overwriting something in it. 'Endo' is a +-- monoid of endomorphisms under composition, it's used to chain different +-- request components easier using @('<>')@. +-- +-- __Note__: this type class is not a part of the public API. +class RequestComponent a where + -- | Get a function that takes a 'L.Request' and changes it somehow + -- returning another 'L.Request'. For example, the 'HttpMethod' instance + -- of 'RequestComponent' just overwrites method. The function is wrapped + -- in 'Endo' so it's easier to chain such “modifying applications” + -- together building bigger and bigger 'RequestComponent's. + getRequestMod :: a -> Endo L.Request + +-- | This wrapper is only used to attach a type-level tag to a given type. +-- This is necessary to define instances of 'RequestComponent' for any thing +-- that implements 'HttpMethod' or 'HttpBody'. Without the tag, GHC can't +-- see the difference between @'HttpMethod' method => 'RequestComponent' +-- 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 Tagged (tag :: Symbol) a = Tagged a + +-- | Exceptions that this library throws. +data HttpException + = -- | A wrapper with an 'L.HttpException' from "Network.HTTP.Client" + VanillaHttpException L.HttpException + | -- | A wrapper with Aeson-produced 'String' describing why decoding + -- failed + JsonHttpException String + deriving (Show, Typeable, Generic) + +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. +-- +-- See also: 'HttpMethod' and 'HttpBody'. +data CanHaveBody + = -- | Indeed can have a body + CanHaveBody + | -- | Should not have a body + NoBody + +-- | A type-level tag that specifies URL scheme used (and thus if HTTPS is +-- enabled). This is used to force TLS requirement for some authentication +-- 'Option's. +data Scheme + = -- | HTTP + Http + | -- | HTTPS + Https + deriving (Eq, Ord, Show, Data, Typeable, Generic, TH.Lift) 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) @@ -20,69 +18,56 @@ import Control.Monad.IO.Class import Data.Aeson -import Data.Default.Class import Network.HTTP.Req main :: IO () -- You can either make your monad an instance of 'MonadHttp', or use -- 'runReq' in any IO-enabled monad without defining new instances. -main = runReq def $ do - let payload = object - [ "foo" .= (10 :: Int) - , "bar" .= (20 :: Int) ] +main = runReq defaultHttpConfig $ do + let payload = + object + [ "foo" .= (10 :: Int), + "bar" .= (20 :: Int) + ] -- One function—full power and flexibility, automatic retrying on timeouts -- and such, automatic connection sharing. - r <- req POST -- method - (https "httpbin.org" /: "post") -- safe by construction URL - (ReqBodyJson payload) -- use built-in options or add your own - jsonResponse -- specify how to interpret response - mempty -- query params, headers, explicit port number, etc. + r <- + req + POST -- method + (https "httpbin.org" /: "post") -- safe by construction URL + (ReqBodyJson payload) -- use built-in options or add your own + jsonResponse -- specify how to interpret response + mempty -- query params, headers, explicit port number, etc. 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 a 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 a 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 a -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 boilerplate down 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: @@ -92,97 +77,11 @@ * [`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 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 such -a common thing and still 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, set, set instead of *being forced* -to declare necessary bits and *being allowed* to declare optional bits in a -way that their combination is certainly valid. And 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 `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. - -It's funny that one client I worked for had to have his own little wrapper -around `http-client` just because he could not possibly use `wreq` and -`http-client` and friends were too low-level. The previous paragraph is -extracted from a talk with a Haskell developer who works for that client. I -thought to myself “something is wrong with HTTP client libraries in Haskell -if they had to make a wrapper”. - -What else? 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, good luck passing 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 The following packages are designed to be used with Req: @@ -202,10 +101,10 @@ Issues, bugs, and questions may be reported in [the GitHub issue tracker for this project](https://github.com/mrkkrp/req/issues). -Pull requests are also welcome and will be reviewed quickly. +Pull requests are also welcome. ## License -Copyright © 2016–2018 Mark Karpov +Copyright © 2016–present Mark Karpov Distributed under BSD 3 clause license. 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,39 +1,37 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.HTTP.ReqSpec - ( spec ) -where +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 (Value (..), ToJSON (..), object, (.=)) -import Data.Default.Class -import Data.Monoid ((<>)) +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 Network.HTTP.Req +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 -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 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 qualified Network.HTTP.Types as Y 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 @@ -41,7 +39,7 @@ describe "exception throwing on non-2xx status codes (Req monad)" $ it "throws indeed for non-2xx" $ - asIO . runReq def $ + asIO . runReq defaultHttpConfig $ liftBaseWith $ \run -> run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty) `shouldThrow` selector404 @@ -52,41 +50,61 @@ 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 (httpbin /: "user-agent") - NoReqBody jsonResponse (header "user-agent" "Req") - responseBody r `shouldBe` object - ["user-agent" .= ("Req" :: Text)] - responseStatusCode r `shouldBe` 200 + r <- + req + GET + (httpbin /: "user-agent") + NoReqBody + jsonResponse + (header "user-agent" "Req") + responseBody r + `shouldBe` object + ["user-agent" .= ("Req" :: Text)] + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving request headers back" $ it "works" $ do - r <- req GET (httpbin /: "headers") - NoReqBody jsonResponse (header "Foo" "bar" <> header "Baz" "quux") - stripFunnyHeaders (responseBody r) `shouldBe` object - [ "headers" .= object - [ "Accept-Encoding" .= ("gzip" :: Text) - , "Connection" .= ("close" :: Text) - , "Foo" .= ("bar" :: Text) - , "Baz" .= ("quux" :: Text) - , "Host" .= ("httpbin.org" :: Text) ] ] - responseStatusCode r `shouldBe` 200 + r <- + req + GET + (httpbin /: "headers") + NoReqBody + jsonResponse + (header "Foo" "bar" <> header "Baz" "quux") + stripFunnyHeaders (responseBody r) + `shouldBe` object + [ "headers" + .= object + [ "Accept-Encoding" .= ("gzip" :: Text), + "Foo" .= ("bar" :: Text), + "Baz" .= ("quux" :: Text) + ] + ] + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" 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) - , "headers" .= object - [ "Accept-Encoding" .= ("gzip" :: Text) - , "Connection" .= ("close" :: Text) - , "Host" .= ("httpbin.org" :: Text) ] ] + (stripFunnyHeaders . stripOrigin) (responseBody r) + `shouldBe` object + [ "args" .= emptyObject, + "url" .= ("http://localhost:1234/get" :: Text), + "headers" + .= object + [ "Accept-Encoding" .= ("gzip" :: Text) + ] + ] responseHeader r "Content-Type" `shouldBe` return "application/json" - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving POST JSON data back" $ @@ -94,49 +112,55 @@ let text = "foo" :: Text reflected = reflectJSON text r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty - (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object - [ "args" .= emptyObject - , "json" .= text - , "data" .= reflected - , "url" .= ("https://httpbin.org/post" :: Text) - , "headers" .= object - [ "Content-Type" .= ("application/json; charset=utf-8" :: Text) - , "Accept-Encoding" .= ("gzip" :: Text) - , "Connection" .= ("close" :: Text) - , "Host" .= ("httpbin.org" :: Text) - , "Content-Length" .= show (T.length reflected) ] - , "files" .= emptyObject - , "form" .= emptyObject ] + (stripFunnyHeaders . stripOrigin) (responseBody r) + `shouldBe` object + [ "args" .= emptyObject, + "json" .= text, + "data" .= reflected, + "url" .= ("http://localhost:1234/post" :: Text), + "headers" + .= object + [ "Content-Type" .= ("application/json; charset=utf-8" :: Text), + "Accept-Encoding" .= ("gzip" :: Text), + "Content-Length" .= show (T.length reflected) + ], + "files" .= emptyObject, + "form" .= emptyObject + ] responseHeader r "Content-Type" `shouldBe` return "application/json" - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving POST data back (multipart form data)" $ it "works" $ do - body <- reqBodyMultipart - [ LM.partBS "foo" "foo data!" - , LM.partBS "bar" "bar data!" ] + 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 - (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object - [ "args" .= emptyObject - , "json" .= Null - , "data" .= ("" :: Text) - , "url" .= ("https://httpbin.org/post" :: Text) - , "headers" .= object - [ "Content-Type" .= T.decodeUtf8 contentType - , "Accept-Encoding" .= ("gzip" :: Text) - , "Connection" .= ("close" :: Text) - , "Host" .= ("httpbin.org" :: Text) - , "Content-Length" .= ("242" :: Text) + let contentType = fromJust (getRequestContentType body) + (stripFunnyHeaders . stripOrigin) (responseBody r) + `shouldBe` object + [ "args" .= emptyObject, + "json" .= Null, + "data" .= ("" :: Text), + "url" .= ("http://localhost:1234/post" :: Text), + "headers" + .= object + [ "Content-Type" .= T.decodeUtf8 contentType, + "Accept-Encoding" .= ("gzip" :: Text), + "Content-Length" .= ("242" :: Text) + ], + "files" .= emptyObject, + "form" + .= object + [ "foo" .= ("foo data!" :: Text), + "bar" .= ("bar data!" :: Text) + ] ] - , "files" .= emptyObject - , "form" .= object - [ "foo" .= ("foo data!" :: Text) - , "bar" .= ("bar data!" :: Text) ] - ] responseHeader r "Content-Type" `shouldBe` return "application/json" - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving PATCHed file back" $ @@ -145,57 +169,69 @@ file = "httpbin-data/robots.txt" contents <- TIO.readFile file r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty - (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object - [ "args" .= emptyObject - , "json" .= Null - , "data" .= contents - , "url" .= ("https://httpbin.org/patch" :: Text) - , "headers" .= object - [ "Accept-Encoding" .= ("gzip" :: Text) - , "Connection" .= ("close" :: Text) - , "Host" .= ("httpbin.org" :: Text) - , "Content-Length" .= show (T.length contents) ] - , "files" .= emptyObject - , "form" .= emptyObject ] + (stripFunnyHeaders . stripOrigin) (responseBody r) + `shouldBe` object + [ "args" .= emptyObject, + "json" .= Null, + "data" .= contents, + "url" .= ("http://localhost:1234/patch" :: Text), + "headers" + .= object + [ "Accept-Encoding" .= ("gzip" :: Text), + "Content-Length" .= show (T.length contents) + ], + "files" .= emptyObject, + "form" .= emptyObject + ] responseHeader r "Content-Type" `shouldBe` return "application/json" - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving PUT form URL-encoded data back" $ it "works" $ do - let params = "foo" =: ("bar" :: Text) <> - "baz" =: (5 :: Int) <> - queryFlag "quux" + let params = + "foo" =: ("bar" :: Text) + <> "baz" =: (5 :: Int) + <> queryFlag "quux" r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty - (stripFunnyHeaders . stripOrigin) (responseBody r) `shouldBe` object - [ "args" .= emptyObject - , "json" .= Null - , "data" .= ("" :: Text) - , "url" .= ("https://httpbin.org/put" :: Text) - , "headers" .= object - [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text) - , "Accept-Encoding" .= ("gzip" :: Text) - , "Connection" .= ("close" :: Text) - , "Host" .= ("httpbin.org" :: Text) - , "Content-Length" .= ("18" :: Text) ] - , "files" .= emptyObject - , "form" .= object - [ "foo" .= ("bar" :: Text) - , "baz" .= ("5" :: Text) - , "quux" .= ("" :: Text) ] ] + (stripFunnyHeaders . stripOrigin) (responseBody r) + `shouldBe` object + [ "args" .= emptyObject, + "json" .= Null, + "data" .= ("" :: Text), + "url" .= ("http://localhost:1234/put" :: Text), + "headers" + .= object + [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text), + "Accept-Encoding" .= ("gzip" :: Text), + "Content-Length" .= ("18" :: Text) + ], + "files" .= emptyObject, + "form" + .= object + [ "foo" .= ("bar" :: Text), + "baz" .= ("5" :: Text), + "quux" .= ("" :: Text) + ] + ] responseHeader r "Content-Type" `shouldBe` return "application/json" - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /delete describe "receiving UTF-8 encoded Unicode data" $ it "works" $ do - r <- req GET (httpbin /: "encoding" /: "utf8") - NoReqBody bsResponse mempty + r <- + req + GET + (httpbin /: "encoding" /: "utf8") + NoReqBody + bsResponse + mempty utf8data <- B.readFile "httpbin-data/utf8.html" - responseBody r `shouldBe` utf8data - responseStatusCode r `shouldBe` 200 + responseBody r `shouldBe` utf8data + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /gzip @@ -206,24 +242,35 @@ -- FIXME We no longer can count retries because all the functions -- responsible for controlling retrying are pure now. let status = 408 :: Int - r <- prepareForShit $ req GET (httpbin /: "status" /~ status) - NoReqBody ignoreResponse mempty + r <- + prepareForShit $ + req + GET + (httpbin /: "status" /~ status) + NoReqBody + ignoreResponse + mempty responseStatusCode r `shouldBe` status -- forM_ [101..102] checkStatusCode - forM_ [200..208] checkStatusCode + forM_ [200 .. 208] checkStatusCode -- forM_ [300..308] checkStatusCode - forM_ [400..431] checkStatusCode - forM_ [500..511] checkStatusCode + forM_ [400 .. 431] checkStatusCode + forM_ [500 .. 511] checkStatusCode -- TODO /response-headers -- TODO /redirect describe "redirects" $ it "follows redirects" $ do - r <- req GET (httpbin /: "redirect-to") NoReqBody ignoreResponse - ("url" =: ("https://httpbin.org" :: Text)) - responseStatusCode r `shouldBe` 200 + r <- + req + GET + (httpbin /: "redirect-to") + NoReqBody + ignoreResponse + ("url" =: ("https://httpbin.org" :: Text)) + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /relative-redicet @@ -232,21 +279,30 @@ describe "basicAuth" $ do let user, password :: Text - user = "Scooby" + user = "Scooby" password = "Doo" context "when we do not send appropriate basic auth data" $ it "fails with 401" $ do - r <- prepareForShit $ req GET - (httpbin /: "basic-auth" /~ user /~ password) - NoReqBody ignoreResponse mempty - responseStatusCode r `shouldBe` 401 + r <- + prepareForShit $ + req + GET + (httpbin /: "basic-auth" /~ user /~ password) + NoReqBody + ignoreResponse + mempty + responseStatusCode r `shouldBe` 401 responseStatusMessage r `shouldBe` "UNAUTHORIZED" 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)) - responseStatusCode r `shouldBe` 200 + r <- + req + GET + (httpbin /: "basic-auth" /~ user /~ password) + NoReqBody + ignoreResponse + (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password)) + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /hidden-basic-auth @@ -261,8 +317,8 @@ it "works" $ do r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty robots <- B.readFile "httpbin-data/robots.txt" - responseBody r `shouldBe` robots - responseStatusCode r `shouldBe` 200 + responseBody r `shouldBe` robots + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /deny @@ -273,10 +329,15 @@ property $ \n' -> do let n :: Word n = getSmall n' - r <- req GET (httpbin /: "bytes" /~ n) - NoReqBody lbsResponse mempty + r <- + req + GET + (httpbin /: "bytes" /~ n) + NoReqBody + lbsResponse + mempty responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length) - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" context "when we try to interpret 1000 random bytes as JSON" $ it "throws correct exception" $ do @@ -285,29 +346,38 @@ selector _ = False n :: Int n = 1000 - req GET (httpbin /: "bytes" /~ n) NoReqBody - (Proxy :: Proxy (JsonResponse Value)) mempty - `shouldThrow` selector + req + GET + (httpbin /: "bytes" /~ n) + NoReqBody + (Proxy :: Proxy (JsonResponse Value)) + 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 + r <- + req + GET + (httpbin /: "stream-bytes" /~ n) + NoReqBody + bsResponse + mempty responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length) - responseStatusCode r `shouldBe` 200 + responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" - -- TODO /links - -- TODO /image - -- TODO /image/png - -- TODO /image/jpeg - -- TODO /image/webp - -- TODO /image/svg - -- TODO /forms/post - -- TODO /xml +-- TODO /links +-- TODO /image +-- TODO /image/png +-- TODO /image/jpeg +-- TODO /image/webp +-- TODO /image/svg +-- TODO /forms/post +-- TODO /xml ---------------------------------------------------------------------------- -- Instances @@ -318,81 +388,125 @@ ---------------------------------------------------------------------------- -- 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 def { httpConfigCheckResponse = noNoise } +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 def { httpConfigCheckResponse = doit } +blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit} where doit _ _ = error "Oops!" -- | 'Url' representing . +httpbin :: Url 'Http +httpbin = http "localhost" -httpbin :: Url 'Https -httpbin = https "httpbin.org" +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 value = value +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" - , "Connection" - , "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 - r <- prepareForShit $ req GET (httpbin /: "status" /~ code) - NoReqBody ignoreResponse mempty + r <- + prepareForShit $ + req + GET + (httpbin /: "status" /~ code) + NoReqBody + ignoreResponse + mempty responseStatusCode r `shouldBe` code -- | Exception selector that selects only 404 “Not found” exceptions. - selector404 :: HttpException -> Bool -selector404 (VanillaHttpException - (L.HttpExceptionRequest _ - (L.StatusCodeException response chunk))) = - L.responseStatus response == Y.status404 && not (B.null chunk) +selector404 + ( VanillaHttpException + ( L.HttpExceptionRequest + _ + (L.StatusCodeException response chunk) + ) + ) = + 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 - --- | Get rendered JSON value as 'Text'. +emptyObject = Object Aeson.KeyMap.empty -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' -- monad. - asIO :: IO a -> IO a asIO = id 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,61 +1,71 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.HTTP.ReqSpec - ( spec ) -where +module Network.HTTP.ReqSpec (spec) where +import Blaze.ByteString.Builder qualified as BB import Control.Exception (throwIO) +import Control.Monad +import Control.Retry import Data.Aeson (ToJSON (..)) +import Data.Aeson qualified as A import Data.ByteString (ByteString) -import Data.Default.Class -import Data.Maybe (isNothing, fromJust) -import Data.Monoid ((<>)) +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 Data.List.NonEmpty qualified as NE +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.Proxy import Data.Text (Text) +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 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 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 qualified Blaze.ByteString.Builder as BB -import qualified Data.Aeson as A -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 qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.HTTP.Client as L -import qualified Network.HTTP.Types as Y -import qualified Network.HTTP.Types.Header as Y +import Text.URI (URI) +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.proxy request `shouldBe` httpConfigProxy config L.redirectCount request `shouldBe` httpConfigRedirectCount config describe "methods" $ do - let mnth - :: forall method. - ( HttpMethod method - , HttpBodyAllowed (AllowsBody method) 'NoBody ) - => method - -> SpecM () () + let mnth :: + forall method. + ( HttpMethod method, + HttpBodyAllowed (AllowsBody method) 'NoBody + ) => + method -> + SpecM () () mnth method = do let name = httpMethodName (Proxy :: Proxy method) describe (B8.unpack name) $ @@ -78,15 +88,15 @@ 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 + 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 + 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 @@ -101,68 +111,96 @@ request <- req_ GET url' NoReqBody mempty L.host request `shouldBe` urlEncode host L.path request `shouldBe` encodePathPieces pieces - describe "parseUrlHttp" $ do + + describe "useHttpURI" $ do it "does not recognize non-http schemes" $ - parseUrlHttp "https://httpbin.org" `shouldSatisfy` isNothing - it "parses correct URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Http host mport' pieces queryParams - (url'', options) = fromJust (parseUrlHttp url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 80 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "rejects gibberish in port component" $ do - parseUrlHttp "http://my-site.com:bob/far" `shouldSatisfy` isNothing - parseUrlHttp "http://my-site.com:7001uh/api" `shouldSatisfy` isNothing - parseUrlHttp "http://my-site.com:/bar" `shouldSatisfy` isNothing - describe "parseUrlHttps" $ do + property $ \uri -> + when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $ + useHttpURI uri `shouldSatisfy` isNothing + 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) + request <- req_ GET url' NoReqBody options + L.host request `shouldBe` uriHost uri + L.port request `shouldBe` uriPort 80 uri + L.path request `shouldBe` uriPath uri + L.queryString request `shouldBe` uriQuery uri + lookup "Authorization" (L.requestHeaders request) + `shouldBe` uriBasicAuth uri + describe "useHttpsURI" $ do it "does not recognize non-https schemes" $ - parseUrlHttps "http://httpbin.org" `shouldSatisfy` isNothing + property $ \uri -> + when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $ + useHttpsURI uri `shouldSatisfy` isNothing it "parses correct URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Https host mport' pieces queryParams - (url'', options) = fromJust (parseUrlHttps url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 443 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "rejects gibberish in port component" $ do - parseUrlHttp "https://my-site.com:bob/far" `shouldSatisfy` isNothing - parseUrlHttp "https://my-site.com:7001uh/api" `shouldSatisfy` isNothing - parseUrlHttp "https://my-site.com:/bar" `shouldSatisfy` isNothing - describe "parseUrl" $ do + property $ \uri' -> do + unless (isRight (URI.uriAuthority uri')) discard + let uri = uri' {URI.uriScheme = Just [QQ.scheme|https|]} + (url', options) = fromJust (useHttpsURI uri) + request <- req_ GET url' NoReqBody options + L.host request `shouldBe` uriHost uri + L.port request `shouldBe` uriPort 443 uri + L.path request `shouldBe` uriPath uri + L.queryString request `shouldBe` uriQuery uri + lookup "Authorization" (L.requestHeaders request) + `shouldBe` uriBasicAuth uri + describe "useURI" $ do it "does not recognize non-http and non-https schemes" $ - parseUrl "ftp://httpbin.org" `shouldSatisfy` isNothing - it "parses correct http URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Http host mport' pieces queryParams - Left (url'', options) = fromJust (parseUrl url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 80 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "parses correct https URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Https host mport' pieces queryParams - Right (url'', options) = fromJust (parseUrl url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 443 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "rejects gibberish in port component" $ do - parseUrl "http://my-site.com:bob/far" `shouldSatisfy` isNothing - parseUrl "https://my-site.com:7001uh/api" `shouldSatisfy` isNothing - parseUrl "http://my-site.com:/bar" `shouldSatisfy` isNothing + 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 + unless (isRight (URI.uriAuthority uri')) discard + let uriHttp = uri' {URI.uriScheme = Just [QQ.scheme|http|]} + uriHttps = uri' {URI.uriScheme = Just [QQ.scheme|https|]} + requestHttp <- + case fromJust (useURI uriHttp) of + Left (url', options) -> req_ GET url' NoReqBody options + _ -> error "(useURI uriHttp) should have returned Left" + requestHttps <- + 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 + L.port requestHttps `shouldBe` uriPort 443 uriHttps + L.path requestHttp `shouldBe` uriPath uriHttp + L.path requestHttps `shouldBe` uriPath uriHttps + L.queryString requestHttp `shouldBe` uriQuery uriHttp + L.queryString requestHttps `shouldBe` uriQuery uriHttps + lookup "Authorization" (L.requestHeaders requestHttp) + `shouldBe` uriBasicAuth uriHttp + 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 @@ -185,7 +223,7 @@ L.RequestBodyBS x -> x `shouldBe` bs _ -> expectationFailure "Wrong request body constructor." describe "ReqBodyLbs" $ - it "sets body to specified lazy byte string" $ + it "sets body to specified lazy byte string" $ property $ \lbs -> do request <- req_ POST url (ReqBodyLbs lbs) mempty case L.requestBody request of @@ -199,6 +237,19 @@ L.RequestBodyLBS x -> x `shouldBe` renderQuery params _ -> expectationFailure "Wrong request body constructor." + describe "query params" $ do + describe "FormUrlEncodedParam" $ do + describe "formToQuery" $ do + it "should produce the same parameters as F.urlEncodeFormStable" $ + property $ \form -> do + request <- req_ POST url (ReqBodyUrlEnc $ formToQuery form) mempty + case L.requestBody request of + L.RequestBodyLBS x -> x `shouldBe` F.urlEncodeFormStable form + _ -> expectationFailure "Wrong request body constructor" + specParamToList (Proxy :: Proxy FormUrlEncodedParam) + describe "Option" $ do + specParamToList (Proxy :: Proxy (Option 'Http)) + describe "optional parameters" $ do describe "header" $ do it "sets specified header value" $ @@ -207,94 +258,136 @@ lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value it "left header wins" $ property $ \name value0 value1 -> do - request <- req_ GET url NoReqBody - (header name value0 <> header name value1) + request <- + req_ + GET + url + 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 - request <- req_ POST url (ReqBodyUrlEnc mempty) - (header "Content-Type" value) + request <- + req_ + POST + url + (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) - L.cookieJar request `shouldBe` pure cjar + L.cookieJar request `shouldSatisfy` (maybe False (L.equalCookieJar cjar)) describe "basicAuth" $ 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` - pure (basicAuthHeader username password) + lookup "Authorization" (L.requestHeaders request) + `shouldBe` Just (basicAuthHeader username password) it "overwrites manual setting of header" $ property $ \username password value -> do - request0 <- req_ GET url NoReqBody - (basicAuth username password <> header "Authorization" value) - request1 <- req_ GET url NoReqBody - (header "Authorization" value <> basicAuth username password) - let result = basicAuthHeader username password - lookup "Authorization" (L.requestHeaders request0) `shouldBe` - pure result - lookup "Authorization" (L.requestHeaders request1) `shouldBe` - pure result + request0 <- + req_ + GET + url + NoReqBody + (basicAuth username password <> header "Authorization" value) + request1 <- + req_ + GET + url + NoReqBody + (header "Authorization" value <> basicAuth username password) + 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 - request <- req_ GET url NoReqBody - (basicAuth username0 password0 <> basicAuth username1 password1) - lookup "Authorization" (L.requestHeaders request) `shouldBe` - pure (basicAuthHeader username0 password0) + request <- + req_ + GET + url + NoReqBody + (basicAuth username0 password0 <> basicAuth username1 password1) + lookup "Authorization" (L.requestHeaders request) + `shouldBe` Just (basicAuthHeader username0 password0) describe "oAuth2Bearer" $ 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) + lookup "Authorization" (L.requestHeaders request) + `shouldBe` pure ("Bearer " <> token) it "overwrites manual setting of header" $ property $ \token value -> do - request0 <- req_ GET url NoReqBody - (oAuth2Bearer token <> header "Authorization" value) - request1 <- req_ GET url NoReqBody - (header "Authorization" value <> oAuth2Bearer token) + request0 <- + req_ + GET + url + NoReqBody + (oAuth2Bearer token <> header "Authorization" value) + request1 <- + req_ + GET + url + NoReqBody + (header "Authorization" value <> oAuth2Bearer token) let result = "Bearer " <> token - lookup "Authorization" (L.requestHeaders request0) `shouldBe` - pure result - lookup "Authorization" (L.requestHeaders request1) `shouldBe` - pure result + lookup "Authorization" (L.requestHeaders request0) + `shouldBe` pure result + lookup "Authorization" (L.requestHeaders request1) + `shouldBe` pure result it "left auth option wins" $ property $ \token0 token1 -> do - request <- req_ GET url NoReqBody - (oAuth2Bearer token0 <> oAuth2Bearer token1) - lookup "Authorization" (L.requestHeaders request) `shouldBe` - pure ("Bearer " <> token0) - describe "ProxyAuthorization" $ do + request <- + req_ + GET + url + NoReqBody + (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) + lookup "Proxy-Authorization" (L.requestHeaders request) + `shouldBe` pure (basicProxyAuthHeader username password) describe "oAuth2Token" $ 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) + lookup "Authorization" (L.requestHeaders request) + `shouldBe` pure ("token " <> token) it "overwrites manual setting of header" $ property $ \token value -> do - request0 <- req_ GET url NoReqBody - (oAuth2Token token <> header "Authorization" value) - request1 <- req_ GET url NoReqBody - (header "Authorization" value <> oAuth2Token token) + request0 <- + req_ + GET + url + NoReqBody + (oAuth2Token token <> header "Authorization" value) + request1 <- + req_ + GET + url + NoReqBody + (header "Authorization" value <> oAuth2Token token) let result = "token " <> token - lookup "Authorization" (L.requestHeaders request0) `shouldBe` - pure result - lookup "Authorization" (L.requestHeaders request1) `shouldBe` - pure result + lookup "Authorization" (L.requestHeaders request0) + `shouldBe` pure result + lookup "Authorization" (L.requestHeaders request1) + `shouldBe` pure result it "left auth option wins" $ property $ \token0 token1 -> do - request <- req_ GET url NoReqBody - (oAuth2Token token0 <> oAuth2Token token1) - lookup "Authorization" (L.requestHeaders request) `shouldBe` - pure ("token " <> token0) + request <- + req_ + GET + url + NoReqBody + (oAuth2Token token0 <> oAuth2Token token1) + lookup "Authorization" (L.requestHeaders request) + `shouldBe` pure ("token " <> token0) describe "port" $ it "sets port overwriting the defaults" $ property $ \n -> do @@ -314,6 +407,19 @@ request <- req_ GET url NoReqBody (httpVersion major minor) L.requestVersion request `shouldBe` Y.HttpVersion major minor + describe "quasiquoter" $ do + it "works for valid urls" $ + -- Doing it this way instead of just checking if [urlQ|...|] :: (Url + -- '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 + 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 + ---------------------------------------------------------------------------- -- Instances @@ -322,21 +428,27 @@ instance Arbitrary HttpConfig where arbitrary = do - httpConfigProxy <- arbitrary + httpConfigProxy <- arbitrary httpConfigRedirectCount <- arbitrary - let httpConfigAltManager = Nothing + let httpConfigAltManager = Nothing httpConfigCheckResponse _ _ _ = Nothing - httpConfigRetryPolicy = def - httpConfigRetryJudge _ _ = False + httpConfigRetryPolicy = retryPolicyDefault + httpConfigRetryJudge _ _ = False + httpConfigRetryJudgeException _ _ = False + httpConfigBodyPreviewLength = 1024 return HttpConfig {..} instance Show HttpConfig where show HttpConfig {..} = - "HttpConfig\n" ++ - "{ httpConfigProxy=" ++ show httpConfigProxy ++ "\n" ++ - ", httpRedirectCount=" ++ show httpConfigRedirectCount ++ "\n" ++ - ", httpConfigAltManager=\n" ++ - ", httpConfigCheckResponse=}\n" + "HttpConfig\n" + ++ "{ httpConfigProxy=" + ++ show httpConfigProxy + ++ "\n" + ++ ", httpRedirectCount=" + ++ show httpConfigRedirectCount + ++ "\n" + ++ ", httpConfigAltManager=\n" + ++ ", httpConfigCheckResponse=}\n" instance Arbitrary L.Proxy where arbitrary = L.Proxy <$> arbitrary <*> arbitrary @@ -354,9 +466,10 @@ show _ = "" data Thing = Thing - { _thingBool :: Bool - , _thingText :: Text - } deriving (Eq, Show, Generic) + { _thingBool :: Bool, + _thingText :: Text + } + deriving (Eq, Show, Generic) instance ToJSON Thing @@ -368,17 +481,17 @@ instance Arbitrary L.Cookie where arbitrary = do - cookie_name <- arbitrary - cookie_value <- arbitrary - cookie_expiry_time <- arbitrary - cookie_domain <- arbitrary - cookie_path <- arbitrary + cookie_name <- arbitrary + cookie_value <- arbitrary + cookie_expiry_time <- arbitrary + cookie_domain <- arbitrary + cookie_path <- arbitrary cookie_creation_time <- arbitrary cookie_last_access_time <- arbitrary - cookie_persistent <- arbitrary - cookie_host_only <- arbitrary - cookie_secure_only <- arbitrary - cookie_http_only <- arbitrary + cookie_persistent <- arbitrary + cookie_host_only <- arbitrary + cookie_secure_only <- arbitrary + cookie_http_only <- arbitrary return L.Cookie {..} instance Arbitrary UTCTime where @@ -390,19 +503,20 @@ instance Arbitrary DiffTime where arbitrary = secondsToDiffTime <$> arbitrary +instance Arbitrary F.Form where + arbitrary = (F.Form . fromList) <$> arbitrary + ---------------------------------------------------------------------------- -- Helper types -- | A wrapper to generate correct hosts. - -newtype Host = Host { unHost :: Text } +newtype Host = Host {unHost :: Text} deriving (Eq, Show) instance Arbitrary Host where arbitrary = Host . T.pack <$> listOf1 (arbitrary `suchThat` (/= ':')) -- | A wrapper to generate correct query parameters. - newtype QueryParams = QueryParams [(Text, Maybe Text)] deriving (Eq, Show) @@ -415,68 +529,84 @@ -- Helpers -- | 'req' that just returns the prepared 'L.Request'. - -req_ - :: ( MonadHttp m - , HttpMethod method - , HttpBody body - , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) - => method -- ^ HTTP method - -> Url scheme -- ^ 'Url' — location of resource - -> body -- ^ Body of the request - -> Option scheme -- ^ Collection of optional parameters - -> m L.Request -- ^ Vanilla request +req_ :: + ( MonadHttp m, + HttpMethod method, + HttpBody body, + HttpBodyAllowed (AllowsBody method) (ProvidesBody body) + ) => + -- | HTTP method + method -> + -- | 'Url' — location of resource + Url scheme -> + -- | Body of the request + body -> + -- | Collection of optional parameters + Option scheme -> + -- | Vanilla request + m L.Request req_ method url' body options = req' method url' body options $ \request _ -> return request -- | A dummy 'Url'. - url :: Url 'Https url = https "httpbin.org" -- | Percent encode given 'Text'. - urlEncode :: Text -> ByteString urlEncode = Y.urlEncode False . T.encodeUtf8 -- | Build URL path from given path pieces. - encodePathPieces :: [Text] -> ByteString encodePathPieces = BL.toStrict . BB.toLazyByteString . Y.encodePathSegments --- | Assemble a URL. +-- | Get host from a 'URI'. This function is not total. +uriHost :: URI -> ByteString +uriHost uri = + fromJust $ + urlEncode . URI.unRText . URI.authHost + <$> either (const Nothing) Just (URI.uriAuthority uri) -assembleUrl - :: Scheme -- ^ Scheme - -> Host -- ^ Host - -> Maybe (NonNegative Int) -- ^ Port - -> [Text] -- ^ Path pieces - -> QueryParams -- ^ Query parameters - -> (ByteString, ByteString, ByteString) -- ^ URL, path, query string -assembleUrl scheme' (Host host') mport' pathPieces (QueryParams queryParams) = - (scheme <> host <> port' <> path <> queryString, path, queryString) - where - scheme = case scheme' of - Http -> "http://" - Https -> "https://" - host = urlEncode host' - port' = - case mport' of - Nothing -> "" - Just (NonNegative x) -> ":" <> B8.pack (show x) - path = encodePathPieces pathPieces - queryString = Y.renderQuery True (Y.queryTextToQuery queryParams) +-- | Get part from a 'URI' defaulting to the provided value. +uriPort :: Int -> URI -> Int +uriPort def uri = + maybe def (fromIntegral) $ + either (const Nothing) Just (URI.uriAuthority uri) >>= URI.authPort +-- | Get the path from a 'URI'. +uriPath :: URI -> ByteString +uriPath uri = fromMaybe "" $ do + (trailingSlash, xs) <- URI.uriPath uri + let pref = (encodePathPieces . fmap URI.unRText . NE.toList) xs + return $ if trailingSlash then pref <> "/" else pref + +-- | Get the query string from a 'URI'. +uriQuery :: URI -> ByteString +uriQuery uri = do + let liftQueryParam = \case + URI.QueryFlag t -> (URI.unRText t, Nothing) + URI.QueryParam k v -> (URI.unRText k, Just (URI.unRText v)) + Y.renderQuery True (Y.queryTextToQuery (liftQueryParam <$> (URI.uriQuery uri))) + +-- | Predict the headrs that should be set if the given 'URI' has username +-- and password in it. +uriBasicAuth :: URI -> Maybe ByteString +uriBasicAuth uri = do + auth <- either (const Nothing) Just (URI.uriAuthority uri) + URI.UserInfo {..} <- URI.authUserInfo auth + let username = T.encodeUtf8 (URI.unRText uiUsername) + password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword + return (basicAuthHeader username password) + +-- | Render a query as lazy 'BL.ByteString'. renderQuery :: [(Text, Maybe Text)] -> BL.ByteString renderQuery = BL.fromStrict . Y.renderQuery False . Y.queryTextToQuery -- | Convert collection of query parameters to 'FormUrlEncodedParam' thing. - formUrlEnc :: [(Text, Maybe Text)] -> FormUrlEncodedParam formUrlEnc = foldMap (uncurry queryParam) -- | Get “Authorization” basic auth header given username and password. - basicAuthHeader :: ByteString -> ByteString -> ByteString basicAuthHeader username password = fromJust . lookup Y.hAuthorization . L.requestHeaders $ @@ -484,8 +614,19 @@ -- | Get "Proxy-Authorization" basic proxy auth header given username and -- password. - basicProxyAuthHeader :: ByteString -> ByteString -> ByteString 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,114 +1,127 @@ -name: req -version: 1.2.1 -cabal-version: 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 -license: BSD3 -license-file: LICENSE.md -author: Mark Karpov -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/req -bug-reports: https://github.com/mrkkrp/req/issues -category: Network, Web -synopsis: Easy-to-use, type-safe, expandable, high-level HTTP client library -build-type: Simple -description: Easy-to-use, type-safe, expandable, high-level HTTP client library. -extra-doc-files: CHANGELOG.md - , README.md -data-files: httpbin-data/utf8.html - , httpbin-data/robots.txt +cabal-version: 2.4 +name: req +version: 3.13.4 +license: BSD-3-Clause +license-file: LICENSE.md +maintainer: Mark Karpov +author: Mark Karpov +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: HTTP client library +description: HTTP client library. +category: Network, Web +build-type: Simple +data-files: + httpbin-data/utf8.html + httpbin-data/robots.txt +extra-doc-files: + CHANGELOG.md + README.md + source-repository head - type: git - location: https://github.com/mrkkrp/req.git + type: git + location: https://github.com/mrkkrp/req.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: aeson >= 0.9 && < 1.5 - , authenticate-oauth >= 1.5 && < 1.7 - , base >= 4.8 && < 5.0 - , blaze-builder >= 0.3 && < 0.5 - , bytestring >= 0.10.8 && < 0.11 - , case-insensitive >= 0.2 && < 1.3 - , connection >= 0.2.2 && < 0.3 - , data-default-class - , http-api-data >= 0.2 && < 0.4 - , http-client >= 0.5 && < 0.6 - , http-client-tls >= 0.3.2 && < 0.4 - , http-types >= 0.8 && < 10.0 - , monad-control >= 1.0 && < 1.1 - , mtl >= 2.0 && < 3.0 - , retry >= 0.7 && < 0.8 - , text >= 0.2 && < 1.3 - , time >= 1.2 && < 1.9 - , transformers >= 0.4 && < 0.6 - , transformers-base - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - exposed-modules: Network.HTTP.Req - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - if flag(dev) && impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances - default-language: Haskell2010 + exposed-modules: Network.HTTP.Req + default-language: GHC2021 + build-depends: + 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.13, + case-insensitive >=0.2 && <1.3, + 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, + modern-uri >=0.3 && <0.4, + monad-control >=1.0 && <1.1, + mtl >=2.0 && <3.0, + 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: + -Wall -Werror -Wpartial-fields -Wunused-packages + -Wno-unused-imports + + else + ghc-options: -O2 -Wall + test-suite pure-tests - main-is: Spec.hs - other-modules: Network.HTTP.ReqSpec - hs-source-dirs: pure-tests - type: exitcode-stdio-1.0 - build-depends: QuickCheck >= 2.7 && < 3.0 - , aeson >= 0.9 && < 1.5 - , base >= 4.8 && < 5.0 - , blaze-builder >= 0.3 && < 0.5 - , bytestring >= 0.10.8 && < 0.11 - , case-insensitive >= 0.2 && < 1.3 - , data-default-class - , hspec >= 2.0 && < 3.0 - , hspec-core >= 2.0 && < 3.0 - , http-client >= 0.5 && < 0.6 - , http-types >= 0.8 && < 10.0 - , mtl >= 2.0 && < 3.0 - , req - , text >= 0.2 && < 1.3 - , time >= 1.2 && < 1.9 - build-tools: hspec-discover >= 2.0 && < 3.0 - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - 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, + aeson >=0.9 && <3, + base >=4.15 && <5.0, + blaze-builder >=0.3 && <0.5, + bytestring >=0.10.8 && <0.13, + case-insensitive >=0.2 && <1.3, + 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, + 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: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + test-suite httpbin-tests - main-is: Spec.hs - other-modules: Network.HTTP.ReqSpec - hs-source-dirs: httpbin-tests - type: exitcode-stdio-1.0 - build-depends: QuickCheck >= 2.7 && < 3.0 - , aeson >= 0.9 && < 1.5 - , base >= 4.8 && < 5.0 - , bytestring >= 0.10.8 && < 0.11 - , data-default-class - , hspec >= 2.0 && < 3.0 - , http-client >= 0.5 && < 0.6 - , http-types >= 0.8 && < 10.0 - , monad-control >= 1.0 && < 1.1 - , mtl >= 2.0 && < 3.0 - , req - , text >= 0.2 && < 1.3 - , unordered-containers >= 0.2.5 && < 0.2.10 - build-tools: hspec-discover >= 2.0 && < 3.0 - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - 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, + aeson >=2 && <3, + base >=4.15 && <5, + bytestring >=0.10.8 && <0.13, + hspec >=2.0 && <3.0, + http-client >=0.7 && <0.8, + http-types >=0.8 && <10, + monad-control >=1.0 && <1.1, + req, + text >=0.2 && <2.2 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + buildable: False