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