5 module Network.HTTP.Lucu.Abortion.Internal
10 import Blaze.ByteString.Builder (Builder)
11 import Control.Exception
13 import Data.Monoid.Unicode
14 import Data.Text (Text)
16 import Network.HTTP.Lucu.Config
17 import Network.HTTP.Lucu.DefaultPage
18 import Network.HTTP.Lucu.Headers
19 import Network.HTTP.Lucu.Request
20 import Network.HTTP.Lucu.Response
21 import Network.HTTP.Lucu.Response.StatusCode
23 -- |'Abortion' is an 'Exception' that aborts the execution of
24 -- 'Network.HTTP.Lucu.Rsrc' monad with a 'StatusCode', additional
25 -- response headers, and an optional message text.
27 -- 1. If the 'Network.HTTP.Lucu.Rsrc' is in the /Deciding Header/ or
28 -- any precedent states, throwing an 'Abortion' affects the HTTP
29 -- response to be sent to the client.
31 -- 2. Otherwise it's too late to overwrite the HTTP response so the
32 -- only possible thing the system can do is to dump the exception
33 -- to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
35 -- Note that the status code doesn't necessarily have to satisfy
36 -- 'isError' so you can abuse this exception for redirections as well
37 -- as error reporting e.g.
40 -- 'Network.HTTP.Lucu.abort' '$' 'Network.HTTP.Lucu.mkAbortion' 'MovedPermanently'
41 -- [(\"Location\", \"http://example.net/\")]
42 -- ('Just' \"It's been moved to example.net.\")
44 data Abortion = Abortion {
45 aboStatus ∷ !SomeStatusCode
46 , aboHeaders ∷ !Headers
47 , aboMessage ∷ !(Maybe Text)
48 } deriving (Eq, Show, Typeable)
50 instance Exception Abortion
52 instance HasHeaders Abortion where
53 getHeaders = aboHeaders
54 setHeaders abo hdr = abo { aboHeaders = hdr }
56 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
57 abortPage conf req res abo
58 = case aboMessage abo of
60 → defaultPageWithMessage conf (aboStatus abo) $ toHtml msg
63 resStatus = aboStatus abo
64 , resHeaders = resHeaders res ⊕ aboHeaders abo
67 defaultPageForResponse conf req res'