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