module Network.HTTP.Lucu.DefaultPage
    ( getDefaultPage
    , writeDefaultPage
    , mkDefaultPage
    )
    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.Maybe
import           Network
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Format
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.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
    = conf `seq` req `seq` res `seq`
      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
    = itr `seq`
      do wroteHeader <- readTVar (itrWroteHeader itr)

         -- Content-Type が正しくなければ補完できない。
         res <- readItr itr itrResponse id
         when (getHeader "Content-Type" res == Just defaultPageContentType)
                  $ do reqM <- readItr itr itrRequest id

                       let 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
mkDefaultPage conf status msgA
    = conf `seq` status `seq` msgA `seq`
      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 (fmtDec 3 sCode ++ " " ++ sMsg)
                        ))
                += ( eelem "body"
                     += ( eelem "h1"
                          += txt sMsg
                        )
                     += ( eelem "p" += msgA )
                     += eelem "hr"
                     += ( eelem "address" += txt sig ))))
{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}

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

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

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

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

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

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

        Unauthorized
            -> txt ("You need a valid authentication to access " ++ path)

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

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

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

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

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

        -- 5xx
        InternalServerError
            -> txt ("An internal server error has occured during the process of your request to " ++ 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

{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}