8 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
9 -- in any 'Prelude.IO' monads or arrows.
10 module Network.HTTP.Lucu.Abortion
20 import Blaze.ByteString.Builder (Builder)
21 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
22 import Control.Arrow.ArrowIO
23 import Control.Arrow.ListArrow
24 import Control.Arrow.Unicode
25 import Control.Concurrent.STM
26 import Control.Exception
27 import Control.Monad.Trans
28 import Data.Ascii (Ascii, CIAscii)
29 import Data.Text (Text)
30 import qualified Data.Text as T
32 import Network.HTTP.Lucu.Config
33 import Network.HTTP.Lucu.DefaultPage
34 import Network.HTTP.Lucu.Headers
35 import Network.HTTP.Lucu.Request
36 import Network.HTTP.Lucu.Response
37 import Prelude.Unicode
38 import Text.XML.HXT.Arrow.WriteDocument
39 import Text.XML.HXT.Arrow.XmlArrow
40 import Text.XML.HXT.Arrow.XmlState
42 data Abortion = Abortion {
43 aboStatus ∷ !StatusCode
44 , aboHeaders ∷ !Headers
45 , aboMessage ∷ !(Maybe Text)
46 } deriving (Eq, Show, Typeable)
48 instance Exception Abortion
50 -- |Computation of @'abort' status headers msg@ aborts the
51 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
52 -- additional response headers, and optional message string.
54 -- What this really does is to throw an instance of 'Exception'. The
55 -- exception will be caught by the Lucu system.
57 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
58 -- Header/ or any precedent states, it is possible to use the
59 -- @status@ and such like as a HTTP response to be sent to the
62 -- 2. Otherwise the HTTP response can't be modified anymore so the
63 -- only possible thing the system can do is to dump it to the
64 -- stderr. See 'cnfDumpTooLateAbortionToStderr'.
66 -- Note that the status code doesn't necessarily have to be an error
67 -- code so you can use this action for redirection as well as error
70 -- > abort MovedPermanently
71 -- > [("Location", "http://example.net/")]
72 -- > (Just "It has been moved to example.net")
73 abort ∷ MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
76 = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers)
78 -- |This is similar to 'abort' but computes it with
79 -- 'System.IO.Unsafe.unsafePerformIO'.
80 abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
81 {-# INLINE abortPurely #-}
82 abortPurely status headers
83 = throw ∘ Abortion status (toHeaders headers)
85 -- |Computation of @'abortSTM' status headers msg@ just computes
86 -- 'abort' in a 'Control.Monad.STM.STM' monad.
87 abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
88 {-# INLINE abortSTM #-}
89 abortSTM status headers
90 = throwSTM ∘ Abortion status (toHeaders headers)
92 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
93 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
94 abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
96 abortA = proc (status, (headers, msg)) →
97 arrIO throwIO ⤙ Abortion status (toHeaders headers) msg
99 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
100 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
102 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
103 abortPage conf reqM res abo
104 = case aboMessage abo of
106 → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
108 writeDocumentToString [ withIndent True ]
113 → let res' = res { resStatus = aboStatus abo }
114 res'' = foldl (∘) id [setHeader name value
115 | (name, value) ← fromHeaders $ aboHeaders abo] res'
117 getDefaultPage conf reqM res''