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