diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,44 +0,0 @@ -# Changelog for `http-types` - -## 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/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 @@ -31,6 +31,7 @@ http10, http11, http20, + http30, -- * Status @@ -114,12 +115,16 @@ imATeapot418, status422, unprocessableEntity422, + status426, + upgradeRequired426, status428, preconditionRequired428, status429, tooManyRequests429, status431, requestHeaderFieldsTooLarge431, + status451, + unavailableForLegalReasons451, status500, internalServerError500, status501, @@ -150,26 +155,61 @@ RequestHeaders, ResponseHeaders, - -- ** Common headers + -- ** Header constants hAccept, + hAcceptCharset, + hAcceptEncoding, hAcceptLanguage, + hAcceptRanges, + hAge, + hAllow, hAuthorization, hCacheControl, - hCookie, 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 (..), @@ -216,7 +256,9 @@ renderQueryBuilderPartialEscape, -- ** Generalized query types - QueryLike (toQuery), + QueryLike (..), + QueryKeyLike (..), + QueryValueLike (..), -- ** Path 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 @@ -96,10 +96,6 @@ import qualified Data.CaseInsensitive as CI import Data.Data (Data) import Data.List (intersperse) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif -import Data.Typeable (Typeable) import GHC.Generics (Generic) -- | A full HTTP header field with the name and value separated. @@ -404,7 +400,7 @@ -- | [Warning](https://www.rfc-editor.org/rfc/rfc9111.html#name-warning) -- --- /This header has been obsoleted in RFC 9110./ +-- /This header has been obsoleted in RFC 9111./ -- -- @since 0.9 hWarning :: HeaderName @@ -452,7 +448,9 @@ hPreferenceApplied :: HeaderName hPreferenceApplied = "Preference-Applied" --- | An individual byte range. +-- | 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! -- @@ -469,8 +467,6 @@ , -- | @since 0.8.4 Ord , -- | @since 0.8.4 - Typeable - , -- | @since 0.8.4 Data , -- | @since 0.12.4 Generic @@ -557,8 +553,13 @@ (r, bs5) <- range bs4 ranges (front . (r :)) bs5 - -- 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 +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 @@ -6,7 +6,7 @@ -- 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 'ByteString'. +-- basic type 'Method' is just a synonym for 'B.ByteString'. module Network.HTTP.Types.Method ( -- * HTTP methods Method, @@ -37,7 +37,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics (Generic) -- $setup @@ -50,42 +49,42 @@ -- arbitrary = encodeUtf8 . pack <$> arbitrary -- :} --- | HTTP method (flat 'ByteString' type). +-- | HTTP method (flat 'B.ByteString' type). type Method = B.ByteString --- | HTTP GET Method +-- | GET Method methodGet :: Method methodGet = renderStdMethod GET --- | HTTP POST Method +-- | POST Method methodPost :: Method methodPost = renderStdMethod POST --- | HTTP HEAD Method +-- | HEAD Method methodHead :: Method methodHead = renderStdMethod HEAD --- | HTTP PUT Method +-- | PUT Method methodPut :: Method methodPut = renderStdMethod PUT --- | HTTP DELETE Method +-- | DELETE Method methodDelete :: Method methodDelete = renderStdMethod DELETE --- | HTTP TRACE Method +-- | TRACE Method methodTrace :: Method methodTrace = renderStdMethod TRACE --- | HTTP CONNECT Method +-- | CONNECT Method methodConnect :: Method methodConnect = renderStdMethod CONNECT --- | HTTP OPTIONS Method +-- | OPTIONS Method methodOptions :: Method methodOptions = renderStdMethod OPTIONS --- | HTTP PATCH Method +-- | PATCH Method -- -- @since 0.8.0 methodPatch :: Method @@ -114,7 +113,6 @@ , Enum , Bounded , Ix - , Typeable , -- | @since 0.12.4 Generic , -- | @since 0.12.4 @@ -133,13 +131,13 @@ 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 -- @@ -147,7 +145,7 @@ 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 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 @@ -57,4 +57,4 @@ 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 @@ -101,6 +101,8 @@ tooManyRequests429, status431, requestHeaderFieldsTooLarge431, + status451, + unavailableForLegalReasons451, status500, internalServerError500, status501, @@ -112,9 +114,9 @@ status504, gatewayTimeout504, status505, + httpVersionNotSupported505, status511, networkAuthenticationRequired511, - httpVersionNotSupported505, -- * Checking status code category statusIsInformational, @@ -126,7 +128,6 @@ import Data.ByteString as B (ByteString, empty) import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics (Generic) -- | HTTP Status. @@ -139,11 +140,16 @@ -- 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 - , Typeable , -- | @since 0.12.4 Data , -- | @since 0.12.4 @@ -160,11 +166,11 @@ -- | 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. @@ -217,6 +223,7 @@ toEnum 428 = status428 toEnum 429 = status429 toEnum 431 = status431 + toEnum 451 = status451 toEnum 500 = status500 toEnum 501 = status501 toEnum 502 = status502 @@ -232,6 +239,8 @@ maxBound = status511 -- | Create a 'Status' from a status code and message. +-- +-- @since 0.7.3 mkStatus :: Int -> B.ByteString -> Status mkStatus = Status @@ -611,6 +620,9 @@ 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 @@ -638,61 +650,75 @@ 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" @@ -762,14 +788,14 @@ 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 @@ -781,7 +807,7 @@ -- -- @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 -- @@ -789,7 +815,7 @@ -- -- @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 -- @@ -797,7 +823,7 @@ -- -- @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 -- @@ -805,7 +831,7 @@ -- -- @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 -- @@ -813,4 +839,4 @@ -- -- @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 @@ -91,14 +91,20 @@ import Data.Char (ord) import Data.List (intersperse) import Data.Maybe (fromMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif 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 + -- | An item from the query string, split up into two parts. -- -- The second part should be 'Nothing' if there was no key-value @@ -160,7 +166,7 @@ simpleQueryToQuery :: SimpleQuery -> Query simpleQueryToQuery = map (second Just) --- | Renders the given 'Query' into a 'Builder'. +-- | Renders the given 'Query' into a 'B.Builder'. -- -- If you want a question mark (@?@) added to the front of the result, use 'True'. -- @@ -193,7 +199,7 @@ renderQuery :: Bool -> Query -> B.ByteString renderQuery qm = BL.toStrict . B.toLazyByteString . renderQueryBuilder qm --- | Render the given 'SimpleQuery' into a 'ByteString'. +-- | Render the given 'SimpleQuery' into a 'B.ByteString'. -- -- If you want a question mark (@?@) added to the front of the result, use 'True'. -- @@ -253,7 +259,7 @@ 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'. @@ -266,6 +272,12 @@ 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: -- "!'()*;" @@ -514,7 +526,7 @@ -- @since 0.12.1 type PartialEscapeQuery = [PartialEscapeQueryItem] --- | Convert 'PartialEscapeQuery' to 'ByteString'. +-- | Convert 'PartialEscapeQuery' to 'B.ByteString'. -- -- If you want a question mark (@?@) added to the front of the result, use 'True'. -- @@ -533,7 +545,7 @@ -- @since 0.12.1 renderQueryBuilderPartialEscape :: Bool -> PartialEscapeQuery -> B.Builder renderQueryBuilderPartialEscape _ [] = mempty --- FIXME replace mconcat + map with foldr +-- FIXME: replace mconcat + map with foldr renderQueryBuilderPartialEscape qmark' (p : ps) = mconcat $ go (if qmark' then qmark else mempty) p 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 @@ -8,10 +8,10 @@ http10, http11, http20, + http30, ) where import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics (Generic) -- | HTTP Version. @@ -24,7 +24,6 @@ deriving ( Eq , Ord - , Typeable , -- | @since 0.12.4 Data , -- | @since 0.12.4 @@ -53,3 +52,9 @@ -- @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,6 +1,6 @@ -Cabal-version: 3.0 +Cabal-version: 2.2 Name: http-types -Version: 0.12.4 +Version: 0.12.5 Synopsis: Generic HTTP types for Haskell (for both client and server code). Description: Types and functions to describe and handle HTTP concepts. Including "methods", "headers", "query strings", "paths" and "HTTP versions". @@ -9,15 +9,22 @@ License-file: LICENSE Author: Aristid Breitkreuz, Michael Snoyman Maintainer: felix.paulusma@gmail.com -Copyright: (C) 2011 Aristid Breitkreuz +Copyright: (C) 2011 Aristid Breitkreuz, (C) 2023 Felix Paulusma Category: Network, Web Build-type: Simple -Extra-source-files: README, CHANGELOG +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/Vlix/http-types.git - tag: 0.12.4 + tag: v0.12.5 Source-repository head type: git @@ -32,27 +39,35 @@ 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.URISpec + 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 default-language: Haskell2010 - build-depends: base, - http-types, - text, + 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 @@ -60,4 +75,4 @@ type: exitcode-stdio-1.0 ghc-options: -threaded -Wall default-language: Haskell2010 - build-depends: base, doctest >= 0.9.3 + 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 --- a/test/Network/HTTP/Types/URISpec.hs +++ b/test/Network/HTTP/Types/URISpec.hs @@ -1,104 +1,258 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Types.URISpec (main, spec) where -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () +module Network.HTTP.Types.URISpec (main, spec) where -import Debug.Trace -import Data.Text (Text) import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Builder as B 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.URI +import Network.HTTP.Types main :: IO () main = hspec spec -propEncodeDecodePath :: ([Text], Query) -> Bool -propEncodeDecodePath (p', q') = - let x = BL.toStrict . B.toLazyByteString $ encodePath a b - y = decodePath x - z = y == (a, b) - in if z then z else traceShow (a, b, x, y) z +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' - b = filter (\(x, _) -> not (B.null x)) q' + x = toStrictBS $ encodePath a b + y = decodePath x + z = y == (a, b) -propEncodeDecodeQuery :: Query -> Bool -propEncodeDecodeQuery q' = - q == parseQuery (renderQuery True q) +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 - q = filter (\(x, _) -> not (B.null x)) q' + actual = case B8.uncons $ renderQuery useQuestionMark query of + Just ('?', _) -> True + _ -> False + expected = useQuestionMark && not (Prelude.null query) -propQueryQuestionMark :: (Bool, Query) -> Bool -propQueryQuestionMark (useQuestionMark, query) = actual == expected - where - actual = case B8.uncons $ renderQuery useQuestionMark query of - Nothing -> False - Just ('?', _) -> True - _ -> False - expected = case (useQuestionMark, null query) of - (False, _) -> False - (True, True) -> False - (True, False) -> True +propConvertQueryText :: QueryGen Text -> Bool +propConvertQueryText (QueryGen q) = + q == (queryToQueryText . queryTextToQuery) q -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" $ - BL.toStrict (B.toLazyByteString (encodePath ["foo-bar.baz"] [])) `shouldBe` "/foo-bar.baz" +propEncodeQueryText :: QueryGen Text -> Bool -> Bool +propEncodeQueryText (QueryGen q) b = + toStrictBS (renderQueryText b q) == renderQuery b (queryTextToQuery q) - describe "encode/decode query" $ do - it "is identity to encode and then decode" $ - property propEncodeDecodeQuery +propEncodeSimpleQuery :: QueryGen B.ByteString -> Bool -> Bool +propEncodeSimpleQuery (QueryGen q) b = + renderSimpleQuery b simpleQuery == renderQuery b (simpleQueryToQuery simpleQuery) + where + simpleQuery = toSimpleQuery q - it "add ? in front of Query if and only if necessary" $ - property propQueryQuestionMark +propDecodeQueryText :: QueryGen Text -> Property +propDecodeQueryText (QueryGen q) = + (parseQueryText rq == queryToQueryText (parseQuery rq)) + .&&. (queryTextToQuery (parseQueryText rq) == parseQuery rq) + where + rq = toStrictBS (renderQueryText True q) - describe "decodePathSegments" $ do - it "is inverse to encodePathSegments" $ - property $ \p -> not (p == [""]) ==> do - (decodePathSegments . BL.toStrict . B.toLazyByteString . encodePathSegments) p `shouldBe` p +propDecodeSimpleQuery :: QueryGen B.ByteString -> Bool +propDecodeSimpleQuery (QueryGen q) = + parseSimpleQuery rq == toSimpleQuery (parseQuery rq) + where + rq = renderQuery True q - describe "extractPath" $ do - context "when used with a relative URL" $ do - it "returns URL unmodified" $ do - property $ \p -> (not . B.null) p ==> - extractPath p `shouldBe` p +propEncodeDecodeQuerySimple :: QueryGen B.ByteString -> Bool -> Bool +propEncodeDecodeQuerySimple (QueryGen q') b = + q == (parseSimpleQuery . renderSimpleQuery b) q + where + q = fmap (fmap $ fromMaybe "") q' - context "when path is empty" $ do - it "returns /" $ do - extractPath "" `shouldBe` "/" +propEncodeDecodeURL :: B.ByteString -> Bool -> Bool -> Bool +propEncodeDecodeURL bs b1 b2 = + bs == urlDecode b1 (urlEncode b3 bs) + where + b3 = b1 || b2 - context "when used with an absolute URL" $ do - context "when used with a HTTP URL" $ do - it "it extracts path" $ do - extractPath "http://example.com/foo" `shouldBe` "/foo" +newtype QueryGenItem b = QueryGenItem (b, Maybe b) + deriving newtype (Show) +newtype QueryGen b = QueryGen [(b, Maybe b)] + deriving newtype (Show) - context "when path is empty" $ do - it "returns /" $ do - extractPath "http://example.com" `shouldBe` "/" +instance Arbitrary (QueryGenItem B.ByteString) where + arbitrary = arbQueryGenItem B.null - context "when used with a HTTPS URL" $ do - it "it extracts path" $ do - extractPath "https://example.com/foo" `shouldBe` "/foo" +instance Arbitrary (QueryGenItem Text) where + arbitrary = arbQueryGenItem T.null - context "when path is empty" $ do - it "returns /" $ do - extractPath "https://example.com" `shouldBe` "/" +instance Arbitrary (QueryGen B.ByteString) where + arbitrary = arbQueryGen - describe "parseQuery" $ do - it "returns value with '+' replaced to ' '" $ do - parseQuery "?a=b+c+d" `shouldBe` [("a", Just "b c d")] +instance Arbitrary (QueryGen Text) where + arbitrary = arbQueryGen - describe "parseQueryReplacePlus" $ do - it "returns value with '+' replaced to ' '" $ do - parseQueryReplacePlus True "?a=b+c+d" `shouldBe` [("a", Just "b c d")] +arbQueryGenItem :: (Arbitrary a) => (a -> Bool) -> Gen (QueryGenItem a) +arbQueryGenItem p = do + k <- arbitrary `suchThat` (not . p) + v <- arbitrary + pure $ QueryGenItem (k, v) - it "returns value with '+' preserved" $ do - parseQueryReplacePlus False "?a=b+c+d" `shouldBe` [("a", Just "b+c+d")] +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,7 +3,8 @@ import Test.DocTest main :: IO () -main = doctest [ - "-XOverloadedStrings" - , "Network/HTTP/Types.hs" - ] +main = + doctest + [ "-XOverloadedStrings" + , "Network/HTTP/Types.hs" + ]