Network/HTTP/Lucu/Abortion.hs

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