module Network.HTTP.Lucu.Abortion
    ( Abortion(..)
    , abort      -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
    , abortSTM   -- StatusCode -> [ (String, String) ] -> String -> STM a
    , abortA     -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
    , aboPage    -- Config -> Abortion -> String
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad.Trans
import           GHC.Conc (unsafeIOToSTM)
import           Data.Dynamic
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.DefaultPage
import           Network.HTTP.Lucu.Headers
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.XmlIOStateArrow
import           Text.XML.HXT.DOM.XmlKeywords


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


abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a
abort status headers msg
    = let abo = Abortion status headers msg
          exc = DynException (toDyn abo)
      in
        liftIO $ throwIO exc


abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a
abortSTM status headers msg
    = unsafeIOToSTM $ abort status headers msg


abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c
abortA status headers msg
    = arrIO0 $ abort status headers msg


aboPage :: Config -> Abortion -> String
aboPage conf abo
    = let [html] = unsafePerformIO 
                   $ runX ( mkDefaultPage conf (aboStatus abo) (txt $ aboMessage abo)
                            >>>
                            writeDocumentToString [(a_indent, v_1)]
                          )
      in
        html