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 Control.Arrow.ArrowIO
21 import Control.Arrow.ListArrow
22 import Control.Arrow.Unicode
23 import Control.Concurrent.STM
24 import Control.Exception
25 import Control.Monad.Trans
26 import Data.Ascii (Ascii, CIAscii)
27 import Data.Text (Text)
28 import qualified Data.Text as T
29 import qualified Data.Text.Lazy as Lazy
31 import Network.HTTP.Lucu.Config
32 import Network.HTTP.Lucu.DefaultPage
33 import Network.HTTP.Lucu.Headers
34 import Network.HTTP.Lucu.Request
35 import Network.HTTP.Lucu.Response
36 import Prelude.Unicode
37 import Text.XML.HXT.Arrow.WriteDocument
38 import Text.XML.HXT.Arrow.XmlArrow
39 import Text.XML.HXT.Arrow.XmlState
41 data Abortion = Abortion {
42 aboStatus ∷ !StatusCode
43 , aboHeaders ∷ !Headers
44 , aboMessage ∷ !(Maybe Text)
45 } deriving (Eq, Show, Typeable)
47 instance Exception Abortion
49 -- |Computation of @'abort' status headers msg@ aborts the
50 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
51 -- additional response headers, and optional message string.
53 -- What this really does is to throw a special
54 -- 'Control.Exception.Exception'. The exception will be caught by the
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
65 -- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
67 -- Note that the status code doesn't have to be an error code so you
68 -- can use this action for redirection as well as error reporting e.g.
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 → Lazy.Text
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''