Network/HTTP/Lucu/Abortion.hs

   1 -- #prune
   2
   3 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
   4 -- in any 'Prelude.IO' monads or arrows.
   5 module Network.HTTP.Lucu.Abortion
   6     ( Abortion(..)
   7     , abort
   8     , abortPurely
   9     , abortSTM
  10     , abortA
  11     , abortPage
  12     )
  13     where
  14
  15 import           Control.Arrow
  16 import           Control.Arrow.ArrowIO
  17 import           Control.Concurrent.STM
  18 import           Control.Exception
  19 import           Control.Monad.Trans
  20 import           Data.ByteString.Base (ByteString)
  21 import           Data.Dynamic
  22 import           GHC.Conc (unsafeIOToSTM)
  23 import           Network.HTTP.Lucu.Config
  24 import           Network.HTTP.Lucu.DefaultPage
  25 import           Network.HTTP.Lucu.Headers
  26 import           Network.HTTP.Lucu.Request
  27 import           Network.HTTP.Lucu.Response
  28 import           System.IO.Unsafe
  29 import           Text.XML.HXT.Arrow.WriteDocument
  30 import           Text.XML.HXT.Arrow.XmlArrow
  31 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  32 import           Text.XML.HXT.DOM.XmlKeywords
  33
  34
  35 data Abortion = Abortion {
  36       aboStatus  :: !StatusCode
  37     , aboHeaders :: !Headers
  38     , aboMessage :: !(Maybe String)
  39     } deriving (Show, Typeable)
  40
  41 -- |Computation of @'abort' status headers msg@ aborts the
  42 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
  43 -- additional response headers, and optional message string.
  44 --
  45 -- What this really does is to just throw a special
  46 -- 'Control.Exception.DynException'. The exception will be caught by
  47 -- the Lucu.
  48 --
  49 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
  50 --    Header/ or any precedent states, it is possible to use the
  51 --    @status@ and such like as a HTTP response to be sent to the
  52 --    client.
  53 --
  54 -- 2. Otherwise the HTTP response can't be modified anymore so the
  55 --    only possible thing the system can do is to dump it to the
  56 --    stderr. See
  57 --    'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
  58 --
  59 -- Note that the status code doesn't have to be an error code so you
  60 -- can use this action for redirection as well as error reporting e.g.
  61 --
  62 -- > abort MovedPermanently
  63 -- >       [("Location", "http://example.net/")]
  64 -- >       (Just "It has been moved to example.net")
  65 abort :: MonadIO m => StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> m a
  66 abort status headers msg
  67     = status `seq` headers `seq` msg `seq`
  68       let abo = Abortion status (toHeaders headers) msg
  69           exc = DynException (toDyn abo)
  70       in
  71         liftIO $ throwIO exc
  72
  73 -- |This is similar to 'abort' but computes it with
  74 -- 'System.IO.Unsafe.unsafePerformIO'.
  75 abortPurely :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> a
  76 abortPurely = ((unsafePerformIO .) .) . abort
  77
  78 -- |Computation of @'abortSTM' status headers msg@ just computes
  79 -- 'abort' in a 'Control.Monad.STM.STM' monad.
  80 abortSTM :: StatusCode -> [ (ByteString, ByteString) ] -> Maybe String -> STM a
  81 abortSTM status headers msg
  82     = status `seq` headers `seq` msg `seq`
  83       unsafeIOToSTM $! abort status headers msg
  84
  85 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
  86 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
  87 abortA :: ArrowIO a => a (StatusCode, ([ (ByteString, ByteString) ], Maybe String)) c
  88 abortA
  89     = arrIO3 abort
  90
  91 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
  92 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
  93 -- ければならない。
  94 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
  95 abortPage conf reqM res abo
  96     = conf `seq` reqM `seq` res `seq` abo `seq`
  97       case aboMessage abo of
  98         Just msg
  99             -> let [html] = unsafePerformIO
 100                             $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
 101                                      >>>
 102                                      writeDocumentToString [(a_indent, v_1)]
 103                                    )
 104                in
 105                  html
 106         Nothing
 107             -> let res'  = res { resStatus = aboStatus abo }
 108                    res'' = foldl (.) id [setHeader name value
 109                                              | (name, value) <- fromHeaders $ aboHeaders abo]
 110                            $ res'
 111                in
 112                  getDefaultPage conf reqM res''