"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 f5cc4764366c62d65edbc165bfb8a0b7f73b5283..a31e754adc2d6c4e16050c478df42b26eda2766c 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,7 +1,8 @@
+-- #hide, prune
 module Network.HTTP.Lucu.DefaultPage
-    ( getDefaultPage   -- Config -> Maybe Request -> Response -> String
-    , writeDefaultPage -- Interaction -> STM ()
-    , mkDefaultPage    --  (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
+    ( getDefaultPage
+    , writeDefaultPage
+    , mkDefaultPage
     )
     where
 
@@ -44,26 +45,15 @@ writeDefaultPage :: Interaction -> STM ()
 writeDefaultPage itr
     = do wroteHeader <- readTVar (itrWroteHeader itr)
 
-         -- ヘッダが出力濟だったら意味が無い。
-         when wroteHeader
-                  $ fail "writeDefaultPage: the header has already been written"
+         -- 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
 
-         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
+                       writeTVar (itrBodyToSend itr)
+                                     $ page
 
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree