5 module Network.HTTP.Lucu.Abortion.Internal
10 import Blaze.ByteString.Builder (Builder)
11 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
12 import Control.Arrow.ListArrow
13 import Control.Arrow.Unicode
14 import Control.Exception
15 import Data.Text (Text)
16 import qualified Data.Text as T
18 import Network.HTTP.Lucu.Config
19 import Network.HTTP.Lucu.DefaultPage
20 import Network.HTTP.Lucu.Headers
21 import Network.HTTP.Lucu.Request
22 import Network.HTTP.Lucu.Response
23 import Prelude.Unicode
24 import Text.XML.HXT.Arrow.WriteDocument
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlState
28 -- |'Abortion' is an 'Exception' that aborts the execution of
29 -- 'Network.HTTP.Lucu.Resource.Resource' monad with a 'StatusCode',
30 -- additional response headers, and an optional message text.
32 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
33 -- Header/ or any precedent states, throwing an 'Abortion' affects
34 -- the HTTP response to be sent to the client.
36 -- 2. Otherwise it's too late to overwrite the HTTP response so the
37 -- only possible thing the system can do is to dump the exception
38 -- to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
40 -- Note that the status code doesn't necessarily have to satisfy
41 -- 'isError' so you can abuse this exception for redirections as well
42 -- as error reporting e.g.
44 -- > abort $ mkAbortion MovedPermanently
45 -- > [("Location", "http://example.net/")]
46 -- > "It has been moved to example.net"
47 data Abortion = Abortion {
48 aboStatus ∷ !SomeStatusCode
49 , aboHeaders ∷ !Headers
50 , aboMessage ∷ !(Maybe Text)
51 } deriving (Eq, Show, Typeable)
53 instance Exception Abortion
55 instance HasHeaders Abortion where
56 getHeaders = aboHeaders
57 setHeaders abo hdr = abo { aboHeaders = hdr }
59 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
60 abortPage conf reqM res abo
61 = case aboMessage abo of
63 → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
65 writeDocumentToString [ withIndent True ]
70 → let res' = res { resStatus = aboStatus abo }
71 res'' = foldl (∘) id [setHeader name value
72 | (name, value) ← fromHeaders $ aboHeaders abo] res'
74 getDefaultPage conf reqM res''