req-3.13.4/0000755000000000000000000000000007346545000010562 5ustar0000000000000000req-3.13.4/CHANGELOG.md0000644000000000000000000001720307346545000012376 0ustar0000000000000000## 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`. ## Req 1.2.0 * Added the `parseUrl` function. ## Req 1.1.0 * Added `customAuth` and `attachHeader` to facilitate creation of custom authentication options. * Added `basicProxyAuth` authentication option. ## Req 1.0.0 * Added the `reqBr` function allowing to consume `Response BodyReader` without using a pre-defined instance of `HttpResponse`, in a custom way. * Now streaming of response body does not happen until we've checked headers and status code with `httpConfigCheckResponse`. It also doesn't happen on every retry. Streaming and obtaining of final response value happens only once when we're happy with everything. Previously we first tried to consume and interpret response body before checking status code and determining whether we should retry the request. This was not good, because we could expect a JSON response but get a response with status code 500, and then still we would try to parse it as JSON first before letting `httpConfigCheckResponse` throw an exception. The corrected behavior should also make retrying more efficient. * Changed signatures of several fields of `HttpConfig`: `httpConfigCheckResponse`, `httpConfigRetryPolicy`, and `httpConfigRetryJudge` in order to eliminate redundant `IO` and prevent the possibility that these functions could start consuming `BodyReader`. * Removed the `makeResponsePreview` method from the `HttpResponse` type class. Preview business is handled by the library automatically on a lower level now. Users do not need to concern themselves with such stuff. * Changed the type signature of the `getHttpResponse` method of the `HttpResponse` type class. Previously it left too much freedom (and responsibility) to implementers of the method. In fact, we now limit what `getHttpResponse` does to just consuming and interpreting `Response BodyReader`, so we can properly control details of connection opening/closing etc., for the user. * Dropped support for GHC 7.8. * Minor documentation improvements. ## Req 0.5.0 * Changed the signature of the `makeResponseBodyPreview` from `response -> IO ByteString` to `response -> ByteString`. * Minor documentation improvements. ## Req 0.4.0 * Added the `Req` monad and `runReq` function to run it. This allows to use `req` without defining new (orphan) instances. ## Req 0.3.1 * Added `basicAuthUnsafe`. ## Req 0.3.0 * Made URL parsing functions `parseUrlHttp` and `parseUrlHttps` recognize port numbers. * Added `req'` function that allows to perform requests via a callback that receives pre-constructed request and manager. * Removed the `ReturnRequest` HTTP response implementation as it was not quite safe and was not going to work with retrying. Use `req'` instead for “pure” testing. * Changed the type of `httpConfigCheckResponse`, so the second argument can be any instance of `HttpResponse`. * Added built-in automatic retrying. See `httpConfigRetryPolicy` and `httpConfigRetryJudge` in `HttpConfig`. The default configuration retries 5 times on request timeouts. * Added the `makeResponseBodyPreview` method to the `HttpResponse` type class that allows to specify how to build a “preview” of response body for inclusion into exceptions. * Improved wording in the documentation and `README.md`. ## Req 0.2.0 * Added support for multipart form data in the form of `ReqBodyMultipart` body option and `reqBodyMultipart` helper function. This also required a change in the type signature of `getRequestContentType`, which now takes `body`, not `Proxy body` because we need to extract boundary from `body` and put it into `Content-Type` header. This change, however, shouldn't be too dangerous for end-users. * Added support for OAuth 1.0 authentication via `oAuth1` option. ## Req 0.1.0 * Initial release. req-3.13.4/LICENSE.md0000644000000000000000000000265607346545000012177 0ustar0000000000000000Copyright © 2016–present Mark Karpov All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name Mark Karpov nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. req-3.13.4/Network/HTTP/0000755000000000000000000000000007346545000012772 5ustar0000000000000000req-3.13.4/Network/HTTP/Req.hs0000644000000000000000000021256707346545000014072 0ustar0000000000000000{-# 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) req-3.13.4/README.md0000644000000000000000000001057307346545000012047 0ustar0000000000000000# Req [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![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) ![CI](https://github.com/mrkkrp/req/workflows/CI/badge.svg?branch=master) * [Related packages](#related-packages) * [Blog posts](#blog-posts) * [Contribution](#contribution) * [License](#license) ```haskell {-# LANGUAGE OverloadedStrings #-} module Main (main) where import Control.Monad.IO.Class import Data.Aeson 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 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. liftIO $ print (responseBody r :: Value) ``` 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 `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. The library uses the following mature packages under the hood to guarantee you the best experience: * [`http-client`](https://hackage.haskell.org/package/http-client)—low level HTTP client used everywhere in Haskell. * [`http-client-tls`](https://hackage.haskell.org/package/http-client-tls)—TLS (HTTPS) support for `http-client`. 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. ## Related packages The following packages are designed to be used with Req: * [`req-conduit`](https://hackage.haskell.org/package/req-conduit)—support for streaming request and response bodies in constant memory. If you happen to have written a package that adds new features to Req, please submit a PR to include it in this list. ## Blog posts * [Req 1.0.0, HTTP client, and streaming](https://markkarpov.com/post/req-1.0.0-http-client-and-streaming.html) ## Contribution 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. ## License Copyright © 2016–present Mark Karpov Distributed under BSD 3 clause license. req-3.13.4/httpbin-data/0000755000000000000000000000000007346545000013141 5ustar0000000000000000req-3.13.4/httpbin-data/robots.txt0000644000000000000000000000003607346545000015211 0ustar0000000000000000User-agent: * Disallow: /deny req-3.13.4/httpbin-data/utf8.html0000644000000000000000000003363707346545000014731 0ustar0000000000000000

