X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=a31e754adc2d6c4e16050c478df42b26eda2766c;hb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;hp=988329d28757d62a600ede2ac7aa66df1a499a61;hpb=30fcb38426696db8b80d322196cc594431e30407;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 988329d..a31e754 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -45,26 +45,15 @@ writeDefaultPage :: Interaction -> STM ()
 writeDefaultPage itr
     = do wroteHeader <- readTVar (itrWroteHeader itr)
 
-         -- ヘッダが出力濟だったら意味が無い。
-         when wroteHeader
-                  $ fail "writeDefaultPage: the header has already been written"
-
-         resM <- readTVar (itrResponse itr)
-
-         -- 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
+         -- Content-Type が正しくなければ補完できない。
+         res <- readTVar (itrResponse itr)
+         when (getHeader "Content-Type" res == Just defaultPageContentType)
+                  $ do let reqM = itrRequest itr
+                           conf = itrConfig itr
+                           page = B.pack $ getDefaultPage conf reqM res
+
+                       writeTVar (itrBodyToSend itr)
+                                     $ page
 
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree