X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FAbortion%2FInternal.hs;fp=Network%2FHTTP%2FLucu%2FAbortion%2FInternal.hs;h=f71e0454a51b9be04aa630df18bd268397574251;hb=f402841101b4b84f263eea1a43c848f81c48ff93;hp=0000000000000000000000000000000000000000;hpb=0aa4f6d758fc12fba468f7cd399bbcc48f693d1e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
new file mode 100644
index 0000000..f71e045
--- /dev/null
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -0,0 +1,74 @@
+{-# 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''