diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Req 0.1.0 + +* Initial release. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright © 2016 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. diff --git a/Network/HTTP/Req.hs b/Network/HTTP/Req.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Req.hs @@ -0,0 +1,1367 @@ +-- | +-- Module : Network.HTTP.Req +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- The documentation below is structured in such a way that most important +-- information goes first: you learn how to do HTTP requests, then how to +-- embed them in any monad you have, then it goes on giving you details +-- about less-common things you may want to know about. The documentation is +-- written with sufficient coverage of details and examples, it's designed +-- to be a complete tutorial on its own. +-- +-- /(A modest intro goes here, click on 'req' to start making requests.)/ +-- +-- === About the library +-- +-- This is an easy-to-use, type-safe, expandable, high-level HTTP library +-- that just works without any fooling around. +-- +-- What does the “easy-to-use” phrase mean? It means that the library is +-- designed to be beginner-friendly, so it's simple to add it to your monad +-- stack, intuitive to work with, well-documented, and does not get in your +-- way. Doing HTTP requests is a common task and Haskell library for this +-- should be very approachable and clear to beginners, thus certain +-- compromises were made. For example, one cannot currently modify +-- 'L.ManagerSettings' of default manager because the library always uses +-- the same implicit global manager for simplicity and maximal connection +-- sharing. There is a way to use your own manager with different settings, +-- but it requires a bit more typing. +-- +-- “Type-safe” means that the library is protective and eliminates certain +-- class of errors. For example, we have correct-by-construction 'Url's, +-- it's guaranteed that user does not send request body when using methods +-- like 'GET' or 'OPTIONS', amount of implicit assumptions is minimized by +-- making user specify his\/her intentions in explicit form (for example, +-- it's not possible to avoid specifying body or method of a request). +-- Authentication methods that assume TLS force user to use TLS on type +-- level. The library carefully hides underlying types from lower-level +-- @http-client@ package because it's not safe enough (for example +-- 'L.Request' is an instance of 'Data.String.IsString' and if it's +-- malformed, it will blow up at run-time). +-- +-- “Expandable” refers to the ability of the library to be expanded without +-- ugly hacking. For example, it's possible to define your own HTTP methods, +-- new ways to construct body of request, new authorization options, new +-- ways to actually perform request and how to represent\/parse response. As +-- user extends the library to satisfy his\/her special needs, the new +-- solutions work just like built-ins. That said, all common cases are +-- covered by the library out-of-the-box. +-- +-- “High-level” means that there are less details to worry about. The +-- library is a result of my experiences as a Haskell consultant, working +-- for several clients who have very different projects and so the library +-- adapts easily to any particular style of writing Haskell applications. +-- For example, some people prefer throwing exceptions, while others are +-- concerned with purity: just define 'handleHttpException' accordingly when +-- making your monad instance of 'MonadHttp' and it will play seamlessly. +-- Finally, the library cuts boilerplate considerably and helps write +-- concise, easy to read and maintain code. +-- +-- === Using with other libraries +-- +-- * You won't need low-level interface of @http-client@ most of the +-- time, but when you do, it's better import it qualified because it +-- has naming conflicts with @req@. +-- * For streaming of large request bodies see companion package +-- @req-conduit@: . +-- +-- === Lightweight, no risk solution +-- +-- The library uses the following mature packages under the hood to +-- guarantee you best experience without bugs or other funny business: +-- +-- * — 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@, as the +-- machinery for performing requests is the same as with @http-conduit@ and +-- @wreq@, it's just the API is different. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +#if MIN_VERSION_base(4,9,0) +{-# LANGUAGE UndecidableInstances #-} +#endif + +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE ConstraintKinds #-} +#endif + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#endif + +module Network.HTTP.Req + ( -- * Making a request + -- $making-a-request + req + , withReqManager + -- * Embedding requests into your monad + -- $embedding-requests + , MonadHttp (..) + , HttpConfig (..) + -- * Request + -- ** Method + -- $method + , GET (..) + , POST (..) + , HEAD (..) + , PUT (..) + , DELETE (..) + , TRACE (..) + , CONNECT (..) + , OPTIONS (..) + , PATCH (..) + , HttpMethod (..) + -- ** URL + -- $url + , Url + , http + , https + , (/~) + , (/:) + , parseUrlHttp + , parseUrlHttps + -- ** Body + -- $body + , NoReqBody (..) + , ReqBodyJson (..) + , ReqBodyFile (..) + , ReqBodyBs (..) + , ReqBodyLbs (..) + , ReqBodyUrlEnc (..) + , FormUrlEncodedParam + , HttpBody (..) + , ProvidesBody + , HttpBodyAllowed + -- ** Optional parameters + -- $optional-parameters + , Option + -- *** Query parameters + -- $query-parameters + , (=:) + , queryFlag + , QueryParam (..) + -- *** Headers + , header + -- *** Cookies + -- $cookies + , cookieJar + -- *** Authentication + -- $authentication + , basicAuth + , oAuth2Bearer + , oAuth2Token + -- *** Other + , port + , decompress + , responseTimeout + , httpVersion + -- * Response + -- ** Response interpretations + , IgnoreResponse + , ignoreResponse + , JsonResponse + , jsonResponse + , BsResponse + , bsResponse + , LbsResponse + , lbsResponse + , ReturnRequest + , returnRequest + -- ** Inspecting a response + , responseBody + , responseStatusCode + , responseStatusMessage + , responseHeader + , responseCookieJar + , responseRequest + -- ** Defining your own interpretation + -- $new-response-interpretation + , HttpResponse (..) + -- * Other + , HttpException (..) + , CanHaveBody (..) + , Scheme (..) ) +where + +import Control.Applicative +import Control.Arrow (first, second) +import Control.Exception (Exception, try, catch, throwIO) +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson (ToJSON (..), FromJSON (..)) +import Data.ByteString (ByteString) +import Data.Data (Data) +import Data.Default.Class +import Data.Function (on) +import Data.IORef +import Data.List (nubBy) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy +import Data.Semigroup hiding (Option, option) +import Data.Typeable (Typeable) +import GHC.Generics +import GHC.TypeLits +import System.IO.Unsafe (unsafePerformIO) +import Web.HttpApiData (ToHttpApiData (..)) +import qualified Blaze.ByteString.Builder as BB +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.Connection as NC +import qualified Network.HTTP.Client as L +import qualified Network.HTTP.Client.Internal as LI +import qualified Network.HTTP.Client.TLS as L +import qualified Network.HTTP.Types as Y + +#if MIN_VERSION_base(4,9,0) +import Data.Kind (Constraint) +#else +import GHC.Exts (Constraint) +#endif + +---------------------------------------------------------------------------- +-- Making a request + +-- $making-a-request +-- +-- To make an HTTP request you 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. It's of type 'Url' (if you click the link it will tell everything +-- about construction of 'Url' things). +-- +-- @body@ is a body option such as 'NoReqBody' or 'ReqBodyJson'. The +-- tutorial has a section about HTTP bodies, but usage in very +-- straightforward and should be clear from the examples below. +-- +-- @response@ is a type hint how to make and interpret response of HTTP +-- request, out-of-the-box it can be the following: 'ignoreResponse', +-- 'jsonResponse', 'bsResponse' (to get strict 'ByteString'), 'lbsResponse' +-- (to get lazy 'BL.ByteString'), and 'returnRequest' (makes no request, +-- just returns response, used for testing). +-- +-- Finally @options@ is a 'Monoid' that holds a composite 'Option' for all +-- other optional things like query parameters, headers, non-standard port +-- number, etc. There are quite a few things you can put there, see +-- 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 very quickly. +-- +-- ==== __Examples__ +-- +-- First, this is a piece of boilerplate that should be in place before you +-- try the examples: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import Control.Exception (throwIO) +-- > import Control.Monad +-- > 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 +-- > +-- > instance MonadHttp IO where +-- > handleHttpException = throwIO +-- +-- We will be making requests against the service. +-- +-- Make a GET request, grab 5 random bytes: +-- +-- > main :: IO () +-- > main = do +-- > let n :: Int +-- > n = 5 +-- > bs <- req GET (https "httpbin.org" /: "bytes" /~ n) NoReqBody bsResponse mempty +-- > B.putStrLn (responseBody bs) +-- +-- The same, but now we use a query parameter named @\"seed\"@ to control +-- seed of the generator: +-- +-- > main :: IO () +-- > main = do +-- > let n, seed :: Int +-- > n = 5 +-- > seed = 100 +-- > bs <- req GET (https "httpbin.org" /: "bytes" /~ n) NoReqBody bsResponse $ +-- > "seed" =: seed +-- > 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 = do +-- > let myData = MyData +-- > { size = 6 +-- > , color = "Green" } +-- > v <- req POST (https "httpbin.org" /: "post") (ReqBodyJson myData) jsonResponse mempty +-- > print (responseBody v :: Value) +-- +-- Sending URL-encoded body: +-- +-- > main :: IO () +-- > main = do +-- > let params = +-- > "foo" =: ("bar" :: Text) <> +-- > queryFlag "baz" +-- > response <- req POST (https "httpbin.org" /: "post") (ReqBodyUrlEnc params) jsonResponse mempty +-- > print (responseBody response :: Value) +-- +-- Using various optional parameters and URL that is not known in advance: +-- +-- > main :: IO () +-- > main = do +-- > -- This is an example of what to do when URL is given dynamically. Of +-- > -- course in a real application you may not want to use 'fromJust'. +-- > let (url, options) = fromJust (parseUrlHttps "https://httpbin.org/get?foo=bar") +-- > response <- req GET url NoReqBody jsonResponse $ +-- > "from" =: (15 :: Int) <> +-- > "to" =: (67 :: Int) <> +-- > basicAuth "username" "password" <> +-- > options <> -- contains the ?foo=bar part +-- > port 443 -- here you can put any port of course +-- > print (responseBody response :: Value) + +req + :: forall m method body response scheme. + ( MonadHttp m + , HttpMethod method + , HttpBody body + , HttpResponse response + , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) + => method -- ^ HTTP method + -> Url scheme -- ^ 'Url' — location of resource + -> body -- ^ Body of the request + -> Proxy response -- ^ A hint how to interpret response + -> Option scheme -- ^ Collection of optional parameters + -> m response -- ^ Response +req method url body Proxy options = do + config <- getHttpConfig + manager <- liftIO (readIORef globalManager) + 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 Order of 'mappend's matters, here method is overwritten first + -- and 'options' take effect last. In particular, this means that + -- 'options' can overwrite things set by other request components, + -- which is useful for setting port number, "Content-Type" header, + -- etc. + nubHeaders <> + getRequestMod options <> + getRequestMod config <> + getRequestMod (Womb body :: Womb "body" body) <> + getRequestMod url <> + getRequestMod (Womb method :: Womb "method" method) + wrappingVanilla m = catch m (throwIO . VanillaHttpException) + (liftIO . try . wrappingVanilla) (getHttpResponse request manager) + >>= either handleHttpException return + +-- | 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 first use of manager. From +-- that moment on the 'IORef' will be just reused — exactly the behaviour 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 #-} + +-- | Perform an action using 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 + +---------------------------------------------------------------------------- +-- Embedding requests into your monad + +-- $embedding-requests +-- +-- To use 'req' in your monad, all you need to do is to make the monad an +-- instance of the 'MonadHttp' type class. +-- +-- When writing a library, keep your API polymorphic in terms of +-- 'MonadHttp', only define instance of 'MonadHttp' in final application. + +-- | 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 + + {-# MINIMAL handleHttpException #-} + + -- | 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.Error.MonadError', this is the right place to pass it to + -- 'Control.Monad.Error.throwError'. + + handleHttpException :: HttpException -> m a + + -- | Return 'HttpConfig' to be used when performing HTTP requests. Default + -- implementation returns its 'def' value, which is described in the + -- documentation for the type. Common usage pattern with manually defined + -- 'getHttpConfig' is to return some hard-coded value, or value extracted + -- from 'Control.Monad.Reader.MonadReader' if a more flexible approach to + -- configuration is desirable. + + getHttpConfig :: m HttpConfig + getHttpConfig = return def + +-- | 'HttpConfig' contains general and default settings to be used when +-- making HTTP requests. + +data HttpConfig = HttpConfig + { httpConfigProxy :: Maybe L.Proxy + -- ^ Proxy to use. By default values of @HTTP_PROXY@ and @HTTPS_PROXY@ + -- environment variables are respected, this setting overwrites them. + -- Default value: 'Nothing'. + , httpConfigRedirectCount :: Int + -- ^ How many redirects to follow when getting a resource. Default + -- value: 10. + , httpConfigAltManager :: Maybe L.Manager + -- ^ Alternative 'L.Manager' to use. 'Nothing' (default value) means + -- that default implicit manager will be used (that's what you want in + -- 99% of cases). + , httpConfigCheckResponse :: L.Request -> L.Response L.BodyReader -> IO () + -- ^ Function to check the response immediately after receiving the + -- status and headers. This is used for throwing exceptions on + -- non-success status codes by default (set to @\\_ _ -> return ()@ if + -- this behavior is not desirable). 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. The + -- thrown exception is caught by the library though and is available in + -- 'handleHttpException'. + } deriving Typeable + +instance Default HttpConfig where + def = HttpConfig + { httpConfigProxy = Nothing + , httpConfigRedirectCount = 10 + , httpConfigAltManager = Nothing + , httpConfigCheckResponse = \_ response -> + let Y.Status statusCode _ = L.responseStatus response in + unless (200 <= statusCode && statusCode < 300) $ do + chunk <- BL.toStrict <$> L.brReadSome (L.responseBody response) 1024 + LI.throwHttp (L.StatusCodeException (void response) chunk) } + +instance RequestComponent HttpConfig where + getRequestMod HttpConfig {..} = Endo $ \x -> + x { L.proxy = httpConfigProxy + , L.redirectCount = httpConfigRedirectCount + , LI.requestManagerOverride = httpConfigAltManager + , LI.checkResponse = httpConfigCheckResponse } + +---------------------------------------------------------------------------- +-- Request — Method + +-- $method +-- +-- The package supports all methods as defined by RFC 2616, and 'PATCH' +-- which is defined by RFC 5789 — that should be enough to talk to RESTful +-- APIs. In some cases, however, you may want to add more methods (e.g. you +-- work with WebDAV ); no need to +-- compromise on type safety and hack, it only takes a couple of seconds to +-- define a new method that will works seamlessly, see 'HttpMethod'. + +-- | 'GET' method. + +data GET = GET + +instance HttpMethod GET where + type AllowsBody GET = 'NoBody + httpMethodName Proxy = Y.methodGet + +-- | 'POST' method. + +data POST = POST + +instance HttpMethod POST where + type AllowsBody POST = 'CanHaveBody + httpMethodName Proxy = Y.methodPost + +-- | 'HEAD' method. + +data HEAD = HEAD + +instance HttpMethod HEAD where + type AllowsBody HEAD = 'NoBody + httpMethodName Proxy = Y.methodHead + +-- | 'PUT' method. + +data PUT = PUT + +instance HttpMethod PUT where + type AllowsBody PUT = 'CanHaveBody + httpMethodName Proxy = Y.methodPut + +-- | 'DELETE' method. This data type does not allow having request body with +-- 'DELETE' requests, as it should be, however some APIs may expect 'DELETE' +-- requests to have bodies, in that case define your own variation of +-- 'DELETE' method and allow it to have a body. + +data DELETE = DELETE + +instance HttpMethod DELETE where + type AllowsBody DELETE = 'NoBody + httpMethodName Proxy = Y.methodDelete + +-- | 'TRACE' method. + +data TRACE = TRACE + +instance HttpMethod TRACE where + type AllowsBody TRACE = 'CanHaveBody + httpMethodName Proxy = Y.methodTrace + +-- | 'CONNECT' method. + +data CONNECT = CONNECT + +instance HttpMethod CONNECT where + type AllowsBody CONNECT = 'CanHaveBody + httpMethodName Proxy = Y.methodConnect + +-- | 'OPTIONS' method. + +data OPTIONS = OPTIONS + +instance HttpMethod OPTIONS where + type AllowsBody OPTIONS = 'NoBody + httpMethodName Proxy = Y.methodOptions + +-- | 'PATCH' method. + +data PATCH = PATCH + +instance HttpMethod PATCH where + type AllowsBody PATCH = 'CanHaveBody + httpMethodName Proxy = Y.methodPatch + +-- | A type class for types that can be used as an HTTP method. To define a +-- non-standard method, follow this example that defines COPY: +-- +-- > data COPY = COPY +-- > +-- > instance HttpMethod COPY where +-- > type AllowsBody COPY = 'CanHaveBody +-- > httpMethodName Proxy = "COPY" + +class HttpMethod a where + + -- | Type function 'AllowsBody' returns type of kind 'CanHaveBody' which + -- tells the rest of the library whether the method can have a body or + -- not. We use the special type 'CanHaveBody' “lifted” into kind instead + -- of 'Bool' to get more user-friendly compiler messages. + + type AllowsBody a :: CanHaveBody + + -- | Return name of the method as a 'ByteString'. + + httpMethodName :: Proxy a -> ByteString + +instance HttpMethod method => RequestComponent (Womb "method" method) where + getRequestMod _ = Endo $ \x -> + x { L.method = httpMethodName (Proxy :: Proxy method) } + +---------------------------------------------------------------------------- +-- Request — URL + +-- $url +-- +-- We use 'Url's which are correct by construction, see 'Url'. To build a +-- 'Url' from a 'ByteString', use 'parseUrlHttp' or 'parseUrlHttps'. + +-- | 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 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 T.Text) + -- NOTE The second value is path segments in reversed order. + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +-- | Given host name, produce a 'Url' which have “http” as its scheme and +-- empty path. This also sets port to @80@. + +http :: T.Text -> Url 'Http +http = Url Http . pure + +-- | Given host name, produce a 'Url' which have “https” as its scheme and +-- empty path. This also sets port to @443@. + +https :: T.Text -> Url 'Https +https = Url Https . pure + +-- | Grow given 'Url' appending a single path segment to it. Note that the +-- path segment can be of any type that is an instance of 'ToHttpApiData'. + +infixl 5 /~ +(/~) :: ToHttpApiData a => Url scheme -> a -> Url scheme +Url secure path /~ segment = Url secure (NE.cons (toUrlPiece segment) path) + +-- | Type-constrained version of @('/~')@ to remove ambiguity in cases when +-- next URL piece is a 'Text' literal. + +infixl 5 /: +(/:) :: Url scheme -> T.Text -> Url scheme +(/:) = (/~) + +-- | The 'parseUrlHttp' function provides an alternative method to get 'Url' +-- (possibly with some 'Option's) from a 'ByteString'. This is useful when +-- you are given a URL to query dynamically and don't know it beforehand. +-- The function parses 'ByteString' because it's the correct type to +-- represent a URL, as 'Url' cannot contain characters outside of ASCII +-- range, thus we can consider every character a 'Data.Word.Word8' value. +-- +-- This function only parses 'Url' (scheme, host, path) and optional query +-- parameters that are returned as 'Option'. It does not parse method name +-- or authentication info from given 'ByteString'. + +parseUrlHttp :: ByteString -> Maybe (Url 'Http, Option scheme) +parseUrlHttp url' = do + url <- B.stripPrefix "http://" url' + (host :| path, option) <- parseUrlHelper url + return (foldl (/:) (http host) path, option) + +-- | Just like 'parseUrlHttp', but expects “https” scheme. + +parseUrlHttps :: ByteString -> Maybe (Url 'Https, Option scheme) +parseUrlHttps url' = do + url <- B.stripPrefix "https://" url' + (host :| path, option) <- parseUrlHelper url + return (foldl (/:) (https host) path, option) + +-- | Get host\/collection of path pieces and possibly query parameters +-- already converted to 'Option'. This function is not public. + +parseUrlHelper :: ByteString -> Maybe (NonEmpty T.Text, Option scheme) +parseUrlHelper url = do + let (path', query') = B.break (== 0x3f) url + query = mconcat (uncurry queryParam <$> Y.parseQueryText query') + path <- NE.nonEmpty (Y.decodePathSegments path') + return (path, query) + +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 body option you use +-- (it's always specified in documentation for given body option). To add +-- your own way to represent request body, see 'HttpBody'. + +-- | This data type represents empty body of an HTTP request. This is the +-- data type to use with 'HttpMethod's that cannot have a body, as it's the +-- only type for which 'ProvidesBody' returns 'NoBody'. +-- +-- Using of this body option does not set the @Content-Type@ header. + +data NoReqBody = NoReqBody + +instance HttpBody NoReqBody where + getRequestBody NoReqBody = L.RequestBodyBS B.empty + +-- | This body option allows to use a JSON object as request body — probably +-- the most popular format right now. Just wrap a data type that is an +-- instance of 'ToJSON' type class and you are done: it will be converted to +-- JSON and inserted as request body. +-- +-- This body option sets the @Content-Type@ header to @\"application/json; +-- charset=utf-8\"@ value. + +newtype ReqBodyJson a = ReqBodyJson a + +instance ToJSON a => HttpBody (ReqBodyJson a) where + getRequestBody (ReqBodyJson a) = L.RequestBodyLBS (A.encode a) + getRequestContentType Proxy = pure "application/json; charset=utf-8" + +-- | This body option streams request body from a file. It is expected that +-- the file size does not change during the streaming. +-- +-- Using of this body option does not set the @Content-Type@ header. + +newtype ReqBodyFile = ReqBodyFile FilePath + +instance HttpBody ReqBodyFile where + getRequestBody (ReqBodyFile path) = + LI.RequestBodyIO (L.streamFile path) + +-- | HTTP request body represented by a strict 'ByteString'. +-- +-- Using of this body option does not set the @Content-Type@ header. + +newtype ReqBodyBs = ReqBodyBs ByteString + +instance HttpBody ReqBodyBs where + getRequestBody (ReqBodyBs bs) = L.RequestBodyBS bs + +-- | HTTP request body represented by a lazy 'BL.ByteString'. +-- +-- Using of this body option does not set the @Content-Type@ header. + +newtype ReqBodyLbs = ReqBodyLbs BL.ByteString + +instance HttpBody ReqBodyLbs where + getRequestBody (ReqBodyLbs bs) = L.RequestBodyLBS bs + +-- | Form URL-encoded body. This can hold a collection of parameters which +-- are encoded similarly to query parameters at the end of query string, +-- with the only difference that they are stored in request body. The +-- similarity is reflected in the API as well, as you can use the same +-- combinators you would use to add query parameters: @('=:')@ and +-- 'queryFlag'. +-- +-- This body option sets the @Content-Type@ header to +-- @\"application/x-www-from-urlencoded\"@ value. + +newtype ReqBodyUrlEnc = ReqBodyUrlEnc FormUrlEncodedParam + +instance HttpBody ReqBodyUrlEnc where + getRequestBody (ReqBodyUrlEnc (FormUrlEncodedParam params)) = + (L.RequestBodyLBS . BB.toLazyByteString) (Y.renderQueryText False params) + getRequestContentType Proxy = 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 [(T.Text, Maybe T.Text)] + deriving (Semigroup, Monoid) + +instance QueryParam FormUrlEncodedParam where + queryParam name mvalue = + FormUrlEncodedParam [(name, toQueryParam <$> mvalue)] + +-- | A type class for things that can be interpreted as HTTP +-- 'L.RequestBody'. + +class HttpBody body where + + {-# MINIMAL getRequestBody #-} + + -- | How to get actual 'L.RequestBody'. + + getRequestBody :: body -> L.RequestBody + + -- | This method allows to optionally specify value of @Content-Type@ + -- header that should be used with particular body option. By default it + -- returns 'Nothing' and so @Content-Type@ is not set. + + getRequestContentType :: Proxy body -> Maybe ByteString + getRequestContentType Proxy = Nothing + +-- | The type function recognizes 'NoReqBody' as having 'NoBody', while any +-- other body option 'CanHaveBody'. This forces user to use 'NoReqBody' with +-- 'GET' method and other methods that should not send a body. + +type family ProvidesBody body :: CanHaveBody where + ProvidesBody NoReqBody = 'NoBody + ProvidesBody body = 'CanHaveBody + +-- | This type function allows any HTTP body if method says it +-- 'CanHaveBody'. When method says it should have 'NoBody', the only body +-- option to use is 'NoReqBody'. +-- +-- __Note__: users of GHC 8.0.1 will see slightly more friendly error +-- messages when method does not allow a body and body is provided. + +type family HttpBodyAllowed + (allowsBody :: CanHaveBody) + (providesBody :: CanHaveBody) :: Constraint where + HttpBodyAllowed 'NoBody 'NoBody = () + HttpBodyAllowed 'CanHaveBody body = () +#if MIN_VERSION_base(4,9,0) + HttpBodyAllowed 'NoBody 'CanHaveBody = TypeError + ('Text "This HTTP method does not allow attaching a request body.") +#endif + +instance HttpBody body => RequestComponent (Womb "body" body) where + getRequestMod (Womb body) = Endo $ \x -> + x { L.requestBody = getRequestBody body + , L.requestHeaders = + let old = L.requestHeaders x in + case getRequestContentType (Proxy :: Proxy body) of + Nothing -> old + Just contentType -> + (Y.hContentType, contentType) : old } + +---------------------------------------------------------------------------- +-- Request — Optional parameters + +-- $optional-parameters +-- +-- Optional parameters to a request include things like query parameters, +-- headers, port number, etc. All optional parameters have the type +-- 'Option', which is a 'Monoid'. This means that you can use 'mempty' as +-- the last argument of 'req' to specify no optional parameters, or combine +-- 'Option's using 'mappend' (or @('<>')@) to have several of them at once. + +-- | 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 (Endo L.Request)) + -- NOTE 'QueryText' is just [(Text, Maybe Text)], we keep it along with + -- Request to avoid appending to existing query string in request every + -- time new parameter is added. Additional Maybe (Endo Request) is a + -- finalizer that will be applied after all over options. This is for + -- authentication methods that sign requests based on data in Request. + +instance Semigroup (Option scheme) where + Option er0 mr0 <> Option er1 mr1 = Option + (er0 <> er1) (mr0 <|> mr1) + +instance Monoid (Option scheme) where + mempty = Option mempty Nothing + mappend = (<>) + +-- | A helper to create an 'Option' that modifies only collection of query +-- parameters. This helper is not a part of 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 + +-- | A helper to create an 'Option' that adds a finalizer (request +-- endomorphism that is run after all other modifications). + +asFinalizer :: (L.Request -> L.Request) -> Option scheme +asFinalizer f = Option mempty (Just (Endo f)) + +instance RequestComponent (Option scheme) where + getRequestMod (Option f finalizer) = Endo $ \x -> + let (qparams, x') = appEndo f ([], x) + query = Y.renderQuery True (Y.queryTextToQuery qparams) + in maybe id appEndo finalizer x' { L.queryString = query } + +---------------------------------------------------------------------------- +-- Request — Optional parameters — Query Parameters + +-- $query-parameters +-- +-- This section describes a polymorphic interface that can be used to +-- construct query parameters (of type 'Option') and form URL-encoded bodies +-- (of type 'FormUrlEncodedParam'). + +-- | This operator builds a query parameter that will be included in URL of +-- your request after 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) => T.Text -> a -> param +name =: value = queryParam name (pure value) + +-- | Construct a flag, that is, valueless query parameter. For example, in +-- the following URL @a@ is a flag, @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 + +queryFlag :: QueryParam param => T.Text -> param +queryFlag name = queryParam name (Nothing :: Maybe ()) + +-- | A type class for query-parameter-like things. The reason to have +-- 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 => T.Text -> Maybe a -> param + +instance QueryParam (Option scheme) where + queryParam name mvalue = + withQueryParams ((:) (name, toQueryParam <$> mvalue)) + +---------------------------------------------------------------------------- +-- Request — Optional parameters — Headers + +-- | Create an 'Option' that adds a header. Note that if you 'mappend' two +-- headers with the same names the leftmost header will win. This means, in +-- particular, that you cannot create a request with several headers of the +-- same name. + +header + :: ByteString -- ^ Header name + -> ByteString -- ^ Header value + -> Option scheme +header name value = withRequest (attachHeader name value) + +-- | A non-public helper that attaches a header with given name and content +-- to a 'L.Request'. + +attachHeader :: ByteString -> ByteString -> L.Request -> L.Request +attachHeader name value x = + x { L.requestHeaders = (CI.mk name, value) : L.requestHeaders x } + +---------------------------------------------------------------------------- +-- Request — Optional parameters — Cookies + +-- $cookies +-- +-- Support for cookies is quite minimalistic at the moment, its' 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 common authentication helpers in 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 cases when +-- authentication relies on TLS for encrypting sensitive data. + +-- | The 'Option' adds basic authentication. +-- +-- See also: . + +basicAuth + :: ByteString -- ^ Username + -> ByteString -- ^ Password + -> Option 'Https -- ^ Auth 'Option' +basicAuth username password = asFinalizer + (L.applyBasicAuth username password) + +-- | The 'Option' adds an OAuth2 bearer token. This is treated by many +-- services as the equivalent of a username and password. +-- +-- The 'Option' is defined as: +-- +-- > oAuth2Bearer token = header "Authorization" ("Bearer " <> token) +-- +-- See also: . + +oAuth2Bearer + :: ByteString -- ^ Token + -> Option 'Https -- ^ Auth 'Option' +oAuth2Bearer token = asFinalizer + (attachHeader "Authorization" ("Bearer " <> token)) + +-- | The 'Option' adds a not-quite-standard OAuth2 bearer token (that seems +-- to be used only by GitHub). This will be treated by whatever services +-- accept it as the equivalent of a username and password. +-- +-- The 'Option' is defined as: +-- +-- > oAuth2Token token = header "Authorization" ("token" <> token) +-- +-- See also: . + +oAuth2Token + :: ByteString -- ^ Token + -> Option 'Https -- ^ Auth 'Option' +oAuth2Token token = asFinalizer + (attachHeader "Authorization" ("token " <> token)) + +---------------------------------------------------------------------------- +-- Request — Optional parameters — Other + +-- | Specify the port to connect to explicitly. Normally, 'Url' you use +-- determines default port, @80@ for HTTP and @443@ for HTTPS, this 'Option' +-- allows to choose arbitrary port overwriting the defaults. + +port :: Int -> Option scheme +port n = withRequest $ \x -> + x { L.port = n } + +-- | This 'Option' controls whether gzipped data should be decompressed on +-- the fly. By default everything except for @application\/x-tar@ is +-- decompressed, i.e. we have: +-- +-- > decompress (/= "application/x-tar") +-- +-- You can also choose to decompress everything like this: +-- +-- > decompress (const True) + +decompress + :: (ByteString -> Bool) -- ^ Predicate that is given MIME type, it + -- returns 'True' when content should be decompressed on the fly. + -> Option scheme +decompress f = withRequest $ \x -> + x { L.decompress = f } + +-- | Specify number of microseconds to wait for response. Default is 30 +-- seconds. + +responseTimeout + :: Int -- ^ Number of microseconds to wait + -> Option scheme +responseTimeout n = withRequest $ \x -> + x { L.responseTimeout = LI.ResponseTimeoutMicro n } + +-- | HTTP version to send to server, default is HTTP 1.1. + +httpVersion + :: Int -- ^ Major version number + -> Int -- ^ Minor version number + -> Option scheme +httpVersion major minor = withRequest $ \x -> + x { L.requestVersion = Y.HttpVersion major minor } + +---------------------------------------------------------------------------- +-- Response interpretations + +-- | Make a request and ignore body of response. + +data IgnoreResponse = IgnoreResponse (L.Response ()) + +instance HttpResponse IgnoreResponse where + type HttpResponseBody IgnoreResponse = () + toVanillaResponse (IgnoreResponse response) = response + getHttpResponse request manager = + IgnoreResponse <$> liftIO (L.httpNoBody request manager) + +-- | Use this as the fourth argument of 'req' to specify that you want it to +-- return the 'IgnoreResponse' interpretation. + +ignoreResponse :: Proxy IgnoreResponse +ignoreResponse = Proxy + +-- | Make a request and interpret body of 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 ('JsonHttpException' constructor will be used). + +newtype JsonResponse a = JsonResponse (L.Response a) + +instance FromJSON a => HttpResponse (JsonResponse a) where + type HttpResponseBody (JsonResponse a) = a + toVanillaResponse (JsonResponse response) = response + getHttpResponse request manager = do + response <- L.httpLbs request manager + case A.eitherDecode (L.responseBody response) of + Left e -> throwIO (JsonHttpException e) + Right x -> return $ JsonResponse response { L.responseBody = x } + +-- | Use this as the forth 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 body of response as a strict 'ByteString'. + +newtype BsResponse = BsResponse (L.Response ByteString) + +instance HttpResponse BsResponse where + type HttpResponseBody BsResponse = ByteString + toVanillaResponse (BsResponse response) = response + getHttpResponse request manager = + L.withResponse request manager $ \response -> do + chunks <- L.brConsume (L.responseBody response) + return $ BsResponse response { L.responseBody = B.concat chunks } + +-- | Use this as the forth argument of 'req' to specify that you want to +-- interpret response body as a strict 'ByteString'. + +bsResponse :: Proxy BsResponse +bsResponse = Proxy + +-- | Make a request and interpret body of response as a lazy +-- 'BL.ByteString'. + +newtype LbsResponse = LbsResponse (L.Response BL.ByteString) + +instance HttpResponse LbsResponse where + type HttpResponseBody LbsResponse = BL.ByteString + toVanillaResponse (LbsResponse response) = response + getHttpResponse request manager = + LbsResponse <$> L.httpLbs request manager + +-- | Use this as the forth argument of 'req' to specify that you want to +-- interpret response body as a lazy 'BL.ByteString'. + +lbsResponse :: Proxy LbsResponse +lbsResponse = Proxy + +-- | This interpretation does not result in any call at all, but you can use +-- the 'responseRequest' function to extract 'L.Request' that 'req' has +-- prepared. This is useful primarily for testing. +-- +-- Note that when you use this interpretation inspecting response will +-- diverge (i.e. it'll blow up with an error, don't do that). + +newtype ReturnRequest = ReturnRequest L.Request + +instance HttpResponse ReturnRequest where + type HttpResponseBody ReturnRequest = () + toVanillaResponse (ReturnRequest _) = error + "Network.HTTP.Req.ReturnRequest interpretation does not make requests" + getHttpResponse request _ = return (ReturnRequest request) + +-- | Use this as the forth argument of 'req' to specify that you want it to +-- just return the request it consturcted without making any requests. + +returnRequest :: Proxy ReturnRequest +returnRequest = Proxy + +---------------------------------------------------------------------------- +-- Inspecting a response + +-- | Get response body. + +responseBody + :: HttpResponse response + => response + -> HttpResponseBody response +responseBody = L.responseBody . toVanillaResponse + +-- | Get response status code. + +responseStatusCode + :: HttpResponse response + => response + -> Int +responseStatusCode = + Y.statusCode . L.responseStatus . toVanillaResponse + +-- | Get response status message. + +responseStatusMessage + :: HttpResponse response + => response + -> ByteString +responseStatusMessage = + Y.statusMessage . L.responseStatus . toVanillaResponse + +-- | Look a particular header from a response. + +responseHeader + :: HttpResponse response + => response -- ^ Response interpretation + -> ByteString -- ^ Header to lookup + -> Maybe ByteString -- ^ Header value if found +responseHeader r h = + (lookup (CI.mk h) . L.responseHeaders . toVanillaResponse) r + +-- | Get response 'L.CookieJar'. + +responseCookieJar + :: HttpResponse response + => response + -> L.CookieJar +responseCookieJar = L.responseCookieJar . toVanillaResponse + +-- | Get the original request from 'ReturnRequest' response interpretation. + +responseRequest :: ReturnRequest -> L.Request +responseRequest (ReturnRequest request) = request + +---------------------------------------------------------------------------- +-- 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 'HttpResponse' type class. + +-- | A type class for response interpretations. It allows to fully control +-- how request is made and how its body is parsed. + +class HttpResponse response where + + -- | The associated type is type of body that can be extracted from a + -- instance of 'HttpResponse'. + + type HttpResponseBody response :: * + + -- | The method describes how to get underlying 'L.Response' record. + + toVanillaResponse :: response -> L.Response (HttpResponseBody response) + + -- | This method describes how to make an HTTP request given 'L.Request' + -- (prepared by the rest of the library) and 'L.Manager'. + + getHttpResponse :: L.Request -> L.Manager -> IO response + +---------------------------------------------------------------------------- +-- 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 +-- endomorphism of functions under composition, it's used to chain different +-- request component easier using @('<>')@. + +class RequestComponent a where + + -- | Get a function that takes a 'L.Request' and changes it somehow + -- returning another 'L.Request'. For example HTTP method 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 given type. +-- This is necessary to define instances of 'RequestComponent' for any thing +-- that implements 'HttpMethod' or 'HttpBody'. Without the tag, GHC is not +-- able to see difference between @'HttpMethod' method => 'RequestComponent' +-- method@ and @'HttpBody' body => 'RequestComponent' body@ when it decides +-- which instance to use (i.e. constraints are taken into account later, +-- when instance is already chosen). + +newtype Womb (tag :: Symbol) a = Womb a + +-- | Exceptions that this library throws. + +data HttpException + = VanillaHttpException L.HttpException + -- ^ A wrapper with an 'L.HttpException' from "Network.HTTP.Client" + | JsonHttpException String + -- ^ A wrapper with Aeson-produced 'String' describing why decoding failed + deriving (Show, Typeable, Generic) + +instance Exception HttpException + +-- | A simple 'Bool'-like type we only have for better error messages. We +-- use it as a kind and its data constructors as type-level tags. +-- +-- See also: 'HttpMethod' and 'HttpBody'. + +data CanHaveBody + = CanHaveBody -- ^ Indeed can have a body + | NoBody -- ^ Should not have a body + +-- | A type-level tag that specifies URL scheme used (and thus if TLS is +-- enabled). This is used to force TLS requirement for some authentication +-- 'Option's. + +data Scheme + = Http -- ^ HTTP, no TLS + | Https -- ^ HTTPS + deriving (Eq, Ord, Show, Data, Typeable, Generic) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,179 @@ +# 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) +[![Build Status](https://travis-ci.org/mrkkrp/req.svg?branch=master)](https://travis-ci.org/mrkkrp/req) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/req/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/req?branch=master) + +* [Motivation and Req vs other libraries](#motivation-and-req-vs-other-libraries) +* [Unsolved problems](#unsolved-problems) +* [Related packages](#related-packages) +* [Contribution](#contribution) +* [License](#license) + +This is an easy-to-use, type-safe, expandable, high-level HTTP library that +just works without any fooling around. + +What does the “easy-to-use” phrase mean? It means that the library is +designed to be beginner-friendly, so it's simple to add it to your monad +stack, intuitive to work with, well-documented, and does not get in your +way. Doing HTTP requests is a common task and Haskell library for this +should be very approachable and clear to beginners, thus certain compromises +were made. For example, one cannot currently modify `ManagerSettings` of +default manager because the library always uses the same implicit global +manager for simplicity and maximal connection sharing. There is a way to use +your own manager with different settings, but it requires a bit more typing. + +“Type-safe” means that the library is protective and eliminates certain +class of errors. For example, we have correct-by-construction URLs, it's +guaranteed that user does not send request body when using methods like GET +or OPTIONS, amount of implicit assumptions is minimized by making user +specify his/her intentions in explicit form (for example, it's not possible +to avoid specifying body or method of a request). Authentication methods +that assume TLS force user to use TLS on type level. The library carefully +hides underlying types from lower-level `http-client` package because it's +not safe enough (for example `Request` is an instance of `IsString` and if +it's malformed, it will blow up at run-time). + +“Expandable” refers to the ability of the library to be expanded without +ugly hacking. For example, it's possible to define your own HTTP methods, +new ways to construct body of request, new authorization options, new ways +to actually perform request and how to represent/parse response. As user +extends the library to satisfy his/her special needs, the new solutions work +just like built-ins. That said, all common cases are covered by the library +out-of-the-box. + +“High-level” means that there are less details to worry about. The library +is a result of my experiences as a Haskell consultant, working for several +clients who have very different projects and so the library adapts easily to +any particular style of writing Haskell applications. For example, some +people prefer throwing exceptions, while others are concerned with purity: +just define `handleHttpException` accordingly when making your monad +instance of `MonadHttp` and it will play seamlessly. Finally, the library +cuts boilerplate considerably and helps write concise, easy to read and +maintain code. + +The library uses the following mature packages under the hood to guarantee +you best experience without bugs or other funny business: + +* [`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's important to note that since we leverage well-known libraries that the +whole Haskell ecosystem uses, there is no risk in using Req, as the +machinery for performing requests is the same as with `http-conduit` and +Wreq, it's just the API is different. + +## Motivation and Req vs other libraries + +*This section is my opinion and it contains criticisms of other well-known +libraries. If you're user/fan of one of these libraries, please remember not +to react aggressively and respect the fact that I may have different views +on API design from yours.* + +I have spent time to write the library because sending HTTP requests is such +a common thing and still there is no high-level library for that in Haskell +that I could use with pleasure. I'll explain why. + +First of all there is `http-client` and `http-client-tls`. They just work. I +have no issues with the libraries except that they are too low-level for my +taste. Indeed, even the docs say that they are low-level and “intended as a +base layer for more user-friendly packages”. This is exactly how I use them +in Req, as base level. Req is nothing but a different API to `http-client`, +so it only works because of hard work put into `http-client`. + +`http-conduit` definitely has its place. For one thing it allows you to +stream request and response bodies in constant memory, what other library +allows you to do that? On the other hand if you take a look at +`Network.HTTP.Simple`, then although it's said that it's a “higher level +API”, it's mostly the same as vanilla `http-client` in spirit/approach and +just adds `conduit`-powered functions to perform requests and allows to use +global implicit `Manager` (super-cool idea, BTW, Req does the same). If I +tried to frame what exactly I don't like about `http-conduit` in words, then +it would be “the way requests are constructed”. You set, set, set instead of +*being forced* to declare necessary bits and *being allowed* to declare +optional bits in a way that their combination is certainly valid. And you +parse request from a string without the protection of TH that otherwise +saves the day as in Yesod. + +Then there is Wreq. +`wreq` +[doesn't see much development lately](https://github.com/bos/wreq/issues/93). +`wreq` is by itself a weird library, IMO. You have functions per method — +not very good, as there may be new methods, like PATCH which is not new but +still missing (well you have `customMethod`, but what is the point of having +per-method functions if you have a more general way to use any method? you +should be able to just insert methods in the “argument slot” of +`customMethod` and end up with a more general solution). Now every method +function has a companion that takes `Options` (like you have `get` and +`getWith`). Why the duplication? Where is generality and flexibility? This +is not all though, because you cannot really use `get` you see in the main +module, because you want to have connection sharing. Wreq's author does not +take the gift of automatic connection re-use `Manager` from `http-client` +provides, it invents the whole new thing of “sessions”. Only inside a +session your connections will be shared and re-used. However with the +session stuff you have yet another set of per-method functions like `get` +and `getWith` — these are different ones, to be used with sessions! Now if +you have multi-threaded app, here is a surprise for you: you can't share +connections between threads as connections are shared only inside +`withSession` friend and “session will no longer be valid after that +function returns”. Disclaimer: I don't use Wreq, see below. If something in +this paragraph is not correct, please let me know and I'll remove it. Also +there are valid uses for sessions, but the point is that they are too +inconvenient for common tasks. + +It's funny that one client I worked for had to have his own little wrapper +around `http-client` just because he could not possibly use `wreq` and +`http-client` and friends were too low-level. The previous paragraph +extracted from a talk with a Haskell developer who works for that client. +Then I thought to myself “something is wrong with HTTP client libraries in +Haskell if they had to make a wrapper”. + +What else? I used `servant-client` a couple of times but amount of +boilerplate is too high. If you have several query parameters, and you use +just one of them, good luck passing lots of `Nothing`s. + +## Unsolved problems + +AWS request signing is problematic because request body can be in form of +action to execute (and all that “popper” stuff for streaming), not just +`ByteString` and so getting its digest (hash) is not trivial without running +the action and consuming body in its entirety before the request in made. In +Wreq the author chose to just use `error` when body is not a (strict or +lazy) `ByteString`. Maybe it's OK for Wreq, but I don't consider this proper +solution for Req as we support full variety of body options. For example +what if I want to upload 1 Gb file to S3? I want to stream it in constant +memory but at the same time I need to calculate its hash before I start +streaming. One solution to the problem seems to be in taking the hash +explicitly (as an argument of hypothetical `awsAuth`) and making it +responsibility of library user to calculate the hash correctly. I don't like +this because it's not user-friendly. So the question stays open, for now +there is no AWS signing functionality provided out-of-the-box. + +## 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. + +## 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 and will be reviewed quickly. + +## License + +Copyright © 2016 Mark Karpov + +Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/httpbin-data/robots.txt b/httpbin-data/robots.txt new file mode 100644 --- /dev/null +++ b/httpbin-data/robots.txt @@ -0,0 +1,2 @@ +User-agent: * +Disallow: /deny diff --git a/httpbin-data/utf8.html b/httpbin-data/utf8.html new file mode 100644 --- /dev/null +++ b/httpbin-data/utf8.html @@ -0,0 +1,220 @@ +

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:                                          █
+                                                                      ▉
+  ╔══╦══╗  ┌──┬──┐  ╭──┬──╮  ╭──┬──╮  ┏━━┳━━┓  ┎┒┏┑   ╷  ╻ ┏┯┓ ┌┰┐    ▊ ╱╲╱╲╳╳╳
+  ║┌─╨─┐║  │╔═╧═╗│  │╒═╪═╕│  │╓─╁─╖│  ┃┌─╂─┐┃  ┗╃╄┙  ╶┼╴╺╋╸┠┼┨ ┝╋┥    ▋ ╲╱╲╱╳╳╳
+  ║│╲ ╱│║  │║   ║│  ││ │ ││  │║ ┃ ║│  ┃│ ╿ │┃  ┍╅╆┓   ╵  ╹ ┗┷┛ └┸┘    ▌ ╱╲╱╲╳╳╳
+  ╠╡ ╳ ╞╣  ├╢   ╟┤  ├┼─┼─┼┤  ├╫─╂─╫┤  ┣┿╾┼╼┿┫  ┕┛┖┚     ┌┄┄┐ ╎ ┏┅┅┓ ┋ ▍ ╲╱╲╱╳╳╳
+  ║│╱ ╲│║  │║   ║│  ││ │ ││  │║ ┃ ║│  ┃│ ╽ │┃  ░░▒▒▓▓██ ┊  ┆ ╎ ╏  ┇ ┋ ▎
+  ║└─╥─┘║  │╚═╤═╝│  │╘═╪═╛│  │╙─╀─╜│  ┃└─╂─┘┃  ░░▒▒▓▓██ ┊  ┆ ╎ ╏  ┇ ┋ ▏
+  ╚══╩══╝  └──┴──┘  ╰──┴──╯  ╰──┴──╯  ┗━━┻━━┛  ▗▄▖▛▀▜   └╌╌┘ ╎ ┗╍╍┛ ┋  ▁▂▃▄▅▆▇█
+                                               ▝▀▘▙▄▟
+
+
diff --git a/httpbin-tests/Network/HTTP/ReqSpec.hs b/httpbin-tests/Network/HTTP/ReqSpec.hs new file mode 100644 --- /dev/null +++ b/httpbin-tests/Network/HTTP/ReqSpec.hs @@ -0,0 +1,366 @@ +-- +-- Tests for ‘req’ package. This test suite tests sending actual requests +-- using the service. +-- +-- Copyright © 2016 Mark Karpov +-- +-- 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. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.HTTP.ReqSpec + ( spec ) +where + +import Control.Exception (throwIO) +import Control.Monad.Reader +import Data.Aeson (Value (..), ToJSON (..), object, (.=)) +import Data.Default.Class +import Data.Monoid ((<>)) +import Data.Proxy +import Data.Text (Text) +import Network.HTTP.Req +import Test.Hspec +import Test.QuickCheck +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as TIO +import qualified Network.HTTP.Client as L +import qualified Network.HTTP.Types as Y + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty) +import Data.Word (Word) +#endif + +spec :: Spec +spec = do + + describe "exception throwing on non 2xx-status codes" $ + it "throws indeed for non-2xx" $ do + let selector :: HttpException -> Bool + selector (VanillaHttpException + (L.HttpExceptionRequest _ + (L.StatusCodeException response chunk))) = + L.responseStatus response == Y.status404 && not (B.null chunk) + selector _ = False + req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty + `shouldThrow` selector + + 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 "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") + responseBody r `shouldBe` object + [ "headers" .= object + [ "Accept-Encoding" .= ("gzip" :: Text) + , "Foo" .= ("bar" :: Text) + , "Baz" .= ("quux" :: Text) + , "Host" .= ("httpbin.org" :: 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 + stripOrigin (responseBody r) `shouldBe` object + [ "args" .= emptyObject + , "url" .= ("https://httpbin.org/get" :: Text) + , "headers" .= object + [ "Accept-Encoding" .= ("gzip" :: Text) + , "Host" .= ("httpbin.org" :: 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 + stripOrigin (responseBody r) `shouldBe` object + [ "args" .= emptyObject + , "json" .= text + , "data" .= reflected + , "url" .= ("https://httpbin.org/post" :: Text) + , "headers" .= object + [ "Content-Type" .= ("application/json; charset=utf-8" :: Text) + , "Accept-Encoding" .= ("gzip" :: Text) + , "Host" .= ("httpbin.org" :: 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 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 + stripOrigin (responseBody r) `shouldBe` object + [ "args" .= emptyObject + , "json" .= Null + , "data" .= contents + , "url" .= ("https://httpbin.org/patch" :: Text) + , "headers" .= object + [ "Accept-Encoding" .= ("gzip" :: Text) + , "Host" .= ("httpbin.org" :: 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 + stripOrigin (responseBody r) `shouldBe` object + [ "args" .= emptyObject + , "json" .= Null + , "data" .= ("" :: Text) + , "url" .= ("https://httpbin.org/put" :: Text) + , "headers" .= object + [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text) + , "Accept-Encoding" .= ("gzip" :: Text) + , "Host" .= ("httpbin.org" :: 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 + + 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 + (basicAuth (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 + +instance MonadHttp (ReaderT HttpConfig IO) where + handleHttpException = liftIO . throwIO + getHttpConfig = ask + +---------------------------------------------------------------------------- +-- Helpers + +-- | Run request with such settings that it does not signal error on adverse +-- response status codes. + +prepareForShit + :: (forall m. MonadHttp m => m a) + -> IO a +prepareForShit m = runReaderT m def { httpConfigCheckResponse = noNoise } + where noNoise _ _ = return () + +-- | Run request with such settings that it throws on any response. + +blindlyThrowing + :: (forall m. MonadHttp m => m a) + -> IO a +blindlyThrowing m = runReaderT m def { httpConfigCheckResponse = doit } + where doit _ _ = error "Oops!" + +-- | 'Url' representing . + +httpbin :: Url 'Https +httpbin = https "httpbin.org" + +-- | Remove “origin” field from JSON value. Origin may change, we don't want +-- to depend on that. + +stripOrigin :: Value -> Value +stripOrigin (Object m) = Object (HM.delete "origin" m) +stripOrigin value = value + +-- | 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 + +-- | Empty JSON 'Object'. + +emptyObject :: Value +emptyObject = Object HM.empty + +-- | Get rendered JSON value as 'Text'. + +reflectJSON :: ToJSON a => a -> Text +reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode diff --git a/httpbin-tests/Spec.hs b/httpbin-tests/Spec.hs new file mode 100644 --- /dev/null +++ b/httpbin-tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/pure-tests/Network/HTTP/ReqSpec.hs b/pure-tests/Network/HTTP/ReqSpec.hs new file mode 100644 --- /dev/null +++ b/pure-tests/Network/HTTP/ReqSpec.hs @@ -0,0 +1,464 @@ +-- +-- Tests for ‘req’ package. This test suite tests correctness of constructed +-- requests. +-- +-- Copyright © 2016 Mark Karpov +-- +-- 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. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE ConstraintKinds #-} +#endif + +module Network.HTTP.ReqSpec + ( spec ) +where + +import Control.Exception (throwIO) +import Control.Monad.Reader +import Data.Aeson (ToJSON (..)) +import Data.ByteString (ByteString) +import Data.Maybe (isNothing, fromJust) +import Data.Monoid ((<>)) +import Data.Proxy +import Data.Text (Text) +import Data.Time +import GHC.Generics +import Network.HTTP.Req +import Test.Hspec +import Test.Hspec.Core.Spec (SpecM) +import Test.QuickCheck +import qualified Blaze.ByteString.Builder as BB +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Client as L +import qualified Network.HTTP.Types as Y + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Foldable (foldMap) +import Data.Monoid (mempty) +#endif + +spec :: Spec +spec = do + + describe "config" $ + it "getHttpConfig has effect on resulting request" $ + property $ \config -> do + request <- runReaderT (req_ GET url NoReqBody mempty) config + L.proxy request `shouldBe` httpConfigProxy config + L.redirectCount request `shouldBe` httpConfigRedirectCount config + + describe "methods" $ do + let mnth + :: forall method. + ( HttpMethod method + , HttpBodyAllowed (AllowsBody method) 'NoBody ) + => method + -> SpecM () () + 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 "parseUrlHttp" $ do + it "does not recognize non-http schemes" $ + parseUrlHttp "https://httpbin.org" `shouldSatisfy` isNothing + it "parses correct URLs" $ + property $ \host pieces queryParams -> + not (T.null host) && wellFormed queryParams ==> do + let (url', path, queryString) = + assembleUrl Http host pieces queryParams + (url'', options) = fromJust (parseUrlHttp url') + request <- req_ GET url'' NoReqBody options + L.host request `shouldBe` urlEncode host + L.path request `shouldBe` path + L.queryString request `shouldBe` queryString + describe "parseUrlHttps" $ do + it "does not recognize non-https schemes" $ + parseUrlHttps "http://httpbin.org" `shouldSatisfy` isNothing + it "parses correct URLs" $ + property $ \host pieces queryParams -> + not (T.null host) && wellFormed queryParams ==> do + let (url', path, queryString) = + assembleUrl Https host pieces queryParams + (url'', options) = fromJust (parseUrlHttps url') + request <- req_ GET url'' NoReqBody options + L.host request `shouldBe` urlEncode host + L.path request `shouldBe` path + L.queryString request `shouldBe` queryString + + 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 "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 `shouldBe` pure cjar + describe "basicAuth" $ do + it "sets Authorization header to correct value" $ + property $ \username password -> do + request <- req_ GET url NoReqBody (basicAuth username password) + lookup "Authorization" (L.requestHeaders request) `shouldBe` + pure (basicAuthHeader username password) + it "overwrites manual setting of header" $ + property $ \username password value -> do + request0 <- req_ GET url NoReqBody + (basicAuth username password <> header "Authorization" value) + request1 <- req_ GET url NoReqBody + (header "Authorization" value <> basicAuth username password) + let result = basicAuthHeader username password + lookup "Authorization" (L.requestHeaders request0) `shouldBe` + pure result + lookup "Authorization" (L.requestHeaders request1) `shouldBe` + pure result + it "left auth option wins" $ + property $ \username0 password0 username1 password1 -> do + request <- req_ GET url NoReqBody + (basicAuth username0 password0 <> basicAuth username1 password1) + lookup "Authorization" (L.requestHeaders request) `shouldBe` + pure (basicAuthHeader username0 password0) + 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 "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 + +---------------------------------------------------------------------------- +-- Instances + +instance MonadHttp IO where + handleHttpException = throwIO + +instance MonadHttp (ReaderT HttpConfig IO) where + handleHttpException = liftIO . throwIO + getHttpConfig = ask + +instance Arbitrary HttpConfig where + arbitrary = do + httpConfigProxy <- arbitrary + httpConfigRedirectCount <- arbitrary + let httpConfigAltManager = Nothing + httpConfigCheckResponse _ _ = return () + 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 + +---------------------------------------------------------------------------- +-- Helpers + +-- | 'req' that just returns the prepared 'L.Request'. + +req_ + :: ( MonadHttp m + , HttpMethod method + , HttpBody body + , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) + => method -- ^ HTTP method + -> Url scheme -- ^ 'Url' — location of resource + -> body -- ^ Body of the request + -> Option scheme -- ^ Collection of optional parameters + -> m L.Request -- ^ Vanilla request +req_ method url' body options = + responseRequest `liftM` req method url' body returnRequest options + +-- | A dummy 'Url'. + +url :: Url 'Https +url = https "httpbin.org" + +-- | Percent encode given 'Text'. + +urlEncode :: Text -> ByteString +urlEncode = Y.urlEncode False . T.encodeUtf8 + +-- | Build URL path from given path pieces. + +encodePathPieces :: [Text] -> ByteString +encodePathPieces = BL.toStrict . BB.toLazyByteString . Y.encodePathSegments + +-- | Assemble entire URL. + +assembleUrl + :: Scheme -- ^ Scheme + -> Text -- ^ Host + -> [Text] -- ^ Path pieces + -> [(Text, Maybe Text)] -- ^ Query parameters + -> (ByteString, ByteString, ByteString) -- ^ URL, path, query string +assembleUrl scheme' host' pathPieces queryParams = + (scheme <> host <> path <> queryString, path, queryString) + where + scheme = case scheme' of + Http -> "http://" + Https -> "https://" + host = urlEncode host' + path = encodePathPieces pathPieces + queryString = Y.renderQuery True (Y.queryTextToQuery queryParams) + +renderQuery :: [(Text, Maybe Text)] -> BL.ByteString +renderQuery = BL.fromStrict . Y.renderQuery False . Y.queryTextToQuery + +-- | Check if collection of query params is well-formed. + +wellFormed :: [(Text, Maybe Text)] -> Bool +wellFormed = all (not . T.null . fst) + +-- | 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 diff --git a/pure-tests/Spec.hs b/pure-tests/Spec.hs new file mode 100644 --- /dev/null +++ b/pure-tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/req.cabal b/req.cabal new file mode 100644 --- /dev/null +++ b/req.cabal @@ -0,0 +1,131 @@ +-- +-- Cabal configuration for ‘req’ package. +-- +-- Copyright © 2016 Mark Karpov +-- +-- 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. + +name: req +version: 0.1.0 +cabal-version: >= 1.10 +license: BSD3 +license-file: LICENSE.md +author: Mark Karpov +maintainer: Mark Karpov +homepage: https://github.com/mrkkrp/req +bug-reports: https://github.com/mrkkrp/req/issues +category: Network, Web +synopsis: Easy-to-use, type-safe, expandable, high-level HTTP library +build-type: Simple +description: Easy-to-use, type-safe, expandable, high-level HTTP library. +extra-doc-files: CHANGELOG.md + , README.md +data-files: httpbin-data/utf8.html + , httpbin-data/robots.txt + +source-repository head + type: git + location: https://github.com/mrkkrp/req.git + +flag dev + description: Turn on development settings. + manual: True + default: False + +library + build-depends: aeson >= 0.11 && < 1.1 + , base >= 4.7 && < 5.0 + , blaze-builder >= 0.3 && < 0.5 + , bytestring >= 0.10.8 && < 0.11 + , case-insensitive >= 0.2 && < 1.3 + , connection >= 0.2.2 && < 0.3 + , data-default-class + , http-api-data >= 0.2 && < 0.4 + , http-client >= 0.5 && < 0.6 + , http-client-tls >= 0.3.2 && < 0.4 + , http-types >= 0.8 && < 10.0 + , mtl >= 2.0 && < 3.0 + , text >= 0.2 && < 1.3 + , time >= 1.2 && < 1.7 + , transformers >= 0.4 && < 0.6 + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* + exposed-modules: Network.HTTP.Req + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite pure-tests + main-is: Spec.hs + other-modules: Network.HTTP.ReqSpec + hs-source-dirs: pure-tests + type: exitcode-stdio-1.0 + build-depends: QuickCheck >= 2.7 && < 3.0 + , aeson >= 0.11 && < 1.1 + , base >= 4.7 && < 5.0 + , blaze-builder >= 0.3 && < 0.5 + , bytestring >= 0.10.8 && < 0.11 + , case-insensitive >= 0.2 && < 1.3 + , hspec >= 2.0 && < 3.0 + , hspec-core >= 2.0 && < 3.0 + , http-client >= 0.5 && < 0.6 + , http-types >= 0.8 && < 10.0 + , mtl >= 2.0 && < 3.0 + , req >= 0.1.0 + , text >= 0.2 && < 1.3 + , time >= 1.2 && < 1.7 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite httpbin-tests + main-is: Spec.hs + other-modules: Network.HTTP.ReqSpec + hs-source-dirs: httpbin-tests + type: exitcode-stdio-1.0 + build-depends: QuickCheck >= 2.7 && < 3.0 + , aeson >= 0.11 && < 1.1 + , base >= 4.7 && < 5.0 + , bytestring >= 0.10.8 && < 0.11 + , data-default-class + , hspec >= 2.0 && < 3.0 + , http-client >= 0.5 && < 0.6 + , http-types >= 0.8 && < 10.0 + , mtl >= 2.0 && < 3.0 + , req >= 0.1.0 + , text >= 0.2 && < 1.3 + , unordered-containers >= 0.2.5 && < 0.2.8 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010