3 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
4 -- in any 'Prelude.IO' monads or arrows.
5 module Network.HTTP.Lucu.Abortion
16 import Control.Arrow.ArrowIO
17 import Control.Concurrent.STM
18 import Control.Exception
19 import Control.Monad.Trans
20 import qualified Data.ByteString.Char8 as C8
22 import GHC.Conc (unsafeIOToSTM)
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.DefaultPage
25 import Network.HTTP.Lucu.Headers
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Response
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
46 -- 'Control.Exception.DynException'. The exception will be caught by
49 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
50 -- Header/ or any precedent states, it is possible to use the
51 -- @status@ and such like as a HTTP response to be sent to the
54 -- 2. Otherwise the HTTP response can't be modified anymore so the
55 -- only possible thing the system can do is to dump it to the
57 -- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
59 -- Note that the status code doesn't have to be an error code so you
60 -- can use this action for redirection as well as error reporting e.g.
62 -- > abort MovedPermanently
63 -- > [("Location", "http://example.net/")]
64 -- > (Just "It has been moved to example.net")
65 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
66 abort status headers msg
67 = status `seq` headers `seq` msg `seq`
68 let abo = Abortion status (toHeaders $ map pack headers) msg
69 exc = DynException (toDyn abo)
73 pack (x, y) = (C8.pack x, C8.pack y)
75 -- |This is similar to 'abort' but computes it with
76 -- 'System.IO.Unsafe.unsafePerformIO'.
77 abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a
78 abortPurely = ((unsafePerformIO .) .) . abort
80 -- |Computation of @'abortSTM' status headers msg@ just computes
81 -- 'abort' in a 'Control.Monad.STM.STM' monad.
82 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
83 abortSTM status headers msg
84 = status `seq` headers `seq` msg `seq`
85 unsafeIOToSTM $! abort status headers msg
87 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
88 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
89 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
93 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
94 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
96 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
97 abortPage conf reqM res abo
98 = conf `seq` reqM `seq` res `seq` abo `seq`
99 case aboMessage abo of
101 -> let [html] = unsafePerformIO
102 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
104 writeDocumentToString [(a_indent, v_1)]
109 -> let res' = res { resStatus = aboStatus abo }
110 res'' = foldl (.) id [setHeader name value
111 | (name, value) <- fromHeaders $ aboHeaders abo]
114 getDefaultPage conf reqM res''