module Web.Apiary.Logger.Internal where
import Control.Applicative
import Web.Apiary hiding (Default(..))
import System.Log.FastLogger
import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans
import Control.Monad.Logger
import Control.Monad.Trans.Control
import Control.Exception
import Data.Reflection
import Data.Default.Class
data LogDest
= File FilePath
| Stdout
| Stderr
| Null
data LogConfig = LogConfig
{ bufferSize :: BufSize
, logDest :: LogDest
}
data Logger = Logger
{ pushLog :: LogStr -> IO ()
, closeLog :: IO ()
}
instance Default LogConfig where
def = LogConfig defaultBufSize Stderr
type HasLogger = Given Logger
newLogger :: BufSize -> LogDest -> IO Logger
newLogger s (File p) = newFileLoggerSet s p >>= \l ->
return $ Logger (pushLogStr l) (flushLogStr l)
newLogger s Stdout = newStdoutLoggerSet s >>= \l ->
return $ Logger (pushLogStr l) (flushLogStr l)
newLogger s Stderr = newStderrLoggerSet s >>= \l ->
return $ Logger (pushLogStr l) (flushLogStr l)
newLogger _ Null = return $ Logger (\_ -> return ()) (return ())
withLogger :: LogConfig -> (HasLogger => IO a) -> IO a
withLogger LogConfig{..} m = bracket
(newLogger bufferSize logDest)
closeLog
(\l -> give l m)
withLogger' :: LogConfig
-> ((forall r. (HasLogger => r) -> r) -> IO a) -> IO a
withLogger' LogConfig{..} m = bracket
(newLogger bufferSize logDest)
closeLog
(\l -> m (give l))
logging :: (MonadIO m, HasLogger) => LogStr -> ActionT m ()
logging msg = liftIO $ pushLog given msg
newtype GivenLoggerT m a = GivenLoggerT { runGivenLoggerT :: m a }
deriving(Functor, Applicative, Monad, MonadIO)
instance MonadBase b m => MonadBase b (GivenLoggerT m) where
liftBase = GivenLoggerT . liftBase
instance MonadTrans GivenLoggerT where
lift = GivenLoggerT
instance MonadBaseControl b m => MonadBaseControl b (GivenLoggerT m) where
newtype StM (GivenLoggerT m) a = StMGivenLogger { unStMGivenLogger :: ComposeSt GivenLoggerT m a }
liftBaseWith = defaultLiftBaseWith StMGivenLogger
restoreM = defaultRestoreM unStMGivenLogger
instance MonadTransControl GivenLoggerT where
newtype StT GivenLoggerT a = StGivenLogger { unStGivenLogger :: a }
liftWith f = GivenLoggerT $ f $ liftM StGivenLogger . runGivenLoggerT
restoreT = GivenLoggerT . liftM unStGivenLogger
instance (MonadIO m, HasLogger) => MonadLogger (GivenLoggerT m) where
monadLoggerLog loc src lv msg = GivenLoggerT . liftIO $
pushLog given (defaultLogStr loc src lv (toLogStr msg))
instance (MonadIO m, HasLogger) => MonadLogger (ActionT m) where
monadLoggerLog loc src lv msg =
logging $ defaultLogStr loc src lv (toLogStr msg)