X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=826cc0e0ce5d035e9a5aacd2999f59702366ccd8;hp=fd949fe9af09e8af5997b5ccf2634e5865777743;hb=8cd9d79234344199a1644f661684bde3ed5e440b;hpb=50e8fe7af585a8d33d93b3721be8f8f01905b891 diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index fd949fe..826cc0e 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,202 +1,127 @@ --- #prune - +{-# 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 + , statusCodes + , module Network.HTTP.Lucu.StatusCode + + -- * Functions + , emptyResponse + , setStatusCode + , resCanHaveBody + , printStatusCode + , printResponse + + , (≈) + , (≉) , isInformational , isSuccessful , isRedirection , isError , isClientError , isServerError - , statusCode ) where - -import Data.ByteString.Base (ByteString) -import qualified Data.ByteString.Char8 as C8 -import Data.Dynamic -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import System.IO - --- |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 (Typeable, Eq) - -instance Show StatusCode where - show sc = case statusCode sc of - (# num, msg #) - -> (fmtDec 3 num) ++ " " ++ C8.unpack msg - - +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 + +-- |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 + resVersion ∷ !HttpVersion + , resStatus ∷ !SomeStatusCode + , resHeaders ∷ !Headers } deriving (Show, Eq) - instance HasHeaders Response where - getHeaders = resHeaders + getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } - -hPutResponse :: Handle -> Response -> IO () -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 - = 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 = case statusCode sc of - (# num, _ #) -> p num - - --- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual --- representation of @sc@. -statusCode :: StatusCode -> (# Int, 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 +-- |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