X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=326054214915d1df157723308094bd867b3521bf;hb=1196f43ecedbb123515065f0440844864af906fb;hp=54d57b2972abe824cfd1d1931a1682a87d531a24;hpb=e624f0db8c4610b36da9e4463a656e0cb8a104dd;p=Lucu.git diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 54d57b2..3260542 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,21 +1,32 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response ( StatusCode(..) , Response(..) - , hPutResponse -- Handle -> Response -> IO () - , isInformational -- StatusCode -> Bool - , isSuccessful -- StatusCode -> Bool - , isRedirection -- 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.Dynamic +import Network.HTTP.Lucu.Format 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 @@ -69,17 +80,17 @@ data StatusCode = Continue 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 @@ -87,84 +98,105 @@ instance HasHeaders Response where 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 h res + = h `seq` res `seq` + do hPutHttpVersion h (resVersion res) + hPutChar h ' ' + hPutStatus h (resStatus res) + C8.hPut 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 h sc + = h `seq` sc `seq` + case statusCode sc of + (# num, msg #) + -> do hPutStr h (fmtDec 3 num) + hPutChar h ' ' + C8.hPut h msg +-- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. isInformational :: StatusCode -> Bool 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 = 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 = let (num, _) = statusCode sc - in - p num - - -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 +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