{-# LANGUAGE
    BangPatterns
  , OverloadedStrings
  , UnboxedTuples
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.DefaultPage
    ( getDefaultPage
    , writeDefaultPage
    , mkDefaultPage
    )
    where
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.Unicode
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Ascii as A
import qualified Data.ByteString.Char8 as C8
import Data.Maybe
import qualified Data.Sequence as S
import qualified Data.Text as T
import Data.Text.Encoding
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 Prelude.Unicode
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 "Content-Type" res == Just defaultPageContentType)
                  $ do reqM ← readItr itr itrRequest id

                       let conf = itrConfig itr
                           page = T.pack $ getDefaultPage conf reqM res

                       writeTVar (itrBodyToSend itr)
                                 (S.singleton (encodeUtf8 page))

mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
{-# INLINEABLE mkDefaultPage #-}
mkDefaultPage !conf !status !msgA
    = let (# sCode, sMsg #) = statusCode status
          sig               = concat [ 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 ))))

getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
{-# INLINEABLE getMsg #-}
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 large to accept.")

        RequestURITooLarge
            → txt "The request URI you sent was too large 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 = A.toString $ fromJust $ getHeader "Location" res