{-# LANGUAGE
    OverloadedStrings
  , RecordWildCards
  , TypeOperators
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.DefaultPage
    ( getDefaultPage
    , defaultPageContentType
    , mkDefaultPage
    )
    where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import Data.Maybe
import qualified Data.Text as T
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.URI hiding (path)
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 → Builder
{-# INLINEABLE getDefaultPage #-}
getDefaultPage conf req res
    = let msgA     = getMsg req res
          [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
                             ⋙ 
                             writeDocumentToString [ withIndent True ]
                           ) ()
      in
        BB.fromString xmlStr

defaultPageContentType ∷ Ascii
{-# INLINE defaultPageContentType #-}
defaultPageContentType = "application/xhtml+xml"

mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
              ⇒ Config
              → sc
              → b ⇝ XmlTree
              → b ⇝ XmlTree
{-# INLINEABLE mkDefaultPage #-}
mkDefaultPage conf status msgA
    = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
          sig  = concat [ A.toString (cnfServerSoftware conf)
                        , " at "
                        , T.unpack (cnfServerHost conf)
                        ]
      in ( eelem "/"
           += ( eelem "html"
                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                += ( eelem "head"
                     += ( eelem "title"
                          += txt sStr
                        ))
                += ( eelem "body"
                     += ( eelem "h1"
                          += txt sStr
                        )
                     += ( eelem "p" += msgA )
                     += eelem "hr"
                     += ( eelem "address" += txt sig ))))

getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
{-# INLINEABLE getMsg #-}
getMsg req res@(Response {..})
    -- 1xx responses don't have a body.
    -- 2xx responses don't need a body to be completed.
    -- 3xx:
    | toStatusCode resStatus ≡ Just MovedPermanently
        = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
          <+>
          eelem "a" += sattr "href" loc
                    += txt loc
          <+>
          txt " permanently."

    | toStatusCode resStatus ≡ Just Found
        = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
          <+>
          eelem "a" += sattr "href" loc
                    += txt loc
          <+>
          txt ". This is not a permanent relocation."

    | toStatusCode resStatus ≡ Just SeeOther
        = txt ("The resource at " ⧺ path ⧺ " can be found at ")
          <+>
          eelem "a" += sattr "href" loc
                    += txt loc
          <+>
          txt "."

    | toStatusCode resStatus ≡ Just TemporaryRedirect
        = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
          <+>
          eelem "a" += sattr "href" loc
                    += txt loc
          <+>
          txt "."

      -- 4xx:
    | toStatusCode resStatus ≡ Just BadRequest
        = txt "The server could not understand the request you sent."
    | toStatusCode resStatus ≡ Just Unauthorized
        = txt ("You need a valid authentication to access " ⧺ path)
    | toStatusCode resStatus ≡ Just Forbidden
        = txt ("You don't have permission to access " ⧺ path)
    | toStatusCode resStatus ≡ Just NotFound
        = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
    | toStatusCode resStatus ≡ Just Gone
        = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
    | toStatusCode resStatus ≡ Just RequestEntityTooLarge
        = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
    | toStatusCode resStatus ≡ Just RequestURITooLarge
        = txt "The request URI you sent was too large to accept."

      -- 5xx:
    | toStatusCode resStatus ≡ Just InternalServerError
        = txt ("An internal server error has occured during the process of your request to " ⧺ path)
    | toStatusCode resStatus ≡ Just ServiceUnavailable
        = txt "The service is temporarily unavailable. Try later."

    | otherwise
        = none
    where
      path ∷ String
      path = uriPath $ reqURI $ fromJust req

      loc ∷ String
      loc = A.toString $ fromJust $ getHeader "Location" res