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.Request
25 import Network.HTTP.Lucu.Response
26 import {-# SOURCE #-} Network.HTTP.Lucu.Resource
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 = status `seq` headers `seq` msg `seq`
66 let abo = Abortion status headers msg
67 exc = DynException (toDyn abo)
70 {-# SPECIALIZE abort :: StatusCode -> [ (String, String) ] -> Maybe String -> Resource a #-}
72 -- | Computation of @'abortSTM' status headers msg@ just computes
73 -- 'abort' in a STM monad.
74 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
75 abortSTM status headers msg
76 = status `seq` headers `seq` msg `seq`
77 unsafeIOToSTM $! abort status headers msg
79 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
80 -- computes 'abort' in an ArrowIO.
81 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
84 {-# SPECIALIZE abortA :: IOSArrow (StatusCode, ([ (String, String) ], Maybe String)) c #-}
86 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
87 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
89 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
90 abortPage conf reqM res abo
91 = conf `seq` reqM `seq` res `seq` abo `seq`
92 case aboMessage abo of
94 -> let [html] = unsafePerformIO
95 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
97 writeDocumentToString [(a_indent, v_1)]
102 -> let res' = res { resStatus = aboStatus abo }
103 res'' = foldl (.) id [setHeader name value
104 | (name, value) <- aboHeaders abo]
107 getDefaultPage conf reqM res''