{-# LANGUAGE
    BangPatterns
  , OverloadedStrings
  , UnboxedTuples
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.DefaultPage
    ( getDefaultPage
    , writeDefaultPage
    , mkDefaultPage
    )
    where
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Ascii as A
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.Encoding as Lazy
import Network.HTTP.Lucu.Config
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 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 → Lazy.Text
{-# INLINEABLE getDefaultPage #-}
getDefaultPage !conf !req !res
    = let msgA     = getMsg req res
          [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
                             ⋙ 
                             writeDocumentToString [ withIndent True ]
                           ) ()
      in
        Lazy.pack xmlStr

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

                       let conf = itrConfig itr
                           page = getDefaultPage conf reqM res

                       putTMVar (itrBodyToSend itr)
                                (BB.fromLazyByteString $ Lazy.encodeUtf8 page)

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