Network/HTTP/Lucu/Abortion.hs

   1 module Network.HTTP.Lucu.Abortion
   2     ( Abortion(..)
   3     , abort
   4     , abortSTM
   5     , abortA
   6     , abortPage
   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.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
  28
  29
  30 data Abortion = Abortion {
  31       aboStatus  :: StatusCode
  32     , aboHeaders :: Headers
  33     , aboMessage :: Maybe String
  34     } deriving (Show, Typeable)
  35
  36
  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)
  41       in
  42         liftIO $ throwIO exc
  43
  44
  45 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
  46 abortSTM status headers msg
  47     = unsafeIOToSTM $ abort status headers msg
  48
  49
  50 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
  51 abortA
  52     = arrIO3 abort
  53
  54
  55 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
  56 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
  57 -- ければならない。
  58 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
  59 abortPage conf reqM res abo
  60     = case aboMessage abo of
  61         Just msg
  62             -> let [html] = unsafePerformIO
  63                             $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
  64                                      >>>
  65                                      writeDocumentToString [(a_indent, v_1)]
  66                                    )
  67                in
  68                  html
  69         Nothing
  70             -> let res'  = res { resStatus = aboStatus abo }
  71                    res'' = foldl (.) id [setHeader name value
  72                                              | (name, value) <- aboHeaders abo]
  73                            $ res'
  74                in
  75                  getDefaultPage conf reqM res''