X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=872a52f178c324d13987259cc6a1dbecbfc42b30;hp=adf8505defd683f03a7292fc74a3f85ba20dc49c;hb=8510a3765130fb171c06b448c50a74e65ac8ae11;hpb=dfc778742934b8f2ac6a6709741c79ecd40c5ff1 diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index adf8505..872a52f 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable + , OverloadedStrings , UnboxedTuples , UnicodeSyntax + , ViewPatterns #-} {-# OPTIONS_HADDOCK prune #-} @@ -9,6 +11,7 @@ module Network.HTTP.Lucu.Response ( StatusCode(..) , Response(..) + , printStatusCode , hPutResponse , isInformational , isSuccessful @@ -19,14 +22,17 @@ module Network.HTTP.Lucu.Response , statusCode ) where - +import Data.Ascii (Ascii) +import qualified Data.Ascii as A 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 Data.Monoid.Unicode +import Data.Typeable +import Network.HTTP.Lucu.Format +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Prelude.Unicode -- |This is the definition of HTTP status code. -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses @@ -82,126 +88,124 @@ data StatusCode = Continue | GatewayTimeout | HttpVersionNotSupported | InsufficientStorage - deriving (Typeable, Eq) - -instance Show StatusCode where - show sc = case statusCode sc of - (# num, msg #) - -> (fmtDec 3 num) ++ " " ++ C8.unpack msg + deriving (Eq, Show, Typeable) +-- |Convert a 'StatusCode' to 'Ascii'. +printStatusCode ∷ StatusCode → Ascii +printStatusCode (statusCode → (# num, msg #)) + = A.fromAsciiBuilder $ + ( fmtDec 3 num ⊕ + A.toAsciiBuilder " " ⊕ + A.toAsciiBuilder msg + ) data Response = Response { - resVersion :: !HttpVersion - , resStatus :: !StatusCode - , resHeaders :: !Headers + resVersion ∷ !HttpVersion + , resStatus ∷ !StatusCode + , resHeaders ∷ !Headers } deriving (Show, Eq) - instance HasHeaders Response where getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } - -hPutResponse :: HandleLike h => h -> Response -> IO () +hPutResponse ∷ HandleLike h => h → Response → IO () hPutResponse h res - = h `seq` res `seq` - do hPutHttpVersion h (resVersion res) + = do hPutHttpVersion h (resVersion res) hPutChar h ' ' hPutStatus h (resStatus res) - hPutBS h (C8.pack "\r\n") + hPutBS h "\r\n" hPutHeaders h (resHeaders res) -hPutStatus :: HandleLike h => h -> StatusCode -> IO () +hPutStatus ∷ HandleLike h => h → StatusCode → IO () hPutStatus h sc - = h `seq` sc `seq` - case statusCode sc of + = case statusCode sc of (# num, msg #) - -> do hPutStr h (fmtDec 3 num) - hPutChar h ' ' - hPutBS h msg - + → do hPutStr h (fmtDec 3 num) + hPutChar h ' ' + hPutBS h msg -- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. -isInformational :: StatusCode -> Bool +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) +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) +isRedirection ∷ StatusCode → Bool +isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400) -- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@ -isError :: StatusCode -> Bool -isError = doesMeet (>= 400) +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) +isClientError ∷ StatusCode → Bool +isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500) -- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@. -isServerError :: StatusCode -> Bool -isServerError = doesMeet (>= 500) +isServerError ∷ StatusCode → Bool +isServerError = doesMeet (≥ 500) -doesMeet :: (Int -> Bool) -> StatusCode -> Bool +doesMeet ∷ (Int → Bool) → StatusCode → Bool doesMeet p sc = case statusCode sc of - (# num, _ #) -> p num + (# 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 +statusCode ∷ StatusCode → (# Int, Ascii #) + +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" #)