3 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
4 -- in any 'Prelude.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.Request
25 import Network.HTTP.Lucu.Response
26 import System.IO.Unsafe
27 import Text.XML.HXT.Arrow.WriteDocument
28 import Text.XML.HXT.Arrow.XmlArrow
29 import Text.XML.HXT.Arrow.XmlIOStateArrow
30 import Text.XML.HXT.DOM.XmlKeywords
33 data Abortion = Abortion {
34 aboStatus :: !StatusCode
35 , aboHeaders :: !Headers
36 , aboMessage :: !(Maybe String)
37 } deriving (Show, Typeable)
39 -- |Computation of @'abort' status headers msg@ aborts the
40 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
41 -- additional response headers, and optional message string.
43 -- What this really does is to just throw a special
44 -- 'Control.Exception.DynException'. The exception will be caught by
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 = status `seq` headers `seq` msg `seq`
66 let abo = Abortion status headers msg
67 exc = DynException (toDyn abo)
71 -- |Computation of @'abortSTM' status headers msg@ just computes
72 -- 'abort' in a 'Control.Monad.STM.STM' monad.
73 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
74 abortSTM status headers msg
75 = status `seq` headers `seq` msg `seq`
76 unsafeIOToSTM $! abort status headers msg
78 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
79 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
80 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
84 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
85 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
87 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
88 abortPage conf reqM res abo
89 = conf `seq` reqM `seq` res `seq` abo `seq`
90 case aboMessage abo of
92 -> let [html] = unsafePerformIO
93 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
95 writeDocumentToString [(a_indent, v_1)]
100 -> let res' = res { resStatus = aboStatus abo }
101 res'' = foldl (.) id [setHeader name value
102 | (name, value) <- aboHeaders abo]
105 getDefaultPage conf reqM res''