+{-# LANGUAGE
+ DeriveDataTypeable
+ , UnboxedTuples
+ , UnicodeSyntax
+ #-}
+{-# OPTIONS_HADDOCK prune #-}
+
+-- |Definition of things related on HTTP response.
module Network.HTTP.Lucu.Response
( StatusCode(..)
, Response(..)
- , hPutResponse -- Handle -> Response -> IO ()
- , isInformational -- StatusCode -> Bool
- , isError -- StatusCode -> Bool
- , statusCode -- StatusCode -> (Int, String)
+ , hPutResponse
+ , isInformational
+ , isSuccessful
+ , isRedirection
+ , isError
+ , isClientError
+ , isServerError
+ , statusCode
)
where
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
+import Data.Typeable
+import Network.HTTP.Lucu.Format
+import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
-import System.IO
-import Text.Printf
+-- |This is the definition of HTTP status code.
+-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses
+-- so you don't have to memorize, for instance, that \"Gateway
+-- Timeout\" is 504.
data StatusCode = Continue
| SwitchingProtocols
| Processing
| GatewayTimeout
| HttpVersionNotSupported
| InsufficientStorage
- deriving (Eq)
+ deriving (Typeable, Eq)
instance Show StatusCode where
- show sc = let (num, msg) = statusCode sc
- in
- printf "%03d %s" num msg
+ show sc = case statusCode sc of
+ (# num, msg #)
+ -> (fmtDec 3 num) ++ " " ++ C8.unpack msg
data Response = Response {
- resVersion :: HttpVersion
- , resStatus :: StatusCode
- , resHeaders :: Headers
- }
- deriving (Show, Eq)
+ resVersion :: !HttpVersion
+ , resStatus :: !StatusCode
+ , resHeaders :: !Headers
+ } deriving (Show, Eq)
+
instance HasHeaders Response where
getHeaders = resHeaders
setHeaders res hdr = res { resHeaders = hdr }
-hPutResponse :: Handle -> Response -> IO ()
-hPutResponse h res = do hPutHttpVersion h (resVersion res)
- hPutChar h ' '
- hPutStatus h (resStatus res)
- hPutStr h "\r\n"
- hPutHeaders h (resHeaders res)
+hPutResponse :: HandleLike h => h -> Response -> IO ()
+hPutResponse h res
+ = h `seq` res `seq`
+ do hPutHttpVersion h (resVersion res)
+ hPutChar h ' '
+ hPutStatus h (resStatus res)
+ hPutBS h (C8.pack "\r\n")
+ hPutHeaders h (resHeaders res)
-hPutStatus :: Handle -> StatusCode -> IO ()
-hPutStatus h sc = let (num, msg) = statusCode sc
- in
- hPrintf h "%03d %s" num msg
+hPutStatus :: HandleLike h => h -> StatusCode -> IO ()
+hPutStatus h sc
+ = h `seq` sc `seq`
+ case statusCode sc of
+ (# num, msg #)
+ -> do hPutStr h (fmtDec 3 num)
+ hPutChar h ' '
+ hPutBS h msg
+-- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
isInformational :: StatusCode -> Bool
-isInformational sc = let (num, _) = statusCode sc
- in num < 200
+isInformational = doesMeet (< 200)
+
+-- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@.
+isSuccessful :: StatusCode -> Bool
+isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
+
+-- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@.
+isRedirection :: StatusCode -> Bool
+isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
+-- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@
isError :: StatusCode -> Bool
-isError sc = let (num, _) = statusCode sc
- in num >= 400
-
-
-statusCode :: StatusCode -> (Int, String)
-statusCode Continue = (100, "Continue")
-statusCode SwitchingProtocols = (101, "Switching Protocols")
-statusCode Processing = (102, "Processing")
---
-statusCode Ok = (200, "OK")
-statusCode Created = (201, "Created")
-statusCode Accepted = (202, "Accepted")
-statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information")
-statusCode NoContent = (204, "No Content")
-statusCode ResetContent = (205, "Reset Content")
-statusCode PartialContent = (206, "Partial Content")
-statusCode MultiStatus = (207, "Multi Status")
---
-statusCode MultipleChoices = (300, "Multiple Choices")
-statusCode MovedPermanently = (301, "Moved Permanently")
-statusCode Found = (302, "Found")
-statusCode SeeOther = (303, "See Other")
-statusCode NotModified = (304, "Not Modified")
-statusCode UseProxy = (305, "Use Proxy")
-statusCode TemporaryRedirect = (306, "Temporary Redirect")
---
-statusCode BadRequest = (400, "Bad Request")
-statusCode Unauthorized = (401, "Unauthorized")
-statusCode PaymentRequired = (402, "Payment Required")
-statusCode Forbidden = (403, "Forbidden")
-statusCode NotFound = (404, "Not Found")
-statusCode MethodNotAllowed = (405, "Method Not Allowed")
-statusCode NotAcceptable = (406, "Not Acceptable")
-statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required")
-statusCode RequestTimeout = (408, "Request Timeout")
-statusCode Conflict = (409, "Conflict")
-statusCode Gone = (410, "Gone")
-statusCode LengthRequired = (411, "Length Required")
-statusCode PreconditionFailed = (412, "Precondition Failed")
-statusCode RequestEntityTooLarge = (413, "Request Entity Too Large")
-statusCode RequestURITooLarge = (414, "Request URI Too Large")
-statusCode UnsupportedMediaType = (415, "Unsupported Media Type")
-statusCode RequestRangeNotSatisfiable = (416, "Request Range Not Satisfiable")
-statusCode ExpectationFailed = (417, "Expectation Failed")
-statusCode UnprocessableEntitiy = (422, "Unprocessable Entity")
-statusCode Locked = (423, "Locked")
-statusCode FailedDependency = (424, "Failed Dependency")
---
-statusCode InternalServerError = (500, "Internal Server Error")
-statusCode NotImplemented = (501, "Not Implemented")
-statusCode BadGateway = (502, "Bad Gateway")
-statusCode ServiceUnavailable = (503, "Service Unavailable")
-statusCode GatewayTimeout = (504, "Gateway Timeout")
-statusCode HttpVersionNotSupported = (505, "HTTP Version Not Supported")
-statusCode InsufficientStorage = (507, "Insufficient Storage")
\ No newline at end of file
+isError = doesMeet (>= 400)
+
+-- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@.
+isClientError :: StatusCode -> Bool
+isClientError = doesMeet (\ n -> n >= 400 && n < 500)
+
+-- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@.
+isServerError :: StatusCode -> Bool
+isServerError = doesMeet (>= 500)
+
+
+doesMeet :: (Int -> Bool) -> StatusCode -> Bool
+doesMeet p sc = case statusCode sc of
+ (# num, _ #) -> p num
+
+
+-- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
+-- representation of @sc@.
+statusCode :: StatusCode -> (# Int, Strict.ByteString #)
+
+statusCode Continue = (# 100, C8.pack "Continue" #)
+statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #)
+statusCode Processing = (# 102, C8.pack "Processing" #)
+
+statusCode Ok = (# 200, C8.pack "OK" #)
+statusCode Created = (# 201, C8.pack "Created" #)
+statusCode Accepted = (# 202, C8.pack "Accepted" #)
+statusCode NonAuthoritativeInformation = (# 203, C8.pack "Non Authoritative Information" #)
+statusCode NoContent = (# 204, C8.pack "No Content" #)
+statusCode ResetContent = (# 205, C8.pack "Reset Content" #)
+statusCode PartialContent = (# 206, C8.pack "Partial Content" #)
+statusCode MultiStatus = (# 207, C8.pack "Multi Status" #)
+
+statusCode MultipleChoices = (# 300, C8.pack "Multiple Choices" #)
+statusCode MovedPermanently = (# 301, C8.pack "Moved Permanently" #)
+statusCode Found = (# 302, C8.pack "Found" #)
+statusCode SeeOther = (# 303, C8.pack "See Other" #)
+statusCode NotModified = (# 304, C8.pack "Not Modified" #)
+statusCode UseProxy = (# 305, C8.pack "Use Proxy" #)
+statusCode TemporaryRedirect = (# 306, C8.pack "Temporary Redirect" #)
+
+statusCode BadRequest = (# 400, C8.pack "Bad Request" #)
+statusCode Unauthorized = (# 401, C8.pack "Unauthorized" #)
+statusCode PaymentRequired = (# 402, C8.pack "Payment Required" #)
+statusCode Forbidden = (# 403, C8.pack "Forbidden" #)
+statusCode NotFound = (# 404, C8.pack "Not Found" #)
+statusCode MethodNotAllowed = (# 405, C8.pack "Method Not Allowed" #)
+statusCode NotAcceptable = (# 406, C8.pack "Not Acceptable" #)
+statusCode ProxyAuthenticationRequired = (# 407, C8.pack "Proxy Authentication Required" #)
+statusCode RequestTimeout = (# 408, C8.pack "Request Timeout" #)
+statusCode Conflict = (# 409, C8.pack "Conflict" #)
+statusCode Gone = (# 410, C8.pack "Gone" #)
+statusCode LengthRequired = (# 411, C8.pack "Length Required" #)
+statusCode PreconditionFailed = (# 412, C8.pack "Precondition Failed" #)
+statusCode RequestEntityTooLarge = (# 413, C8.pack "Request Entity Too Large" #)
+statusCode RequestURITooLarge = (# 414, C8.pack "Request URI Too Large" #)
+statusCode UnsupportedMediaType = (# 415, C8.pack "Unsupported Media Type" #)
+statusCode RequestRangeNotSatisfiable = (# 416, C8.pack "Request Range Not Satisfiable" #)
+statusCode ExpectationFailed = (# 417, C8.pack "Expectation Failed" #)
+statusCode UnprocessableEntitiy = (# 422, C8.pack "Unprocessable Entity" #)
+statusCode Locked = (# 423, C8.pack "Locked" #)
+statusCode FailedDependency = (# 424, C8.pack "Failed Dependency" #)
+
+statusCode InternalServerError = (# 500, C8.pack "Internal Server Error" #)
+statusCode NotImplemented = (# 501, C8.pack "Not Implemented" #)
+statusCode BadGateway = (# 502, C8.pack "Bad Gateway" #)
+statusCode ServiceUnavailable = (# 503, C8.pack "Service Unavailable" #)
+statusCode GatewayTimeout = (# 504, C8.pack "Gateway Timeout" #)
+statusCode HttpVersionNotSupported = (# 505, C8.pack "HTTP Version Not Supported" #)
+statusCode InsufficientStorage = (# 507, C8.pack "Insufficient Storage" #)
\ No newline at end of file