+module Network.HTTP.Lucu.DefaultPage
+ ( getDefaultPage -- Maybe Request -> Response -> String
+ , writeDefaultPage -- Interaction -> STM ()
+ )
+ where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Maybe
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import System.IO.Unsafe
+import Text.Printf
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
+
+
+getDefaultPage :: Maybe Request -> Response -> String
+getDefaultPage req res
+ = let msgA = getMsg req res
+ in
+ unsafePerformIO $
+ do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ return xmlStr
+
+
+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
+ page = B.pack $ getDefaultPage reqM res
+
+ writeTVar (itrResponse itr)
+ $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
+
+ writeTVar (itrBodyToSend itr)
+ $ page
+
+
+mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
+mkDefaultPage status msgA
+ = let (sCode, sMsg) = statusCode status
+ in ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt (printf "%03d %s" sCode sMsg)
+ ))
+ += ( eelem "body"
+ += ( eelem "h1"
+ += txt sMsg
+ )
+ += ( msgA
+ >>>
+ eelem "p" += ( this
+ >>>
+ mkText
+ )))))
+
+
+getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
+getMsg req res
+ = constA "FIXME: NOT IMPL"