Network/HTTP/Lucu/Abortion.hs

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