Network/HTTP/Lucu/Abortion.hs

   1 -- #prune
   2
   3 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
   4 -- in any 'Prelude.IO' monads or arrows.
   5 module Network.HTTP.Lucu.Abortion
   6     ( Abortion(..)
   7     , abort
   8     , abortSTM
   9     , abortA
  10     , abortPage
  11     )
  12     where
  13
  14 import           Control.Arrow
  15 import           Control.Arrow.ArrowIO
  16 import           Control.Concurrent.STM
  17 import           Control.Exception
  18 import           Control.Monad.Trans
  19 import           GHC.Conc (unsafeIOToSTM)
  20 import           Data.Dynamic
  21 import           Network.HTTP.Lucu.Config
  22 import           Network.HTTP.Lucu.DefaultPage
  23 import           Network.HTTP.Lucu.Headers
  24 import           Network.HTTP.Lucu.Request
  25 import           Network.HTTP.Lucu.Response
  26 import {-# SOURCE #-} Network.HTTP.Lucu.Resource
  27 import           System.IO.Unsafe
  28 import           Text.XML.HXT.Arrow.WriteDocument
  29 import           Text.XML.HXT.Arrow.XmlArrow
  30 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  31 import           Text.XML.HXT.DOM.XmlKeywords
  32
  33
  34 data Abortion = Abortion {
  35       aboStatus  :: !StatusCode
  36     , aboHeaders :: !Headers
  37     , aboMessage :: !(Maybe String)
  38     } deriving (Show, Typeable)
  39
  40 -- |Computation of @'abort' status headers msg@ aborts the
  41 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
  42 -- additional response headers, and optional message string.
  43 --
  44 -- What this really does is to just throw a special
  45 -- 'Control.Exception.DynException'. The exception will be caught by
  46 -- the Lucu.
  47 --
  48 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
  49 --    Header/ or any precedent states, it is possible to use the
  50 --    @status@ and such like as a HTTP response to be sent to the
  51 --    client.
  52 --
  53 -- 2. Otherwise the HTTP response can't be modified anymore so the
  54 --    only possible thing the system can do is to dump it to the
  55 --    stderr. See
  56 --    'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
  57 --
  58 -- Note that the status code doesn't have to be an error code so you
  59 -- can use this action for redirection as well as error reporting e.g.
  60 --
  61 -- > abort MovedPermanently
  62 -- >       [("Location", "http://example.net/")]
  63 -- >       (Just "It has been moved to example.net")
  64 abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
  65 abort status headers msg
  66     = status `seq` headers `seq` msg `seq`
  67       let abo = Abortion status headers msg
  68           exc = DynException (toDyn abo)
  69       in
  70         liftIO $ throwIO exc
  71 {-# SPECIALIZE abort :: StatusCode -> [ (String, String) ] -> Maybe String -> Resource a #-}
  72
  73 -- |Computation of @'abortSTM' status headers msg@ just computes
  74 -- 'abort' in a 'Control.Monad.STM.STM' monad.
  75 abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
  76 abortSTM status headers msg
  77     = status `seq` headers `seq` msg `seq`
  78       unsafeIOToSTM $! abort status headers msg
  79
  80 -- | Computation of @'abortA' -< (status, (headers, msg))@ just
  81 -- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
  82 abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
  83 abortA
  84     = arrIO3 abort
  85 {-# SPECIALIZE abortA :: IOSArrow (StatusCode, ([ (String, String) ], Maybe String)) c #-}
  86
  87 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
  88 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
  89 -- ければならない。
  90 abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
  91 abortPage conf reqM res abo
  92     = conf `seq` reqM `seq` res `seq` abo `seq`
  93       case aboMessage abo of
  94         Just msg
  95             -> let [html] = unsafePerformIO
  96                             $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
  97                                      >>>
  98                                      writeDocumentToString [(a_indent, v_1)]
  99                                    )
 100                in
 101                  html
 102         Nothing
 103             -> let res'  = res { resStatus = aboStatus abo }
 104                    res'' = foldl (.) id [setHeader name value
 105                                              | (name, value) <- aboHeaders abo]
 106                            $ res'
 107                in
 108                  getDefaultPage conf reqM res''