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.Text (Text)
  16 import qualified Data.Text as T
  17 import Data.Typeable
  18 import Network.HTTP.Lucu.Config
  19 import Network.HTTP.Lucu.DefaultPage
  20 import Network.HTTP.Lucu.Headers
  21 import Network.HTTP.Lucu.Request
  22 import Network.HTTP.Lucu.Response
  23 import Prelude.Unicode
  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.Resource.Resource' monad with a 'StatusCode',
  30 -- additional response headers, and an optional message text.
  31 --
  32 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
  33 --    Header/ or any precedent states, throwing an 'Abortion' affects
  34 --    the HTTP 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 -- > abort $ mkAbortion MovedPermanently
  45 -- >         [("Location", "http://example.net/")]
  46 -- >         "It has been moved to example.net"
  47 data Abortion = Abortion {
  48       aboStatus  ∷ !SomeStatusCode
  49     , aboHeaders ∷ !Headers
  50     , aboMessage ∷ !(Maybe Text)
  51     } deriving (Eq, Show, Typeable)
  52
  53 instance Exception Abortion
  54
  55 instance HasHeaders Abortion where
  56     getHeaders         = aboHeaders
  57     setHeaders abo hdr = abo { aboHeaders = hdr }
  58
  59 abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
  60 abortPage conf reqM res abo
  61     = case aboMessage abo of
  62         Just msg
  63             → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
  64                                    ⋙
  65                                    writeDocumentToString [ withIndent True ]
  66                                  ) ()
  67               in
  68                 BB.fromString html
  69         Nothing
  70             → let res'  = res { resStatus = aboStatus abo }
  71                   res'' = foldl (∘) id [setHeader name value
  72                                             | (name, value) ← fromHeaders $ aboHeaders abo] res'
  73                in
  74                  getDefaultPage conf reqM res''