Fixed many bugs...

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index b530455f6ce99d686843f343aa4d4ba7042baab7..785e4c19480d385d2bc783cd441a2fc800983bf7 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -5,24 +5,21 @@
   #-}
 module Network.HTTP.Lucu.DefaultPage
     ( getDefaultPage
-    , writeDefaultPage
+    , defaultPageContentType
     , mkDefaultPage
     )
     where
-import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow
 import Control.Arrow.ArrowList
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
-import Control.Concurrent.STM
-import Control.Monad
+import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as Lazy
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.URI hiding (path)
@@ -43,13 +40,9 @@ getDefaultPage conf req res
       in
         Lazy.pack xmlStr
 
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage (Interaction {..})
-    -- Content-Type が正しくなければ補完できない。
-    = do res ← readTVar itrResponse
-         when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
-             $ do let page = getDefaultPage itrConfig itrRequest res
-                  putTMVar itrBodyToSend (BB.fromLazyText page)
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}