--- #prune
+{-# LANGUAGE
+ DeriveDataTypeable
+ , OverloadedStrings
+ , RecordWildCards
+ , UnboxedTuples
+ , UnicodeSyntax
+ , ViewPatterns
+ #-}
-- |Definition of things related on HTTP response.
module Network.HTTP.Lucu.Response
( StatusCode(..)
+ , printStatusCode
+
, Response(..)
- , hPutResponse
+ , emptyResponse
+ , resCanHaveBody
+ , printResponse
+
, isInformational
, isSuccessful
, isRedirection
, isError
, isClientError
, isServerError
- , statusCode
)
where
-
-import Data.Dynamic
-import Network.HTTP.Lucu.Format
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import System.IO
+import Data.Ascii (Ascii, AsciiBuilder)
+import qualified Data.Ascii as A
+import Data.Monoid.Unicode
+import Data.Typeable
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Utils
+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
+-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status
+-- codes so you don't have to memorize, for instance, that \"Gateway
-- Timeout\" is 504.
data StatusCode = Continue
| SwitchingProtocols
| GatewayTimeout
| HttpVersionNotSupported
| InsufficientStorage
- deriving (Typeable, Eq)
-
-instance Show StatusCode where
- show sc = let (# num, msg #) = statusCode sc
- in
- (fmtDec 3 num) ++ " " ++ msg
-
-
+ deriving (Eq, Show, Typeable)
+
+-- |Convert a 'StatusCode' to an 'AsciiBuilder'.
+printStatusCode ∷ StatusCode → AsciiBuilder
+{-# INLINEABLE printStatusCode #-}
+printStatusCode (statusCode → (# num, msg #))
+ = ( show3 num ⊕
+ A.toAsciiBuilder " " ⊕
+ A.toAsciiBuilder msg
+ )
+
+-- |This is the definition of an HTTP response.
data Response = Response {
- resVersion :: !HttpVersion
- , resStatus :: !StatusCode
- , resHeaders :: !Headers
+ resVersion ∷ !HttpVersion
+ , resStatus ∷ !StatusCode
+ , 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)
- hPutStr h "\r\n"
- hPutHeaders h (resHeaders res)
-
-hPutStatus :: Handle -> StatusCode -> IO ()
-hPutStatus h sc
- = h `seq` sc `seq`
- hPutStr h (show sc)
-
--- |@'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' sc@ returns an unboxed tuple of numeric and textual
--- representation of @sc@.
-statusCode :: StatusCode -> (# Int, String #)
+-- |Returns an HTTP\/1.1 'Response' with no header fields.
+emptyResponse ∷ StatusCode → Response
+emptyResponse sc
+ = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = sc
+ , resHeaders = (∅)
+ }
+
+-- |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 → Bool
+{-# INLINE isInformational #-}
+isInformational = satisfy (< 200)
+
+-- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@.
+isSuccessful ∷ StatusCode → Bool
+{-# INLINE isSuccessful #-}
+isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
+
+-- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@.
+isRedirection ∷ StatusCode → Bool
+{-# INLINE isRedirection #-}
+isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
+
+-- |@'isError' sc@ returns 'True' iff @400 <= sc@
+isError ∷ StatusCode → Bool
+{-# INLINE isError #-}
+isError = satisfy (≥ 400)
+
+-- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@.
+isClientError ∷ StatusCode → Bool
+{-# INLINE isClientError #-}
+isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
+
+-- |@'isServerError' sc@ returns 'True' iff @500 <= sc@.
+isServerError ∷ StatusCode → Bool
+{-# INLINE isServerError #-}
+isServerError = satisfy (≥ 500)
+
+satisfy ∷ (Int → Bool) → StatusCode → Bool
+{-# INLINE satisfy #-}
+satisfy p (statusCode → (# num, _ #)) = p num
+
+statusCode ∷ StatusCode → (# Int, Ascii #)
+{-# INLINEABLE statusCode #-}
statusCode Continue = (# 100, "Continue" #)
statusCode SwitchingProtocols = (# 101, "Switching Protocols" #)
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
+statusCode InsufficientStorage = (# 507, "Insufficient Storage" #)
+-- FIXME: Textual representations should also include numbers.
+-- FIXME: StatusCode should be a type class rather than a type.