Network/HTTP/Lucu/Abortion/Internal.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , UnicodeSyntax
   4   #-}
   5 module Network.HTTP.Lucu.Abortion.Internal
   6     ( Abortion(..)
   7     , abortPage
   8     )
   9     where
  10 import Blaze.ByteString.Builder (Builder)
  11 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
  12 import Control.Arrow.ListArrow
  13 import Control.Arrow.Unicode
  14 import Control.Exception
  15 import Data.Monoid.Unicode
  16 import Data.Text (Text)
  17 import qualified Data.Text as T
  18 import Data.Typeable
  19 import Network.HTTP.Lucu.Config
  20 import Network.HTTP.Lucu.DefaultPage
  21 import Network.HTTP.Lucu.Headers
  22 import Network.HTTP.Lucu.Request
  23 import Network.HTTP.Lucu.Response
  24 import Text.XML.HXT.Arrow.WriteDocument
  25 import Text.XML.HXT.Arrow.XmlArrow
  26 import Text.XML.HXT.Arrow.XmlState
  27
  28 -- |'Abortion' is an 'Exception' that aborts the execution of
  29 -- 'Network.HTTP.Lucu.Rsrc' monad with a 'StatusCode', additional
  30 -- response headers, and an optional message text.
  31 --
  32 -- 1. If the 'Network.HTTP.Lucu.Rsrc' is in the /Deciding Header/ or
  33 --    any precedent states, throwing an 'Abortion' affects the HTTP
  34 --    response to be sent to the client.
  35 --
  36 -- 2. Otherwise it's too late to overwrite the HTTP response so the
  37 --    only possible thing the system can do is to dump the exception
  38 --    to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
  39 --
  40 -- Note that the status code doesn't necessarily have to satisfy
  41 -- 'isError' so you can abuse this exception for redirections as well
  42 -- as error reporting e.g.
  43 --
  44 -- @
  45 --   'Network.HTTP.Lucu.abort' '$' 'Network.HTTP.Lucu.mkAbortion' 'MovedPermanently'
  46 --           [(\"Location\", \"http://example.net/\")]
  47 --           ('Just' \"It's been moved to example.net.\")
  48 -- @
  49 data Abortion = Abortion {
  50       aboStatus  ∷ !SomeStatusCode
  51     , aboHeaders ∷ !Headers
  52     , aboMessage ∷ !(Maybe Text)
  53     } deriving (Eq, Show, Typeable)
  54
  55 instance Exception Abortion
  56
  57 instance HasHeaders Abortion where
  58     getHeaders         = aboHeaders
  59     setHeaders abo hdr = abo { aboHeaders = hdr }
  60
  61 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
  62 abortPage conf reqM res abo
  63     = case aboMessage abo of
  64         Just msg
  65             → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
  66                                    ⋙
  67                                    writeDocumentToString [ withIndent True ]
  68                                  ) ()
  69               in
  70                 BB.fromString html
  71         Nothing
  72             → let res' = res {
  73                             resStatus  = aboStatus abo
  74                           , resHeaders = resHeaders res ⊕ aboHeaders abo
  75                           }
  76                in
  77                  getDefaultPage conf reqM res'