"driftTo Done" was trying to change the response header, which is impossible.

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 988329d28757d62a600ede2ac7aa66df1a499a61..a31e754adc2d6c4e16050c478df42b26eda2766c 100644 (file)
--- 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