-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- Copyright 2009, Henning Thielemann.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright notice,
--    this list of conditions and the following disclaimer.
--
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--
--  * Neither the name of the copyright holder(s) nor the names of
--    contributors may be used to endorse or promote products derived from
--    this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------

module Network.MoHWS.Logger.Error (
    Handle,
    start,
    stop,
    log,

    HasHandle(getHandle),
    debug,
    abort,
    debugOnAbort,
    logError,
    logInfo,
    logDebug,
   ) where

import qualified Network.MoHWS.Logger as Logger
import qualified Network.MoHWS.Logger.Level as LogLevel
import Network.MoHWS.Utility (formatTimeSensibly, )

import System.Time (ClockTime, toUTCTime, getClockTime, )

import Control.Concurrent (myThreadId, )
import Control.Monad.IO.Class (MonadIO, liftIO, )
import Control.Monad.Trans.Class (lift, )
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, )
import Control.Monad (mzero, )


import Prelude hiding (log, )


data Handle = Handle
    {
     Handle -> Handle Message
logger ::Logger.Handle Message,
     Handle -> T
minLevel :: LogLevel.T
    }

data Message = Message
    {
     Message -> ClockTime
time   :: ClockTime,
     Message -> String
string :: String
    }


start :: FilePath -> LogLevel.T -> IO Handle
start :: String -> T -> IO Handle
start String
file T
level =
    do Handle Message
l <- (Message -> IO String) -> String -> IO (Handle Message)
forall a. (a -> IO String) -> String -> IO (Handle a)
Logger.start (String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String)
-> (Message -> String) -> Message -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> String
format) String
file
       let h :: Handle
h = Handle :: Handle Message -> T -> Handle
Handle {
                logger :: Handle Message
logger = Handle Message
l,
                minLevel :: T
minLevel = T
level
               }
       Handle -> T -> String -> IO ()
log Handle
h T
LogLevel.Warn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting error logger with log level "
                                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ T -> String
forall a. Show a => a -> String
show T
level String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
       Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
  where format :: Message -> String
format Message
m = CalendarTime -> String
formatTimeSensibly (ClockTime -> CalendarTime
toUTCTime (Message -> ClockTime
time Message
m))
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message -> String
string Message
m

stop :: Handle -> IO ()
stop :: Handle -> IO ()
stop Handle
l =
   do Handle -> T -> String -> IO ()
log Handle
l T
LogLevel.Warn String
"Stopping error logger..."
      Handle Message -> IO ()
forall a. Handle a -> IO ()
Logger.stop (Handle -> Handle Message
logger Handle
l)

log :: Handle -> LogLevel.T -> String -> IO ()
log :: Handle -> T -> String -> IO ()
log Handle
l T
level String
s =
   if T
level T -> T -> Bool
forall a. Ord a => a -> a -> Bool
< Handle -> T
minLevel Handle
l
     then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else do ClockTime
t <- IO ClockTime
getClockTime
             Handle Message -> Message -> IO ()
forall a. Handle a -> a -> IO ()
Logger.log (Handle -> Handle Message
logger Handle
l) (ClockTime -> String -> Message
Message ClockTime
t String
s)


-- * logging in more general contexts

class HasHandle h where
   getHandle :: h -> Handle

instance HasHandle Handle where
   getHandle :: Handle -> Handle
getHandle = Handle -> Handle
forall a. a -> a
id


debug :: (HasHandle h, MonadIO io) => h -> String -> io ()
debug :: h -> String -> io ()
debug h
h String
s =
   IO () -> io ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$
   do ThreadId
t <- IO ThreadId
myThreadId
      h -> String -> IO ()
forall h. HasHandle h => h -> String -> IO ()
logDebug h
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> String
forall a. Show a => a -> String
show ThreadId
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

abort :: (HasHandle h) => h -> String -> MaybeT IO a
abort :: h -> String -> MaybeT IO a
abort h
h String
s = IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (h -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug h
h String
s) MaybeT IO () -> MaybeT IO a -> MaybeT IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

debugOnAbort :: (HasHandle h) => h -> String -> MaybeT IO a -> MaybeT IO a
debugOnAbort :: h -> String -> MaybeT IO a -> MaybeT IO a
debugOnAbort h
h String
s MaybeT IO a
act =
   IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe a) -> MaybeT IO a) -> IO (Maybe a) -> MaybeT IO a
forall a b. (a -> b) -> a -> b
$
   do Maybe a
x <- MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT IO a
act
      case Maybe a
x of
         Maybe a
Nothing -> h -> String -> IO ()
forall h (io :: * -> *).
(HasHandle h, MonadIO io) =>
h -> String -> io ()
debug h
h String
s
         Maybe a
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
x

logError :: (HasHandle h) => h -> String -> IO ()
logError :: h -> String -> IO ()
logError h
h = Handle -> T -> String -> IO ()
log (h -> Handle
forall h. HasHandle h => h -> Handle
getHandle h
h) T
LogLevel.Error

logInfo :: (HasHandle h) => h -> String -> IO ()
logInfo :: h -> String -> IO ()
logInfo h
h = Handle -> T -> String -> IO ()
log (h -> Handle
forall h. HasHandle h => h -> Handle
getHandle h
h) T
LogLevel.Info

logDebug :: (HasHandle h) => h -> String -> IO ()
logDebug :: h -> String -> IO ()
logDebug h
h = Handle -> T -> String -> IO ()
log (h -> Handle
forall h. HasHandle h => h -> Handle
getHandle h
h) T
LogLevel.Debug