--- /dev/null
+{-# 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 ∷ !StatusCode
+ , 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''