Unicode Demo

Taken from http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-demo.txt


UTF-8 encoded sample plain-text file
‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

Markus Kuhn [ˈmaʳkʊs kuːn]  — 2002-07-25


The ASCII compatible UTF-8 encoding used in this plain-text file
is defined in Unicode, ISO 10646-1, and RFC 2279.


Using Unicode/UTF-8, you can write in emails and source code things such as

Mathematics and sciences:

  ∮ E⋅da = Q,  n → ∞, ∑ f(i) = ∏ g(i),      ⎧⎡⎛┌─────┐⎞⎤⎫
                                            ⎪⎢⎜│a²+b³ ⎟⎥⎪
  ∀x∈ℝ: ⌈x⌉ = −⌊−x⌋, α ∧ ¬β = ¬(¬α ∨ β),    ⎪⎢⎜│───── ⎟⎥⎪
                                            ⎪⎢⎜⎷ c₈   ⎟⎥⎪
  ℕ ⊆ ℕ₀ ⊂ ℤ ⊂ ℚ ⊂ ℝ ⊂ ℂ,                   ⎨⎢⎜       ⎟⎥⎬
                                            ⎪⎢⎜ ∞     ⎟⎥⎪
  ⊥ < a ≠ b ≡ c ≤ d ≪ ⊤ ⇒ (⟦A⟧ ⇔ ⟪B⟫),      ⎪⎢⎜ ⎲     ⎟⎥⎪
                                            ⎪⎢⎜ ⎳aⁱ-bⁱ⎟⎥⎪
  2H₂ + O₂ ⇌ 2H₂O, R = 4.7 kΩ, ⌀ 200 mm     ⎩⎣⎝i=1    ⎠⎦⎭

Linguistics and dictionaries:

  ði ıntəˈnæʃənəl fəˈnɛtık əsoʊsiˈeıʃn
  Y [ˈʏpsilɔn], Yen [jɛn], Yoga [ˈjoːgɑ]

APL:

  ((V⍳V)=⍳⍴V)/V←,V    ⌷←⍳→⍴∆∇⊃‾⍎⍕⌈

Nicer typography in plain text files:

  ╔══════════════════════════════════════════╗
  ║                                          ║
  ║   • ‘single’ and “double” quotes         ║
  ║                                          ║
  ║   • Curly apostrophes: “We’ve been here” ║
  ║                                          ║
  ║   • Latin-1 apostrophe and accents: '´`  ║
  ║                                          ║
  ║   • ‚deutsche‘ „Anführungszeichen“       ║
  ║                                          ║
  ║   • †, ‡, ‰, •, 3–4, —, −5/+5, ™, …      ║
  ║                                          ║
  ║   • ASCII safety test: 1lI|, 0OD, 8B     ║
  ║                      ╭─────────╮         ║
  ║   • the euro symbol: │ 14.95 € │         ║
  ║                      ╰─────────╯         ║
  ╚══════════════════════════════════════════╝

Combining characters:

  STARGΛ̊TE SG-1, a = v̇ = r̈, a⃑ ⊥ b⃑

