http-types 0.12.4 → 0.12.5
raw patch · 20 files changed
+843/−207 lines, 20 filesdep +filepathdep +hspec-goldendep ~arraydep ~basedep ~bytestring
Dependencies added: filepath, hspec-golden
Dependency ranges changed: array, base, bytestring, case-insensitive, doctest, text
Files
- CHANGELOG +0/−44
- CHANGELOG.md +57/−0
- Network/HTTP/Types.hs +45/−3
- Network/HTTP/Types/Header.hs +14/−13
- Network/HTTP/Types/Method.hs +14/−16
- Network/HTTP/Types/QueryLike.hs +1/−1
- Network/HTTP/Types/Status.hs +46/−20
- Network/HTTP/Types/URI.hs +20/−8
- Network/HTTP/Types/Version.hs +7/−2
- README +0/−5
- README.md +21/−0
- http-types.cabal +31/−16
- test/.golden/urlEncode-path/golden +1/−0
- test/.golden/urlEncode-query/golden +1/−0
- test/Network/HTTP/Types/HeaderSpec.hs +127/−0
- test/Network/HTTP/Types/MethodSpec.hs +50/−0
- test/Network/HTTP/Types/StatusSpec.hs +145/−0
- test/Network/HTTP/Types/URISpec.hs +229/−75
- test/Network/HTTP/Types/VersionSpec.hs +29/−0
- test/doctests.hs +5/−4
− CHANGELOG
@@ -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`.
+ CHANGELOG.md view
@@ -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`.
Network/HTTP/Types.hs view
@@ -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
Network/HTTP/Types/Header.hs view
@@ -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
Network/HTTP/Types/Method.hs view
@@ -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
Network/HTTP/Types/QueryLike.hs view
@@ -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
Network/HTTP/Types/Status.hs view
@@ -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--- (<https://tools.ietf.org/html/rfc7231#section-6.5.15>)+-- (<https://tools.ietf.org/html/rfc7231#section-6.5.15 RFC 7231>) -- -- @since 0.10 status426 :: Status status426 = mkStatus 426 "Upgrade Required" -- | Upgrade Required 426--- (<https://tools.ietf.org/html/rfc7231#section-6.5.15>)+-- (<https://tools.ietf.org/html/rfc7231#section-6.5.15 RFC 7231>) -- -- @since 0.10 upgradeRequired426 :: Status upgradeRequired426 = status426 -- | Precondition Required 428--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-3 RFC 6585>) -- -- @since 0.8.5 status428 :: Status status428 = mkStatus 428 "Precondition Required" -- | Precondition Required 428--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-3 RFC 6585>) -- -- @since 0.8.5 preconditionRequired428 :: Status preconditionRequired428 = status428 -- | Too Many Requests 429--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-4 RFC 6585>) -- -- @since 0.8.5 status429 :: Status status429 = mkStatus 429 "Too Many Requests" -- | Too Many Requests 429--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-4 RFC 6585>) -- -- @since 0.8.5 tooManyRequests429 :: Status tooManyRequests429 = status429 -- | Request Header Fields Too Large 431--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-5 RFC 6585>) -- -- @since 0.8.5 status431 :: Status status431 = mkStatus 431 "Request Header Fields Too Large" -- | Request Header Fields Too Large 431--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-5 RFC 6585>) -- -- @since 0.8.5 requestHeaderFieldsTooLarge431 :: Status requestHeaderFieldsTooLarge431 = status431 +-- | Unavailable For Legal Reasons 451+-- (<https://tools.ietf.org/html/rfc7725 RFC 7725>)+--+-- @since 0.12.5+status451 :: Status+status451 = mkStatus 451 "Unavailable For Legal Reasons"++-- | Unavailable For Legal Reasons 451+-- (<https://tools.ietf.org/html/rfc7725 RFC 7725>)+--+-- @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--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-6 RFC 6585>) -- -- @since 0.8.5 status511 :: Status status511 = mkStatus 511 "Network Authentication Required" -- | Network Authentication Required 511--- (<https://tools.ietf.org/html/rfc6585 RFC 6585>)+-- (<https://tools.ietf.org/html/rfc6585#section-6 RFC 6585>) -- -- @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
Network/HTTP/Types/URI.hs view
@@ -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
Network/HTTP/Types/Version.hs view
@@ -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
− README
@@ -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.
+ README.md view
@@ -0,0 +1,21 @@++[](https://hackage.haskell.org/package/http-types)+[](http://stackage.org/lts/package/http-types)+[](http://stackage.org/nightly/package/http-types)+[](./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.
http-types.cabal view
@@ -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
+ test/.golden/urlEncode-path/golden view
@@ -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
+ test/.golden/urlEncode-query/golden view
@@ -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
+ test/Network/HTTP/Types/HeaderSpec.hs view
@@ -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
+ test/Network/HTTP/Types/MethodSpec.hs view
@@ -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]
+ test/Network/HTTP/Types/StatusSpec.hs view
@@ -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
test/Network/HTTP/Types/URISpec.hs view
@@ -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
+ test/Network/HTTP/Types/VersionSpec.hs view
@@ -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
test/doctests.hs view
@@ -3,7 +3,8 @@ import Test.DocTest main :: IO ()-main = doctest [- "-XOverloadedStrings"- , "Network/HTTP/Types.hs"- ]+main =+ doctest+ [ "-XOverloadedStrings"+ , "Network/HTTP/Types.hs"+ ]