module Network.HTTP.Lucu.Abortion
    ( Abortion(..)
    , abort
    , abortSTM
    , abortA
    , abortPage
    )
    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.HttpVersion
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.XmlIOStateArrow
import           Text.XML.HXT.DOM.XmlKeywords


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


abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe 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) ] -> Maybe String -> STM a
abortSTM status headers msg
    = unsafeIOToSTM $ abort status headers msg


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
    = case aboMessage abo of
        Just msg
            -> let [html] = unsafePerformIO 
                            $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
                                     >>>
                                     writeDocumentToString [(a_indent, v_1)]
                                   )
               in
                 html
        Nothing
            -> let res'  = res { resStatus = aboStatus abo }
                   res'' = foldl (.) id [setHeader name value
                                             | (name, value) <- aboHeaders abo]
                           $ res'
               in
                 getDefaultPage conf reqM res''