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