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"