module Network.HTTP.Lucu.Abortion
( Abortion(..)
, abort
, abortPurely
, abortSTM
, abortA
, abortPage
)
where
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
import Data.Dynamic
import GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import System.IO.Unsafe
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.DOM.XmlKeywords
data Abortion = Abortion {
aboStatus :: !StatusCode
, aboHeaders :: !Headers
, aboMessage :: !(Maybe String)
} deriving (Show, Typeable)
instance Exception Abortion
abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
abort status headers msg
= status `seq` headers `seq` msg `seq`
let abo = Abortion status (toHeaders $ map pack headers) msg
in
liftIO $ throwIO abo
where
pack (x, y) = (C8.pack x, C8.pack y)
abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a
abortPurely = ((unsafePerformIO .) .) . abort
abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
abortSTM status headers msg
= status `seq` headers `seq` msg `seq`
unsafeIOToSTM $! abort status headers msg
abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
abortA
= arrIO3 abort
abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
abortPage conf reqM res abo
= conf `seq` reqM `seq` res `seq` abo `seq`
case aboMessage abo of
Just msg
-> let [html] = unsafePerformIO
$ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
>>>
writeDocumentToString [(a_indent, v_1)]
)
in
html
Nothing
-> let res' = res { resStatus = aboStatus abo }
res'' = foldl (.) id [setHeader name value
| (name, value) <- fromHeaders $ aboHeaders abo]
$ res'
in
getDefaultPage conf reqM res''