{-# LANGUAGE
    DeriveDataTypeable
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Abortion.Internal
    ( Abortion(..)
    , abortPage
    )
    where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Control.Exception
import Data.Text (Text)
import qualified Data.Text as T
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 Prelude.Unicode
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState

-- |'Abortion' is an 'Exception' that aborts the execution of
-- 'Network.HTTP.Lucu.Resource.Resource' monad with a 'StatusCode',
-- additional response headers, and an optional message text.
--
-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' 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.
--
-- > abort $ mkAbortion MovedPermanently
-- >         [("Location", "http://example.net/")]
-- >         "It has 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 reqM res abo
    = case aboMessage abo of
        Just msg
            → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
                                   ⋙
                                   writeDocumentToString [ withIndent True ]
                                 ) ()
              in
                BB.fromString html
        Nothing
            → let res'  = res { resStatus = aboStatus abo }
                  res'' = foldl (∘) id [setHeader name value
                                            | (name, value) ← fromHeaders $ aboHeaders abo] res'
               in
                 getDefaultPage conf reqM res''