Network/HTTP/Lucu/Abortion.hs

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