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