X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=826cc0e0ce5d035e9a5aacd2999f59702366ccd8;hp=1c19da4cc87babe36f9f407aed2fdf1615e2ff7f;hb=8cd9d79234344199a1644f661684bde3ed5e440b;hpb=a9e9f50818285bf66cd64e5a248175eecb8e1fea diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 1c19da4..826cc0e 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,158 +1,127 @@ +{-# LANGUAGE + OverloadedStrings + , RecordWildCards + , UnicodeSyntax + , ViewPatterns + #-} +-- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response - ( StatusCode(..) + ( -- * Class and Types + StatusCode(..) + , SomeStatusCode(..) , Response(..) - , hPutResponse -- Handle -> Response -> IO () - , isInformational -- StatusCode -> Bool - , isError -- StatusCode -> Bool - , statusCode -- StatusCode -> (Int, String) + , statusCodes + , module Network.HTTP.Lucu.StatusCode + + -- * Functions + , emptyResponse + , setStatusCode + , resCanHaveBody + , printStatusCode + , printResponse + + , (≈) + , (≉) + , isInformational + , isSuccessful + , isRedirection + , isError + , isClientError + , isServerError ) where +import Data.Ascii (AsciiBuilder) +import qualified Data.Ascii as A +import Data.Monoid.Unicode +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.StatusCode +import Network.HTTP.Lucu.StatusCode.Internal +import Prelude.Unicode -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import System.IO -import Text.Printf - -data StatusCode = Continue - | SwitchingProtocols - | Processing - -- - | Ok - | Created - | Accepted - | NonAuthoritativeInformation - | NoContent - | ResetContent - | PartialContent - | MultiStatus - -- - | MultipleChoices - | MovedPermanently - | Found - | SeeOther - | NotModified - | UseProxy - | TemporaryRedirect - -- - | BadRequest - | Unauthorized - | PaymentRequired - | Forbidden - | NotFound - | MethodNotAllowed - | NotAcceptable - | ProxyAuthenticationRequired - | RequestTimeout - | Conflict - | Gone - | LengthRequired - | PreconditionFailed - | RequestEntityTooLarge - | RequestURITooLarge - | UnsupportedMediaType - | RequestRangeNotSatisfiable - | ExpectationFailed - | UnprocessableEntitiy - | Locked - | FailedDependency - -- - | InternalServerError - | NotImplemented - | BadGateway - | ServiceUnavailable - | GatewayTimeout - | HttpVersionNotSupported - | InsufficientStorage - deriving (Eq) - -instance Show StatusCode where - show sc = let (num, msg) = statusCode sc - in - printf "%03d %s" num msg - +-- |Convert a 'StatusCode' to an 'AsciiBuilder'. +printStatusCode ∷ StatusCode sc ⇒ sc → AsciiBuilder +{-# INLINEABLE printStatusCode #-} +printStatusCode = A.toAsciiBuilder ∘ textualStatus +-- |This is the definition of an HTTP response. data Response = Response { - resVersion :: HttpVersion - , resStatus :: StatusCode - , resHeaders :: Headers - } - deriving (Show, Eq) + resVersion ∷ !HttpVersion + , resStatus ∷ !SomeStatusCode + , resHeaders ∷ !Headers + } deriving (Show, Eq) instance HasHeaders Response where - getHeaders = resHeaders + getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } +-- |Returns an HTTP\/1.1 'Response' with no header fields. +emptyResponse ∷ StatusCode sc ⇒ sc → Response +emptyResponse sc + = Response { + resVersion = HttpVersion 1 1 + , resStatus = fromStatusCode sc + , resHeaders = (∅) + } + +-- |@'setStatusCode' sc res@ sets the status code of @res@ to @sc@. +setStatusCode ∷ StatusCode sc ⇒ sc → Response → Response +setStatusCode sc res + = res { + resStatus = fromStatusCode sc + } + +-- |Returns 'True' iff a given 'Response' allows the existence of +-- response entity body. +resCanHaveBody ∷ Response → Bool +{-# INLINEABLE resCanHaveBody #-} +resCanHaveBody (Response {..}) + | isInformational resStatus = False + | resStatus ≈ NoContent = False + | resStatus ≈ ResetContent = False + | resStatus ≈ NotModified = False + | otherwise = True + +-- |Convert a 'Response' to 'AsciiBuilder'. +printResponse ∷ Response → AsciiBuilder +{-# INLINEABLE printResponse #-} +printResponse (Response {..}) + = printHttpVersion resVersion ⊕ + A.toAsciiBuilder " " ⊕ + printStatusCode resStatus ⊕ + A.toAsciiBuilder "\x0D\x0A" ⊕ + printHeaders resHeaders + +-- |@'isInformational' sc@ returns 'True' iff @sc < 200@. +isInformational ∷ StatusCode sc ⇒ sc → Bool +{-# INLINE isInformational #-} +isInformational = satisfy (< 200) + +-- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@. +isSuccessful ∷ StatusCode sc ⇒ sc → Bool +{-# INLINE isSuccessful #-} +isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300) + +-- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@. +isRedirection ∷ StatusCode sc ⇒ sc → Bool +{-# INLINE isRedirection #-} +isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400) + +-- |@'isError' sc@ returns 'True' iff @400 <= sc@ +isError ∷ StatusCode sc ⇒ sc → Bool +{-# INLINE isError #-} +isError = satisfy (≥ 400) + +-- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@. +isClientError ∷ StatusCode sc ⇒ sc → Bool +{-# INLINE isClientError #-} +isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500) + +-- |@'isServerError' sc@ returns 'True' iff @500 <= sc@. +isServerError ∷ StatusCode sc ⇒ sc → Bool +{-# INLINE isServerError #-} +isServerError = satisfy (≥ 500) -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) - -hPutStatus :: Handle -> StatusCode -> IO () -hPutStatus h sc = let (num, msg) = statusCode sc - in - hPrintf h "%03d %s" num msg - - -isInformational :: StatusCode -> Bool -isInformational sc = let (num, _) = statusCode sc - in num < 200 - -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 +satisfy ∷ StatusCode sc ⇒ (Int → Bool) → sc → Bool +{-# INLINE satisfy #-} +satisfy p (numericCode → num) = p num