1 module Network.HTTP.Lucu.Abortion
11 import Control.Arrow.ArrowIO
12 import Control.Concurrent.STM
13 import Control.Exception
14 import Control.Monad.Trans
15 import GHC.Conc (unsafeIOToSTM)
17 import Network.HTTP.Lucu.Config
18 import Network.HTTP.Lucu.DefaultPage
19 import Network.HTTP.Lucu.Headers
20 import Network.HTTP.Lucu.HttpVersion
21 import Network.HTTP.Lucu.Request
22 import Network.HTTP.Lucu.Response
23 import System.IO.Unsafe
24 import Text.XML.HXT.Arrow.WriteDocument
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlIOStateArrow
27 import Text.XML.HXT.DOM.XmlKeywords
30 data Abortion = Abortion {
31 aboStatus :: StatusCode
32 , aboHeaders :: Headers
33 , aboMessage :: Maybe String
34 } deriving (Show, Typeable)
37 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
38 abort status headers msg
39 = let abo = Abortion status headers msg
40 exc = DynException (toDyn abo)
45 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
46 abortSTM status headers msg
47 = unsafeIOToSTM $ abort status headers msg
50 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
55 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
56 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
58 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
59 abortPage conf reqM res abo
60 = case aboMessage abo of
62 -> let [html] = unsafePerformIO
63 $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
65 writeDocumentToString [(a_indent, v_1)]
70 -> let res' = res { resStatus = aboStatus abo }
71 res'' = foldl (.) id [setHeader name value
72 | (name, value) <- aboHeaders abo]
75 getDefaultPage conf reqM res''