From 54778963482bef9f6dfc305e593658e0e9d1a4c5 Mon Sep 17 00:00:00 2001 From: PHO 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