X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=c315424414857aba8b5ffe0d1047dac10c0db5bb;hb=0ff0346;hp=b5a934118e68cf513b3fe72a4c357b212bd847eb;hpb=69686745233be9269796be9f26621040fb7d9d1c;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index b5a9341..c315424 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -10,6 +10,7 @@ module Network.HTTP.Lucu.DefaultPage
     , mkDefaultPage
     )
     where
+import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Arrow
 import Control.Arrow.ArrowList
 import Control.Arrow.ListArrow
@@ -17,14 +18,11 @@ 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 qualified Data.Text.Lazy as Lazy
+import qualified Data.Text.Lazy.Encoding as Lazy
 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
@@ -36,7 +34,7 @@ import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.DOM.TypeDefs
 
-getDefaultPage ∷ Config → Maybe Request → Response → Text
+getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
 {-# INLINEABLE getDefaultPage #-}
 getDefaultPage !conf !req !res
     = let msgA     = getMsg req res
@@ -45,39 +43,39 @@ getDefaultPage !conf !req !res
                              writeDocumentToString [ withIndent True ]
                            ) ()
       in
-        T.pack xmlStr
+        Lazy.pack xmlStr
 
 writeDefaultPage ∷ Interaction → STM ()
 writeDefaultPage !itr
     -- Content-Type が正しくなければ補完できない。
-    = do res ← readItr itr itrResponse id
+    = do res ← readItr itrResponse id itr
          when (getHeader "Content-Type" res == Just defaultPageContentType)
-                  $ do reqM ← readItr itr itrRequest id
+                  $ do reqM ← readItr itrRequest id itr
 
                        let conf = itrConfig itr
                            page = getDefaultPage conf reqM res
 
-                       writeTVar (itrBodyToSend itr)
-                                 (S.singleton (encodeUtf8 page))
+                       putTMVar (itrBodyToSend itr)
+                                (BB.fromLazyByteString $ Lazy.encodeUtf8 page)
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}
 mkDefaultPage !conf !status !msgA
-    = let (# sCode, sMsg #) = statusCode status
-          sig               = concat [ C8.unpack (cnfServerSoftware conf)
-                                     , " at "
-                                     , C8.unpack (cnfServerHost conf)
-                                     ]
+    = let sStr = A.toString $ A.fromAsciiBuilder $ 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"