Greek (in Polytonic):

  The Greek anthem:

  Σὲ γνωρίζω ἀπὸ τὴν κόψη
  τοῦ σπαθιοῦ τὴν τρομερή,
  σὲ γνωρίζω ἀπὸ τὴν ὄψη
  ποὺ μὲ βία μετράει τὴ γῆ.

  ᾿Απ᾿ τὰ κόκκαλα βγαλμένη
  τῶν ῾Ελλήνων τὰ ἱερά
  καὶ σὰν πρῶτα ἀνδρειωμένη
  χαῖρε, ὦ χαῖρε, ᾿Ελευθεριά!

  From a speech of Demosthenes in the 4th century BC:

  Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι,
  ὅταν τ᾿ εἰς τὰ πράγματα ἀποβλέψω καὶ ὅταν πρὸς τοὺς
  λόγους οὓς ἀκούω· τοὺς μὲν γὰρ λόγους περὶ τοῦ
  τιμωρήσασθαι Φίλιππον ὁρῶ γιγνομένους, τὰ δὲ πράγματ᾿
  εἰς τοῦτο προήκοντα,  ὥσθ᾿ ὅπως μὴ πεισόμεθ᾿ αὐτοὶ
  πρότερον κακῶς σκέψασθαι δέον. οὐδέν οὖν ἄλλο μοι δοκοῦσιν
  οἱ τὰ τοιαῦτα λέγοντες ἢ τὴν ὑπόθεσιν, περὶ ἧς βουλεύεσθαι,
  οὐχὶ τὴν οὖσαν παριστάντες ὑμῖν ἁμαρτάνειν. ἐγὼ δέ, ὅτι μέν
  ποτ᾿ ἐξῆν τῇ πόλει καὶ τὰ αὑτῆς ἔχειν ἀσφαλῶς καὶ Φίλιππον
  τιμωρήσασθαι, καὶ μάλ᾿ ἀκριβῶς οἶδα· ἐπ᾿ ἐμοῦ γάρ, οὐ πάλαι
  γέγονεν ταῦτ᾿ ἀμφότερα· νῦν μέντοι πέπεισμαι τοῦθ᾿ ἱκανὸν
  προλαβεῖν ἡμῖν εἶναι τὴν πρώτην, ὅπως τοὺς συμμάχους
  σώσομεν. ἐὰν γὰρ τοῦτο βεβαίως ὑπάρξῃ, τότε καὶ περὶ τοῦ
  τίνα τιμωρήσεταί τις καὶ ὃν τρόπον ἐξέσται σκοπεῖν· πρὶν δὲ
  τὴν ἀρχὴν ὀρθῶς ὑποθέσθαι, μάταιον ἡγοῦμαι περὶ τῆς
  τελευτῆς ὁντινοῦν ποιεῖσθαι λόγον.

  Δημοσθένους, Γ´ ᾿Ολυνθιακὸς

Georgian:

  From a Unicode conference invitation:

  გთხოვთ ახლავე გაიაროთ რეგისტრაცია Unicode-ის მეათე საერთაშორისო
  კონფერენციაზე დასასწრებად, რომელიც გაიმართება 10-12 მარტს,
  ქ. მაინცში, გერმანიაში. კონფერენცია შეჰკრებს ერთად მსოფლიოს
  ექსპერტებს ისეთ დარგებში როგორიცაა ინტერნეტი და Unicode-ი,
  ინტერნაციონალიზაცია და ლოკალიზაცია, Unicode-ის გამოყენება
  ოპერაციულ სისტემებსა, და გამოყენებით პროგრამებში, შრიფტებში,
  ტექსტების დამუშავებასა და მრავალენოვან კომპიუტერულ სისტემებში.

Russian:

  From a Unicode conference invitation:

  Зарегистрируйтесь сейчас на Десятую Международную Конференцию по
  Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии.
  Конференция соберет широкий круг экспертов по  вопросам глобального
  Интернета и Unicode, локализации и интернационализации, воплощению и
  применению Unicode в различных операционных системах и программных
  приложениях, шрифтах, верстке и многоязычных компьютерных системах.

