X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=826cc0e0ce5d035e9a5aacd2999f59702366ccd8;hp=2791616cbd3071243b2f8db966a7eb3b93397e50;hb=8cd9d79234344199a1644f661684bde3ed5e440b;hpb=54778963482bef9f6dfc305e593658e0e9d1a4c5 diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 2791616..826cc0e 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,206 +1,127 @@ {-# LANGUAGE - DeriveDataTypeable - , OverloadedStrings + OverloadedStrings , RecordWildCards - , UnboxedTuples , UnicodeSyntax , ViewPatterns #-} -{-# OPTIONS_HADDOCK prune #-} - -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response - ( StatusCode(..) + ( -- * Class and Types + StatusCode(..) + , SomeStatusCode(..) , Response(..) + , statusCodes + , module Network.HTTP.Lucu.StatusCode + + -- * Functions + , emptyResponse + , setStatusCode + , resCanHaveBody , printStatusCode - , hPutResponse + , printResponse + + , (≈) + , (≉) , isInformational , isSuccessful , isRedirection , isError , isClientError , isServerError - , statusCode ) where -import Data.Ascii (Ascii) +import Data.Ascii (AsciiBuilder) import qualified Data.Ascii as A 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 Network.HTTP.Lucu.StatusCode +import Network.HTTP.Lucu.StatusCode.Internal import Prelude.Unicode --- |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 - -- - | 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, Show, Typeable) - --- |Convert a 'StatusCode' to 'Ascii'. -printStatusCode ∷ StatusCode → Ascii -printStatusCode (statusCode → (# num, msg #)) - = A.fromAsciiBuilder $ - ( fmtDec 3 num ⊕ - A.toAsciiBuilder " " ⊕ - A.toAsciiBuilder 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 + , resStatus ∷ !SomeStatusCode , resHeaders ∷ !Headers } deriving (Show, Eq) instance HasHeaders Response where - getHeaders = resHeaders + getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } -hPutResponse ∷ HandleLike h ⇒ h → Response → IO () -hPutResponse h (Response {..}) - = do hPutHttpVersion h resVersion - hPutChar h ' ' - hPutStatus h resStatus - hPutBS h "\r\n" - hPutHeaders h resHeaders - -hPutStatus ∷ HandleLike h ⇒ h → StatusCode → IO () -hPutStatus h (statusCode → (# num, msg #)) - = do hPutBS h (A.toByteString $ A.fromAsciiBuilder $ fmtDec 3 num) - hPutChar h ' ' - hPutBS h (A.toByteString 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 -{-# INLINE doesMeet #-} -doesMeet p (statusCode → (# num, _ #)) = p num - --- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual --- representation of @sc@. -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" #) +-- |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) + +satisfy ∷ StatusCode sc ⇒ (Int → Bool) → sc → Bool +{-# INLINE satisfy #-} +satisfy p (numericCode → num) = p num