Network/HTTP/Lucu/Abortion.hs

   1 module Network.HTTP.Lucu.Abortion
   2     ( Abortion(..)
   3     , abort      -- MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
   4     , abortSTM   -- StatusCode -> [ (String, String) ] -> Maybe String -> STM a
   5     , abortA     -- ArrowIO a => StatusCode -> [ (String, String) ] -> Maybe String -> a b c
   6     , abortPage  -- Config -> Maybe Request -> Maybe Response -> 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.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 => StatusCode -> [ (String, String) ] -> Maybe String -> a b c
  51 abortA status headers msg
  52     = arrIO0 $ abort status headers msg
  53
  54
  55 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
  56 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
  57 -- ければならない。しかもその時は resM から Response を捏造までする必要
  58 -- がある。
  59 abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String
  60 abortPage conf reqM resM abo
  61     = let msg    = case aboMessage abo of
  62                      Just msg -> msg
  63                      Nothing  -> let res' = case resM of
  64                                               Just res -> res { resStatus = aboStatus abo }
  65                                               Nothing  -> Response {
  66                                                             resVersion = HttpVersion 1 1
  67                                                           , resStatus  = aboStatus abo
  68                                                           , resHeaders = []
  69                                                           }
  70                                      res  = foldl (.) id [setHeader name value
  71                                                               | (name, value) <- aboHeaders abo]
  72                                             $ res'
  73                                  in
  74                                    getDefaultPage conf reqM res
  75           [html] = unsafePerformIO
  76                    $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
  77                             >>>
  78                             writeDocumentToString [(a_indent, v_1)]
  79                           )
  80       in
  81         html