module Web.Apiary.Logger
( Logger
, LogDest(..), LogConfig(..)
, initLogger
, logging
, LogWrapper, logWrapper, runLogWrapper
) where
import System.Log.FastLogger
import Control.Applicative
import Control.Monad
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Control
import Control.Exception.Lifted
import Data.Default.Class
import Control.Monad.Apiary
import Control.Monad.Apiary.Action
import Data.Apiary.Compat
import Data.Apiary.Extension
data LogDest
= LogFile FilePath
| LogStdout
| LogStderr
| NoLog
data LogConfig = LogConfig
{ bufferSize :: BufSize
, logDest :: LogDest
}
instance Default LogConfig where
def = LogConfig defaultBufSize LogStderr
data Logger = Logger
{ pushLog :: LogStr -> IO ()
, closeLog :: IO ()
}
instance Extension Logger
newLogger :: BufSize -> LogDest -> IO Logger
newLogger s (LogFile p) = newFileLoggerSet s p >>= \l ->
return $ Logger (pushLogStr l) (flushLogStr l)
newLogger s LogStdout = newStdoutLoggerSet s >>= \l ->
return $ Logger (pushLogStr l) (flushLogStr l)
newLogger s LogStderr = newStderrLoggerSet s >>= \l ->
return $ Logger (pushLogStr l) (flushLogStr l)
newLogger _ NoLog = return $ Logger (\_ -> return ()) (return ())
initLogger :: (MonadBaseControl IO m, MonadIO m) => LogConfig -> Initializer' m Logger
initLogger LogConfig{..} = initializerBracket' $ bracket
(liftIO $ newLogger bufferSize logDest)
(liftIO . closeLog)
logging :: (Has Logger exts, MonadIO m)
=> LogStr -> ActionT exts prms m ()
logging m = do
l <- getExt (Proxy :: Proxy Logger)
liftIO $ pushLog l m
instance (MonadIO m, Has Logger exts) => MonadLogger (ActionT exts prms m) where
monadLoggerLog loc src lv msg = do
l <- getExt (Proxy :: Proxy Logger)
liftIO . pushLog l $ defaultLogStr loc src lv (toLogStr msg)
instance (Monad actM, MonadIO m, Has Logger exts) => MonadLogger (ApiaryT exts prms actM m) where
monadLoggerLog loc src lv msg = do
l <- apiaryExt (Proxy :: Proxy Logger)
liftIO . pushLog l $ defaultLogStr loc src lv (toLogStr msg)
newtype LogWrapper exts m a =
LogWrapper { unLogWrapper :: ReaderT (Extensions exts) m a }
deriving ( Functor, Applicative
, Monad, MonadIO, MonadTrans, MonadBase b)
logWrapper :: Monad m => m a -> LogWrapper exts m a
logWrapper = LogWrapper . lift
runLogWrapper :: Extensions exts -> LogWrapper exts m a -> m a
runLogWrapper e = flip runReaderT e . unLogWrapper
instance (MonadIO m, Has Logger exts) => MonadLogger (LogWrapper exts m) where
monadLoggerLog loc src lv msg = do
l <- getExtension (Proxy :: Proxy Logger) `liftM` LogWrapper ask
liftIO . pushLog l $ defaultLogStr loc src lv (toLogStr msg)
instance MonadTransControl (LogWrapper exts) where
newtype StT (LogWrapper exts) a = StLogWrapper { unStLogWrapper :: StT (ReaderT (Extensions exts)) a }
liftWith = defaultLiftWith LogWrapper unLogWrapper StLogWrapper
restoreT = defaultRestoreT LogWrapper unStLogWrapper
instance MonadBaseControl b m => MonadBaseControl b (LogWrapper exts m) where
newtype StM (LogWrapper exts m) a = StMLogWrapper { unStMLogWrapper :: ComposeSt (LogWrapper exts) m a }
liftBaseWith = defaultLiftBaseWith StMLogWrapper
restoreM = defaultRestoreM unStMLogWrapper