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 Data.ByteString.Base (ByteString)
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 -> [ (ByteString, ByteString) ] -> Maybe String -> m a
66 abort status headers msg
67 = status `seq` headers `seq` msg `seq`
68 let abo = Abortion status (toHeaders headers) msg
69 exc = DynException (toDyn abo)
73 -- |This is similar to 'abort' but computes it with
74 -- 'System.IO.Unsafe.unsafePerformIO'.
75 abortPurely :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> a
76 abortPurely = ((unsafePerformIO .) .) . abort
78 -- |Computation of @'abortSTM' status headers msg@ just computes
79 -- 'abort' in a 'Control.Monad.STM.STM' monad.
80 abortSTM :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> STM a
81 abortSTM status headers msg
82 = status `seq` headers `seq` msg `seq`
83 unsafeIOToSTM $! abort status headers msg
85 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
86 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
87 abortA :: ArrowIO a => a (StatusCode, ([ (ByteString, ByteString) ], Maybe String)) c
91 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
92 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
94 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
95 abortPage conf reqM res abo
96 = conf `seq` reqM `seq` res `seq` abo `seq`
97 case aboMessage abo of
99 -> let [html] = unsafePerformIO
100 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
102 writeDocumentToString [(a_indent, v_1)]
107 -> let res' = res { resStatus = aboStatus abo }
108 res'' = foldl (.) id [setHeader name value
109 | (name, value) <- fromHeaders $ aboHeaders abo]
112 getDefaultPage conf reqM res''