diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,24 +0,0 @@ -* 0.11 [2017-11-29] - -Remove dependency on blaze-builder. (Note that as a side effect of this, URI encoding is now using lower-case rather than uppercase hexadecimal.) - -Add Bounded instance to Status. - -Re-export more status codes and http20 from Network.HTTP.Types. - -* 0.10 [2017-10-22] - -New status codes, new headers. - -Fixed typo in imATeapot, added missing toEnum. - -Oh, and http20. - -* 0.9.1 [2016-06-04] - -New function: parseByteRanges. -Support for HTTP status 422 "Unprocessable Entity" (RFC 4918). - -* 0.9 [2015-10-09] - -No changelog was maintained up to version 0.9. diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,57 @@ +# Changelog for `http-types` + +## 0.12.5 [2026-05-31] + +* Add status `451 Unavailable For Legal Reasons` +* Add `http30` as a shortcut for `HttpVersion 3 0` +* Export everything from `Network.HTTP.Types` +* Added a bunch of regression, unit and property tests for stability. +* Updated the `README.md` +* Lowest GHC version supported is now `7.10.3`. + Adjusted dependency constraints to reflect this. +* Removed explicit `Typeable` class derivations since that happens automatically + since GHC `7.10` + +## 0.12.4 [2023-11-29] + +* Add `Data` and `Generic` instances to `ByteRange`, `StdMethod`, `Status` + and `HttpVersion`. +* Rework of all the documentation, with the addition of `@since` notations. + +## 0.12.3 [2019-02-24] + +* Remove now-invalid doctest options from `doctests.hs`. + +## 0.12.2 [2018-09-26] + +* Add new `parseQueryReplacePlus` function, which allows specifying whether to replace `'+'` with `' '`. +* Add header name constants for "Prefer" and "Preference-Applied" (RFC 7240). + +## 0.12.1 [2018-01-31] + +* Add new functions for constructing a query URI where not all parts are escaped. + +## 0.12 [2018-01-28] + +* URI encoding is now back to upper-case hexadecimal, as that is the preferred canonicalization, and the previous change caused issues with URI signing in at least `amazonka`. + +## 0.11 [2017-11-29] + +* Remove dependency on `blaze-builder`. (Note that as a side effect of this, URI encoding is now using lower-case rather than upper-case hexadecimal.) +* Add `Bounded` instance to `Status`. +* Re-export more status codes and `http20` from `Network.HTTP.Types`. + +## 0.10 [2017-10-22] + +* New status codes, new headers. +* Fixed typo in `imATeapot`, added missing `toEnum`. +* Oh, and `http20`. + +## 0.9.1 [2016-06-04] + +* New function: `parseByteRanges`. +* Support for HTTP status 422 "Unprocessable Entity" (RFC 4918). + +## 0.9 [2015-10-09] + +* No changelog was maintained up to version `0.9`. diff --git a/Network/HTTP/Types.hs b/Network/HTTP/Types.hs --- a/Network/HTTP/Types.hs +++ b/Network/HTTP/Types.hs @@ -1,195 +1,281 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Types -( - -- * Methods - Method -, methodGet -, methodPost -, methodHead -, methodPut -, methodDelete -, methodTrace -, methodConnect -, methodOptions -, methodPatch -, StdMethod(..) -, parseMethod -, renderMethod -, renderStdMethod - -- * Versions -, HttpVersion(..) -, http09 -, http10 -, http11 -, http20 --- * Status -, Status(..) -, mkStatus -, status100 -, continue100 -, status101 -, switchingProtocols101 -, status200 -, ok200 -, status201 -, created201 -, status202 -, accepted202 -, status203 -, nonAuthoritative203 -, status204 -, noContent204 -, status205 -, resetContent205 -, status206 -, partialContent206 -, status300 -, multipleChoices300 -, status301 -, movedPermanently301 -, status302 -, found302 -, status303 -, seeOther303 -, status304 -, notModified304 -, status305 -, useProxy305 -, status307 -, temporaryRedirect307 -, status308 -, permanentRedirect308 -, status400 -, badRequest400 -, status401 -, unauthorized401 -, status402 -, paymentRequired402 -, status403 -, forbidden403 -, status404 -, notFound404 -, status405 -, methodNotAllowed405 -, status406 -, notAcceptable406 -, status407 -, proxyAuthenticationRequired407 -, status408 -, requestTimeout408 -, status409 -, conflict409 -, status410 -, gone410 -, status411 -, lengthRequired411 -, status412 -, preconditionFailed412 -, status413 -, requestEntityTooLarge413 -, status414 -, requestURITooLong414 -, status415 -, unsupportedMediaType415 -, status416 -, requestedRangeNotSatisfiable416 -, status417 -, expectationFailed417 -, status418 -, imATeapot418 -, status422 -, unprocessableEntity422 -, status428 -, preconditionRequired428 -, status429 -, tooManyRequests429 -, status431 -, requestHeaderFieldsTooLarge431 -, status500 -, internalServerError500 -, status501 -, notImplemented501 -, status502 -, badGateway502 -, status503 -, serviceUnavailable503 -, status504 -, gatewayTimeout504 -, status505 -, httpVersionNotSupported505 -, status511 -, networkAuthenticationRequired511 -, statusIsInformational -, statusIsSuccessful -, statusIsRedirection -, statusIsClientError -, statusIsServerError - -- * Headers - -- ** Types -, Header -, HeaderName -, RequestHeaders -, ResponseHeaders - -- ** Common headers -, hAccept -, hAcceptLanguage -, hAuthorization -, hCacheControl -, hCookie -, hConnection -, hContentEncoding -, hContentLength -, hContentMD5 -, hContentType -, hDate -, hIfModifiedSince -, hIfRange -, hLastModified -, hLocation -, hRange -, hReferer -, hServer -, hUserAgent - -- ** Byte ranges -, ByteRange(..) -, renderByteRangeBuilder -, renderByteRange -, ByteRanges -, renderByteRangesBuilder -, renderByteRanges -, parseByteRanges - -- * URI - -- ** Query string -, QueryItem -, Query -, SimpleQueryItem -, SimpleQuery -, simpleQueryToQuery -, renderQuery -, renderQueryBuilder -, renderSimpleQuery -, parseQuery -, parseSimpleQuery - -- *** Text query string (UTF8 encoded) -, QueryText -, queryTextToQuery -, queryToQueryText -, renderQueryText -, parseQueryText - -- ** Generalized query types -, QueryLike(toQuery) - -- ** Path segments -, encodePathSegments -, decodePathSegments -, encodePathSegmentsRelative - -- ** Path (segments + query string) -, extractPath -, encodePath -, decodePath - -- ** URL encoding / decoding -, urlEncodeBuilder -, urlEncode -, urlDecode +module Network.HTTP.Types ( + -- * Methods + + -- | __For more information__: "Network.HTTP.Types.Method" + + Method, + + -- ** Constants + methodGet, + methodPost, + methodHead, + methodPut, + methodDelete, + methodTrace, + methodConnect, + methodOptions, + methodPatch, + StdMethod (..), + + -- ** Parsing and redering methods + parseMethod, + renderMethod, + renderStdMethod, + + -- * Versions + + -- | __For more information__: "Network.HTTP.Types.Version" + + HttpVersion (..), + http09, + http10, + http11, + http20, + http30, + + -- * Status + + -- | __For more information__: "Network.HTTP.Types.Status" + + Status (..), + + -- ** Constants + mkStatus, + status100, + continue100, + status101, + switchingProtocols101, + status200, + ok200, + status201, + created201, + status202, + accepted202, + status203, + nonAuthoritative203, + status204, + noContent204, + status205, + resetContent205, + status206, + partialContent206, + status300, + multipleChoices300, + status301, + movedPermanently301, + status302, + found302, + status303, + seeOther303, + status304, + notModified304, + status305, + useProxy305, + status307, + temporaryRedirect307, + status308, + permanentRedirect308, + status400, + badRequest400, + status401, + unauthorized401, + status402, + paymentRequired402, + status403, + forbidden403, + status404, + notFound404, + status405, + methodNotAllowed405, + status406, + notAcceptable406, + status407, + proxyAuthenticationRequired407, + status408, + requestTimeout408, + status409, + conflict409, + status410, + gone410, + status411, + lengthRequired411, + status412, + preconditionFailed412, + status413, + requestEntityTooLarge413, + status414, + requestURITooLong414, + status415, + unsupportedMediaType415, + status416, + requestedRangeNotSatisfiable416, + status417, + expectationFailed417, + status418, + imATeapot418, + status422, + unprocessableEntity422, + status426, + upgradeRequired426, + status428, + preconditionRequired428, + status429, + tooManyRequests429, + status431, + requestHeaderFieldsTooLarge431, + status451, + unavailableForLegalReasons451, + status500, + internalServerError500, + status501, + notImplemented501, + status502, + badGateway502, + status503, + serviceUnavailable503, + status504, + gatewayTimeout504, + status505, + httpVersionNotSupported505, + status511, + networkAuthenticationRequired511, + statusIsInformational, + statusIsSuccessful, + statusIsRedirection, + statusIsClientError, + statusIsServerError, + + -- * Headers + + -- | __For more information__: "Network.HTTP.Types.Header" + + -- ** Types + Header, + HeaderName, + RequestHeaders, + ResponseHeaders, + + -- ** Header constants + hAccept, + hAcceptCharset, + hAcceptEncoding, + hAcceptLanguage, + hAcceptRanges, + hAge, + hAllow, + hAuthorization, + hCacheControl, + hConnection, + hContentDisposition, + hContentEncoding, + hContentLanguage, + hContentLength, + hContentLocation, + hContentMD5, + hContentRange, + hContentType, + hCookie, + hDate, + hETag, + hExpect, + hExpires, + hFrom, + hHost, + hIfMatch, + hIfModifiedSince, + hIfNoneMatch, + hIfRange, + hIfUnmodifiedSince, + hLastModified, + hLocation, + hMaxForwards, + hMIMEVersion, + hOrigin, + hPragma, + hPrefer, + hPreferenceApplied, + hProxyAuthenticate, + hProxyAuthorization, + hRange, + hReferer, + hRetryAfter, + hServer, + hSetCookie, + hTE, + hTrailer, + hTransferEncoding, + hUpgrade, + hUserAgent, + hVary, + hVia, + hWWWAuthenticate, + hWarning, + + -- ** Byte ranges + ByteRange (..), + renderByteRangeBuilder, + renderByteRange, + ByteRanges, + renderByteRangesBuilder, + renderByteRanges, + parseByteRanges, + + -- * URI + + -- | __For more extensive information__: "Network.HTTP.Types.URI" + + -- ** Query strings + + -- *** Query + Query, + QueryItem, + renderQuery, + renderQueryBuilder, + parseQuery, + parseQueryReplacePlus, + + -- *** Text query string (UTF8 encoded) + QueryText, + queryTextToQuery, + queryToQueryText, + renderQueryText, + parseQueryText, + + -- *** SimpleQuery + SimpleQuery, + SimpleQueryItem, + simpleQueryToQuery, + renderSimpleQuery, + parseSimpleQuery, + + -- *** PartialEscapeQuery + PartialEscapeQuery, + PartialEscapeQueryItem, + EscapeItem (..), + renderQueryPartialEscape, + renderQueryBuilderPartialEscape, + + -- ** Generalized query types + QueryLike (..), + QueryKeyLike (..), + QueryValueLike (..), + + -- ** Path + + -- *** Segments + Query String + extractPath, + encodePath, + decodePath, + + -- *** Path Segments + encodePathSegments, + encodePathSegmentsRelative, + decodePathSegments, + + -- ** URL encoding / decoding + urlEncode, + urlEncodeBuilder, + urlDecode, ) where diff --git a/Network/HTTP/Types/Header.hs b/Network/HTTP/Types/Header.hs --- a/Network/HTTP/Types/Header.hs +++ b/Network/HTTP/Types/Header.hs @@ -1,188 +1,513 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, CPP #-} -module Network.HTTP.Types.Header -( - -- ** Types - Header -, HeaderName -, RequestHeaders -, ResponseHeaders - -- ** Common headers -, hAccept -, hAcceptCharset -, hAcceptEncoding -, hAcceptLanguage -, hAcceptRanges -, hAge -, hAllow -, hAuthorization -, hCacheControl -, hConnection -, hContentEncoding -, hContentLanguage -, hContentLength -, hContentLocation -, hContentMD5 -, hContentRange -, hContentType -, hDate -, hETag -, hExpect -, hExpires -, hFrom -, hHost -, hIfMatch -, hIfModifiedSince -, hIfNoneMatch -, hIfRange -, hIfUnmodifiedSince -, hLastModified -, hLocation -, hMaxForwards -, hOrigin -, hPragma -, hProxyAuthenticate -, hProxyAuthorization -, hRange -, hReferer -, hRetryAfter -, hServer -, hTE -, hTrailer -, hTransferEncoding -, hUpgrade -, hUserAgent -, hVary -, hVia -, hWWWAuthenticate -, hWarning -, hContentDisposition -, hMIMEVersion -, hCookie -, hSetCookie - -- ** Byte ranges -, ByteRange(..) -, renderByteRangeBuilder -, renderByteRange -, ByteRanges -, renderByteRangesBuilder -, renderByteRanges -, parseByteRanges +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Type and constants for handling HTTP header fields. +-- +-- At the bottom are also some functions to handle certain header field values. +module Network.HTTP.Types.Header ( + -- * HTTP Headers + Header, + HeaderName, + RequestHeaders, + ResponseHeaders, + + -- ** Common headers + + -- | The following header constants are provided for convenience, + -- to prevent accidental spelling errors. + hAccept, + hAcceptCharset, + hAcceptEncoding, + hAcceptLanguage, + hAcceptRanges, + hAge, + hAllow, + hAuthorization, + hCacheControl, + hConnection, + hContentDisposition, + hContentEncoding, + hContentLanguage, + hContentLength, + hContentLocation, + hContentMD5, + hContentRange, + hContentType, + hCookie, + hDate, + hETag, + hExpect, + hExpires, + hFrom, + hHost, + hIfMatch, + hIfModifiedSince, + hIfNoneMatch, + hIfRange, + hIfUnmodifiedSince, + hLastModified, + hLocation, + hMaxForwards, + hMIMEVersion, + hOrigin, + hPragma, + hPrefer, + hPreferenceApplied, + hProxyAuthenticate, + hProxyAuthorization, + hRange, + hReferer, + hRetryAfter, + hServer, + hSetCookie, + hTE, + hTrailer, + hTransferEncoding, + hUpgrade, + hUserAgent, + hVary, + hVia, + hWWWAuthenticate, + hWarning, + + -- ** Byte ranges + + -- | Convenience functions and types to handle values from Range headers. + -- + -- https://www.rfc-editor.org/rfc/rfc9110.html#name-byte-ranges + ByteRange (..), + renderByteRangeBuilder, + renderByteRange, + ByteRanges, + renderByteRangesBuilder, + renderByteRanges, + parseByteRanges, ) where -import Data.List -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import Data.ByteString.Char8 () {-IsString-} -import Data.Typeable (Typeable) -import Data.Data (Data) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import Data.Data (Data) +import Data.List (intersperse) +import GHC.Generics (Generic) --- | Header +-- | A full HTTP header field with the name and value separated. +-- +-- E.g. @\"Content-Length: 28\"@ parsed into a 'Header' would turn into @("Content-Length", "28")@ type Header = (HeaderName, B.ByteString) --- | Header name +-- | A case-insensitive name of a header field. +-- +-- This is the part of the header field before the colon: @HeaderName: some value@ type HeaderName = CI.CI B.ByteString --- | Request Headers +-- | A list of 'Header's. +-- +-- Same type as 'ResponseHeaders', but useful to differentiate in type signatures. type RequestHeaders = [Header] --- | Response Headers +-- | A list of 'Header's. +-- +-- Same type as 'RequestHeaders', but useful to differentiate in type signatures. type ResponseHeaders = [Header] --- | HTTP Header names according to http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html -hAccept, hAcceptCharset, hAcceptEncoding, hAcceptLanguage, hAcceptRanges, hAge, hAllow, hAuthorization, hCacheControl, hConnection, hContentEncoding, hContentLanguage, hContentLength, hContentLocation, hContentMD5, hContentRange, hContentType, hDate, hETag, hExpect, hExpires, hFrom, hHost, hIfMatch, hIfModifiedSince, hIfNoneMatch, hIfRange, hIfUnmodifiedSince, hLastModified, hLocation, hMaxForwards, hPragma, hProxyAuthenticate, hProxyAuthorization, hRange, hReferer, hRetryAfter, hServer, hTE, hTrailer, hTransferEncoding, hUpgrade, hUserAgent, hVary, hVia, hWWWAuthenticate, hWarning :: HeaderName -hAccept = "Accept" -hAcceptCharset = "Accept-Charset" -hAcceptEncoding = "Accept-Encoding" -hAcceptLanguage = "Accept-Language" -hAcceptRanges = "Accept-Ranges" -hAge = "Age" -hAllow = "Allow" -hAuthorization = "Authorization" -hCacheControl = "Cache-Control" -hConnection = "Connection" -hContentEncoding = "Content-Encoding" -hContentLanguage = "Content-Language" -hContentLength = "Content-Length" -hContentLocation = "Content-Location" -hContentMD5 = "Content-MD5" -hContentRange = "Content-Range" -hContentType = "Content-Type" -hDate = "Date" -hETag = "ETag" -hExpect = "Expect" -hExpires = "Expires" -hFrom = "From" -hHost = "Host" -hIfMatch = "If-Match" -hIfModifiedSince = "If-Modified-Since" -hIfNoneMatch = "If-None-Match" -hIfRange = "If-Range" -hIfUnmodifiedSince = "If-Unmodified-Since" -hLastModified = "Last-Modified" -hLocation = "Location" -hMaxForwards = "Max-Forwards" -hPragma = "Pragma" -hProxyAuthenticate = "Proxy-Authenticate" +-- | [Accept](https://www.rfc-editor.org/rfc/rfc9110.html#name-accept) +-- +-- @since 0.7.0 +hAccept :: HeaderName +hAccept = "Accept" + +-- | [Accept-Charset](https://www.rfc-editor.org/rfc/rfc9110.html#name-accept-charset) +-- +-- @since 0.9 +hAcceptCharset :: HeaderName +hAcceptCharset = "Accept-Charset" + +-- | [Accept-Encoding](https://www.rfc-editor.org/rfc/rfc9110.html#name-accept-encoding) +-- +-- @since 0.9 +hAcceptEncoding :: HeaderName +hAcceptEncoding = "Accept-Encoding" + +-- | [Accept-Language](https://www.rfc-editor.org/rfc/rfc9110.html#name-accept-language) +-- +-- @since 0.7.0 +hAcceptLanguage :: HeaderName +hAcceptLanguage = "Accept-Language" + +-- | [Accept-Ranges](https://www.rfc-editor.org/rfc/rfc9110.html#name-accept-ranges) +-- +-- @since 0.9 +hAcceptRanges :: HeaderName +hAcceptRanges = "Accept-Ranges" + +-- | [Age](https://www.rfc-editor.org/rfc/rfc9111.html#name-age) +-- +-- @since 0.9 +hAge :: HeaderName +hAge = "Age" + +-- | [Allow](https://www.rfc-editor.org/rfc/rfc9110.html#name-allow) +-- +-- @since 0.9 +hAllow :: HeaderName +hAllow = "Allow" + +-- | [Authorization](https://www.rfc-editor.org/rfc/rfc9110.html#name-authorization) +-- +-- @since 0.7.0 +hAuthorization :: HeaderName +hAuthorization = "Authorization" + +-- | [Cache-Control](https://www.rfc-editor.org/rfc/rfc9111.html#name-cache-control) +-- +-- @since 0.7.0 +hCacheControl :: HeaderName +hCacheControl = "Cache-Control" + +-- | [Connection](https://www.rfc-editor.org/rfc/rfc9110.html#name-connection) +-- +-- @since 0.7.0 +hConnection :: HeaderName +hConnection = "Connection" + +-- | [Content-Encoding](https://www.rfc-editor.org/rfc/rfc9110.html#name-content-encoding) +-- +-- @since 0.7.0 +hContentEncoding :: HeaderName +hContentEncoding = "Content-Encoding" + +-- | [Content-Language](https://www.rfc-editor.org/rfc/rfc9110.html#name-content-language) +-- +-- @since 0.9 +hContentLanguage :: HeaderName +hContentLanguage = "Content-Language" + +-- | [Content-Length](https://www.rfc-editor.org/rfc/rfc9110.html#name-content-length) +-- +-- @since 0.7.0 +hContentLength :: HeaderName +hContentLength = "Content-Length" + +-- | [Content-Location](https://www.rfc-editor.org/rfc/rfc9110.html#name-content-location) +-- +-- @since 0.9 +hContentLocation :: HeaderName +hContentLocation = "Content-Location" + +-- | [Content-MD5](https://www.rfc-editor.org/rfc/rfc2616.html#section-14.15) +-- +-- /This header has been obsoleted in RFC 9110./ +-- +-- @since 0.7.0 +hContentMD5 :: HeaderName +hContentMD5 = "Content-MD5" + +-- | [Content-Range](https://www.rfc-editor.org/rfc/rfc9110.html#name-content-range) +-- +-- @since 0.9 +hContentRange :: HeaderName +hContentRange = "Content-Range" + +-- | [Content-Type](https://www.rfc-editor.org/rfc/rfc9110.html#name-content-type) +-- +-- @since 0.7.0 +hContentType :: HeaderName +hContentType = "Content-Type" + +-- | [Date](https://www.rfc-editor.org/rfc/rfc9110.html#name-date) +-- +-- @since 0.7.0 +hDate :: HeaderName +hDate = "Date" + +-- | [ETag](https://www.rfc-editor.org/rfc/rfc9110.html#name-etag) +-- +-- @since 0.9 +hETag :: HeaderName +hETag = "ETag" + +-- | [Expect](https://www.rfc-editor.org/rfc/rfc9110.html#name-expect) +-- +-- @since 0.9 +hExpect :: HeaderName +hExpect = "Expect" + +-- | [Expires](https://www.rfc-editor.org/rfc/rfc9111.html#name-expires) +-- +-- @since 0.9 +hExpires :: HeaderName +hExpires = "Expires" + +-- | [From](https://www.rfc-editor.org/rfc/rfc9110.html#name-from) +-- +-- @since 0.9 +hFrom :: HeaderName +hFrom = "From" + +-- | [Host](https://www.rfc-editor.org/rfc/rfc9110.html#name-host-and-authority) +-- +-- @since 0.9 +hHost :: HeaderName +hHost = "Host" + +-- | [If-Match](https://www.rfc-editor.org/rfc/rfc9110.html#name-if-match) +-- +-- @since 0.9 +hIfMatch :: HeaderName +hIfMatch = "If-Match" + +-- | [If-Modified-Since](https://www.rfc-editor.org/rfc/rfc9110.html#name-if-modified-since) +-- +-- @since 0.7.0 +hIfModifiedSince :: HeaderName +hIfModifiedSince = "If-Modified-Since" + +-- | [If-None-Match](https://www.rfc-editor.org/rfc/rfc9110.html#name-if-none-match) +-- +-- @since 0.9 +hIfNoneMatch :: HeaderName +hIfNoneMatch = "If-None-Match" + +-- | [If-Range](https://www.rfc-editor.org/rfc/rfc9110.html#name-if-range) +-- +-- @since 0.7.0 +hIfRange :: HeaderName +hIfRange = "If-Range" + +-- | [If-Unmodified-Since](https://www.rfc-editor.org/rfc/rfc9110.html#name-if-unmodified-since) +-- +-- @since 0.9 +hIfUnmodifiedSince :: HeaderName +hIfUnmodifiedSince = "If-Unmodified-Since" + +-- | [Last-Modified](https://www.rfc-editor.org/rfc/rfc9110.html#name-last-modified) +-- +-- @since 0.7.0 +hLastModified :: HeaderName +hLastModified = "Last-Modified" + +-- | [Location](https://www.rfc-editor.org/rfc/rfc9110.html#name-location) +-- +-- @since 0.7.1 +hLocation :: HeaderName +hLocation = "Location" + +-- | [Max-Forwards](https://www.rfc-editor.org/rfc/rfc9110.html#name-max-forwards) +-- +-- @since 0.9 +hMaxForwards :: HeaderName +hMaxForwards = "Max-Forwards" + +-- | [Pragma](https://www.rfc-editor.org/rfc/rfc9111.html#name-pragma) +-- +-- /This header has been deprecated in RFC 9111 in favor of "Cache-Control"./ +-- +-- @since 0.9 +hPragma :: HeaderName +hPragma = "Pragma" + +-- | [Proxy-Authenticate](https://www.rfc-editor.org/rfc/rfc9110.html#name-proxy-authenticate) +-- +-- @since 0.9 +hProxyAuthenticate :: HeaderName +hProxyAuthenticate = "Proxy-Authenticate" + +-- | [Proxy-Authorization](https://www.rfc-editor.org/rfc/rfc9110.html#name-proxy-authorization) +-- +-- @since 0.9 +hProxyAuthorization :: HeaderName hProxyAuthorization = "Proxy-Authorization" -hRange = "Range" -hReferer = "Referer" -hRetryAfter = "Retry-After" -hServer = "Server" -hTE = "TE" -hTrailer = "Trailer" -hTransferEncoding = "Transfer-Encoding" -hUpgrade = "Upgrade" -hUserAgent = "User-Agent" -hVary = "Vary" -hVia = "Via" -hWWWAuthenticate = "WWW-Authenticate" -hWarning = "Warning" --- | HTTP Header names according to http://www.w3.org/Protocols/rfc2616/rfc2616-sec19.html -hContentDisposition, hMIMEVersion :: HeaderName +-- | [Range](https://www.rfc-editor.org/rfc/rfc9110.html#name-range) +-- +-- @since 0.7.0 +hRange :: HeaderName +hRange = "Range" + +-- | [Referer](https://www.rfc-editor.org/rfc/rfc9110.html#name-referer) +-- +-- @since 0.7.0 +hReferer :: HeaderName +hReferer = "Referer" + +-- | [Retry-After](https://www.rfc-editor.org/rfc/rfc9110.html#name-retry-after) +-- +-- @since 0.9 +hRetryAfter :: HeaderName +hRetryAfter = "Retry-After" + +-- | [Server](https://www.rfc-editor.org/rfc/rfc9110.html#name-server) +-- +-- @since 0.7.1 +hServer :: HeaderName +hServer = "Server" + +-- | [TE](https://www.rfc-editor.org/rfc/rfc9110.html#name-te) +-- +-- @since 0.9 +hTE :: HeaderName +hTE = "TE" + +-- | [Trailer](https://www.rfc-editor.org/rfc/rfc9110.html#name-trailer) +-- +-- @since 0.9 +hTrailer :: HeaderName +hTrailer = "Trailer" + +-- | [Transfer-Encoding](https://www.rfc-editor.org/rfc/rfc9112#name-transfer-encoding) +-- +-- @since 0.9 +hTransferEncoding :: HeaderName +hTransferEncoding = "Transfer-Encoding" + +-- | [Upgrade](https://www.rfc-editor.org/rfc/rfc9110.html#name-upgrade) +-- +-- @since 0.9 +hUpgrade :: HeaderName +hUpgrade = "Upgrade" + +-- | [User-Agent](https://www.rfc-editor.org/rfc/rfc9110.html#name-user-agent) +-- +-- @since 0.7.0 +hUserAgent :: HeaderName +hUserAgent = "User-Agent" + +-- | [Vary](https://www.rfc-editor.org/rfc/rfc9110.html#name-vary) +-- +-- @since 0.9 +hVary :: HeaderName +hVary = "Vary" + +-- | [Via](https://www.rfc-editor.org/rfc/rfc9110.html#name-via) +-- +-- @since 0.9 +hVia :: HeaderName +hVia = "Via" + +-- | [WWW-Authenticate](https://www.rfc-editor.org/rfc/rfc9110.html#name-www-authenticate) +-- +-- @since 0.9 +hWWWAuthenticate :: HeaderName +hWWWAuthenticate = "WWW-Authenticate" + +-- | [Warning](https://www.rfc-editor.org/rfc/rfc9111.html#name-warning) +-- +-- /This header has been obsoleted in RFC 9111./ +-- +-- @since 0.9 +hWarning :: HeaderName +hWarning = "Warning" + +-- | [Content-Disposition](https://www.rfc-editor.org/rfc/rfc6266.html) +-- +-- @since 0.10 +hContentDisposition :: HeaderName hContentDisposition = "Content-Disposition" -hMIMEVersion = "MIME-Version" --- | HTTP Header names according to https://tools.ietf.org/html/rfc6265#section-4 -hCookie, hSetCookie :: HeaderName -hCookie = "Cookie" -hSetCookie = "Set-Cookie" +-- | [MIME-Version](https://www.rfc-editor.org/rfc/rfc2616.html#section-19.4.1) +-- +-- @since 0.10 +hMIMEVersion :: HeaderName +hMIMEVersion = "MIME-Version" --- | HTTP Header names according to https://tools.ietf.org/html/rfc6454 +-- | [Cookie](https://www.rfc-editor.org/rfc/rfc6265.html#section-4.2) +-- +-- @since 0.7.0 +hCookie :: HeaderName +hCookie = "Cookie" + +-- | [Set-Cookie](https://www.rfc-editor.org/rfc/rfc6265.html#section-4.1) +-- +-- @since 0.10 +hSetCookie :: HeaderName +hSetCookie = "Set-Cookie" + +-- | [Origin](https://www.rfc-editor.org/rfc/rfc6454.html#section-7) +-- +-- @since 0.10 hOrigin :: HeaderName hOrigin = "Origin" --- | RFC 2616 Byte range (individual). +-- | [Prefer](https://www.rfc-editor.org/rfc/rfc7240.html#section-2) -- +-- @since 0.12.2 +hPrefer :: HeaderName +hPrefer = "Prefer" + +-- | [Preference-Applied](https://www.rfc-editor.org/rfc/rfc7240.html#section-3) +-- +-- @since 0.12.2 +hPreferenceApplied :: HeaderName +hPreferenceApplied = "Preference-Applied" + +-- | An individual byte range. Used in @Range@ request headers. +-- This type and its accompanying functions are /NOT/ compatible with the +-- @Content-Range@ response header. +-- -- Negative indices are not allowed! +-- +-- @since 0.6.11 data ByteRange - = ByteRangeFrom !Integer - | ByteRangeFromTo !Integer !Integer - | ByteRangeSuffix !Integer - deriving (Show, Eq, Ord, Typeable, Data) + = ByteRangeFrom !Integer + | ByteRangeFromTo !Integer !Integer + | ByteRangeSuffix !Integer + deriving + ( -- | @since 0.8.4 + Show + , -- | @since 0.8.4 + Eq + , -- | @since 0.8.4 + Ord + , -- | @since 0.8.4 + Data + , -- | @since 0.12.4 + Generic + ) +-- | Turns a byte range into a byte string 'B.Builder'. +-- +-- @since 0.6.11 renderByteRangeBuilder :: ByteRange -> B.Builder renderByteRangeBuilder (ByteRangeFrom from) = B.integerDec from `mappend` B.char7 '-' renderByteRangeBuilder (ByteRangeFromTo from to) = B.integerDec from `mappend` B.char7 '-' `mappend` B.integerDec to renderByteRangeBuilder (ByteRangeSuffix suffix) = B.char7 '-' `mappend` B.integerDec suffix +-- | Renders a byte range into a 'B.ByteString'. +-- +-- >>> renderByteRange (ByteRangeFrom 2048) +-- "2048-" +-- +-- @since 0.6.11 renderByteRange :: ByteRange -> B.ByteString renderByteRange = BL.toStrict . B.toLazyByteString . renderByteRangeBuilder --- | RFC 2616 Byte ranges (set). +-- | A list of byte ranges. +-- +-- @since 0.6.11 type ByteRanges = [ByteRange] +-- | Turns a list of byte ranges into a byte string 'B.Builder'. +-- +-- @since 0.6.11 renderByteRangesBuilder :: ByteRanges -> B.Builder -renderByteRangesBuilder xs = B.byteString "bytes=" `mappend` - mconcat (intersperse (B.char7 ',') (map renderByteRangeBuilder xs)) +renderByteRangesBuilder xs = + B.byteString "bytes=" + `mappend` mconcat (intersperse (B.char7 ',') $ map renderByteRangeBuilder xs) +-- | Renders a list of byte ranges into a 'B.ByteString'. +-- +-- >>> renderByteRanges [ByteRangeFrom 2048, ByteRangeSuffix 20] +-- "bytes=2048-,-20" +-- +-- @since 0.6.11 renderByteRanges :: ByteRanges -> B.ByteString renderByteRanges = BL.toStrict . B.toLazyByteString . renderByteRangesBuilder @@ -204,11 +529,13 @@ -- Just [ByteRangeFromTo 500 600,ByteRangeFromTo 601 999] -- >>> parseByteRanges "bytes=500-700,601-999" -- Just [ByteRangeFromTo 500 700,ByteRangeFromTo 601 999] +-- +-- @since 0.9.1 parseByteRanges :: B.ByteString -> Maybe ByteRanges parseByteRanges bs1 = do bs2 <- stripPrefixB "bytes=" bs1 (r, bs3) <- range bs2 - ranges (r:) bs3 + ranges (r :) bs3 where range bs2 = do (i, bs3) <- B8.readInteger bs2 @@ -224,8 +551,15 @@ | otherwise = do bs4 <- stripPrefixB "," bs3 (r, bs5) <- range bs4 - ranges (front . (r:)) bs5 + ranges (front . (r :)) bs5 - stripPrefixB x y - | x `B.isPrefixOf` y = Just (B.drop (B.length x) y) - | otherwise = Nothing +stripPrefixB :: B.ByteString -> B.ByteString -> Maybe B.ByteString +#if !MIN_VERSION_bytestring(0,10,8) +-- FIXME: Use 'stripPrefix' from the 'bytestring' package. +-- Might have to update the dependency constraints though. +stripPrefixB x y + | x `B.isPrefixOf` y = Just (B.drop (B.length x) y) + | otherwise = Nothing +#else +stripPrefixB = B.stripPrefix +#endif diff --git a/Network/HTTP/Types/Method.hs b/Network/HTTP/Types/Method.hs --- a/Network/HTTP/Types/Method.hs +++ b/Network/HTTP/Types/Method.hs @@ -1,46 +1,99 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Network.HTTP.Types.Method -( - Method -, methodGet -, methodPost -, methodHead -, methodPut -, methodDelete -, methodTrace -, methodConnect -, methodOptions -, methodPatch -, StdMethod(..) -, parseMethod -, renderMethod -, renderStdMethod +{-# LANGUAGE DeriveGeneric #-} + +-- | Types and constants for HTTP methods. +-- +-- The HTTP standard defines a set of standard methods, when to use them, +-- and how to handle them. The standard set has been provided as a separate +-- data type 'StdMethod', but since you can also use custom methods, the +-- basic type 'Method' is just a synonym for 'B.ByteString'. +module Network.HTTP.Types.Method ( + -- * HTTP methods + Method, + + -- ** Constants + methodGet, + methodPost, + methodHead, + methodPut, + methodDelete, + methodTrace, + methodConnect, + methodOptions, + methodPatch, + + -- ** Standard Methods + + -- | One data type that holds all standard HTTP methods. + StdMethod (..), + parseMethod, + renderMethod, + renderStdMethod, ) where -import Control.Arrow ((|||)) -import Data.Array -import qualified Data.ByteString as B +import Control.Arrow ((|||)) +import Data.Array (Array, Ix, assocs, listArray, (!)) +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 -import Data.Typeable +import Data.Data (Data) +import GHC.Generics (Generic) --- | HTTP method (flat string type). +-- $setup +-- >>> import Data.ByteString.Char8 (ByteString) +-- >>> import Data.Text (pack) +-- >>> import Data.Text.Encoding (encodeUtf8) +-- >>> import Test.QuickCheck +-- >>> :{ +-- instance Arbitrary ByteString where +-- arbitrary = encodeUtf8 . pack <$> arbitrary +-- :} + +-- | HTTP method (flat 'B.ByteString' type). type Method = B.ByteString --- | HTTP Method constants. -methodGet, methodPost, methodHead, methodPut, methodDelete, methodTrace, methodConnect, methodOptions, methodPatch :: Method -methodGet = renderStdMethod GET -methodPost = renderStdMethod POST -methodHead = renderStdMethod HEAD -methodPut = renderStdMethod PUT -methodDelete = renderStdMethod DELETE -methodTrace = renderStdMethod TRACE +-- | GET Method +methodGet :: Method +methodGet = renderStdMethod GET + +-- | POST Method +methodPost :: Method +methodPost = renderStdMethod POST + +-- | HEAD Method +methodHead :: Method +methodHead = renderStdMethod HEAD + +-- | PUT Method +methodPut :: Method +methodPut = renderStdMethod PUT + +-- | DELETE Method +methodDelete :: Method +methodDelete = renderStdMethod DELETE + +-- | TRACE Method +methodTrace :: Method +methodTrace = renderStdMethod TRACE + +-- | CONNECT Method +methodConnect :: Method methodConnect = renderStdMethod CONNECT + +-- | OPTIONS Method +methodOptions :: Method methodOptions = renderStdMethod OPTIONS -methodPatch = renderStdMethod PATCH +-- | PATCH Method +-- +-- @since 0.8.0 +methodPatch :: Method +methodPatch = renderStdMethod PATCH + -- | HTTP standard method (as defined by RFC 2616, and PATCH which is defined -- by RFC 5789). +-- +-- @since 0.2.0 data StdMethod = GET | POST @@ -50,26 +103,50 @@ | TRACE | CONNECT | OPTIONS - | PATCH - deriving (Read, Show, Eq, Ord, Enum, Bounded, Ix, Typeable) + | -- | @since 0.8.0 + PATCH + deriving + ( Read + , Show + , Eq + , Ord + , Enum + , Bounded + , Ix + , -- | @since 0.12.4 + Generic + , -- | @since 0.12.4 + Data + ) + -- These are ordered by suspected frequency. More popular methods should go first. -- The reason is that methodList is used with lookup. -- lookup is probably faster for these few cases than setting up an elaborate data structure. +-- FIXME: listArray (minBound, maxBound) $ fmap fst methodList methodArray :: Array StdMethod Method methodArray = listArray (minBound, maxBound) $ map (B8.pack . show) [minBound :: StdMethod .. maxBound] +-- FIXME: map (\m -> (B8.pack $ show m, m)) [minBound .. maxBound] methodList :: [(Method, StdMethod)] methodList = map (\(a, b) -> (b, a)) (assocs methodArray) --- | Convert a method 'ByteString' to a 'StdMethod' if possible. +-- | Convert a method 'B.ByteString' to a 'StdMethod' if possible. +-- +-- @since 0.2.0 parseMethod :: Method -> Either B.ByteString StdMethod parseMethod bs = maybe (Left bs) Right $ lookup bs methodList --- | Convert an algebraic method to a 'ByteString'. +-- | Convert an algebraic method to a 'B.ByteString'. +-- +-- prop> renderMethod (parseMethod bs) == bs +-- +-- @since 0.3.0 renderMethod :: Either B.ByteString StdMethod -> Method renderMethod = id ||| renderStdMethod --- | Convert a 'StdMethod' to a 'ByteString'. +-- | Convert a 'StdMethod' to a 'B.ByteString'. +-- +-- @since 0.2.0 renderStdMethod :: StdMethod -> Method renderStdMethod m = methodArray ! m diff --git a/Network/HTTP/Types/QueryLike.hs b/Network/HTTP/Types/QueryLike.hs --- a/Network/HTTP/Types/QueryLike.hs +++ b/Network/HTTP/Types/QueryLike.hs @@ -1,43 +1,51 @@ {-# LANGUAGE FlexibleInstances #-} -module Network.HTTP.Types.QueryLike -( - QueryLike(..) -, QueryKeyLike(..) -, QueryValueLike(..) + +-- | Some type classes to make more general functions when handling query strings. +module Network.HTTP.Types.QueryLike ( + QueryLike (..), + QueryKeyLike (..), + QueryValueLike (..), ) where -import Network.HTTP.Types.URI -import Data.Maybe -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Control.Arrow +import Control.Arrow ((***)) +import Data.ByteString as B (ByteString, concat) +import Data.ByteString.Lazy as L (ByteString, toChunks) +import Data.Maybe (catMaybes) +import Data.Text as T (Text, pack) +import Data.Text.Encoding as T (encodeUtf8) +import Network.HTTP.Types.URI (Query) + -- | Types which can, and commonly are, converted to 'Query' are in this class. --- --- You can use lists of simple key value pairs, with 'B.ByteString' (strict, or lazy: +-- +-- You can use lists of simple key value pairs, with 'B.ByteString' (strict, or lazy: -- 'L.ByteString'), 'T.Text', or 'String' as the key/value types. You can also have the value -- type lifted into a Maybe to support keys without values; and finally it is possible to put -- each pair into a Maybe for key-value pairs that aren't always present. +-- +-- @since 0.7.0 class QueryLike a where - -- | Convert to 'Query'. - toQuery :: a -> Query + -- | Convert to 'Query'. + toQuery :: a -> Query -- | Types which, in a Query-like key-value list, are used in the Key position. +-- +-- @since 0.7.0 class QueryKeyLike a where - toQueryKey :: a -> B.ByteString + toQueryKey :: a -> B.ByteString -- | Types which, in a Query-like key-value list, are used in the Value position. +-- +-- @since 0.7.0 class QueryValueLike a where - toQueryValue :: a -> Maybe B.ByteString + toQueryValue :: a -> Maybe B.ByteString instance (QueryKeyLike k, QueryValueLike v) => QueryLike [(k, v)] where - toQuery = map (toQueryKey *** toQueryValue) + toQuery = map (toQueryKey *** toQueryValue) instance (QueryKeyLike k, QueryValueLike v) => QueryLike [Maybe (k, v)] where - toQuery = toQuery . catMaybes + toQuery = toQuery . catMaybes instance QueryKeyLike B.ByteString where toQueryKey = id instance QueryKeyLike L.ByteString where toQueryKey = B.concat . L.toChunks @@ -48,6 +56,5 @@ instance QueryValueLike L.ByteString where toQueryValue = Just . B.concat . L.toChunks instance QueryValueLike T.Text where toQueryValue = Just . T.encodeUtf8 instance QueryValueLike [Char] where toQueryValue = Just . T.encodeUtf8 . T.pack - instance QueryValueLike a => QueryValueLike (Maybe a) where - toQueryValue = maybe Nothing toQueryValue + toQueryValue mVal = mVal >>= toQueryValue diff --git a/Network/HTTP/Types/Status.hs b/Network/HTTP/Types/Status.hs --- a/Network/HTTP/Types/Status.hs +++ b/Network/HTTP/Types/Status.hs @@ -1,132 +1,185 @@ -{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} -module Network.HTTP.Types.Status -( Status(..) -, mkStatus -, status100 -, continue100 -, status101 -, switchingProtocols101 -, status200 -, ok200 -, status201 -, created201 -, status202 -, accepted202 -, status203 -, nonAuthoritative203 -, status204 -, noContent204 -, status205 -, resetContent205 -, status206 -, partialContent206 -, status300 -, multipleChoices300 -, status301 -, movedPermanently301 -, status302 -, found302 -, status303 -, seeOther303 -, status304 -, notModified304 -, status305 -, useProxy305 -, status307 -, temporaryRedirect307 -, status308 -, permanentRedirect308 -, status400 -, badRequest400 -, status401 -, unauthorized401 -, status402 -, paymentRequired402 -, status403 -, forbidden403 -, status404 -, notFound404 -, status405 -, methodNotAllowed405 -, status406 -, notAcceptable406 -, status407 -, proxyAuthenticationRequired407 -, status408 -, requestTimeout408 -, status409 -, conflict409 -, status410 -, gone410 -, status411 -, lengthRequired411 -, status412 -, preconditionFailed412 -, status413 -, requestEntityTooLarge413 -, status414 -, requestURITooLong414 -, status415 -, unsupportedMediaType415 -, status416 -, requestedRangeNotSatisfiable416 -, status417 -, expectationFailed417 -, status418 -, imATeapot418 -, status422 -, unprocessableEntity422 -, status426 -, upgradeRequired426 -, status428 -, preconditionRequired428 -, status429 -, tooManyRequests429 -, status431 -, requestHeaderFieldsTooLarge431 -, status500 -, internalServerError500 -, status501 -, notImplemented501 -, status502 -, badGateway502 -, status503 -, serviceUnavailable503 -, status504 -, gatewayTimeout504 -, status505 -, status511 -, networkAuthenticationRequired511 -, httpVersionNotSupported505 -, statusIsInformational -, statusIsSuccessful -, statusIsRedirection -, statusIsClientError -, statusIsServerError +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Types and constants to describe HTTP status codes. +-- +-- At the bottom are some functions to check if a given 'Status' is from a certain category. (i.e. @1XX@, @2XX@, etc.) +module Network.HTTP.Types.Status ( + -- * HTTP Status + + -- If we ever want to deprecate the 'Status' data constructor: + -- #if __GLASGOW_HASKELL__ >= 908 + -- {-# DEPRECATED "Use 'mkStatus' when constructing a 'Status'" #-} Status(Status) + -- #else + Status (Status), + -- #endif + statusCode, + statusMessage, + mkStatus, + + -- * Common statuses + status100, + continue100, + status101, + switchingProtocols101, + status200, + ok200, + status201, + created201, + status202, + accepted202, + status203, + nonAuthoritative203, + status204, + noContent204, + status205, + resetContent205, + status206, + partialContent206, + status300, + multipleChoices300, + status301, + movedPermanently301, + status302, + found302, + status303, + seeOther303, + status304, + notModified304, + status305, + useProxy305, + status307, + temporaryRedirect307, + status308, + permanentRedirect308, + status400, + badRequest400, + status401, + unauthorized401, + status402, + paymentRequired402, + status403, + forbidden403, + status404, + notFound404, + status405, + methodNotAllowed405, + status406, + notAcceptable406, + status407, + proxyAuthenticationRequired407, + status408, + requestTimeout408, + status409, + conflict409, + status410, + gone410, + status411, + lengthRequired411, + status412, + preconditionFailed412, + status413, + requestEntityTooLarge413, + status414, + requestURITooLong414, + status415, + unsupportedMediaType415, + status416, + requestedRangeNotSatisfiable416, + status417, + expectationFailed417, + status418, + imATeapot418, + status422, + unprocessableEntity422, + status426, + upgradeRequired426, + status428, + preconditionRequired428, + status429, + tooManyRequests429, + status431, + requestHeaderFieldsTooLarge431, + status451, + unavailableForLegalReasons451, + status500, + internalServerError500, + status501, + notImplemented501, + status502, + badGateway502, + status503, + serviceUnavailable503, + status504, + gatewayTimeout504, + status505, + httpVersionNotSupported505, + status511, + networkAuthenticationRequired511, + + -- * Checking status code category + statusIsInformational, + statusIsSuccessful, + statusIsRedirection, + statusIsClientError, + statusIsServerError, ) where -import qualified Data.ByteString as B -import Data.Typeable +import Data.ByteString as B (ByteString, empty) +import Data.Data (Data) +import GHC.Generics (Generic) -- | HTTP Status. -- -- Only the 'statusCode' is used for comparisons. -- --- Please use 'mkStatus' to create status codes from code and message, or the 'Enum' instance or the --- status code constants (like 'ok200'). There might be additional record members in the future. +-- /Please use 'mkStatus' to create status codes from code and message, or the 'Enum' instance or the/ +-- /status code constants (like 'ok200'). There might be additional record members in the future./ -- --- Note that the Show instance is only for debugging. -data Status - = Status { statusCode :: Int - , statusMessage :: B.ByteString - } deriving (Show, Typeable) +-- Note that the 'Show' instance is only for debugging. +data Status = Status + { statusCode :: Int + -- ^ The 3-digit code of a 'Status' + -- + -- For example: "200" in a @200 OK@ status + , statusMessage :: B.ByteString + -- ^ The textual message of a 'Status' + -- + -- For example: "Not Found" in a @404 Not Found@ status + } + deriving + ( Show + , -- | @since 0.12.4 + Data + , -- | @since 0.12.4 + Generic + ) +-- FIXME: If the data constructor of 'Status' is ever deprecated, we should define +-- a pattern synonym to minimize any breakage. This also involves changing the +-- name of the constructor, so that it doesn't clash with the new pattern synonym +-- that's replacing it. +-- +-- > data Status = MkStatus ... +-- > pattern Status code msg = MkStatus code msg + +-- | A 'Status' is equal to another 'Status' if the status codes are equal. instance Eq Status where - Status { statusCode = a } == Status { statusCode = b } = a == b + Status{statusCode = a} == Status{statusCode = b} = a == b +-- | 'Status'es are ordered according to their status codes only. instance Ord Status where - compare Status { statusCode = a } Status { statusCode = b } = a `compare` b + compare Status{statusCode = a} Status{statusCode = b} = a `compare` b +-- | Be advised, that when using the \"enumFrom*\" family of methods or +-- ranges in lists, it will generate all possible status codes. +-- +-- E.g. @[status100 .. status200]@ generates 'Status'es of @100, 101, 102 .. 198, 199, 200@ +-- +-- The statuses not included in this library will have an empty message. +-- +-- @since 0.7.3 instance Enum Status where fromEnum = statusCode toEnum 100 = status100 @@ -170,6 +223,7 @@ toEnum 428 = status428 toEnum 429 = status429 toEnum 431 = status431 + toEnum 451 = status451 toEnum 500 = status500 toEnum 501 = status501 toEnum 502 = status502 @@ -177,29 +231,40 @@ toEnum 504 = status504 toEnum 505 = status505 toEnum 511 = status511 - toEnum c = mkStatus c B.empty + toEnum c = mkStatus c B.empty +-- | @since 0.11 instance Bounded Status where - minBound = status100 - maxBound = status511 + minBound = status100 + maxBound = status511 --- | Create a Status from status code and message. +-- | Create a 'Status' from a status code and message. +-- +-- @since 0.7.3 mkStatus :: Int -> B.ByteString -> Status mkStatus = Status -- | Continue 100 +-- +-- @since 0.6.6 status100 :: Status status100 = mkStatus 100 "Continue" -- | Continue 100 +-- +-- @since 0.6.6 continue100 :: Status continue100 = status100 -- | Switching Protocols 101 +-- +-- @since 0.6.6 status101 :: Status status101 = mkStatus 101 "Switching Protocols" -- | Switching Protocols 101 +-- +-- @since 0.6.6 switchingProtocols101 :: Status switchingProtocols101 = status101 @@ -220,42 +285,62 @@ created201 = status201 -- | Accepted 202 +-- +-- @since 0.6.6 status202 :: Status status202 = mkStatus 202 "Accepted" -- | Accepted 202 +-- +-- @since 0.6.6 accepted202 :: Status accepted202 = status202 -- | Non-Authoritative Information 203 +-- +-- @since 0.6.6 status203 :: Status status203 = mkStatus 203 "Non-Authoritative Information" -- | Non-Authoritative Information 203 +-- +-- @since 0.6.6 nonAuthoritative203 :: Status nonAuthoritative203 = status203 -- | No Content 204 +-- +-- @since 0.6.6 status204 :: Status status204 = mkStatus 204 "No Content" -- | No Content 204 +-- +-- @since 0.6.6 noContent204 :: Status noContent204 = status204 -- | Reset Content 205 +-- +-- @since 0.6.6 status205 :: Status status205 = mkStatus 205 "Reset Content" -- | Reset Content 205 +-- +-- @since 0.6.6 resetContent205 :: Status resetContent205 = status205 -- | Partial Content 206 +-- +-- @since 0.5.1 status206 :: Status status206 = mkStatus 206 "Partial Content" -- | Partial Content 206 +-- +-- @since 0.5.1 partialContent206 :: Status partialContent206 = status206 @@ -292,34 +377,50 @@ seeOther303 = status303 -- | Not Modified 304 +-- +-- @since 0.6.1 status304 :: Status status304 = mkStatus 304 "Not Modified" -- | Not Modified 304 +-- +-- @since 0.6.1 notModified304 :: Status notModified304 = status304 -- | Use Proxy 305 +-- +-- @since 0.6.6 status305 :: Status status305 = mkStatus 305 "Use Proxy" -- | Use Proxy 305 +-- +-- @since 0.6.6 useProxy305 :: Status useProxy305 = status305 -- | Temporary Redirect 307 +-- +-- @since 0.6.6 status307 :: Status status307 = mkStatus 307 "Temporary Redirect" -- | Temporary Redirect 307 +-- +-- @since 0.6.6 temporaryRedirect307 :: Status temporaryRedirect307 = status307 -- | Permanent Redirect 308 +-- +-- @since 0.9 status308 :: Status status308 = mkStatus 308 "Permanent Redirect" -- | Permanent Redirect 308 +-- +-- @since 0.9 permanentRedirect308 :: Status permanentRedirect308 = status308 @@ -340,10 +441,14 @@ unauthorized401 = status401 -- | Payment Required 402 +-- +-- @since 0.6.6 status402 :: Status status402 = mkStatus 402 "Payment Required" -- | Payment Required 402 +-- +-- @since 0.6.6 paymentRequired402 :: Status paymentRequired402 = status402 @@ -372,159 +477,248 @@ methodNotAllowed405 = status405 -- | Not Acceptable 406 +-- +-- @since 0.6.6 status406 :: Status status406 = mkStatus 406 "Not Acceptable" -- | Not Acceptable 406 +-- +-- @since 0.6.6 notAcceptable406 :: Status notAcceptable406 = status406 -- | Proxy Authentication Required 407 +-- +-- @since 0.6.6 status407 :: Status status407 = mkStatus 407 "Proxy Authentication Required" -- | Proxy Authentication Required 407 +-- +-- @since 0.6.6 proxyAuthenticationRequired407 :: Status proxyAuthenticationRequired407 = status407 -- | Request Timeout 408 +-- +-- @since 0.6.6 status408 :: Status status408 = mkStatus 408 "Request Timeout" -- | Request Timeout 408 +-- +-- @since 0.6.6 requestTimeout408 :: Status requestTimeout408 = status408 -- | Conflict 409 +-- +-- @since 0.6.6 status409 :: Status status409 = mkStatus 409 "Conflict" -- | Conflict 409 +-- +-- @since 0.6.6 conflict409 :: Status conflict409 = status409 -- | Gone 410 +-- +-- @since 0.6.6 status410 :: Status status410 = mkStatus 410 "Gone" -- | Gone 410 +-- +-- @since 0.6.6 gone410 :: Status gone410 = status410 -- | Length Required 411 +-- +-- @since 0.6.6 status411 :: Status status411 = mkStatus 411 "Length Required" -- | Length Required 411 +-- +-- @since 0.6.6 lengthRequired411 :: Status lengthRequired411 = status411 -- | Precondition Failed 412 +-- +-- @since 0.6.1 status412 :: Status status412 = mkStatus 412 "Precondition Failed" -- | Precondition Failed 412 +-- +-- @since 0.6.1 preconditionFailed412 :: Status preconditionFailed412 = status412 -- | Request Entity Too Large 413 +-- +-- @since 0.6.6 status413 :: Status status413 = mkStatus 413 "Request Entity Too Large" -- | Request Entity Too Large 413 +-- +-- @since 0.6.6 requestEntityTooLarge413 :: Status requestEntityTooLarge413 = status413 -- | Request-URI Too Long 414 +-- +-- @since 0.6.6 status414 :: Status status414 = mkStatus 414 "Request-URI Too Long" -- | Request-URI Too Long 414 +-- +-- @since 0.6.6 requestURITooLong414 :: Status requestURITooLong414 = status414 -- | Unsupported Media Type 415 +-- +-- @since 0.6.6 status415 :: Status status415 = mkStatus 415 "Unsupported Media Type" -- | Unsupported Media Type 415 +-- +-- @since 0.6.6 unsupportedMediaType415 :: Status unsupportedMediaType415 = status415 -- | Requested Range Not Satisfiable 416 +-- +-- @since 0.6.1 status416 :: Status status416 = mkStatus 416 "Requested Range Not Satisfiable" -- | Requested Range Not Satisfiable 416 +-- +-- @since 0.6.1 requestedRangeNotSatisfiable416 :: Status requestedRangeNotSatisfiable416 = status416 -- | Expectation Failed 417 +-- +-- @since 0.6.6 status417 :: Status status417 = mkStatus 417 "Expectation Failed" -- | Expectation Failed 417 +-- +-- @since 0.6.6 expectationFailed417 :: Status expectationFailed417 = status417 +-- FIXME: RFC 7168 updates the message to "I'm a Teapot" (capital T) +-- Should we update this? + -- | I'm a teapot 418 +-- +-- @since 0.6.6 status418 :: Status status418 = mkStatus 418 "I'm a teapot" -- | I'm a teapot 418 +-- +-- @since 0.6.6 imATeapot418 :: Status imATeapot418 = status418 -- | Unprocessable Entity 422 -- () +-- +-- @since 0.9.1 status422 :: Status status422 = mkStatus 422 "Unprocessable Entity" -- | Unprocessable Entity 422 -- () +-- +-- @since 0.9.1 unprocessableEntity422 :: Status unprocessableEntity422 = status422 -- | Upgrade Required 426 --- () +-- () +-- +-- @since 0.10 status426 :: Status status426 = mkStatus 426 "Upgrade Required" -- | Upgrade Required 426 --- () +-- () +-- +-- @since 0.10 upgradeRequired426 :: Status upgradeRequired426 = status426 -- | Precondition Required 428 --- () +-- () +-- +-- @since 0.8.5 status428 :: Status status428 = mkStatus 428 "Precondition Required" -- | Precondition Required 428 --- () +-- () +-- +-- @since 0.8.5 preconditionRequired428 :: Status preconditionRequired428 = status428 -- | Too Many Requests 429 --- () +-- () +-- +-- @since 0.8.5 status429 :: Status status429 = mkStatus 429 "Too Many Requests" -- | Too Many Requests 429 --- () +-- () +-- +-- @since 0.8.5 tooManyRequests429 :: Status tooManyRequests429 = status429 -- | Request Header Fields Too Large 431 --- () +-- () +-- +-- @since 0.8.5 status431 :: Status status431 = mkStatus 431 "Request Header Fields Too Large" -- | Request Header Fields Too Large 431 --- () +-- () +-- +-- @since 0.8.5 requestHeaderFieldsTooLarge431 :: Status requestHeaderFieldsTooLarge431 = status431 +-- | Unavailable For Legal Reasons 451 +-- () +-- +-- @since 0.12.5 +status451 :: Status +status451 = mkStatus 451 "Unavailable For Legal Reasons" + +-- | Unavailable For Legal Reasons 451 +-- () +-- +-- @since 0.12.5 +unavailableForLegalReasons451 :: Status +unavailableForLegalReasons451 = status451 + -- | Internal Server Error 500 status500 :: Status status500 = mkStatus 500 "Internal Server Error" @@ -534,71 +728,115 @@ internalServerError500 = status500 -- | Not Implemented 501 +-- +-- @since 0.6.1 status501 :: Status status501 = mkStatus 501 "Not Implemented" -- | Not Implemented 501 +-- +-- @since 0.6.1 notImplemented501 :: Status notImplemented501 = status501 -- | Bad Gateway 502 +-- +-- @since 0.6.6 status502 :: Status status502 = mkStatus 502 "Bad Gateway" -- | Bad Gateway 502 +-- +-- @since 0.6.6 badGateway502 :: Status badGateway502 = status502 -- | Service Unavailable 503 +-- +-- @since 0.6.6 status503 :: Status status503 = mkStatus 503 "Service Unavailable" -- | Service Unavailable 503 +-- +-- @since 0.6.6 serviceUnavailable503 :: Status serviceUnavailable503 = status503 -- | Gateway Timeout 504 +-- +-- @since 0.6.6 status504 :: Status status504 = mkStatus 504 "Gateway Timeout" -- | Gateway Timeout 504 +-- +-- @since 0.6.6 gatewayTimeout504 :: Status gatewayTimeout504 = status504 -- | HTTP Version Not Supported 505 +-- +-- @since 0.6.6 status505 :: Status status505 = mkStatus 505 "HTTP Version Not Supported" -- | HTTP Version Not Supported 505 +-- +-- @since 0.6.6 httpVersionNotSupported505 :: Status httpVersionNotSupported505 = status505 -- | Network Authentication Required 511 --- () +-- () +-- +-- @since 0.8.5 status511 :: Status status511 = mkStatus 511 "Network Authentication Required" -- | Network Authentication Required 511 --- () +-- () +-- +-- @since 0.8.5 networkAuthenticationRequired511 :: Status networkAuthenticationRequired511 = status511 -- | Informational class +-- +-- Checks if the status is in the 1XX range. +-- +-- @since 0.8.0 statusIsInformational :: Status -> Bool -statusIsInformational (Status {statusCode=code}) = code >= 100 && code < 200 +statusIsInformational (Status{statusCode = code}) = code >= 100 && code < 200 -- | Successful class +-- +-- Checks if the status is in the 2XX range. +-- +-- @since 0.8.0 statusIsSuccessful :: Status -> Bool -statusIsSuccessful (Status {statusCode=code}) = code >= 200 && code < 300 +statusIsSuccessful (Status{statusCode = code}) = code >= 200 && code < 300 -- | Redirection class +-- +-- Checks if the status is in the 3XX range. +-- +-- @since 0.8.0 statusIsRedirection :: Status -> Bool -statusIsRedirection (Status {statusCode=code}) = code >= 300 && code < 400 +statusIsRedirection (Status{statusCode = code}) = code >= 300 && code < 400 -- | Client Error class +-- +-- Checks if the status is in the 4XX range. +-- +-- @since 0.8.0 statusIsClientError :: Status -> Bool -statusIsClientError (Status {statusCode=code}) = code >= 400 && code < 500 +statusIsClientError (Status{statusCode = code}) = code >= 400 && code < 500 -- | Server Error class +-- +-- Checks if the status is in the 5XX range. +-- +-- @since 0.8.0 statusIsServerError :: Status -> Bool -statusIsServerError (Status {statusCode=code}) = code >= 500 && code < 600 +statusIsServerError (Status{statusCode = code}) = code >= 500 && code < 600 diff --git a/Network/HTTP/Types/URI.hs b/Network/HTTP/Types/URI.hs --- a/Network/HTTP/Types/URI.hs +++ b/Network/HTTP/Types/URI.hs @@ -1,140 +1,236 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} -module Network.HTTP.Types.URI -( - -- * Query string - QueryItem -, Query -, SimpleQueryItem -, SimpleQuery -, simpleQueryToQuery -, renderQuery -, renderQueryBuilder -, renderSimpleQuery -, parseQuery -, parseSimpleQuery - -- ** Text query string (UTF8 encoded) -, QueryText -, queryTextToQuery -, queryToQueryText -, renderQueryText -, parseQueryText - -- * Path segments -, encodePathSegments -, decodePathSegments -, encodePathSegmentsRelative - -- * Path (segments + query string) -, extractPath -, encodePath -, decodePath - -- * URL encoding / decoding -, urlEncodeBuilder -, urlEncode -, urlDecode +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Query strings generally have the following form: @"key1=value1&key2=value2"@ +-- +-- >>> renderQuery False [("key1", Just "value1"), ("key2", Just "value2")] +-- "key1=value1&key2=value2" +-- +-- But if the value of @key1@ is 'Nothing', it becomes: @key1&key2=value2@ +-- +-- >>> renderQuery False [("key1", Nothing), ("key2", Just "value2")] +-- "key1&key2=value2" +-- +-- This module also provides type synonyms and functions to handle queries +-- that do not allow/expect keys without values ('SimpleQuery'), handle +-- queries which have partially escaped characters +module Network.HTTP.Types.URI ( + -- * Query strings + + -- ** Query + Query, + QueryItem, + renderQuery, + renderQueryBuilder, + parseQuery, + parseQueryReplacePlus, + + -- *** Query (Text) + QueryText, + queryTextToQuery, + queryToQueryText, + renderQueryText, + parseQueryText, + + -- ** SimpleQuery + + -- | If values are guaranteed, it might be easier working with 'SimpleQuery'. + -- + -- This way, you don't have to worry about any 'Maybe's, though when parsing + -- a query string and there's no @\'=\'@ after the key in the query item, the + -- value will just be an empty 'B.ByteString'. + SimpleQuery, + SimpleQueryItem, + simpleQueryToQuery, + renderSimpleQuery, + parseSimpleQuery, + + -- ** PartialEscapeQuery + + -- | For some values in query items, certain characters must not be percent-encoded, + -- for example @\'+\'@ or @\':\'@ in + -- + -- @q=a+language:haskell+created:2009-01-01..2009-02-01&sort=stars@ + -- + -- Using specific 'EscapeItem's provides a way to decide which parts of a query string value + -- will be URL encoded and which won't. + -- + -- This is mandatory when searching for @\'+\'@ (@%2B@ being a percent-encoded @\'+\'@): + -- + -- @q=%2B+language:haskell@ + PartialEscapeQuery, + PartialEscapeQueryItem, + EscapeItem (..), + renderQueryPartialEscape, + renderQueryBuilderPartialEscape, + + -- * Path + + -- ** Segments + Query String + extractPath, + encodePath, + decodePath, + + -- ** Path Segments + encodePathSegments, + encodePathSegmentsRelative, + decodePathSegments, + + -- * URL encoding / decoding + urlEncode, + urlEncodeBuilder, + urlDecode, ) where -import Control.Arrow -import Data.Bits -import Data.Char -import Data.List -import Data.Maybe -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid +import Control.Arrow (second, (***)) +import Data.Bits (shiftL, (.|.)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BL +import Data.Char (ord) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Word (Word8) + +-- This section is needed to run doctests for GHC 8.10.7 +#if !MIN_VERSION_bytestring(0,11,1) +-- $setup +-- >>> :{ +-- instance Show B.Builder where +-- show = show . B.toLazyByteString +-- :} #endif -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Word -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Char8 () {-IsString-} --- | Query item +-- | An item from the query string, split up into two parts. +-- +-- The second part should be 'Nothing' if there was no key-value +-- separator after the query item name. +-- +-- @since 0.2.0 type QueryItem = (B.ByteString, Maybe B.ByteString) --- | Query. --- --- General form: a=b&c=d, but if the value is Nothing, it becomes --- a&c=d. +-- | A sequence of 'QueryItem's. type Query = [QueryItem] -- | Like Query, but with 'Text' instead of 'B.ByteString' (UTF8-encoded). +-- +-- @since 0.5.2 type QueryText = [(Text, Maybe Text)] -- | Convert 'QueryText' to 'Query'. +-- +-- @since 0.5.2 queryTextToQuery :: QueryText -> Query queryTextToQuery = map $ encodeUtf8 *** fmap encodeUtf8 -- | Convert 'QueryText' to a 'B.Builder'. -renderQueryText :: Bool -- ^ prepend a question mark? - -> QueryText - -> B.Builder +-- +-- If you want a question mark (@?@) added to the front of the result, use 'True'. +-- +-- @since 0.5.2 +renderQueryText :: Bool -> QueryText -> B.Builder renderQueryText b = renderQueryBuilder b . queryTextToQuery -- | Convert 'Query' to 'QueryText' (leniently decoding the UTF-8). +-- +-- @since 0.5.2 queryToQueryText :: Query -> QueryText queryToQueryText = map $ go *** fmap go where go = decodeUtf8With lenientDecode --- | Parse 'QueryText' from a 'B.ByteString'. See 'parseQuery' for details. +-- | Parse a 'QueryText' from a 'B.ByteString'. See 'parseQuery' for details. +-- +-- @'queryToQueryText' . 'parseQuery'@ +-- +-- @since 0.5.2 parseQueryText :: B.ByteString -> QueryText parseQueryText = queryToQueryText . parseQuery --- | Simplified Query item type without support for parameter-less items. +-- | Simplified query item type without support for parameter-less items. +-- +-- @since 0.2.0 type SimpleQueryItem = (B.ByteString, B.ByteString) --- | Simplified Query type without support for parameter-less items. +-- | A sequence of 'SimpleQueryItem's. type SimpleQuery = [SimpleQueryItem] -- | Convert 'SimpleQuery' to 'Query'. +-- +-- @since 0.5 simpleQueryToQuery :: SimpleQuery -> Query simpleQueryToQuery = map (second Just) --- | Convert 'Query' to a 'Builder'. -renderQueryBuilder :: Bool -- ^ prepend a question mark? - -> Query - -> B.Builder +-- | Renders the given 'Query' into a 'B.Builder'. +-- +-- If you want a question mark (@?@) added to the front of the result, use 'True'. +-- +-- @since 0.5 +renderQueryBuilder :: Bool -> Query -> B.Builder renderQueryBuilder _ [] = mempty --- FIXME replace mconcat + map with foldr -renderQueryBuilder qmark' (p:ps) = mconcat - $ go (if qmark' then qmark else mempty) p - : map (go amp) ps +renderQueryBuilder qmark' (p : ps) = + -- FIXME: replace mconcat + map with foldr + mconcat $ + go (if qmark' then qmark else mempty) p + : map (go amp) ps where qmark = B.byteString "?" amp = B.byteString "&" equal = B.byteString "=" - go sep (k, mv) = mconcat [ - sep - , urlEncodeBuilder True k - , case mv of - Nothing -> mempty - Just v -> equal `mappend` urlEncodeBuilder True v - ] + go sep (k, mv) = + mconcat + [ sep + , urlEncodeBuilder True k + , case mv of + Nothing -> mempty + Just v -> equal `mappend` urlEncodeBuilder True v + ] --- | Convert 'Query' to 'ByteString'. -renderQuery :: Bool -- ^ prepend question mark? - -> Query -> B.ByteString +-- | Renders the given 'Query' into a 'B.ByteString'. +-- +-- If you want a question mark (@?@) added to the front of the result, use 'True'. +-- +-- @since 0.2.0 +renderQuery :: Bool -> Query -> B.ByteString renderQuery qm = BL.toStrict . B.toLazyByteString . renderQueryBuilder qm --- | Convert 'SimpleQuery' to 'ByteString'. -renderSimpleQuery :: Bool -- ^ prepend question mark? - -> SimpleQuery -> B.ByteString +-- | Render the given 'SimpleQuery' into a 'B.ByteString'. +-- +-- If you want a question mark (@?@) added to the front of the result, use 'True'. +-- +-- @since 0.2.0 +renderSimpleQuery :: Bool -> SimpleQuery -> B.ByteString renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . simpleQueryToQuery -- | Split out the query string into a list of keys and values. A few -- importants points: --- +-- -- * The result returned is still bytestrings, since we perform no character -- decoding here. Most likely, you will want to use UTF-8 decoding, but this is -- left to the user of the library. --- --- * Percent decoding errors are ignored. In particular, "%Q" will be output as --- "%Q". +-- +-- * Percent decoding errors are ignored. In particular, @"%Q"@ will be output as +-- @"%Q"@. +-- +-- * It decodes @\'+\'@ characters to @\' \'@ +-- +-- @since 0.2.0 parseQuery :: B.ByteString -> Query -parseQuery = parseQueryString' . dropQuestion +parseQuery = parseQueryReplacePlus True + +-- | Same functionality as 'parseQuery', but with the option to decode @\'+\'@ characters to @\' \'@ +-- or to preserve any @\'+\'@ encountered. +-- +-- If you want to replace any @\'+\'@ with a space, use 'True'. +-- +-- @since 0.12.2 +parseQueryReplacePlus :: Bool -> B.ByteString -> Query +parseQueryReplacePlus replacePlus bs = parseQueryString' $ dropQuestion bs where dropQuestion q = case B.uncons q of @@ -149,12 +245,12 @@ let (k, v) = B.break (== 61) x -- equal sign v'' = case B.uncons v of - Just (_, v') -> Just $ urlDecode True v' + Just (_, v') -> Just $ urlDecode replacePlus v' _ -> Nothing - in (urlDecode True k, v'') + in (urlDecode replacePlus k, v'') queryStringSeparators :: B.ByteString -queryStringSeparators = B.pack [38,59] -- ampersand, semicolon +queryStringSeparators = B.pack [38, 59] -- ampersand, semicolon -- | Break the second bytestring at the first occurrence of any bytes from -- the first bytestring, discarding that byte. @@ -163,7 +259,12 @@ let (x, y) = B.break (`B.elem` seps) s in (x, B.drop 1 y) --- | Parse 'SimpleQuery' from a 'ByteString'. +-- | Parse 'SimpleQuery' from a 'B.ByteString'. +-- +-- This uses 'parseQuery' under the hood, and will transform +-- any 'Nothing' values into an empty 'B.ByteString'. +-- +-- @since 0.2.0 parseSimpleQuery :: B.ByteString -> SimpleQuery parseSimpleQuery = map (second $ fromMaybe B.empty) . parseQuery @@ -171,47 +272,96 @@ ord8 = fromIntegral . ord unreservedQS, unreservedPI :: [Word8] +-- FIXME: According to RFC 3986, the following are also allowed in query segments: +-- "!'()*;:@&=+$,/?" +-- +-- https://www.rfc-editor.org/rfc/rfc3986#section-3.4 +-- +-- Incidentally, this is also the list of unreserved characters for fragments. unreservedQS = map ord8 "-_.~" +-- FIXME: According to RFC 3986, the following are also allowed in path segments: +-- "!'()*;" +-- +-- https://www.rfc-editor.org/rfc/rfc3986#section-3.3 unreservedPI = map ord8 "-_.~:@&=+$," -- | Percent-encoding for URLs. +-- +-- This will substitute every byte with its percent-encoded equivalent unless: +-- +-- * The byte is alphanumeric. (i.e. one of @/[A-Za-z0-9]/@) +-- +-- * The byte is one of the 'Word8' listed in the first argument. urlEncodeBuilder' :: [Word8] -> B.ByteString -> B.Builder -urlEncodeBuilder' extraUnreserved = mconcat . map encodeChar . B.unpack - where - encodeChar ch | unreserved ch = B.word8 ch - | otherwise = h2 ch +urlEncodeBuilder' extraUnreserved = + mconcat . map encodeChar . B.unpack + where + encodeChar ch + | unreserved ch = B.word8 ch + | otherwise = h2 ch - unreserved ch | ch >= 65 && ch <= 90 = True -- A-Z - | ch >= 97 && ch <= 122 = True -- a-z - | ch >= 48 && ch <= 57 = True -- 0-9 - unreserved c = c `elem` extraUnreserved + unreserved ch + | ch >= 65 && ch <= 90 = True -- A-Z + | ch >= 97 && ch <= 122 = True -- a-z + | ch >= 48 && ch <= 57 = True -- 0-9 + unreserved c = c `elem` extraUnreserved - h2 v = B.word8 37 `mappend` B.word8HexFixed v -- percent (%) + -- must be upper-case + h2 v = B.word8 37 `mappend` B.word8 (h a) `mappend` B.word8 (h b) -- 37 = % + where + (a, b) = v `divMod` 16 + h i + | i < 10 = 48 + i -- zero (0) + | otherwise = 65 + i - 10 -- 65: A --- | Percent-encoding for URLs (using 'B.Builder'). -urlEncodeBuilder - :: Bool -- ^ Whether input is in query string. True: Query string, False: Path element - -> B.ByteString - -> B.Builder -urlEncodeBuilder True = urlEncodeBuilder' unreservedQS +-- | Percent-encoding for URLs. +-- +-- Like 'urlEncode', but only makes the 'B.Builder'. +-- +-- @since 0.5 +urlEncodeBuilder :: Bool -> B.ByteString -> B.Builder +urlEncodeBuilder True = urlEncodeBuilder' unreservedQS urlEncodeBuilder False = urlEncodeBuilder' unreservedPI -- | Percent-encoding for URLs. -urlEncode :: Bool -- ^ Whether to decode '+' to ' ' - -> B.ByteString -- ^ The ByteString to encode as URL - -> B.ByteString -- ^ The encoded URL +-- +-- In short: +-- +-- * if you're encoding (parts of) a path element, use 'False'. +-- +-- * if you're encoding (parts of) a query string, use 'True'. +-- +-- === __In-depth explanation__ +-- +-- This will substitute every byte with its percent-encoded equivalent unless: +-- +-- * The byte is alphanumeric. (i.e. @A-Z@, @a-z@, or @0-9@) +-- +-- * The byte is either a dash @\'-\'@, an underscore @\'_\'@, a dot @\'.\'@, or a tilde @\'~\'@ +-- +-- * If 'False' is used, the following will also /not/ be percent-encoded: +-- +-- * colon @\':\'@, at sign @\'\@\'@, ampersand @\'&\'@, equals sign @\'=\'@, plus sign @\'+\'@, dollar sign @\'$\'@ or a comma @\',\'@ +-- +-- @since 0.2.0 +urlEncode :: Bool -> B.ByteString -> B.ByteString urlEncode q = BL.toStrict . B.toLazyByteString . urlEncodeBuilder q -- | Percent-decoding. -urlDecode :: Bool -- ^ Whether to decode '+' to ' ' - -> B.ByteString -> B.ByteString +-- +-- If you want to replace any @\'+\'@ with a space, use 'True'. +-- +-- @since 0.2.0 +urlDecode :: Bool -> B.ByteString -> B.ByteString urlDecode replacePlus z = fst $ B.unfoldrN (B.length z) go z where go bs = case B.uncons bs of Nothing -> Nothing - Just (43, ws) | replacePlus -> Just (32, ws) -- plus to space - Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent + -- plus to space + Just (43, ws) | replacePlus -> Just (32, ws) + -- percent + Just (37, ws) -> Just $ fromMaybe (37, ws) $ do (x, xs) <- B.uncons ws x' <- hexVal x (y, ys) <- B.uncons xs @@ -219,44 +369,51 @@ Just (combine x' y', ys) Just (w, ws) -> Just (w, ws) hexVal w - | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9 - | 65 <= w && w <= 70 = Just $ w - 55 -- A - F + | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9 + | 65 <= w && w <= 70 = Just $ w - 55 -- A - F | 97 <= w && w <= 102 = Just $ w - 87 -- a - f | otherwise = Nothing combine :: Word8 -> Word8 -> Word8 combine a b = shiftL a 4 .|. b -- | Encodes a list of path segments into a valid URL fragment. --- +-- -- This function takes the following three steps: --- +-- -- * UTF-8 encodes the characters. --- --- * Performs percent encoding on all unreserved characters, as well as \:\@\=\+\$, --- +-- -- * Prepends each segment with a slash. --- +-- +-- * Performs percent-encoding on all characters that are __not__: +-- +-- * alphanumeric (i.e. @A-Z@ and @a-z@) +-- +-- * digits (i.e. @0-9@) +-- +-- * a dash @\'-\'@, an underscore @\'_\'@, a dot @\'.\'@, or a tilde @\'~\'@ +-- -- For example: --- --- > encodePathSegments [\"foo\", \"bar\", \"baz\"] --- --- \"\/foo\/bar\/baz\" --- --- > encodePathSegments [\"foo bar\", \"baz\/bin\"] --- --- \"\/foo\%20bar\/baz\%2Fbin\" --- --- > encodePathSegments [\"שלום\"] --- --- \"\/%D7%A9%D7%9C%D7%95%D7%9D\" --- --- Huge thanks to Jeremy Shaw who created the original implementation of this +-- +-- >>> encodePathSegments ["foo", "bar1", "~baz"] +-- "/foo/bar1/~baz" +-- +-- >>> encodePathSegments ["foo bar", "baz/bin"] +-- "/foo%20bar/baz%2Fbin" +-- +-- >>> encodePathSegments ["שלום"] +-- "/%D7%A9%D7%9C%D7%95%D7%9D" +-- +-- Huge thanks to /Jeremy Shaw/ who created the original implementation of this -- function in web-routes and did such thorough research to determine all -- correct escaping procedures. +-- +-- @since 0.5 encodePathSegments :: [Text] -> B.Builder encodePathSegments = foldr (\x -> mappend (B.byteString "/" `mappend` encodePathSegment x)) mempty --- | Like encodePathSegments, but without the initial slash. +-- | Like 'encodePathSegments', but without the initial slash. +-- +-- @since 0.6.10 encodePathSegmentsRelative :: [Text] -> B.Builder encodePathSegmentsRelative xs = mconcat $ intersperse (B.byteString "/") (map encodePathSegment xs) @@ -264,6 +421,10 @@ encodePathSegment = urlEncodeBuilder False . encodeUtf8 -- | Parse a list of path segments from a valid URL fragment. +-- +-- Will also decode any percent-encoded characters. +-- +-- @since 0.5 decodePathSegments :: B.ByteString -> [Text] decodePathSegments "" = [] decodePathSegments "/" = [] @@ -276,17 +437,24 @@ _ -> bs go bs = let (x, y) = B.break (== 47) bs - in decodePathSegment x : - if B.null y - then [] - else go $ B.drop 1 y + in decodePathSegment x + : if B.null y + then [] + else go $ B.drop 1 y decodePathSegment :: B.ByteString -> Text decodePathSegment = decodeUtf8With lenientDecode . urlDecode False -- | Extract whole path (path segments + query) from a --- . +-- [RFC 2616 Request-URI](http://tools.ietf.org/html/rfc2616#section-5.1.2). -- +-- Though a more accurate description of this function's behaviour is that +-- it removes the domain/origin if the string starts with an HTTP protocol. +-- (i.e. @http://@ or @https://@) +-- +-- This function will not change anything when given any other 'B.ByteString'. +-- (except return a root path @\"\/\"@ if given an empty string) +-- -- >>> extractPath "/path" -- "/path" -- @@ -298,24 +466,101 @@ -- -- >>> extractPath "" -- "/" +-- +-- >>> extractPath "www.google.com/some/path" +-- "www.google.com/some/path" +-- +-- @since 0.8.5 extractPath :: B.ByteString -> B.ByteString extractPath = ensureNonEmpty . extract where extract path - | "http://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 7) path - | "https://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 8) path - | otherwise = path + | "http://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 7) path + | "https://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 8) path + | otherwise = path breakOnSlash = B.break (== 47) ensureNonEmpty "" = "/" - ensureNonEmpty p = p + ensureNonEmpty p = p -- | Encode a whole path (path segments + query). +-- +-- @since 0.5 encodePath :: [Text] -> Query -> B.Builder encodePath x [] = encodePathSegments x encodePath x y = encodePathSegments x `mappend` renderQueryBuilder True y -- | Decode a whole path (path segments + query). +-- +-- @since 0.5 decodePath :: B.ByteString -> ([Text], Query) decodePath b = let (x, y) = B.break (== 63) b -- question mark - in (decodePathSegments x, parseQuery y) + in (decodePathSegments x, parseQuery y) + +----------------------------------------------------------------------------------------- + +-- | Section of a query item value that decides whether to use +-- regular URL encoding (using @'urlEncode True'@) with 'QE', +-- or to not encode /anything/ with 'QN'. +-- +-- @since 0.12.1 +data EscapeItem + = -- | will be URL encoded + QE B.ByteString + | -- | will NOT /at all/ be URL encoded + QN B.ByteString + deriving (Show, Eq, Ord) + +-- | Partially escaped query item. +-- +-- The key will always be encoded using @'urlEncode True'@, +-- but the value will be encoded depending on which 'EscapeItem's are used. +-- +-- @since 0.12.1 +type PartialEscapeQueryItem = (B.ByteString, [EscapeItem]) + +-- | Query with some characters that should not be escaped. +-- +-- General form: @a=b&c=d:e+f&g=h@ +-- +-- @since 0.12.1 +type PartialEscapeQuery = [PartialEscapeQueryItem] + +-- | Convert 'PartialEscapeQuery' to 'B.ByteString'. +-- +-- If you want a question mark (@?@) added to the front of the result, use 'True'. +-- +-- >>> renderQueryPartialEscape True [("a", [QN "x:z + ", QE (encodeUtf8 "They said: \"שלום\"")])] +-- "?a=x:z + They%20said%3A%20%22%D7%A9%D7%9C%D7%95%D7%9D%22" +-- +-- @since 0.12.1 +renderQueryPartialEscape :: Bool -> PartialEscapeQuery -> B.ByteString +renderQueryPartialEscape qm = + BL.toStrict . B.toLazyByteString . renderQueryBuilderPartialEscape qm + +-- | Convert a 'PartialEscapeQuery' to a 'B.Builder'. +-- +-- If you want a question mark (@?@) added to the front of the result, use 'True'. +-- +-- @since 0.12.1 +renderQueryBuilderPartialEscape :: Bool -> PartialEscapeQuery -> B.Builder +renderQueryBuilderPartialEscape _ [] = mempty +-- FIXME: replace mconcat + map with foldr +renderQueryBuilderPartialEscape qmark' (p : ps) = + mconcat $ + go (if qmark' then qmark else mempty) p + : map (go amp) ps + where + qmark = B.byteString "?" + amp = B.byteString "&" + equal = B.byteString "=" + go sep (k, mv) = + mconcat + [ sep + , urlEncodeBuilder True k + , case mv of + [] -> mempty + vs -> equal `mappend` mconcat (map encode vs) + ] + encode (QE v) = urlEncodeBuilder True v + encode (QN v) = B.byteString v diff --git a/Network/HTTP/Types/Version.hs b/Network/HTTP/Types/Version.hs --- a/Network/HTTP/Types/Version.hs +++ b/Network/HTTP/Types/Version.hs @@ -1,26 +1,37 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Network.HTTP.Types.Version -( - HttpVersion(..) -, http09 -, http10 -, http11 -, http20 -) -where +{-# LANGUAGE DeriveGeneric #-} -import Data.Typeable +-- | Types and constants to describe the HTTP version. +module Network.HTTP.Types.Version ( + HttpVersion (..), + http09, + http10, + http11, + http20, + http30, +) where +import Data.Data (Data) +import GHC.Generics (Generic) + -- | HTTP Version. -- --- Note that the Show instance is intended merely for debugging. -data HttpVersion - = HttpVersion { - httpMajor :: !Int - , httpMinor :: !Int - } - deriving (Eq, Ord, Typeable) +-- Note that the 'Show' instance is intended merely for debugging. +data HttpVersion = HttpVersion + { httpMajor :: !Int + , httpMinor :: !Int + } + deriving + ( Eq + , Ord + , -- | @since 0.12.4 + Data + , -- | @since 0.12.4 + Generic + ) +-- | >>> show http11 +-- "HTTP/1.1" instance Show HttpVersion where show (HttpVersion major minor) = "HTTP/" ++ show major ++ "." ++ show minor @@ -37,5 +48,13 @@ http11 = HttpVersion 1 1 -- | HTTP 2.0 +-- +-- @since 0.10 http20 :: HttpVersion http20 = HttpVersion 2 0 + +-- | HTTP 3.0 +-- +-- @since 0.12.5 +http30 :: HttpVersion +http30 = HttpVersion 3 0 diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,5 +0,0 @@ -Generic HTTP types for Haskell (for both client and server code). - -This library also contains some utility functions, e.g. related to URI -handling, that are not necessarily restricted in use to HTTP, but the scope is -restricted to things that are useful inside HTTP, i.e. no FTP URI parsing. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +![Build Status](https://github.com/Vlix/http-types/actions/workflows/ci.yml/badge.svg?branch=master) +[![Hackage](https://img.shields.io/hackage/v/http-types.svg)](https://hackage.haskell.org/package/http-types) +[![Stackage LTS](http://stackage.org/package/http-types/badge/lts)](http://stackage.org/lts/package/http-types) +[![Stackage Nightly](http://stackage.org/package/http-types/badge/nightly)](http://stackage.org/nightly/package/http-types) +[![BSD 3-Clause License](https://img.shields.io/badge/License-BSD_3--Clause-blue.svg)](./LICENSE) + +# Generic HTTP types for Haskell (for both client and server code). + +The goal of this library is to have one location for any library, package or project +to base their general HTTP types on for better interoperability. + +### This library provides basic types for the following: + +* HTTP versions (e.g. `HTTP/1.1`) +* HTTP methods (e.g. `GET`) +* HTTP headers (e.g. `Content-Type`) +* HTTP statusses (e.g. `404`) + +This library also contains some utility functions, e.g. related to URI handling, +that are not necessarily restricted in use to HTTP, but the scope is restricted +to things that are useful inside HTTP, i.e. no FTP URI parsing. diff --git a/http-types.cabal b/http-types.cabal --- a/http-types.cabal +++ b/http-types.cabal @@ -1,26 +1,34 @@ +Cabal-version: 2.2 Name: http-types -Version: 0.11 +Version: 0.12.5 Synopsis: Generic HTTP types for Haskell (for both client and server code). -Description: Generic HTTP types for Haskell (for both client and server code). -Homepage: https://github.com/aristidb/http-types -License: BSD3 +Description: Types and functions to describe and handle HTTP concepts. + Including "methods", "headers", "query strings", "paths" and "HTTP versions". +Homepage: https://github.com/Vlix/http-types +License: BSD-3-Clause License-file: LICENSE Author: Aristid Breitkreuz, Michael Snoyman -Maintainer: aristidb@googlemail.com -Copyright: (C) 2011 Aristid Breitkreuz +Maintainer: felix.paulusma@gmail.com +Copyright: (C) 2011 Aristid Breitkreuz, (C) 2023 Felix Paulusma Category: Network, Web Build-type: Simple -Extra-source-files: README, CHANGELOG -Cabal-version: >=1.8 +Tested-with: + GHC == 7.10.3, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.4, GHC == 9.14.1 +Extra-source-files: + test/.golden/urlEncode-path/golden + test/.golden/urlEncode-query/golden +Extra-doc-files: + README.md + CHANGELOG.md Source-repository this type: git - location: https://github.com/aristidb/http-types.git - tag: 0.11 + location: https://github.com/Vlix/http-types.git + tag: v0.12.5 Source-repository head type: git - location: https://github.com/aristidb/http-types.git + location: https://github.com/Vlix/http-types.git Library Exposed-modules: Network.HTTP.Types @@ -31,28 +39,40 @@ Network.HTTP.Types.URI Network.HTTP.Types.Version GHC-Options: -Wall - Build-depends: base >= 4 && < 5, - bytestring >=0.10.4.0 && <1.0, - array >=0.2 && <0.6, - case-insensitive >=0.2 && <1.3, - text >= 0.11.0.2 + Build-depends: base >= 4.8 && < 5, + bytestring >= 0.10.6.0 && < 1, + array >= 0.5.1.0 && < 0.6, + case-insensitive >= 1.2.0.2 && < 1.3, + text >= 1.2.0.2 && < 3 + Default-language: Haskell2010 Test-suite spec main-is: Spec.hs hs-source-dirs: test + other-modules: Network.HTTP.Types.HeaderSpec + Network.HTTP.Types.MethodSpec + Network.HTTP.Types.StatusSpec + Network.HTTP.Types.URISpec + Network.HTTP.Types.VersionSpec type: exitcode-stdio-1.0 GHC-Options: -Wall - build-depends: base, - http-types, - text, + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover + build-depends: base < 5, bytestring, + case-insensitive, + filepath, + hspec >= 1.3, + hspec-golden >= 0.2, + http-types, QuickCheck, quickcheck-instances, - hspec >= 1.3 + text Test-Suite doctests main-is: doctests.hs hs-source-dirs: test type: exitcode-stdio-1.0 ghc-options: -threaded -Wall - build-depends: base, doctest >= 0.9.3 + default-language: Haskell2010 + build-depends: base < 5, doctest >= 0.19.0 diff --git a/test/.golden/urlEncode-path/golden b/test/.golden/urlEncode-path/golden new file mode 100644 --- /dev/null +++ b/test/.golden/urlEncode-path/golden @@ -0,0 +1,1 @@ +%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20%21%22%23$%25&%27%28%29%2A+,-.%2F0123456789:%3B%3C=%3E%3F@ABCDEFGHIJKLMNOPQRSTUVWXYZ%5B%5C%5D%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF diff --git a/test/.golden/urlEncode-query/golden b/test/.golden/urlEncode-query/golden new file mode 100644 --- /dev/null +++ b/test/.golden/urlEncode-query/golden @@ -0,0 +1,1 @@ +%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20%21%22%23%24%25%26%27%28%29%2A%2B%2C-.%2F0123456789%3A%3B%3C%3D%3E%3F%40ABCDEFGHIJKLMNOPQRSTUVWXYZ%5B%5C%5D%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF diff --git a/test/Network/HTTP/Types/HeaderSpec.hs b/test/Network/HTTP/Types/HeaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Types/HeaderSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Network.HTTP.Types.HeaderSpec (main, spec) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Data.CaseInsensitive (original) +import Data.Word (Word8) +import Test.Hspec +import Test.QuickCheck (Arbitrary (..), Gen, NonEmptyList (..), oneof, property) +import Test.QuickCheck.Instances () + +import Network.HTTP.Types + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Regression tests" $ do + mapM_ headerCheck allHeaders + + describe "byte ranges" $ do + it "is identity to render and parse ByteRanges" $ + property $ \(NonEmpty brs) -> + Just brs == parseByteRanges (renderByteRanges brs) + it "is satisfiable with from-to of zero" $ + parseByteRanges "bytes=0-0" `shouldBe` Just [ByteRangeFromTo 0 0] + it "is not satisfiable with suffix of zero" $ + parseByteRanges "bytes=-0" `shouldBe` Nothing + it "is not satisfiable with 'from' lower than 'to'" $ + property $ \w81 w82 -> + let w8toInt = fromIntegral :: Word8 -> Integer + -- if both are 0 it's @not (start < end)@ so we add 1 + start = w8toInt w81 + end + 1 + end = w8toInt w82 + range = show start <> "-" <> show end + in parseByteRanges ("bytes=" <> B8.pack range) `shouldBe` Nothing + +type HeaderTuple = (HeaderName, HeaderName) + +allHeaders :: [HeaderTuple] +allHeaders = + [ (hAccept, "Accept") + , (hAcceptCharset, "Accept-Charset") + , (hAcceptEncoding, "Accept-Encoding") + , (hAcceptLanguage, "Accept-Language") + , (hAcceptRanges, "Accept-Ranges") + , (hAge, "Age") + , (hAllow, "Allow") + , (hAuthorization, "Authorization") + , (hCacheControl, "Cache-Control") + , (hConnection, "Connection") + , (hContentDisposition, "Content-Disposition") + , (hContentEncoding, "Content-Encoding") + , (hContentLanguage, "Content-Language") + , (hContentLength, "Content-Length") + , (hContentLocation, "Content-Location") + , (hContentMD5, "Content-MD5") + , (hContentRange, "Content-Range") + , (hContentType, "Content-Type") + , (hCookie, "Cookie") + , (hDate, "Date") + , (hETag, "ETag") + , (hExpect, "Expect") + , (hExpires, "Expires") + , (hFrom, "From") + , (hHost, "Host") + , (hIfMatch, "If-Match") + , (hIfModifiedSince, "If-Modified-Since") + , (hIfNoneMatch, "If-None-Match") + , (hIfRange, "If-Range") + , (hIfUnmodifiedSince, "If-Unmodified-Since") + , (hLastModified, "Last-Modified") + , (hLocation, "Location") + , (hMaxForwards, "Max-Forwards") + , (hMIMEVersion, "MIME-Version") + , (hOrigin, "Origin") + , (hPragma, "Pragma") + , (hPrefer, "Prefer") + , (hPreferenceApplied, "Preference-Applied") + , (hProxyAuthenticate, "Proxy-Authenticate") + , (hProxyAuthorization, "Proxy-Authorization") + , (hRange, "Range") + , (hReferer, "Referer") + , (hRetryAfter, "Retry-After") + , (hServer, "Server") + , (hSetCookie, "Set-Cookie") + , (hTE, "TE") + , (hTrailer, "Trailer") + , (hTransferEncoding, "Transfer-Encoding") + , (hUpgrade, "Upgrade") + , (hUserAgent, "User-Agent") + , (hVary, "Vary") + , (hVia, "Via") + , (hWWWAuthenticate, "WWW-Authenticate") + , (hWarning, "Warning") + ] + +headerCheck :: HeaderTuple -> Spec +headerCheck (hdr, msg) = do + it (B8.unpack . pad $ original msg) $ hdr `shouldBe` msg + where + pad bs = + let padding = B8.replicate (maxMsg - B.length bs) ' ' + in bs <> padding + +maxMsg :: Int +maxMsg = maximum $ fmap (B.length . original . snd) allHeaders + +-- | Generate valid ranges. +-- +-- All values are positive and non-zero for easier testing. +instance Arbitrary ByteRange where + arbitrary = + oneof + [ ByteRangeFrom <$> num + , num >>= \from -> + ByteRangeFromTo from . (from +) <$> num + , ByteRangeSuffix <$> num + ] + where + num = + (+ 1) -- making sure it's non-zero + . fromIntegral + <$> (arbitrary :: Gen Word) -- making sure it's positive diff --git a/test/Network/HTTP/Types/MethodSpec.hs b/test/Network/HTTP/Types/MethodSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Types/MethodSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Network.HTTP.Types.MethodSpec (main, spec) where + +import Test.Hspec +import Test.QuickCheck (property) +import Test.QuickCheck.Instances () + +import Network.HTTP.Types + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Regression tests" $ do + it "GET " $ methodGet `shouldBe` "GET" + it "POST " $ methodPost `shouldBe` "POST" + it "HEAD " $ methodHead `shouldBe` "HEAD" + it "PUT " $ methodPut `shouldBe` "PUT" + it "DELETE " $ methodDelete `shouldBe` "DELETE" + it "TRACE " $ methodTrace `shouldBe` "TRACE" + it "CONNECT" $ methodConnect `shouldBe` "CONNECT" + it "OPTIONS" $ methodOptions `shouldBe` "OPTIONS" + it "PATCH " $ methodPatch `shouldBe` "PATCH" + it "StdMethod has all constants" $ + let methodList = + [ methodGet + , methodPost + , methodHead + , methodPut + , methodDelete + , methodTrace + , methodConnect + , methodOptions + , methodPatch + ] + in allMethods `shouldBe` methodList + + describe "parse/render method" $ do + it "round trips" $ do + renderMethod . parseMethod <$> allMethods `shouldBe` allMethods + it "also round trips for any ByteString" $ + property $ \bs -> + renderMethod (parseMethod bs) `shouldBe` bs + +allMethods :: [Method] +allMethods = + renderStdMethod <$> [minBound @StdMethod .. maxBound] diff --git a/test/Network/HTTP/Types/StatusSpec.hs b/test/Network/HTTP/Types/StatusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Types/StatusSpec.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Network.HTTP.Types.StatusSpec (main, spec) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Data.Function (on) +import qualified Data.List as L +import Test.Hspec +import Test.QuickCheck (Arbitrary (..), choose, property, resize) +import Test.QuickCheck.Instances () + +import Network.HTTP.Types + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "Regression tests" $ do + mapM_ statusCheck allStatusses + context "Category checks" $ do + categoryCheck "statusIsInformational" statusIsInformational _100Statusses + categoryCheck "statusIsSuccessful" statusIsSuccessful _200Statusses + categoryCheck "statusIsRedirection" statusIsRedirection _300Statusses + categoryCheck "statusIsClientError" statusIsClientError _400Statusses + categoryCheck "statusIsServerError" statusIsServerError _500Statusses + describe "Eq instance" $ do + it "only matches on 'statusCode'" $ + property $ + \st1 st2 -> (st1 == st2) == ((==) `on` statusCode) st1 st2 + describe "Ord instance" $ do + it "only orders on 'statusCode'" $ + property $ + \st1 st2 -> (st1 < st2) == ((<) `on` statusCode) st1 st2 + +categoryCheck :: String -> (Status -> Bool) -> [StatusTuple] -> Spec +categoryCheck name p shoulds = do + it msg $ do + mapM_ (\(st, _, _, _) -> st `shouldSatisfy` p) shoulds + mapM_ (\(st, _, _, _) -> st `shouldNotSatisfy` p) $ + allStatusses L.\\ shoulds + where + msg = "'" <> name <> "' " <> "identifies correct statusses" <> extra + extra = replicate (length ("statusIsInformational" :: String) - length name) ' ' + +type StatusTuple = (Status, Status, Int, B.ByteString) + +_100Statusses :: [StatusTuple] +_100Statusses = + [ (status100, continue100, 100, "Continue") + , (status101, switchingProtocols101, 101, "Switching Protocols") + ] + +_200Statusses :: [StatusTuple] +_200Statusses = + [ (status200, ok200, 200, "OK") + , (status201, created201, 201, "Created") + , (status202, accepted202, 202, "Accepted") + , (status203, nonAuthoritative203, 203, "Non-Authoritative Information") + , (status204, noContent204, 204, "No Content") + , (status205, resetContent205, 205, "Reset Content") + , (status206, partialContent206, 206, "Partial Content") + ] + +_300Statusses :: [StatusTuple] +_300Statusses = + [ (status300, multipleChoices300, 300, "Multiple Choices") + , (status301, movedPermanently301, 301, "Moved Permanently") + , (status302, found302, 302, "Found") + , (status303, seeOther303, 303, "See Other") + , (status304, notModified304, 304, "Not Modified") + , (status305, useProxy305, 305, "Use Proxy") + , (status307, temporaryRedirect307, 307, "Temporary Redirect") + , (status308, permanentRedirect308, 308, "Permanent Redirect") + ] + +_400Statusses :: [StatusTuple] +_400Statusses = + [ (status400, badRequest400, 400, "Bad Request") + , (status401, unauthorized401, 401, "Unauthorized") + , (status402, paymentRequired402, 402, "Payment Required") + , (status403, forbidden403, 403, "Forbidden") + , (status404, notFound404, 404, "Not Found") + , (status405, methodNotAllowed405, 405, "Method Not Allowed") + , (status406, notAcceptable406, 406, "Not Acceptable") + , (status407, proxyAuthenticationRequired407, 407, "Proxy Authentication Required") + , (status408, requestTimeout408, 408, "Request Timeout") + , (status409, conflict409, 409, "Conflict") + , (status410, gone410, 410, "Gone") + , (status411, lengthRequired411, 411, "Length Required") + , (status412, preconditionFailed412, 412, "Precondition Failed") + , (status413, requestEntityTooLarge413, 413, "Request Entity Too Large") + , (status414, requestURITooLong414, 414, "Request-URI Too Long") + , (status415, unsupportedMediaType415, 415, "Unsupported Media Type") + , (status416, requestedRangeNotSatisfiable416, 416, "Requested Range Not Satisfiable") + , (status417, expectationFailed417, 417, "Expectation Failed") + , (status418, imATeapot418, 418, "I'm a teapot") + , (status422, unprocessableEntity422, 422, "Unprocessable Entity") + , (status426, upgradeRequired426, 426, "Upgrade Required") + , (status428, preconditionRequired428, 428, "Precondition Required") + , (status429, tooManyRequests429, 429, "Too Many Requests") + , (status431, requestHeaderFieldsTooLarge431, 431, "Request Header Fields Too Large") + , (status451, unavailableForLegalReasons451, 451, "Unavailable For Legal Reasons") + ] + +_500Statusses :: [StatusTuple] +_500Statusses = + [ (status500, internalServerError500, 500, "Internal Server Error") + , (status501, notImplemented501, 501, "Not Implemented") + , (status502, badGateway502, 502, "Bad Gateway") + , (status503, serviceUnavailable503, 503, "Service Unavailable") + , (status504, gatewayTimeout504, 504, "Gateway Timeout") + , (status505, httpVersionNotSupported505, 505, "HTTP Version Not Supported") + , (status511, networkAuthenticationRequired511, 511, "Network Authentication Required") + ] + +allStatusses :: [StatusTuple] +allStatusses = + concat + [ _100Statusses + , _200Statusses + , _300Statusses + , _400Statusses + , _500Statusses + ] + +statusCheck :: (Status, Status, Int, B.ByteString) -> Spec +statusCheck (st, st', code, msg) = do + it (show code <> " " <> B8.unpack (pad msg)) $ do + st `shouldBe` st' + where + pad bs = + let padding = B8.replicate (maxMsg - B.length bs) ' ' + in bs <> padding + +maxMsg :: Int +maxMsg = maximum $ fmap (\(_, _, _, bs) -> B.length bs) allStatusses + +instance Arbitrary Status where + arbitrary = + Status + <$> choose (statusCode minBound, statusCode maxBound) + <*> resize 20 arbitrary diff --git a/test/Network/HTTP/Types/URISpec.hs b/test/Network/HTTP/Types/URISpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Types/URISpec.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Types.URISpec (main, spec) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Maybe (fromMaybe) +import Data.Text as T (Text, null) +import Debug.Trace (traceShow) +import System.FilePath (()) +import Test.Hspec +import Test.Hspec.Golden (Golden (..)) +import Test.QuickCheck ( + Arbitrary (..), + Gen, + Property, + listOf, + property, + suchThat, + (.&&.), + (==>), + ) +import Test.QuickCheck.Instances () + +import Network.HTTP.Types + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "encode/decode path" $ do + it "is identity to encode and then decode" $ + property propEncodeDecodePath + it "does not escape period and dash" $ + toStrictBS (encodePath ["foo-bar.baz"] []) + `shouldBe` "/foo-bar.baz" + -- FIXME: needs more path tests + + describe "encode/decode query" $ do + it "is identity to encode and then decode" $ + property propEncodeDecodeQuery + it "is identity to convert to and from Text" $ + property propConvertQueryText + it "is identity to convert to and from Simple" $ + property propEncodeDecodeQuerySimple + it "renderQuery is same as renderQueryText" $ + property propEncodeQueryText + it "parseQuery is same as parseQueryText" $ + property propDecodeQueryText + it "renderQuery is same as renderSimpleQuery" $ + property propEncodeSimpleQuery + it "parseQuery is same as parseSimpleQuery" $ + property propDecodeSimpleQuery + it "add ? in front of Query if and only if necessary" $ + property propQueryQuestionMark + it "renders as expected" $ + renderQuery True [("a", Just "x"), ("b", Nothing), ("c", Just "")] + `shouldBe` "?a=x&b&c=" + it "renders as expected without '?'" $ + renderQuery False [("a", Just "x"), ("b", Nothing), ("c", Just "")] + `shouldBe` "a=x&b&c=" + + describe "URL encode/decode" $ do + it "is identity to encode and then decode" $ + property propEncodeDecodeURL + let asciis = B.pack [0 .. 255] + it "encodes all ASCII and decodes again" $ do + urlDecode True (urlEncode True asciis) `shouldBe` asciis + urlDecode False (urlEncode True asciis) `shouldBe` asciis + -- FIXME: not encoding '+' doesn't cooperate with decoding while + -- replacing the '+' with ' '. + -- urlDecode True (urlEncode False asciis) `shouldBe` asciis + urlDecode False (urlEncode False asciis) `shouldBe` asciis + it "still encodes the same (path)" $ + mkGoldenFile "urlEncode-path" $ + urlEncode False asciis + it "still encodes the same (query)" $ + mkGoldenFile "urlEncode-query" $ + urlEncode True asciis + + describe "decodePathSegments" $ do + it "is inverse to encodePathSegments" $ + property $ \p -> + (p /= [""]) ==> p == (decodePathSegments . toStrictBS . encodePathSegments) p + + describe "extractPath" $ do + context "when used with a relative URL" $ do + it "returns URL unmodified" $ do + property $ \p -> + (not . B.null) p ==> extractPath p == p + + context "when path is empty" $ do + it "returns /" $ + extractPath "" `shouldBe` "/" + + context "when used with an absolute URL" $ do + context "when used with a HTTP URL" $ do + it "it extracts path" $ + extractPath "http://example.com/foo" `shouldBe` "/foo" + + context "when path is empty" $ + it "returns /" $ + extractPath "http://example.com" `shouldBe` "/" + + context "when used with a HTTPS URL" $ do + it "it extracts path" $ + extractPath "https://example.com/foo" `shouldBe` "/foo" + + context "when path is empty" $ do + it "returns /" $ + extractPath "https://example.com" `shouldBe` "/" + + context "when used without protocol" $ do + it "returns unchanged" $ + extractPath "www.example.com/foo" `shouldBe` "www.example.com/foo" + + context "even without path" $ + it "returns unchanged" $ + extractPath "www.example.com" `shouldBe` "www.example.com" + + -- FIXME: Add tests for the 'PartialEscapeQuery' types and functions. + + let sampleQuery = [("a", Just "b c d"), ("x", Just ""), ("y", Nothing)] + describe "parseQuery" $ do + it "returns value with '+' replaced to ' '" $ + parseQuery "?a=b+c+d&x=&y" `shouldBe` sampleQuery + it "also does so without the question mark" $ + parseQuery "a=b+c+d&x=&y" `shouldBe` sampleQuery + it "is parsed the same regardless of question mark" $ + property $ \(QueryGen q) -> do + let q' = renderQuery False q + parseQuery q' `shouldBe` parseQuery ("?" <> q') + + describe "parseQueryReplacePlus" $ do + it "returns value with '+' replaced by ' '" $ + parseQueryReplacePlus True "?a=b+c+d&x=&y" `shouldBe` [("a", Just "b c d"), ("x", Just ""), ("y", Nothing)] + it "returns value with '+' preserved" $ + parseQueryReplacePlus False "?a=b+c+d&x=&y" `shouldBe` [("a", Just "b+c+d"), ("x", Just ""), ("y", Nothing)] + +goldenDir :: FilePath +goldenDir = "test" ".golden" + +mkGoldenFile :: String -> B.ByteString -> Golden B.ByteString +mkGoldenFile name content = + Golden { + output = content, + encodePretty = B8.unpack, + writeToFile = B.writeFile, + readFromFile = B.readFile, + goldenFile = goldenDir name "golden", + actualFile = Just (goldenDir name "actual"), + failFirstTime = False + } + +propEncodeDecodePath :: ([Text], QueryGen B.ByteString) -> Bool +propEncodeDecodePath (p', QueryGen b) = + if z then z else traceShow (a, b, x, y) z + where + a = if p' == [""] then [] else p' + x = toStrictBS $ encodePath a b + y = decodePath x + z = y == (a, b) + +propEncodeDecodeQuery :: QueryGen B.ByteString -> Bool -> Bool +propEncodeDecodeQuery (QueryGen q) b = + q == parseQuery (renderQuery b q) + +propQueryQuestionMark :: Bool -> Query -> Bool +propQueryQuestionMark useQuestionMark query = + actual == expected + where + actual = case B8.uncons $ renderQuery useQuestionMark query of + Just ('?', _) -> True + _ -> False + expected = useQuestionMark && not (Prelude.null query) + +propConvertQueryText :: QueryGen Text -> Bool +propConvertQueryText (QueryGen q) = + q == (queryToQueryText . queryTextToQuery) q + +propEncodeQueryText :: QueryGen Text -> Bool -> Bool +propEncodeQueryText (QueryGen q) b = + toStrictBS (renderQueryText b q) == renderQuery b (queryTextToQuery q) + +propEncodeSimpleQuery :: QueryGen B.ByteString -> Bool -> Bool +propEncodeSimpleQuery (QueryGen q) b = + renderSimpleQuery b simpleQuery == renderQuery b (simpleQueryToQuery simpleQuery) + where + simpleQuery = toSimpleQuery q + +propDecodeQueryText :: QueryGen Text -> Property +propDecodeQueryText (QueryGen q) = + (parseQueryText rq == queryToQueryText (parseQuery rq)) + .&&. (queryTextToQuery (parseQueryText rq) == parseQuery rq) + where + rq = toStrictBS (renderQueryText True q) + +propDecodeSimpleQuery :: QueryGen B.ByteString -> Bool +propDecodeSimpleQuery (QueryGen q) = + parseSimpleQuery rq == toSimpleQuery (parseQuery rq) + where + rq = renderQuery True q + +propEncodeDecodeQuerySimple :: QueryGen B.ByteString -> Bool -> Bool +propEncodeDecodeQuerySimple (QueryGen q') b = + q == (parseSimpleQuery . renderSimpleQuery b) q + where + q = fmap (fmap $ fromMaybe "") q' + +propEncodeDecodeURL :: B.ByteString -> Bool -> Bool -> Bool +propEncodeDecodeURL bs b1 b2 = + bs == urlDecode b1 (urlEncode b3 bs) + where + b3 = b1 || b2 + +newtype QueryGenItem b = QueryGenItem (b, Maybe b) + deriving newtype (Show) +newtype QueryGen b = QueryGen [(b, Maybe b)] + deriving newtype (Show) + +instance Arbitrary (QueryGenItem B.ByteString) where + arbitrary = arbQueryGenItem B.null + +instance Arbitrary (QueryGenItem Text) where + arbitrary = arbQueryGenItem T.null + +instance Arbitrary (QueryGen B.ByteString) where + arbitrary = arbQueryGen + +instance Arbitrary (QueryGen Text) where + arbitrary = arbQueryGen + +arbQueryGenItem :: (Arbitrary a) => (a -> Bool) -> Gen (QueryGenItem a) +arbQueryGenItem p = do + k <- arbitrary `suchThat` (not . p) + v <- arbitrary + pure $ QueryGenItem (k, v) + +arbQueryGen :: (Arbitrary (QueryGenItem a)) => Gen (QueryGen a) +arbQueryGen = do + items <- listOf arbitrary + pure . QueryGen $ go <$> items + where + go (QueryGenItem i) = i + +toStrictBS :: BB.Builder -> B.ByteString +toStrictBS = BL.toStrict . BB.toLazyByteString + +toSimpleQuery :: Query -> SimpleQuery +toSimpleQuery q = fmap (fromMaybe "") <$> q diff --git a/test/Network/HTTP/Types/VersionSpec.hs b/test/Network/HTTP/Types/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Types/VersionSpec.hs @@ -0,0 +1,29 @@ +module Network.HTTP.Types.VersionSpec (main, spec) where + +import Test.Hspec + +import Network.HTTP.Types + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + describe "Regression tests" $ + mapM_ checkVersion allVersions + +-- | [("Rendered", {constant}, {literal})] +allVersions :: [(String, HttpVersion, HttpVersion)] +allVersions = + [ ("HTTP/0.9", http09, HttpVersion 0 9) + , ("HTTP/1.0", http10, HttpVersion 1 0) + , ("HTTP/1.1", http11, HttpVersion 1 1) + , ("HTTP/2.0", http20, HttpVersion 2 0) + , ("HTTP/3.0", http30, HttpVersion 3 0) + ] + +checkVersion :: (String, HttpVersion, HttpVersion) -> Spec +checkVersion (str, v1, v2) = + it str $ do + v1 `shouldBe` v2 + show v1 `shouldBe` str diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -3,10 +3,8 @@ import Test.DocTest main :: IO () -main = doctest [ - "-idist/build/autogen/" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "-XOverloadedStrings" - , "Network/HTTP/Types.hs" - ] +main = + doctest + [ "-XOverloadedStrings" + , "Network/HTTP/Types.hs" + ]