Working on Postprocess...

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Lucu.cabal b/Lucu.cabal
index f5dddee7d2cca60c79650bc00376f3642ded00fe..e1650f84836c4e3b27d1c8f87e0acb1ad2ad8548 100644 (file)
--- 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 dea56b331df71a19807e043f31a7fa85f8338911..dbc3835d6bbd8e5e7362426c900c81d736771278 100644 (file)
--- 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 86bca83aacca170075c0676e0201bab68dac4589..42508b92e849b2f720cffbac7e02acc4ef9293b1 100644 (file)
--- 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 989ad164707ca9afb99f94f55dcc69fe2840e658..ca416b9f4dc24b96cf5f206554c7d4a8bf212100 100644 (file)
--- 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 872a52f178c324d13987259cc6a1dbecbfc42b30..2791616cbd3071243b2f8db966a7eb3b93397e50 100644 (file)
--- 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@.