Thai (UCS Level 2):

  Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
  classic 'San Gua'):

  [----------------------------|------------------------]
    ๏ แผ่นดินฮั่นเสื่อมโทรมแสนสังเวช  พระปกเกศกองบู๊กู้ขึ้นใหม่
  สิบสองกษัตริย์ก่อนหน้าแลถัดไป       สององค์ไซร้โง่เขลาเบาปัญญา
    ทรงนับถือขันทีเป็นที่พึ่ง           บ้านเมืองจึงวิปริตเป็นนักหนา
  โฮจิ๋นเรียกทัพทั่วหัวเมืองมา         หมายจะฆ่ามดชั่วตัวสำคัญ
    เหมือนขับไสไล่เสือจากเคหา      รับหมาป่าเข้ามาเลยอาสัญ
  ฝ่ายอ้องอุ้นยุแยกให้แตกกัน          ใช้สาวนั้นเป็นชนวนชื่นชวนใจ
    พลันลิฉุยกุยกีกลับก่อเหตุ          ช่างอาเพศจริงหนาฟ้าร้องไห้
  ต้องรบราฆ่าฟันจนบรรลัย           ฤๅหาใครค้ำชูกู้บรรลังก์ ฯ

  (The above is a two-column text. If combining characters are handled
  correctly, the lines of the second column should be aligned with the
  | character above.)

Ethiopian:

  Proverbs in the Amharic language:

  ሰማይ አይታረስ ንጉሥ አይከሰስ።
  ብላ ካለኝ እንደአባቴ በቆመጠኝ።
  ጌጥ ያለቤቱ ቁምጥና ነው።
  ደሀ በሕልሙ ቅቤ ባይጠጣ ንጣት በገደለው።
  የአፍ ወለምታ በቅቤ አይታሽም።
  አይጥ በበላ ዳዋ ተመታ።
  ሲተረጉሙ ይደረግሙ።
  ቀስ በቀስ፥ ዕንቁላል በእግሩ ይሄዳል።
  ድር ቢያብር አንበሳ ያስር።
  ሰው እንደቤቱ እንጅ እንደ ጉረቤቱ አይተዳደርም።
  እግዜር የከፈተውን ጉሮሮ ሳይዘጋው አይድርም።
  የጎረቤት ሌባ፥ ቢያዩት ይስቅ ባያዩት ያጠልቅ።
  ሥራ ከመፍታት ልጄን ላፋታት።
  ዓባይ ማደሪያ የለው፥ ግንድ ይዞ ይዞራል።
  የእስላም አገሩ መካ የአሞራ አገሩ ዋርካ።
  ተንጋሎ ቢተፉ ተመልሶ ባፉ።
  ወዳጅህ ማር ቢሆን ጨርስህ አትላሰው።
  እግርህን በፍራሽህ ልክ ዘርጋ።

