{-# LANGUAGE
    BangPatterns
  , UnboxedTuples
  , UnicodeSyntax
  #-}
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.Char8 as C8
import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.Maybe
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 hiding (path)
import           System.IO.Unsafe
import           Text.XML.HXT.Arrow.WriteDocument
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlState
import           Text.XML.HXT.DOM.TypeDefs


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 [ withIndent True ]
                            )
           return xmlStr


writeDefaultPage :: Interaction -> STM ()
writeDefaultPage !itr
    -- Content-Type が正しくなければ補完できない。
    = do res <- readItr itr itrResponse id
         when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
                  $ do reqM <- readItr itr itrRequest id

                       let conf = itrConfig itr
                           page = L8.pack $ getDefaultPage conf reqM 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               = C8.unpack (cnfServerSoftware conf)
                              ++ " at "
                              ++ C8.unpack (cnfServerHost conf)
      in ( eelem "/"
           += ( eelem "html"
                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                += ( eelem "head"
                     += ( eelem "title"
                          += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
                        ))
                += ( eelem "body"
                     += ( eelem "h1"
                          += txt (C8.unpack 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
    = 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 = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res

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