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 Data.ByteString.Base (ByteString)
21 import GHC.Conc (unsafeIOToSTM)
22 import Network.HTTP.Lucu.Config
23 import Network.HTTP.Lucu.DefaultPage
24 import Network.HTTP.Lucu.Headers
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
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
45 -- 'Control.Exception.DynException'. The exception will be caught by
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 -> [ (ByteString, ByteString) ] -> Maybe String -> m a
65 abort status headers msg
66 = status `seq` headers `seq` msg `seq`
67 let abo = Abortion status (toHeaders headers) msg
68 exc = DynException (toDyn abo)
72 -- |Computation of @'abortSTM' status headers msg@ just computes
73 -- 'abort' in a 'Control.Monad.STM.STM' monad.
74 abortSTM :: StatusCode -> [ (ByteString, ByteString) ] -> 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 'Control.Arrow.ArrowIO.ArrowIO'.
81 abortA :: ArrowIO a => a (StatusCode, ([ (ByteString, ByteString) ], Maybe String)) c
85 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
86 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
88 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
89 abortPage conf reqM res abo
90 = conf `seq` reqM `seq` res `seq` abo `seq`
91 case aboMessage abo of
93 -> let [html] = unsafePerformIO
94 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
96 writeDocumentToString [(a_indent, v_1)]
101 -> let res' = res { resStatus = aboStatus abo }
102 res'' = foldl (.) id [setHeader name value
103 | (name, value) <- fromHeaders $ aboHeaders abo]
106 getDefaultPage conf reqM res''