Network/HTTP/Lucu/Abortion.hs

   1 module Network.HTTP.Lucu.Abortion
   2     ( Abortion(..)
   3     , abort      -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
   4     , abortIO    -- StatusCode -> [ (String, String) ] -> String -> IO a
   5     , abortSTM   -- StatusCode -> [ (String, String) ] -> String -> STM a
   6     , abortA     -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
   7     , aboPage    -- Config -> Abortion -> String
   8     )
   9     where
  10
  11 import           Control.Arrow
  12 import           Control.Arrow.ArrowIO
  13 import           Control.Concurrent.STM
  14 import           Control.Exception
  15 import           Control.Monad.Trans
  16 import           GHC.Conc (unsafeIOToSTM)
  17 import           Data.Dynamic
  18 import           Network.HTTP.Lucu.Config
  19 import           Network.HTTP.Lucu.DefaultPage
  20 import           Network.HTTP.Lucu.Headers
  21 import           Network.HTTP.Lucu.Response
  22 import           System.IO.Unsafe
  23 import           Text.XML.HXT.Arrow.WriteDocument
  24 import           Text.XML.HXT.Arrow.XmlArrow
  25 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  26 import           Text.XML.HXT.DOM.XmlKeywords
  27
  28
  29 data Abortion = Abortion {
  30       aboStatus  :: StatusCode
  31     , aboHeaders :: Headers
  32     , aboMessage ::  String
  33     } deriving (Show, Typeable)
  34
  35
  36 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
  37 abort status headers msg
  38     = liftIO $ abortIO status headers msg
  39
  40
  41 abortIO :: StatusCode -> [ (String, String) ] -> String -> IO a
  42 abortIO status headers msg
  43     = let abo = Abortion status headers msg
  44           exc = DynException (toDyn abo)
  45       in
  46         throwIO exc
  47
  48
  49 abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a
  50 abortSTM status headers msg
  51     = unsafeIOToSTM $ abortIO status headers msg
  52
  53
  54 abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
  55 abortA status headers msg
  56     = arrIO0 $ abortIO status headers msg
  57
  58
  59 aboPage :: Config -> Abortion -> String
  60 aboPage conf abo
  61     = let [html] = unsafePerformIO
  62                    $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo)
  63                             >>>
  64                             writeDocumentToString [(a_indent, v_1)]
  65                           )
  66       in
  67         html