From 54778963482bef9f6dfc305e593658e0e9d1a4c5 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Fri, 26 Aug 2011 04:35:08 +0900
Subject: [PATCH] Working on Postprocess...
Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa
---
Lucu.cabal | 1 +
Network/HTTP/Lucu/DefaultPage.hs | 16 ++++++--------
Network/HTTP/Lucu/Format.hs | 6 ++---
Network/HTTP/Lucu/Postprocess.hs | 38 +++++++++++++++++---------------
Network/HTTP/Lucu/Response.hs | 31 +++++++++++---------------
5 files changed, 43 insertions(+), 49 deletions(-)
diff --git a/Lucu.cabal b/Lucu.cabal
index f5dddee..e1650f8 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -51,6 +51,7 @@ Library
base == 4.3.*,
base-unicode-symbols == 0.2.*,
base64-bytestring == 0.1.*,
+ blaze-builder == 0.3.*,
bytestring == 0.9.*,
containers == 0.4.*,
containers-unicode-symbols == 0.3.*,
diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index dea56b3..dbc3835 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -17,14 +17,12 @@ import Control.Arrow.Unicode
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Ascii as A
-import qualified Data.ByteString.Char8 as C8
import Data.Maybe
import qualified Data.Sequence as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
@@ -63,21 +61,21 @@ writeDefaultPage !itr
mkDefaultPage â· (ArrowXml a) â Config â StatusCode â a b XmlTree â a b XmlTree
{-# INLINEABLE mkDefaultPage #-}
mkDefaultPage !conf !status !msgA
- = let (# sCode, sMsg #) = statusCode status
- sig = concat [ A.toString (cnfServerSoftware conf)
- , " at "
- , T.unpack (cnfServerHost conf)
- ]
+ = let sStr = A.toString $ printStatusCode status
+ sig = concat [ A.toString (cnfServerSoftware conf)
+ , " at "
+ , T.unpack (cnfServerHost conf)
+ ]
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (fmtDec 3 sCode ⧺ " " ⧺ C8.unpack sMsg)
+ += txt sStr
))
+= ( eelem "body"
+= ( eelem "h1"
- += txt (C8.unpack sMsg)
+ += txt sStr
)
+= ( eelem "p" += msgA )
+= eelem "hr"
diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs
index 86bca83..42508b9 100644
--- a/Network/HTTP/Lucu/Format.hs
+++ b/Network/HTTP/Lucu/Format.hs
@@ -13,6 +13,7 @@ module Network.HTTP.Lucu.Format
, fmtHex
)
where
+import qualified Blaze.ByteString.Builder.Char8 as BC
import Data.Ascii (AsciiBuilder)
import qualified Data.ByteString.Char8 as BS
import qualified Data.Ascii as A
@@ -116,7 +117,4 @@ digitToChar n
fromDigit â· Integral n â n â AsciiBuilder
{-# INLINE fromDigit #-}
-fromDigit = A.toAsciiBuilder â
- A.unsafeFromByteString â
- BS.singleton â
- digitToChar
+fromDigit = A.unsafeFromBuilder â BC.fromChar â digitToChar
diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 989ad16..ca416b9 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -9,27 +9,28 @@ module Network.HTTP.Lucu.Postprocess
)
where
import Control.Applicative
-import Control.Concurrent.STM
-import Control.Monad
+import Control.Concurrent.STM
+import Control.Monad
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import Data.IORef
-import Data.Maybe
-import Data.Time
+import Data.IORef
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Time
import qualified Data.Time.HTTP as HTTP
-import GHC.Conc (unsafeIOToSTM)
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
+import GHC.Conc (unsafeIOToSTM)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
import Prelude.Unicode
-import System.IO.Unsafe
+import System.IO.Unsafe
{-
@@ -71,11 +72,12 @@ postprocess !itr
let sc = resStatus res
unless (any (\ p â p sc) [isSuccessful, isRedirection, isError])
- $ abortSTM InternalServerError []
- $ Just ("The status code is not good for a final status: "
- ++ show sc)
+ $ abortSTM InternalServerError []
+ $ Just
+ $ A.toText ( "The status code is not good for a final status of a response: "
+ â printStatusCode sc )
- when (sc ⡠MethodNotAllowed ⧠getHeader (C8.pack "Allow") res ⡠Nothing)
+ when (sc ⡠MethodNotAllowed ⧠getHeader "Allow" res ⡠Nothing)
$ abortSTM InternalServerError []
$ Just ("The status was " ++ show sc ++ " but no Allow header.")
diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 872a52f..2791616 100644
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE
DeriveDataTypeable
, OverloadedStrings
+ , RecordWildCards
, UnboxedTuples
, UnicodeSyntax
, ViewPatterns
@@ -24,8 +25,6 @@ module Network.HTTP.Lucu.Response
where
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
-import qualified Data.ByteString as Strict (ByteString)
-import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Monoid.Unicode
import Data.Typeable
import Network.HTTP.Lucu.Format
@@ -109,21 +108,19 @@ instance HasHeaders Response where
getHeaders = resHeaders
setHeaders res hdr = res { resHeaders = hdr }
-hPutResponse â· HandleLike h => h â Response â IO ()
-hPutResponse h res
- = do hPutHttpVersion h (resVersion res)
+hPutResponse â· HandleLike h â h â Response â IO ()
+hPutResponse h (Response {..})
+ = do hPutHttpVersion h resVersion
hPutChar h ' '
- hPutStatus h (resStatus res)
+ hPutStatus h resStatus
hPutBS h "\r\n"
- hPutHeaders h (resHeaders res)
+ hPutHeaders h resHeaders
-hPutStatus â· HandleLike h => h â StatusCode â IO ()
-hPutStatus h sc
- = case statusCode sc of
- (# num, msg #)
- â do hPutStr h (fmtDec 3 num)
- hPutChar h ' '
- hPutBS h msg
+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
@@ -149,11 +146,9 @@ isClientError = doesMeet (\ n â n ⥠400 ⧠n < 500)
isServerError â· StatusCode â Bool
isServerError = doesMeet (⥠500)
-
doesMeet â· (Int â Bool) â StatusCode â Bool
-doesMeet p sc = case statusCode sc of
- (# num, _ #) â p num
-
+{-# INLINE doesMeet #-}
+doesMeet p (statusCode â (# num, _ #)) = p num
-- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
-- representation of @sc@.
--
2.40.0