{-# LANGUAGE ScopedTypeVariables #-}
-- Copyright (c) 2002 John Meacham (john@foo.net)
--
-- Permission is hereby granted, free of charge, to any person obtaining a
-- copy of this software and associated documentation files (the
-- "Software"), to deal in the Software without restriction, including
-- without limitation the rights to use, copy, modify, merge, publish,
-- distribute, sublicense, and/or sell copies of the Software, and to
-- permit persons to whom the Software is furnished to do so, subject to
-- the following conditions:
--
-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.


-- | Manages an error log with proper locking. has a number of useful routines for detecting
-- and reporting erronious conditions.

module ErrorLog(
    -- * Log handling
    LogLevel(..),
    withErrorLog,
    withStartEndEntrys,
    withErrorMessage,
    setLogLevel,
    setErrorLogPutStr,
    -- ** adding log entries
    putLogLn,putLog,
    putLogException,
    -- ** annotating exceptions
    -- emapM, eannM,
    -- ** exception-aware composition
    retryIO,
    firstIO,
    tryMapM,
    trySeveral,
    -- ** random functions
    attemptIO, tryIO,
    indent
    ) where

import Control.Exception as E
import Data.Either
import System.IO
import System.IO.Unsafe
import Control.Monad
import Control.Concurrent
import System.Time(getClockTime)
import Data.List(delete)

------------
-- Error log
------------

data LogLevel = LogEmergency | LogAlert | LogCritical | LogError | LogWarning | LogNotice | LogInfo | LogDebug
    deriving (Eq, Enum, Ord)

{-# NOINLINE ior #-}
ior :: MVar Handle
ior = unsafePerformIO $ newMVar stderr

{-# NOINLINE log_level #-}
log_level :: MVar LogLevel
log_level = unsafePerformIO $ newMVar LogNotice

{-# NOINLINE hPutStr_v #-}
hPutStr_v :: MVar (Handle -> String -> IO ())
hPutStr_v = unsafePerformIO $ newMVar hPutStr

-- | open file for logging and run action, with errors being logged to the file.
-- This will reinstall the old errorlog handle when it finishes, by default stderr
-- is used and this routine need not be called unless you wish to log somewhere else.
-- the filename consisting of a single dash is treated specially and sets the errorlog
-- to stderr. note, that while the errorlog will function properly with concurrent
-- applications, a single errorlog is shared by all threads.
withErrorLog :: String    -- ^ filename of log
                -> IO a      -- ^ action to execute with logging to file
                -> IO a
withErrorLog "-" action = bracket (swapMVar ior stderr) (swapMVar ior) (\_ -> action)
withErrorLog fn action = E.bracket (openFile fn WriteMode) hClose $ \h -> do
        hSetBuffering h LineBuffering
        bracket (swapMVar ior h) (swapMVar ior) (\_ -> action)

-- | sets log level to new value, returns old log level.
setLogLevel :: LogLevel -> IO LogLevel
setLogLevel ll = swapMVar log_level ll

-- | add entries to log at the start and end of action with timestamp.
-- If the action throws an exception, it will be logged along with the
-- exit entry.
withStartEndEntrys :: String  -- ^ title to use in log entries
                      -> IO a    -- ^ action to execute
                      -> IO a
withStartEndEntrys n action = do
    gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Starting")
    handle
        (\(e :: SomeException) -> gct >>= \ct -> putLogException (ct ++ " " ++ n ++ " Ending due to Exception:" ) e >> throw e)
        (action >>= \r -> gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Ending") >> return r) where
            gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]"


-- | run an action, printing an error message to the log if it ends with an exception.
-- this is similar to 'withStartEndEntrys' but only adds an entry on error.
withErrorMessage :: String -> IO a -> IO a
withErrorMessage n action = do
    handle
        (\(e :: SomeException) -> gct >>= \ct -> putLogLn (normalize n ++ ct ++ " Ending due to Exception:\n" ++ indent 4 (show e) ) >> throw e )
        action  where
            gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]"


-- | set routine with same signature as 'hPutStr' to use for writing to log.
-- useful for charset conversions which might be necisarry. By default the
-- haskell 98 'IO.hPutStr' is used.
setErrorLogPutStr :: (Handle -> String -> IO ()) -> IO ()
setErrorLogPutStr hp = swapMVar hPutStr_v hp >> return ()



normalize :: String -> String
normalize = unlines . lines

-- | place log entry, normalize string to always have a single \'\n\' at the end
-- of the string. A single log entry is created for each 'putLogLn', do not
-- split entrys among calls to this function.
putLogLn :: String -> IO ()
putLogLn s = do
    hp <- readMVar hPutStr_v
    withMVar ior (\h -> hp h (normalize s))
    withMVar ior (\h -> hFlush h)

{-
-- | log entry, depreciated. will be used for more general logging interface at some point.
putLog :: String -> IO ()
putLog s = do
    hp <- readMVar hPutStr_v
    withMVar ior (\h -> hp h s)

-}

-- | create log entry with given loglevel. entry is normalized as in 'putLogLn'.
putLog :: LogLevel -> String -> IO ()
putLog ll s = do
    cll <- readMVar log_level
    when (ll <= cll) $ putLogLn s

{-
-- | transform an exception with a function.
emapM :: (Exception -> Exception) -> IO a -> IO a
emapM f action = do
    handle (\e -> throw (f e)) action


-- | annotates an exception using emapM, the original
-- type of the error cannot be recovered so this should only be used
-- if the exception is not meant to be caught later.
eannM :: String -> IO a -> IO a
eannM s action = emapM f action where
    f (ErrorCall es) = ErrorCall $ normalize s ++ normalize es
    f e = ErrorCall $ normalize s ++ normalize (show e)
-}

-- | attempt an action, add a log entry with the exception if it
-- fails
attemptIO :: IO a -> IO ()
attemptIO action = E.catch (action >> return ())
  (\(e :: IOException) -> putLogException "attempt ExceptionCaught" e)

tryMapM :: (a -> IO b) -> [a] -> IO [b]
tryMapM f xs = do
    ys <- mapM (tryIO . f) xs
    return $ rights ys

tryIO :: IO a -> IO (Either IOException a)
tryIO = E.try

-- | return the first non-excepting action. if all actions throw exceptions,
-- the last actions exception is rethrown.
firstIO :: [IO a] -> IO a
firstIO [] = fail "empty argument to first"
firstIO [x] = x
firstIO (x:xs) = E.try x >>= either (\(_ :: IOException) -> firstIO xs) return

indent :: Int -> String -> String
indent n s = unlines $ map (replicate n ' ' ++)$ lines s

-- | Retry an action until it succeeds.
retryIO :: Float      -- ^ number of seconds to pause between trys
         -> String  -- ^ string to annotate log entries with when retrying
         -> IO a    -- ^ action to retry
         -> IO a
retryIO delay n action = do
    handle (\(e :: IOException) -> putLogException (n ++ " (retrying in " ++ show delay ++ "s):") e >> threadDelay (floor $ 1000000 * delay) >> retryIO delay n action) action


putLogException :: Exception e => String -> e -> IO ()
putLogException n e =  putLog LogError (n ++ "\n" ++ indent 4 (show e))


-- | concurrently try several IO actions, returning the result of the first to finish.
-- if all actions throw exceptions, one is passed on non-deterministically
trySeveral :: [IO a] -> IO a
trySeveral [] = error "trySeveral has nothing to try!"
trySeveral arms = do
    v <- newEmptyMVar
    ts <- mapM (forkIO . f v) arms
    g v ts where
        f v arm = do
            t <- myThreadId
            r <- tryIO arm
            putMVar v (t,r)
        g v ts = do
            (t,r) <- takeMVar v
            let ts' = delete t ts
            case r of
                Left e -> if null ts' then throw e else g v ts'
                Right x -> do
                    mapM_ killThread ts'
                    return x