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 Control.Arrow.ArrowIO
  21 import Control.Arrow.ListArrow
  22 import Control.Arrow.Unicode
  23 import Control.Concurrent.STM
  24 import Control.Exception
  25 import Control.Monad.Trans
  26 import Data.Ascii (Ascii, CIAscii)
  27 import Data.Text (Text)
  28 import qualified Data.Text as T
  29 import qualified Data.Text.Lazy as Lazy
  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 a special
  54 -- 'Control.Exception.Exception'. The exception will be caught by the
  55 -- 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
  65 --    'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
  66 --
  67 -- Note that the status code doesn't have to be an error code so you
  68 -- can use this action for redirection as well as error 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 → Lazy.Text
 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                 Lazy.pack 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''