X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=913c491f6f1242373f4c52d9ef10a62a9ddd781e;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hp=0e6fbe2d8f2bb120b9f229cc5290db9610cb5957;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 0e6fbe2..913c491 100644
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,17 +1,30 @@
+-- #prune
+
+-- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)
-    , hPutResponse    -- Handle -> Response -> IO ()
-    , isInformational -- StatusCode -> Bool
-    , isError         -- StatusCode -> Bool
+    , hPutResponse
+    , 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           Text.Printf
 
+-- |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
@@ -62,20 +75,20 @@ data StatusCode = Continue
                 | GatewayTimeout
                 | HttpVersionNotSupported
                 | InsufficientStorage
-                  deriving (Eq)
+                  deriving (Typeable, Eq)
 
 instance Show StatusCode where
     show sc = let (num, msg) = statusCode sc
               in
-                printf "%03d %s" num msg
+                (fmtDec 3 num) ++ " " ++ msg
 
 
 data Response = Response {
-      resVersion :: HttpVersion
-    , resStatus  :: StatusCode
-    , resHeaders :: Headers
-    }
-                deriving (Show, Eq)
+      resVersion :: !HttpVersion
+    , resStatus  :: !StatusCode
+    , resHeaders :: !Headers
+    } deriving (Show, Eq)
+
 
 instance HasHeaders Response where
     getHeaders = resHeaders
@@ -83,27 +96,52 @@ instance HasHeaders Response where
 
 
 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)
+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 = let (num, msg) = statusCode sc
-                  in
-                    hPrintf h "%03d %s" num msg
-
+hPutStatus h sc
+    = h `seq` sc `seq`
+      hPutStr h (show sc)
 
+-- |@'isInformational' sc@ is True iff @sc < 200@.
 isInformational :: StatusCode -> Bool
-isInformational sc = let (num, _) = statusCode sc
-                     in num < 200
+isInformational = doesMeet (< 200)
+
+-- |@'isSuccessful' sc@ is True iff @200 <= sc < 300@.
+isSuccessful :: StatusCode -> Bool
+isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
+
+-- |@'isRedirection' sc@ is True iff @300 <= sc < 400@.
+isRedirection :: StatusCode -> Bool
+isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
 
+-- |@'isError' sc@ is True iff @400 <= sc@
 isError :: StatusCode -> Bool
-isError sc = let (num, _) = statusCode sc
-             in num >= 400
+isError = doesMeet (>= 400)
+
+-- |@'isClientError' sc@ is True iff @400 <= sc < 500@.
+isClientError :: StatusCode -> Bool
+isClientError = doesMeet (\ n -> n >= 400 && n < 500)
+
+-- |@'isServerError' sc@ is 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 a tuple of numeric and textual
+-- representation of @sc@.
 statusCode :: StatusCode -> (Int, String)
 statusCode Continue                    = (100, "Continue")
 statusCode SwitchingProtocols          = (101, "Switching Protocols")