{-# LANGUAGE
    OverloadedStrings
  , RecordWildCards
  , TypeOperators
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.DefaultPage
    ( defaultPageContentType
    , defaultPageForResponse
    , defaultPageWithMessage
    )
    where
import Blaze.ByteString.Builder (Builder)
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import qualified Data.CaseInsensitive as CI
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
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 hiding (head)
import Prelude.Unicode
import Text.Blaze
import Text.Blaze.Html5 hiding (hr)
import Text.Blaze.Html5.Attributes hiding (title)
import Text.Blaze.Renderer.Utf8

defaultPageContentType ∷ Ascii
{-# INLINE defaultPageContentType #-}
defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""

defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
{-# INLINEABLE defaultPageForResponse #-}
defaultPageForResponse conf req res
    = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res

defaultPageWithMessage ∷ StatusCode sc ⇒ Config → sc → Html → Builder
{-# INLINEABLE defaultPageWithMessage #-}
defaultPageWithMessage (Config {..}) sc msg
    = renderHtmlBuilder $
      do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
         docType
         html ! xmlns "http://www.w3.org/1999/xhtml" $
             do let status = toHtml ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc
                head $ title status
                body $ do h1 status
                          p msg
                          hr
                          address $ do toHtml $ A.toText cnfServerSoftware
                                       unsafeByteString " at "
                                       toHtml $ CI.original cnfServerHost

defaultMessage ∷ Maybe Request → Response → Html
{-# INLINEABLE defaultMessage #-}
defaultMessage req res@(Response {..})
    -- 1xx responses don't have a body.
    -- 2xx responses don't need a body to be completed.
    -- 3xx:
    | resStatus ≈ MovedPermanently
        = do unsafeByteString "The resource at "
             path
             unsafeByteString " has been moved to "
             a ! href (toValue loc) $ toHtml loc
             unsafeByteString " permanently."

    | resStatus ≈ Found
        = do unsafeByteString "The resource at "
             path
             unsafeByteString " is currently located at "
             a ! href (toValue loc) $ toHtml loc
             unsafeByteString ". This is not a permanent relocation."

    | resStatus ≈ SeeOther
        = do unsafeByteString "The resource at "
             path
             unsafeByteString " can be found at "
             a ! href (toValue loc) $ toHtml loc
             unsafeByteString "."

    | resStatus ≈ TemporaryRedirect
        = do unsafeByteString "The resource at "
             path
             unsafeByteString " is temporarily located at "
             a ! href (toValue loc) $ toHtml loc
             unsafeByteString "."

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

      -- 5xx:
    | resStatus ≈ InternalServerError
        = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
    | resStatus ≈ ServiceUnavailable
        = unsafeByteString "The service is temporarily unavailable. Try later."

    | otherwise
        = (∅)
    where
      path ∷ Html
      path = toHtml ∘ uriPath ∘ reqURI $ fromJust req

      loc ∷ Text
      loc = A.toText ∘ fromJust $ getHeader "Location" res

hr ∷ Html
{-# INLINE hr #-}
hr = unsafeByteString "<hr/>"