X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=bb4ba2824e979582db1ca79fc841f2221328e2d2;hb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;hp=988329d28757d62a600ede2ac7aa66df1a499a61;hpb=b340a77fa7bd051dd13a41d0a5b1ad30220bc6b6;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 988329d..bb4ba28 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -45,26 +45,16 @@ writeDefaultPage :: Interaction -> STM ()
 writeDefaultPage itr
     = do wroteHeader <- readTVar (itrWroteHeader itr)
 
-         -- ヘッダが出力濟だったら意味が無い。
-         when wroteHeader
-                  $ fail "writeDefaultPage: the header has already been written"
+         -- Content-Type が正しくなければ補完できない。
+         res <- readItr itr itrResponse id
+         when (getHeader "Content-Type" res == Just defaultPageContentType)
+                  $ do reqM <- readItr itr itrRequest id
 
-         resM <- readTVar (itrResponse itr)
+                       let conf = itrConfig itr
+                           page = B.pack $ getDefaultPage conf reqM res
 
-         -- Response が不明ならばページ書込も不可
-         when (resM == Nothing)
-                  $ fail "writeDefaultPage: response was Nothing"
-
-         let reqM = itrRequest itr
-             res  = fromJust resM
-             conf = itrConfig itr
-             page = B.pack $ getDefaultPage conf reqM res
-
-         writeTVar (itrResponse itr)
-                       $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
-
-         writeTVar (itrBodyToSend itr)
-                       $ page
+                       writeTVar (itrBodyToSend itr)
+                                     $ page
 
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree