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
    )
    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
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Headers
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Request
import           Network.HTTP.Lucu.Response
import           Network.URI
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 :: Config -> Maybe Request -> Response -> String
getDefaultPage conf req res
    = let msgA = getMsg req res
      in
        unsafePerformIO $
        do [xmlStr] <- runX ( mkDefaultPage conf (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
             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
                             )
      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
                        )
                     += ( eelem "p" += msgA )
                     += eelem "hr"
                     += ( eelem "address" += txt sig ))))


getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
getMsg req res
    = case resStatus res of
        -- 1xx は body を持たない
        -- 2xx の body は補完しない

        -- 3xx
        MovedPermanently
            -> txt (printf "The resource at %s has been moved to " path)
               <+>
               eelem "a" += sattr "href" loc
                         += txt loc
               <+>
               txt " permanently."

        Found
            -> txt (printf "The resource at %s is currently located at " path)
               <+>
               eelem "a" += sattr "href" loc
                         += txt loc
               <+>
               txt ". This is not a permanent relocation."

        SeeOther
            -> txt (printf "The resource at %s can be found at " path)
               <+>
               eelem "a" += sattr "href" loc
                         += txt loc
               <+>
               txt "."

        TemporaryRedirect
            -> txt (printf "The resource at %s is temporarily located at " path)
               <+>
               eelem "a" += sattr "href" loc
                         += txt loc
               <+>
               txt "."

        -- 4xx
        BadRequest
            -> txt "The server could not understand the request you sent."

        Unauthorized
            -> txt (printf "You need a valid authentication to access %s" path)

        Forbidden
            -> txt (printf "You don't have permission to access %s" path)

        NotFound
            -> txt (printf "The requested URL %s was not found on this server." path)

        Gone
            -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)

        RequestEntityTooLarge
            -> txt (printf "The request entity you sent for %s was too big to accept." path)

        RequestURITooLarge
            -> txt "The request URI you sent was too big to accept."

        -- 5xx
        InternalServerError
            -> txt (printf "An internal server error has occured during the process of your request to %s" path)

        ServiceUnavailable
            -> txt "The service is temporarily unavailable. Try later."

        _  -> none

                            
    where
      path :: String
      path = let uri = reqURI $ fromJust req
             in
               uriPath uri

      loc :: String
      loc = fromJust $ getHeader "Location" res