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 Control.Exception
  12 import Text.Blaze
  13 import Data.Monoid.Unicode
  14 import Data.Text (Text)
  15 import Data.Typeable
  16 import Network.HTTP.Lucu.Config
  17 import Network.HTTP.Lucu.DefaultPage
  18 import Network.HTTP.Lucu.Headers
  19 import Network.HTTP.Lucu.Request
  20 import Network.HTTP.Lucu.Response
  21
  22 -- |'Abortion' is an 'Exception' that aborts the execution of
  23 -- 'Network.HTTP.Lucu.Rsrc' monad with a 'StatusCode', additional
  24 -- response headers, and an optional message text.
  25 --
  26 -- 1. If the 'Network.HTTP.Lucu.Rsrc' is in the /Deciding Header/ or
  27 --    any precedent states, throwing an 'Abortion' affects the HTTP
  28 --    response to be sent to the client.
  29 --
  30 -- 2. Otherwise it's too late to overwrite the HTTP response so the
  31 --    only possible thing the system can do is to dump the exception
  32 --    to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
  33 --
  34 -- Note that the status code doesn't necessarily have to satisfy
  35 -- 'isError' so you can abuse this exception for redirections as well
  36 -- as error reporting e.g.
  37 --
  38 -- @
  39 --   'Network.HTTP.Lucu.abort' '$' 'Network.HTTP.Lucu.mkAbortion' 'MovedPermanently'
  40 --           [(\"Location\", \"http://example.net/\")]
  41 --           ('Just' \"It's been moved to example.net.\")
  42 -- @
  43 data Abortion = Abortion {
  44       aboStatus  ∷ !SomeStatusCode
  45     , aboHeaders ∷ !Headers
  46     , aboMessage ∷ !(Maybe Text)
  47     } deriving (Eq, Show, Typeable)
  48
  49 instance Exception Abortion
  50
  51 instance HasHeaders Abortion where
  52     getHeaders         = aboHeaders
  53     setHeaders abo hdr = abo { aboHeaders = hdr }
  54
  55 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
  56 abortPage conf req res abo
  57     = case aboMessage abo of
  58         Just msg
  59             → defaultPageWithMessage conf (aboStatus abo) $ toHtml msg
  60         Nothing
  61             → let res' = res {
  62                             resStatus  = aboStatus abo
  63                           , resHeaders = resHeaders res ⊕ aboHeaders abo
  64                           }
  65                in
  66                  defaultPageForResponse conf req res'