)
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 Text.Blaze
+import Data.Monoid.Unicode
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
+import Network.HTTP.Lucu.Response.StatusCode
-- |'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.
+-- 'Network.HTTP.Lucu.Rsrc' 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.
+-- 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
-- '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"
+-- @
+-- '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 ∷ !StatusCode
+ aboStatus ∷ !SomeStatusCode
, aboHeaders ∷ !Headers
, aboMessage ∷ !(Maybe Text)
} deriving (Eq, Show, Typeable)
setHeaders abo hdr = abo { aboHeaders = hdr }
abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
-abortPage conf reqM res abo
+abortPage conf req 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
+ → defaultPageWithMessage conf (aboStatus abo) $ toHtml msg
Nothing
- → let res' = res { resStatus = aboStatus abo }
- res'' = foldl (∘) id [setHeader name value
- | (name, value) ← fromHeaders $ aboHeaders abo] res'
+ → let res' = res {
+ resStatus = aboStatus abo
+ , resHeaders = resHeaders res ⊕ aboHeaders abo
+ }
in
- getDefaultPage conf reqM res''
+ defaultPageForResponse conf req res'