{-# LANGUAGE
    Arrows
  , DeriveDataTypeable
  , TypeOperators
  , UnicodeSyntax
  #-}

-- |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 Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
import Control.Arrow.ArrowIO
import Control.Arrow.ListArrow
import Control.Arrow.Unicode
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Trans
import Data.Ascii (Ascii, CIAscii)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
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 Prelude.Unicode
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 Text)
    } deriving (Eq, 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 an instance of '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 'cnfDumpTooLateAbortionToStderr'.
--
-- Note that the status code doesn't necessarily 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 → [ (CIAscii, Ascii) ] → Maybe Text → m a
{-# INLINE abort #-}
abort status headers
    = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers)

-- |This is similar to 'abort' but computes it with
-- 'System.IO.Unsafe.unsafePerformIO'.
abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
{-# INLINE abortPurely #-}
abortPurely status headers
    = throw ∘ Abortion status (toHeaders headers)

-- |Computation of @'abortSTM' status headers msg@ just computes
-- 'abort' in a 'Control.Monad.STM.STM' monad.
abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
{-# INLINE abortSTM #-}
abortSTM status headers
    = throwSTM ∘ Abortion status (toHeaders headers)

-- | Computation of @'abortA' -< (status, (headers, msg))@ just
-- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
{-# INLINE abortA #-}
abortA = proc (status, (headers, msg)) →
         arrIO throwIO ⤙ Abortion status (toHeaders headers) msg

-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
abortPage conf reqM res abo
    = case aboMessage abo of
        Just msg
            → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
                                   ⋙
                                   writeDocumentToString [ withIndent True ]
                                 ) ()
              in
                BB.fromString 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''