1 {-# OPTIONS_HADDOCK prune #-}
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 instance Exception Abortion where
42 toException = SomeException
43 fromException (SomeException e) = cast e
45 -- |Computation of @'abort' status headers msg@ aborts the
46 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
47 -- additional response headers, and optional message string.
49 -- What this really does is to throw a special
50 -- 'Control.Exception.Exception'. The exception will be caught by the
53 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
54 -- Header/ or any precedent states, it is possible to use the
55 -- @status@ and such like as a HTTP response to be sent to the
58 -- 2. Otherwise the HTTP response can't be modified anymore so the
59 -- only possible thing the system can do is to dump it to the
61 -- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
63 -- Note that the status code doesn't have to be an error code so you
64 -- can use this action for redirection as well as error reporting e.g.
66 -- > abort MovedPermanently
67 -- > [("Location", "http://example.net/")]
68 -- > (Just "It has been moved to example.net")
69 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
70 abort status headers msg
71 = status `seq` headers `seq` msg `seq`
72 let abo = Abortion status (toHeaders $ map pack headers) msg
76 pack (x, y) = (C8.pack x, C8.pack y)
78 -- |This is similar to 'abort' but computes it with
79 -- 'System.IO.Unsafe.unsafePerformIO'.
80 abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a
81 abortPurely = ((unsafePerformIO .) .) . abort
83 -- |Computation of @'abortSTM' status headers msg@ just computes
84 -- 'abort' in a 'Control.Monad.STM.STM' monad.
85 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
86 abortSTM status headers msg
87 = status `seq` headers `seq` msg `seq`
88 unsafeIOToSTM $! abort status headers msg
90 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
91 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
92 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
96 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
97 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
99 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
100 abortPage conf reqM res abo
101 = conf `seq` reqM `seq` res `seq` abo `seq`
102 case aboMessage abo of
104 -> let [html] = unsafePerformIO
105 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
107 writeDocumentToString [(a_indent, v_1)]
112 -> let res' = res { resStatus = aboStatus abo }
113 res'' = foldl (.) id [setHeader name value
114 | (name, value) <- fromHeaders $ aboHeaders abo]
117 getDefaultPage conf reqM res''