{-# 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)