Network/HTTP/Lucu/Abortion.hs

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