X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=35c168fb38cde77ea2227cb2b808d00c9da79322;hb=48bc90d;hp=2791616cbd3071243b2f8db966a7eb3b93397e50;hpb=e34910f85f459f049b9e6e6b79db9ef95dfccc13;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 2791616..35c168f 100644
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -6,36 +6,37 @@
   , UnicodeSyntax
   , ViewPatterns
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
-    , Response(..)
     , printStatusCode
-    , hPutResponse
+
+    , Response(..)
+    , emptyResponse
+    , resCanHaveBody
+    , printResponse
+
     , isInformational
     , isSuccessful
     , isRedirection
     , isError
     , isClientError
     , isServerError
-    , statusCode
     )
     where
-import Data.Ascii (Ascii)
+import Data.Ascii (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.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
@@ -89,15 +90,16 @@ data StatusCode = Continue
                 | InsufficientStorage
                   deriving (Eq, Show, Typeable)
 
--- |Convert a 'StatusCode' to 'Ascii'.
-printStatusCode ∷ StatusCode → Ascii
+-- |Convert a 'StatusCode' to an 'AsciiBuilder'.
+printStatusCode ∷ StatusCode → AsciiBuilder
+{-# INLINEABLE printStatusCode #-}
 printStatusCode (statusCode → (# num, msg #))
-    = A.fromAsciiBuilder $
-      ( fmtDec 3 num ⊕
+    = ( show3 num            ⊕
         A.toAsciiBuilder " " ⊕
         A.toAsciiBuilder msg
       )
 
+-- |This is the definition of an HTTP response.
 data Response = Response {
       resVersion ∷ !HttpVersion
     , resStatus  ∷ !StatusCode
@@ -105,54 +107,75 @@ data Response = Response {
     } 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@.
+-- |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
-isInformational = doesMeet (< 200)
+{-# INLINE isInformational #-}
+isInformational = satisfy (< 200)
 
--- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@.
+-- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@.
 isSuccessful ∷ StatusCode → Bool
-isSuccessful = doesMeet (\ n → n ≥ 200 ∧ n < 300)
+{-# INLINE isSuccessful #-}
+isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300)
 
--- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@.
+-- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@.
 isRedirection ∷ StatusCode → Bool
-isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400)
+{-# INLINE isRedirection #-}
+isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400)
 
--- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@
+-- |@'isError' sc@ returns 'True' iff @400 <= sc@
 isError ∷ StatusCode → Bool
-isError = doesMeet (≥ 400)
+{-# INLINE isError #-}
+isError = satisfy (≥ 400)
 
--- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@.
+-- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@.
 isClientError ∷ StatusCode → Bool
-isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500)
+{-# INLINE isClientError #-}
+isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500)
 
--- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@.
+-- |@'isServerError' sc@ returns 'True' iff @500 <= sc@.
 isServerError ∷ StatusCode → Bool
-isServerError = doesMeet (≥ 500)
+{-# INLINE isServerError #-}
+isServerError = satisfy (≥ 500)
 
-doesMeet ∷ (Int → Bool) → StatusCode → Bool
-{-# INLINE doesMeet #-}
-doesMeet p (statusCode → (# num, _ #)) = p num
+satisfy ∷ (Int → Bool) → StatusCode → Bool
+{-# INLINE satisfy #-}
+satisfy p (statusCode → (# num, _ #)) = p num
 
--- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
--- representation of @sc@.
 statusCode ∷ StatusCode → (# Int, Ascii #)
+{-# INLINEABLE statusCode #-}
 
 statusCode Continue                    = (# 100, "Continue"                      #)
 statusCode SwitchingProtocols          = (# 101, "Switching Protocols"           #)
@@ -204,3 +227,5 @@ statusCode ServiceUnavailable          = (# 503, "Service Unavailable"
 statusCode GatewayTimeout              = (# 504, "Gateway Timeout"               #)
 statusCode HttpVersionNotSupported     = (# 505, "HTTP Version Not Supported"    #)
 statusCode InsufficientStorage         = (# 507, "Insufficient Storage"          #)
+-- FIXME: Textual representations should also include numbers.
+-- FIXME: StatusCode should be a type class rather than a type.