X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=19a72936e2718608034e22c15885fb9ea2fbe747;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=5c6846bdc0dc94479ee4ba755e6864088117977c;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 5c6846b..19a7293 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,29 +1,25 @@
 {-# LANGUAGE
     OverloadedStrings
-  , RecordWildCards
-  , UnboxedTuples
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage
     ( getDefaultPage
-    , writeDefaultPage
+    , defaultPageContentType
     , mkDefaultPage
     )
     where
+import Blaze.ByteString.Builder (Builder)
 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)
@@ -33,7 +29,7 @@ import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.DOM.TypeDefs
 
-getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
+getDefaultPage ∷ Config → Maybe Request → Response → Builder
 {-# INLINEABLE getDefaultPage #-}
 getDefaultPage conf req res
     = let msgA     = getMsg req res
@@ -42,16 +38,11 @@ getDefaultPage conf req res
                              writeDocumentToString [ withIndent True ]
                            ) ()
       in
-        Lazy.pack xmlStr
-
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage (Interaction {..})
-    -- Content-Type が正しくなければ補完できない。
-    = do res ← readTVar itrResponse
-         when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
-             $ do reqM ← readTVar itrRequest
-                  let page = getDefaultPage itrConfig reqM res
-                  putTMVar itrBodyToSend (BB.fromLazyText page)
+        BB.fromString xmlStr
+
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}