many changes...

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index dbc3835d6bbd8e5e7362426c900c81d736771278..bc75af51f153768091799704ce7d69cb2a75b7a4 100644 (file)
--- 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
@@ -18,7 +19,6 @@ import Control.Concurrent.STM
 import Control.Monad
 import qualified Data.Ascii as A
 import Data.Maybe
-import qualified Data.Sequence as S
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
@@ -48,20 +48,20 @@ getDefaultPage !conf !req !res
 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.fromByteString $ encodeUtf8 page)
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}
 mkDefaultPage !conf !status !msgA
-    = let sStr = A.toString $ printStatusCode status
+    = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "
                         , T.unpack (cnfServerHost conf)