Abortion.hs

{-# OPTIONS_HADDOCK prune #-}

-- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
-- in any 'Prelude.IO' monads or arrows.
module Network.HTTP.Lucu.Abortion
    ( Abortion(..)
    , abort
    , abortPurely
    , abortSTM
    , abortA
    , abortPage
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
import           Data.Dynamic
import           GHC.Conc (unsafeIOToSTM)
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.DefaultPage
import           Network.HTTP.Lucu.Headers
import           Network.HTTP.Lucu.Request
import           Network.HTTP.Lucu.Response
import           System.IO.Unsafe
import           Text.XML.HXT.Arrow.WriteDocument
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlState


data Abortion = Abortion {
      aboStatus  :: !StatusCode
    , aboHeaders :: !Headers
    , aboMessage :: !(Maybe String)
    } deriving (Show, Typeable)

instance Exception Abortion

-- |Computation of @'abort' status headers msg@ aborts the
-- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
-- additional response headers, and optional message string.
--
-- What this really does is to throw a special
-- 'Control.Exception.Exception'. The exception will be caught by the
-- Lucu system.
--
-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
--    Header/ or any precedent states, it is possible to use the
--    @status@ and such like as a HTTP response to be sent to the
--    client.
--
-- 2. Otherwise the HTTP response can't be modified anymore so the
--    only possible thing the system can do is to dump it to the
--    stderr. See
--    'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
--
-- Note that the status code doesn't have to be an error code so you
-- can use this action for redirection as well as error reporting e.g.
--
-- > abort MovedPermanently
-- >       [("Location", "http://example.net/")]
-- >       (Just "It has been moved to example.net")
abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
abort status headers msg
    = status `seq` headers `seq` msg `seq`
      let abo = Abortion status (toHeaders $ map pack headers) msg
      in
        liftIO $ throwIO abo
    where
      pack (x, y) = (C8.pack x, C8.pack y)

-- |This is similar to 'abort' but computes it with
-- 'System.IO.Unsafe.unsafePerformIO'.
abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a
abortPurely = ((unsafePerformIO .) .) . abort

-- |Computation of @'abortSTM' status headers msg@ just computes
-- 'abort' in a 'Control.Monad.STM.STM' monad.
abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
abortSTM status headers msg
    = status `seq` headers `seq` msg `seq`
      unsafeIOToSTM $! abort status headers msg

-- | Computation of @'abortA' -< (status, (headers, msg))@ just
-- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
abortA 
    = arrIO3 abort

-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
abortPage conf reqM res abo
    = conf `seq` reqM `seq` res `seq` abo `seq`
      case aboMessage abo of
        Just msg
            -> let [html] = unsafePerformIO 
                            $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
                                     >>>
                                     writeDocumentToString [ withIndent True ]
                                   )
               in
                 html
        Nothing
            -> let res'  = res { resStatus = aboStatus abo }
                   res'' = foldl (.) id [setHeader name value
                                             | (name, value) <- fromHeaders $ aboHeaders abo] res'
               in
                 getDefaultPage conf reqM res''