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 {-# SOURCE #-} Network.HTTP.Lucu.Resource
28 import System.IO.Unsafe
29 import Text.XML.HXT.Arrow.WriteDocument
30 import Text.XML.HXT.Arrow.XmlArrow
31 import Text.XML.HXT.Arrow.XmlIOStateArrow
32 import Text.XML.HXT.DOM.XmlKeywords
35 data Abortion = Abortion {
36 aboStatus :: !StatusCode
37 , aboHeaders :: !Headers
38 , aboMessage :: !(Maybe String)
39 } deriving (Show, Typeable)
41 -- | Computation of @'abort' status headers msg@ aborts the
42 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
43 -- additional response headers, and optional message string.
45 -- What this really does is to just throw a special DynException. The
46 -- exception will be caught by the system.
48 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
49 -- Header/ or any precedent states, it is possible to use the
50 -- @status@ and such like as a HTTP response to be sent to the
53 -- 2. Otherwise the HTTP response can't be modified anymore so the
54 -- only possible thing the system can do is to dump it to the
56 -- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
58 -- Note that the status code doesn't have to be an error code so you
59 -- can use this action for redirection as well as error reporting e.g.
61 -- > abort MovedPermanently
62 -- > [("Location", "http://example.net/")]
63 -- > (Just "It has been moved to example.net")
64 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
65 abort status headers msg
66 = status `seq` headers `seq` msg `seq`
67 let abo = Abortion status headers msg
68 exc = DynException (toDyn abo)
71 {-# SPECIALIZE abort :: StatusCode -> [ (String, String) ] -> Maybe String -> Resource a #-}
73 -- | Computation of @'abortSTM' status headers msg@ just computes
74 -- 'abort' in a STM monad.
75 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
76 abortSTM status headers msg
77 = status `seq` headers `seq` msg `seq`
78 unsafeIOToSTM $! abort status headers msg
80 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
81 -- computes 'abort' in an ArrowIO.
82 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
85 {-# SPECIALIZE abortA :: IOSArrow (StatusCode, ([ (String, String) ], Maybe String)) c #-}
87 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
88 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
90 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
91 abortPage conf reqM res abo
92 = conf `seq` reqM `seq` res `seq` abo `seq`
93 case aboMessage abo of
95 -> let [html] = unsafePerformIO
96 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
98 writeDocumentToString [(a_indent, v_1)]
103 -> let res' = res { resStatus = aboStatus abo }
104 res'' = foldl (.) id [setHeader name value
105 | (name, value) <- aboHeaders abo]
108 getDefaultPage conf reqM res''