{-# LANGUAGE
    DeriveDataTypeable
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Abortion.Internal
    ( Abortion(..)
    , abortPage
    )
    where
import Blaze.ByteString.Builder (Builder)
import Control.Exception
import Text.Blaze
import Data.Monoid.Unicode
import Data.Text (Text)
import Data.Typeable
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Response.StatusCode

-- |'Abortion' is an 'Exception' that aborts the execution of
-- 'Network.HTTP.Lucu.Rsrc' monad with a 'StatusCode', additional
-- response headers, and an optional message text.
--
-- 1. If the 'Network.HTTP.Lucu.Rsrc' is in the /Deciding Header/ or
--    any precedent states, throwing an 'Abortion' affects the HTTP
--    response to be sent to the client.
--
-- 2. Otherwise it's too late to overwrite the HTTP response so the
--    only possible thing the system can do is to dump the exception
--    to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
--
-- Note that the status code doesn't necessarily have to satisfy
-- 'isError' so you can abuse this exception for redirections as well
-- as error reporting e.g.
--
-- @
--   'Network.HTTP.Lucu.abort' '$' 'Network.HTTP.Lucu.mkAbortion' 'MovedPermanently'
--           [(\"Location\", \"http://example.net/\")]
--           ('Just' \"It's been moved to example.net.\")
-- @
data Abortion = Abortion {
      aboStatus  ∷ !SomeStatusCode
    , aboHeaders ∷ !Headers
    , aboMessage ∷ !(Maybe Text)
    } deriving (Eq, Show, Typeable)

instance Exception Abortion

instance HasHeaders Abortion where
    getHeaders         = aboHeaders
    setHeaders abo hdr = abo { aboHeaders = hdr }

abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
abortPage conf req res abo
    = case aboMessage abo of
        Just msg
            → defaultPageWithMessage conf (aboStatus abo) $ toHtml msg
        Nothing
            → let res' = res {
                            resStatus  = aboStatus abo
                          , resHeaders = resHeaders res ⊕ aboHeaders abo
                          }
               in
                 defaultPageForResponse conf req res'