X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponse.hs;h=547947b4726b94240f1e909bc0180f7f2e5e5f68;hb=72a3e24;hp=b1ad3d8df4a914b1a7900e4d7463a19902421863;hpb=ea8f823ffa1004582d403c69f52a83e20486269f;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index b1ad3d8..547947b 100644
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,25 +1,39 @@
--- #prune
+{-# LANGUAGE
+    DeriveDataTypeable
+  , OverloadedStrings
+  , RecordWildCards
+  , UnboxedTuples
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}
 
 -- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
+    , printStatusCode
+
     , Response(..)
-    , hPutResponse
+    , 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
@@ -75,73 +89,88 @@ data StatusCode = Continue
                 | 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 'AsciiBuilder'.
+printStatusCode ∷ StatusCode → AsciiBuilder
+{-# INLINEABLE printStatusCode #-}
+printStatusCode (statusCode → (# num, msg #))
+    = ( show3 num            ⊕
+        A.toAsciiBuilder " " ⊕
+        A.toAsciiBuilder msg
+      )
 
 data Response = Response {
-      resVersion :: !HttpVersion
-    , resStatus  :: !StatusCode
-    , resHeaders :: !Headers
+      resVersion ∷ !HttpVersion
+    , resStatus  ∷ !StatusCode
+    , resHeaders ∷ !Headers
     } deriving (Show, Eq)
 
-
 instance HasHeaders Response where
+    {-# INLINE getHeaders #-}
     getHeaders = resHeaders
+    {-# INLINE setHeaders #-}
     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 = case statusCode sc of
-                  (# num, _ #) -> p num
-
+-- |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' sc@ returns an unboxed tuple of numeric and textual
 -- representation of @sc@.
-statusCode :: StatusCode -> (# Int, String #)
+statusCode ∷ StatusCode → (# Int, Ascii #)
+{-# INLINEABLE statusCode #-}
 
 statusCode Continue                    = (# 100, "Continue"                      #)
 statusCode SwitchingProtocols          = (# 101, "Switching Protocols"           #)
@@ -192,4 +221,4 @@ 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"          #)
\ No newline at end of file
+statusCode InsufficientStorage         = (# 507, "Insufficient Storage"          #)