Network/HTTP/Lucu/Abortion.hs

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