Working on Postprocess...

[Lucu.git] / Network / HTTP / Lucu / Response.hs

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 573b98d21e8341d0467cbd3bd36b32ccc182f781..2791616cbd3071243b2f8db966a7eb3b93397e50 100644 (file)
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,9 +1,18 @@
--- #prune
+{-# LANGUAGE
+    DeriveDataTypeable
+  , OverloadedStrings
+  , RecordWildCards
+  , UnboxedTuples
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}
+{-# OPTIONS_HADDOCK prune #-}
 
 -- |Definition of things related on HTTP response.
 module Network.HTTP.Lucu.Response
     ( StatusCode(..)
     , Response(..)
+    , printStatusCode
     , hPutResponse
     , isInformational
     , isSuccessful
@@ -14,12 +23,15 @@ module Network.HTTP.Lucu.Response
     , 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)
+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 Prelude.Unicode
 
 -- |This is the definition of HTTP status code.
 -- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses
@@ -75,74 +87,72 @@ 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 'Ascii'.
+printStatusCode ∷ StatusCode → Ascii
+printStatusCode (statusCode → (# num, msg #))
+    = A.fromAsciiBuilder $
+      ( fmtDec 3 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
     getHeaders = resHeaders
     setHeaders res hdr = res { resHeaders = hdr }
 
-
-hPutResponse :: Handle -> Response -> IO ()
-hPutResponse h res
-    = h `seq` res `seq`
-      do hPutHttpVersion h (resVersion res)
+hPutResponse ∷ HandleLike h ⇒ h → Response → IO ()
+hPutResponse h (Response {..})
+    = do hPutHttpVersion h resVersion
          hPutChar        h ' '
-         hPutStatus      h (resStatus  res)
-         hPutStr         h "\r\n"
-         hPutHeaders     h (resHeaders res)
+         hPutStatus      h resStatus
+         hPutBS          h "\r\n"
+         hPutHeaders     h resHeaders
 
-hPutStatus :: Handle -> StatusCode -> IO ()
-hPutStatus h sc
-    = h `seq` sc `seq`
-      hPutStr h (show sc)
+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@.
-isInformational :: StatusCode -> Bool
+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)
+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)
+isRedirection ∷ StatusCode → Bool
+isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400)
 
 -- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@
-isError :: StatusCode -> Bool
-isError = doesMeet (>= 400)
+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)
+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
+isServerError ∷ StatusCode → Bool
+isServerError = doesMeet (≥ 500)
 
+doesMeet ∷ (Int → Bool) → StatusCode → Bool
+{-# INLINE doesMeet #-}
+doesMeet 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 #)
 
 statusCode Continue                    = (# 100, "Continue"                      #)
 statusCode SwitchingProtocols          = (# 101, "Switching Protocols"           #)
@@ -193,4 +203,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"          #)