{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module Program.Mighty.Report (
    Reporter
  , initReporter
  , finReporter
  , report
  , reportDo
  , warpHandler
  , printStdout
  ) where

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Exception
import qualified Control.Exception as E (catch)
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.UnixTime
import GHC.IO.Exception (IOErrorType(..))
import Network.Wai
import Network.Wai.Handler.Warp (InvalidRequest)
import Network.Wai.Handler.Warp.Internal (TimeoutThread(..))
import System.IO
import System.IO.Error (ioeGetErrorType)
import System.Posix (getProcessID)

import Program.Mighty.ByteString

data Method = FileOnly | FileAndStdout deriving Eq
data Reporter = Reporter Method Handle

initReporter :: Bool -> FilePath -> IO (Either SomeException Reporter)
initReporter debug reportFile = try $ Reporter method <$> openFile reportFile AppendMode
  where
    method
      | debug     = FileAndStdout
      | otherwise = FileOnly

finReporter :: Reporter -> IO ()
finReporter (Reporter _ rpthdl) = hClose rpthdl

report :: Reporter -> ByteString -> IO ()
report (Reporter method rpthdl) msg = handle (\(SomeException _) -> return ()) $ do
    pid <- BS.pack . show <$> getProcessID
    tm <- getUnixTime >>= formatUnixTime "%d %b %Y %H:%M:%S"
    let logmsg = BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"]
    BS.hPutStr rpthdl logmsg
    hFlush rpthdl
    when (method == FileAndStdout) $ BS.putStr logmsg

----------------------------------------------------------------

reportDo :: Reporter -> IO () -> IO ()
reportDo rpt act = act `E.catch` warpHandler rpt Nothing

----------------------------------------------------------------

warpHandler :: Reporter -> Maybe Request -> SomeException -> IO ()
warpHandler rpt _ e = throwIO e `catches` handlers
  where
    handlers = [Handler ah, Handler th, Handler ih, Handler oh, Handler sh]
    ah :: AsyncException -> IO ()
    ah ThreadKilled = norecode
    ah x            = recode x
    th :: TimeoutThread -> IO ()
    th TimeoutThread = norecode
    ih :: InvalidRequest -> IO ()
    ih _ = norecode
    oh :: IOException -> IO ()
    oh x
      | et `elem` ignEts = norecode
      | otherwise        = recode x
      where
        et = ioeGetErrorType x
        ignEts = [ResourceVanished, InvalidArgument]
    sh :: SomeException -> IO ()
    sh x = recode x
    norecode = return ()
    recode :: Exception e => e -> IO ()
    recode   = report rpt . bshow

----------------------------------------------------------------

printStdout :: Maybe Request -> SomeException -> IO ()
printStdout _ x = print x >> hFlush stdout