{-# LANGUAGE
    OverloadedStrings
  , 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 a) ⇒ Config → StatusCode → a b XmlTree → a 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 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