Network/HTTP/Lucu/Abortion.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , DeriveDataTypeable
   4   , TypeOperators
   5   , UnicodeSyntax
   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
  12     , abort
  13     , abortPurely
  14     , abortSTM
  15     , abortA
  16     , abortPage
  17     )
  18     where
  19 import Blaze.ByteString.Builder (Builder)
  20 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
  21 import Control.Arrow.ArrowIO
  22 import Control.Arrow.ListArrow
  23 import Control.Arrow.Unicode
  24 import Control.Concurrent.STM
  25 import Control.Exception
  26 import Control.Monad.Trans
  27 import Data.Ascii (Ascii, CIAscii)
  28 import Data.Text (Text)
  29 import qualified Data.Text as T
  30 import Data.Typeable
  31 import Network.HTTP.Lucu.Config
  32 import Network.HTTP.Lucu.DefaultPage
  33 import Network.HTTP.Lucu.Headers
  34 import Network.HTTP.Lucu.Request
  35 import Network.HTTP.Lucu.Response
  36 import Prelude.Unicode
  37 import Text.XML.HXT.Arrow.WriteDocument
  38 import Text.XML.HXT.Arrow.XmlArrow
  39 import Text.XML.HXT.Arrow.XmlState
  40
  41 data Abortion = Abortion {
  42       aboStatus  ∷ !StatusCode
  43     , aboHeaders ∷ !Headers
  44     , aboMessage ∷ !(Maybe Text)
  45     } deriving (Eq, Show, Typeable)
  46
  47 instance Exception Abortion
  48
  49 -- |Computation of @'abort' status headers msg@ aborts the
  50 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
  51 -- additional response headers, and optional message string.
  52 --
  53 -- What this really does is to throw an instance of 'Exception'. The
  54 -- exception will be caught by the 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 'cnfDumpTooLateAbortionToStderr'.
  64 --
  65 -- Note that the status code doesn't necessarily have to be an error
  66 -- code so you can use this action for redirection as well as error
  67 -- 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 ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
  94 {-# INLINE abortA #-}
  95 abortA = proc (status, (headers, msg)) →
  96          arrIO throwIO ⤙ Abortion status (toHeaders headers) msg
  97
  98 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
  99 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
 100 -- ければならない。
 101 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
 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                 BB.fromString 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''