Runes:

  ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ

  (Old English, which transcribed into Latin reads 'He cwaeth that he
  bude thaem lande northweardum with tha Westsae.' and means 'He said
  that he lived in the northern land near the Western Sea.')

Braille:

  ⡌⠁⠧⠑ ⠼⠁⠒  ⡍⠜⠇⠑⠹⠰⠎ ⡣⠕⠌

  ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠙⠑⠁⠙⠒ ⠞⠕ ⠃⠑⠛⠔ ⠺⠊⠹⠲ ⡹⠻⠑ ⠊⠎ ⠝⠕ ⠙⠳⠃⠞
  ⠱⠁⠞⠑⠧⠻ ⠁⠃⠳⠞ ⠹⠁⠞⠲ ⡹⠑ ⠗⠑⠛⠊⠌⠻ ⠕⠋ ⠙⠊⠎ ⠃⠥⠗⠊⠁⠇ ⠺⠁⠎
  ⠎⠊⠛⠝⠫ ⠃⠹ ⠹⠑ ⠊⠇⠻⠛⠹⠍⠁⠝⠂ ⠹⠑ ⠊⠇⠻⠅⠂ ⠹⠑ ⠥⠝⠙⠻⠞⠁⠅⠻⠂
  ⠁⠝⠙ ⠹⠑ ⠡⠊⠑⠋ ⠍⠳⠗⠝⠻⠲ ⡎⠊⠗⠕⠕⠛⠑ ⠎⠊⠛⠝⠫ ⠊⠞⠲ ⡁⠝⠙
  ⡎⠊⠗⠕⠕⠛⠑⠰⠎ ⠝⠁⠍⠑ ⠺⠁⠎ ⠛⠕⠕⠙ ⠥⠏⠕⠝ ⠰⡡⠁⠝⠛⠑⠂ ⠋⠕⠗ ⠁⠝⠹⠹⠔⠛ ⠙⠑
  ⠡⠕⠎⠑ ⠞⠕ ⠏⠥⠞ ⠙⠊⠎ ⠙⠁⠝⠙ ⠞⠕⠲

  ⡕⠇⠙ ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲

  ⡍⠔⠙⠖ ⡊ ⠙⠕⠝⠰⠞ ⠍⠑⠁⠝ ⠞⠕ ⠎⠁⠹ ⠹⠁⠞ ⡊ ⠅⠝⠪⠂ ⠕⠋ ⠍⠹
  ⠪⠝ ⠅⠝⠪⠇⠫⠛⠑⠂ ⠱⠁⠞ ⠹⠻⠑ ⠊⠎ ⠏⠜⠞⠊⠊⠥⠇⠜⠇⠹ ⠙⠑⠁⠙ ⠁⠃⠳⠞
  ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲ ⡊ ⠍⠊⠣⠞ ⠙⠁⠧⠑ ⠃⠑⠲ ⠔⠊⠇⠔⠫⠂ ⠍⠹⠎⠑⠇⠋⠂ ⠞⠕
  ⠗⠑⠛⠜⠙ ⠁ ⠊⠕⠋⠋⠔⠤⠝⠁⠊⠇ ⠁⠎ ⠹⠑ ⠙⠑⠁⠙⠑⠌ ⠏⠊⠑⠊⠑ ⠕⠋ ⠊⠗⠕⠝⠍⠕⠝⠛⠻⠹
  ⠔ ⠹⠑ ⠞⠗⠁⠙⠑⠲ ⡃⠥⠞ ⠹⠑ ⠺⠊⠎⠙⠕⠍ ⠕⠋ ⠳⠗ ⠁⠝⠊⠑⠌⠕⠗⠎
  ⠊⠎ ⠔ ⠹⠑ ⠎⠊⠍⠊⠇⠑⠆ ⠁⠝⠙ ⠍⠹ ⠥⠝⠙⠁⠇⠇⠪⠫ ⠙⠁⠝⠙⠎
  ⠩⠁⠇⠇ ⠝⠕⠞ ⠙⠊⠌⠥⠗⠃ ⠊⠞⠂ ⠕⠗ ⠹⠑ ⡊⠳⠝⠞⠗⠹⠰⠎ ⠙⠕⠝⠑ ⠋⠕⠗⠲ ⡹⠳
  ⠺⠊⠇⠇ ⠹⠻⠑⠋⠕⠗⠑ ⠏⠻⠍⠊⠞ ⠍⠑ ⠞⠕ ⠗⠑⠏⠑⠁⠞⠂ ⠑⠍⠏⠙⠁⠞⠊⠊⠁⠇⠇⠹⠂ ⠹⠁⠞
  ⡍⠜⠇⠑⠹ ⠺⠁⠎ ⠁⠎ ⠙⠑⠁⠙ ⠁⠎ ⠁ ⠙⠕⠕⠗⠤⠝⠁⠊⠇⠲

  (The first couple of paragraphs of "A Christmas Carol" by Dickens)

Compact font selection example text:

  ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
  abcdefghijklmnopqrstuvwxyz £©µÀÆÖÞßéöÿ
  –—‘“”„†•…‰™œŠŸž€ ΑΒΓΔΩαβγδω АБВГДабвгд
  ∀∂∈ℝ∧∪≡∞ ↑↗↨↻⇣ ┐┼╔╘░►☺♀ fi�⑀₂ἠḂӥẄɐː⍎אԱა

Greetings in various languages:

  Hello world, Καλημέρα κόσμε, コンニチハ

Box drawing alignment tests:                                          █
                                                                      ▉
  ╔══╦══╗  ┌──┬──┐  ╭──┬──╮  ╭──┬──╮  ┏━━┳━━┓  ┎┒┏┑   ╷  ╻ ┏┯┓ ┌┰┐    ▊ ╱╲╱╲╳╳╳
  ║┌─╨─┐║  │╔═╧═╗│  │╒═╪═╕│  │╓─╁─╖│  ┃┌─╂─┐┃  ┗╃╄┙  ╶┼╴╺╋╸┠┼┨ ┝╋┥    ▋ ╲╱╲╱╳╳╳
  ║│╲ ╱│║  │║   ║│  ││ │ ││  │║ ┃ ║│  ┃│ ╿ │┃  ┍╅╆┓   ╵  ╹ ┗┷┛ └┸┘    ▌ ╱╲╱╲╳╳╳
  ╠╡ ╳ ╞╣  ├╢   ╟┤  ├┼─┼─┼┤  ├╫─╂─╫┤  ┣┿╾┼╼┿┫  ┕┛┖┚     ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
  ║│╱ ╲│║  │║   ║│  ││ │ ││  │║ ┃ ║│  ┃│ ╽ │┃  ░░▒▒▓▓██ ┊  ┆ ╎ ╏  ┇ ┋ ▎
  ║└─╥─┘║  │╚═╤═╝│  │╘═╪═╛│  │╙─╀─╜│  ┃└─╂─┘┃  ░░▒▒▓▓██ ┊  ┆ ╎ ╏  ┇ ┋ ▏
  ╚══╩══╝  └──┴──┘  ╰──┴──╯  ╰──┴──╯  ┗━━┻━━┛  ▗▄▖▛▀▜   └╌╌┘ ╎ ┗╍╍┛ ┋  ▁▂▃▄▅▆▇█
                                               ▝▀▘▙▄▟
req-3.13.4/httpbin-tests/Network/HTTP/0000755000000000000000000000000007346545000015602 5ustar0000000000000000req-3.13.4/httpbin-tests/Network/HTTP/ReqSpec.hs0000644000000000000000000003711007346545000017502 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.HTTP.ReqSpec (spec) where import Control.Exception import Control.Monad (forM_) import Control.Monad.Trans.Control 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 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 spec :: Spec spec = do describe "exception throwing on non-2xx status codes" $ it "throws indeed for non-2xx" $ req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty `shouldThrow` selector404 describe "exception throwing on non-2xx status codes (Req monad)" $ it "throws indeed for non-2xx" $ asIO . runReq defaultHttpConfig $ liftBaseWith $ \run -> run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty) `shouldThrow` selector404 describe "response check via httpConfigCheckResponse" $ context "if it's set to always throw" $ it "throws indeed" $ blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty) `shouldThrow` anyException describe "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 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), "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" .= ("http://localhost:1234/get" :: Text), "headers" .= object [ "Accept-Encoding" .= ("gzip" :: Text) ] ] responseHeader r "Content-Type" `shouldBe` return "application/json" responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving POST JSON data back" $ it "works" $ do 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" .= ("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 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!" ] r <- req POST (httpbin /: "post") body jsonResponse mempty 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) ] ] responseHeader r "Content-Type" `shouldBe` return "application/json" responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" describe "receiving PATCHed file back" $ it "works" $ do let file :: FilePath 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" .= ("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 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" r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty (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 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 utf8data <- B.readFile "httpbin-data/utf8.html" responseBody r `shouldBe` utf8data responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /gzip -- TODO /deflate describe "retrying" $ it "retries as many times as specified" $ do -- FIXME We no longer can count retries because all the functions -- responsible for controlling retrying are pure now. let status = 408 :: Int r <- prepareForShit $ req GET (httpbin /: "status" /~ status) NoReqBody ignoreResponse mempty responseStatusCode r `shouldBe` status -- forM_ [101..102] checkStatusCode forM_ [200 .. 208] checkStatusCode -- forM_ [300..308] 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 responseStatusMessage r `shouldBe` "OK" -- TODO /relative-redicet -- TODO /absolute-redirect -- TODO /cookies describe "basicAuth" $ do let user, password :: Text 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 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 (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password)) responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /hidden-basic-auth -- TODO /digest-auth -- TODO /stream -- TODO /delay -- TODO /drip -- TODO /range -- TODO /html describe "robots.txt" $ it "works" $ do r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty robots <- B.readFile "httpbin-data/robots.txt" responseBody r `shouldBe` robots responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" -- TODO /deny -- TODO /cache describe "getting random bytes" $ do it "works" $ property $ \n' -> do let n :: Word n = getSmall n' r <- req GET (httpbin /: "bytes" /~ n) NoReqBody lbsResponse mempty responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length) responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" context "when we try to interpret 1000 random bytes as JSON" $ it "throws correct exception" $ do let selector :: HttpException -> Bool selector (JsonHttpException _) = True selector _ = False n :: Int n = 1000 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 responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length) 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 ---------------------------------------------------------------------------- -- Instances instance MonadHttp IO where handleHttpException = throwIO ---------------------------------------------------------------------------- -- Helpers -- | Run a request with such settings that it does not signal errors. prepareForShit :: Req a -> IO a prepareForShit = runReq defaultHttpConfig {httpConfigCheckResponse = noNoise} where noNoise _ _ _ = Nothing -- | Run a request with such settings that it throws on any response. blindlyThrowing :: Req a -> IO a blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit} where doit _ _ = error "Oops!" -- | 'Url' representing . httpbin :: Url 'Http httpbin = http "localhost" req :: ( MonadHttp m, HttpMethod method, HttpBody body, HttpResponse response, HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) => method -> Url scheme -> body -> Proxy response -> Option scheme -> m response req method url body responseProxy options = Req.req method url body responseProxy (options <> defaultOptions) -- | Options to apply by default. defaultOptions :: Option scheme defaultOptions = port 1234 -- | Remove “origin” field from JSON value. Origin may change, we don't want -- to depend on that. stripOrigin :: Value -> Value stripOrigin (Object m) = Object (Aeson.KeyMap.delete "origin" m) stripOrigin value = value -- | Remove funny headers that might break the tests. 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 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 _ = False -- | 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 Aeson.KeyMap.empty -- | 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 req-3.13.4/httpbin-tests/0000755000000000000000000000000007346545000013372 5ustar0000000000000000req-3.13.4/httpbin-tests/Spec.hs0000644000000000000000000000005407346545000014617 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} req-3.13.4/pure-tests/Network/HTTP/0000755000000000000000000000000007346545000015105 5ustar0000000000000000req-3.13.4/pure-tests/Network/HTTP/ReqSpec.hs0000644000000000000000000005724607346545000017021 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-orphans #-} 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.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 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.redirectCount request `shouldBe` httpConfigRedirectCount config describe "methods" $ do 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) $ it "affects name of HTTP method" $ do request <- req_ method url NoReqBody mempty L.method request `shouldBe` name mnth GET mnth POST mnth HEAD mnth PUT mnth DELETE mnth TRACE mnth CONNECT mnth OPTIONS mnth PATCH describe "urls" $ do describe "http" $ it "sets all the params correctly" $ property $ \host -> do request <- req_ GET (http host) NoReqBody mempty L.secure request `shouldBe` False L.port request `shouldBe` 80 L.host request `shouldBe` urlEncode host describe "https" $ it "sets all the params correctly" $ property $ \host -> do request <- req_ GET (https host) NoReqBody mempty L.secure request `shouldBe` True L.port request `shouldBe` 443 L.host request `shouldBe` urlEncode host describe "(/~)" $ it "attaches a path piece that is URL-encoded" $ property $ \host pieces -> do let url' = foldl (/~) (https host) pieces request <- req_ GET url' NoReqBody mempty L.host request `shouldBe` urlEncode host L.path request `shouldBe` encodePathPieces pieces describe "(/:)" $ it "attaches a path piece that is URL-encoded" $ property $ \host pieces -> do let url' = foldl (/:) (https host) pieces request <- req_ GET url' NoReqBody mempty L.host request `shouldBe` urlEncode host L.path request `shouldBe` encodePathPieces pieces describe "useHttpURI" $ do it "does not recognize non-http schemes" $ property $ \uri -> when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $ useHttpURI uri `shouldSatisfy` isNothing it "accepts correct URLs" $ property $ \uri' -> do 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" $ property $ \uri -> when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $ useHttpsURI uri `shouldSatisfy` isNothing it "parses correct URLs" $ property $ \uri' -> do unless (isRight (URI.uriAuthority uri')) discard let uri = uri' {URI.uriScheme = Just [QQ.scheme|https|]} (url', options) = fromJust (useHttpsURI uri) 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" $ 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 request <- req_ POST url NoReqBody mempty case L.requestBody request of L.RequestBodyBS x -> x `shouldBe` B.empty _ -> expectationFailure "Wrong request body constructor." describe "ReqBodyJson" $ it "sets body to correct lazy byte string" $ property $ \thing -> do request <- req_ POST url (ReqBodyJson thing) mempty case L.requestBody request of L.RequestBodyLBS x -> x `shouldBe` A.encode (thing :: Thing) _ -> expectationFailure "Wrong request body constructor." describe "ReqBodyBs" $ it "sets body to specified strict byte string" $ property $ \bs -> do request <- req_ POST url (ReqBodyBs bs) mempty case L.requestBody request of L.RequestBodyBS x -> x `shouldBe` bs _ -> expectationFailure "Wrong request body constructor." describe "ReqBodyLbs" $ it "sets body to specified lazy byte string" $ property $ \lbs -> do request <- req_ POST url (ReqBodyLbs lbs) mempty case L.requestBody request of L.RequestBodyLBS x -> x `shouldBe` lbs _ -> expectationFailure "Wrong request body constructor." describe "ReqBodyUrlEnc" $ it "sets body to correct lazy byte string" $ property $ \params -> do request <- req_ POST url (ReqBodyUrlEnc (formUrlEnc params)) mempty case L.requestBody request of L.RequestBodyLBS x -> x `shouldBe` renderQuery params _ -> expectationFailure "Wrong request body constructor." describe "query params" $ do describe "FormUrlEncodedParam" $ do describe "formToQuery" $ do it "should produce the same parameters as F.urlEncodeFormStable" $ property $ \form -> do request <- req_ POST url (ReqBodyUrlEnc $ formToQuery form) mempty case L.requestBody request of L.RequestBodyLBS x -> x `shouldBe` F.urlEncodeFormStable form _ -> expectationFailure "Wrong request body constructor" specParamToList (Proxy :: Proxy FormUrlEncodedParam) describe "Option" $ do specParamToList (Proxy :: Proxy (Option 'Http)) describe "optional parameters" $ do describe "header" $ do it "sets specified header value" $ property $ \name value -> do request <- req_ GET url NoReqBody (header name value) lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value it "left header wins" $ property $ \name value0 value1 -> do 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) 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 `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` 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 = 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` 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) 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) let result = "Bearer " <> token 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" $ it "sets Authorization header to correct value" $ property $ \username password -> do request <- req_ GET url NoReqBody (basicProxyAuth username password) lookup "Proxy-Authorization" (L.requestHeaders request) `shouldBe` pure (basicProxyAuthHeader username password) describe "oAuth2Token" $ do it "sets Authorization header to correct value" $ property $ \token -> do request <- req_ GET url NoReqBody (oAuth2Token token) lookup "Authorization" (L.requestHeaders request) `shouldBe` pure ("token " <> token) it "overwrites manual setting of header" $ property $ \token value -> do 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 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) describe "port" $ it "sets port overwriting the defaults" $ property $ \n -> do request <- req_ GET url NoReqBody (port n) L.port request `shouldBe` n describe "decompress" $ it "sets decompress function overwriting the defaults" $ property $ \token -> do request <- req_ GET url NoReqBody (decompress (/= token)) L.decompress request token `shouldBe` False -- FIXME Can't really test responseTimeout right new because the -- ResponseTimeout data type does not implement Eq and its constructors -- are also not exported. Sent a PR. describe "httpVersion" $ it "sets HTTP version overwriting the defaults" $ property $ \major minor -> do request <- req_ GET url NoReqBody (httpVersion major minor) L.requestVersion request `shouldBe` Y.HttpVersion major minor describe "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 instance MonadHttp IO where handleHttpException = throwIO instance Arbitrary HttpConfig where arbitrary = do httpConfigProxy <- arbitrary httpConfigRedirectCount <- arbitrary let httpConfigAltManager = Nothing httpConfigCheckResponse _ _ _ = Nothing 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" instance Arbitrary L.Proxy where arbitrary = L.Proxy <$> arbitrary <*> arbitrary instance Arbitrary ByteString where arbitrary = B.pack <$> arbitrary instance Arbitrary BL.ByteString where arbitrary = BL.pack <$> arbitrary instance Arbitrary Text where arbitrary = T.pack <$> arbitrary instance Show (Option scheme) where show _ = "" data Thing = Thing { _thingBool :: Bool, _thingText :: Text } deriving (Eq, Show, Generic) instance ToJSON Thing instance Arbitrary Thing where arbitrary = Thing <$> arbitrary <*> arbitrary instance Arbitrary L.CookieJar where arbitrary = L.createCookieJar <$> arbitrary instance Arbitrary L.Cookie where arbitrary = do 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 return L.Cookie {..} instance Arbitrary UTCTime where arbitrary = UTCTime <$> arbitrary <*> arbitrary instance Arbitrary Day where arbitrary = ModifiedJulianDay <$> arbitrary 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} 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) instance Arbitrary QueryParams where arbitrary = QueryParams <$> (arbitrary `suchThat` wellFormed) where wellFormed = all (not . T.null . fst) ---------------------------------------------------------------------------- -- Helpers -- | 'req' that just returns the prepared 'L.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 -- | 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) -- | 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 $ L.applyBasicAuth username password L.defaultRequest -- | 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 req-3.13.4/pure-tests/0000755000000000000000000000000007346545000012675 5ustar0000000000000000req-3.13.4/pure-tests/Spec.hs0000644000000000000000000000005407346545000014122 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} req-3.13.4/req.cabal0000644000000000000000000000713407346545000012342 0ustar0000000000000000cabal-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 flag dev description: Turn on development settings. default: False manual: True library 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 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 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