]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Abortion/Internal.hs
StatusCode is now a type class, not an algebraic data type.
[Lucu.git] / Network / HTTP / Lucu / Abortion / Internal.hs
1 {-# LANGUAGE
2     DeriveDataTypeable
3   , UnicodeSyntax
4   #-}
5 module Network.HTTP.Lucu.Abortion.Internal
6     ( Abortion(..)
7     , abortPage
8     )
9     where
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
17 import Data.Typeable
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
27
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.
31 --
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.
35 --
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'.
39 --
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.
43 --
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)
52
53 instance Exception Abortion
54
55 instance HasHeaders Abortion where
56     getHeaders         = aboHeaders
57     setHeaders abo hdr = abo { aboHeaders = hdr }
58
59 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
60 abortPage conf reqM res abo
61     = case aboMessage abo of
62         Just msg
63             → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
64                                    ⋙
65                                    writeDocumentToString [ withIndent True ]
66                                  ) ()
67               in
68                 BB.fromString html
69         Nothing
70             → let res'  = res { resStatus = aboStatus abo }
71                   res'' = foldl (∘) id [setHeader name value
72                                             | (name, value) ← fromHeaders $ aboHeaders abo] res'
73                in
74                  getDefaultPage conf reqM res''