3 -- | Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
4 -- in any IO monads or arrows.
5 module Network.HTTP.Lucu.Abortion
15 import Control.Arrow.ArrowIO
16 import Control.Concurrent.STM
17 import Control.Exception
18 import Control.Monad.Trans
19 import GHC.Conc (unsafeIOToSTM)
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.DefaultPage
23 import Network.HTTP.Lucu.Headers
24 import Network.HTTP.Lucu.HttpVersion
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
27 import System.IO.Unsafe
28 import Text.XML.HXT.Arrow.WriteDocument
29 import Text.XML.HXT.Arrow.XmlArrow
30 import Text.XML.HXT.Arrow.XmlIOStateArrow
31 import Text.XML.HXT.DOM.XmlKeywords
34 data Abortion = Abortion {
35 aboStatus :: StatusCode
36 , aboHeaders :: Headers
37 , aboMessage :: Maybe String
38 } deriving (Show, Typeable)
40 -- | Computation of @'abort' status headers msg@ aborts the
41 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
42 -- additional response headers, and optional message string.
44 -- What this really does is to just throw a special DynException. The
45 -- exception will be caught by the system.
47 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
48 -- Header/ or any precedent states, it is possible to use the
49 -- @status@ and such like as a HTTP response to be sent to the
52 -- 2. Otherwise the HTTP response can't be modified anymore so the
53 -- only possible thing the system can do is to dump it to the
55 -- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
57 -- Note that the status code doesn't have to be an error code so you
58 -- can use this action for redirection as well as error reporting e.g.
60 -- > abort MovedPermanently
61 -- > [("Location", "http://example.net/")]
62 -- > (Just "It has been moved to example.net")
63 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
64 abort status headers msg
65 = let abo = Abortion status headers msg
66 exc = DynException (toDyn abo)
70 -- | Computation of @'abortSTM' status headers msg@ just computes
71 -- 'abort' in a STM monad.
72 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
73 abortSTM status headers msg
74 = unsafeIOToSTM $ abort status headers msg
76 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
77 -- computes 'abort' in an ArrowIO.
78 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
83 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
84 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
86 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
87 abortPage conf reqM res abo
88 = case aboMessage abo of
90 -> let [html] = unsafePerformIO
91 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
93 writeDocumentToString [(a_indent, v_1)]
98 -> let res' = res { resStatus = aboStatus abo }
99 res'' = foldl (.) id [setHeader name value
100 | (name, value) <- aboHeaders abo]
103 getDefaultPage conf reqM res''