-
-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
-
-
-mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
-mkDefaultPage conf status msgA
- = let (sCode, sMsg) = statusCode status
- sig = cnfServerSoftware conf
- ++ " at "
- ++ cnfServerHost conf
- ++ ( case cnfServerPort conf of
- Service serv -> ", service " ++ serv
- PortNumber num -> ", port " ++ show num
- UnixSocket path -> ", unix socket " ++ show path
- )
+writeDefaultPage ∷ Interaction → STM ()
+writeDefaultPage !itr
+ -- Content-Type が正しくなければ補完できない。
+ = do res ← readItr itr itrResponse id
+ when (getHeader "Content-Type" res == Just defaultPageContentType)
+ $ do reqM ← readItr itr itrRequest id
+
+ let conf = itrConfig itr
+ page = T.pack $ getDefaultPage conf reqM res
+
+ writeTVar (itrBodyToSend itr)
+ (S.singleton (encodeUtf8 page))
+
+mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
+{-# INLINEABLE mkDefaultPage #-}
+mkDefaultPage !conf !status !msgA
+ = let (# sCode, sMsg #) = statusCode status
+ sig = concat [ C8.unpack (cnfServerSoftware conf)
+ , " at "
+ , C8.unpack (cnfServerHost conf)
+ ]