Network/HTTP/Lucu/Abortion.hs

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