Use blaze-html instead of HXT.

[Lucu.git] / Network / HTTP / Lucu / Abortion / Internal.hs

diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
index f71e0454a51b9be04aa630df18bd268397574251..a1ff54c5be0d209cf4cfcb30867d8b4d04982441 100644 (file)
--- a/Network/HTTP/Lucu/Abortion/Internal.hs
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -8,30 +8,24 @@ module Network.HTTP.Lucu.Abortion.Internal
     )
     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
 
 -- |'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
@@ -41,11 +35,13 @@ import Text.XML.HXT.Arrow.XmlState
 -- '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)
@@ -57,18 +53,14 @@ instance HasHeaders Abortion where
     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'