logger-0.1.0.2: src/System/Log/Logger/Handler.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Log.Logger.Handler
-- Copyright : (C) 2015 Flowbox
-- License : Apache-2.0
-- Maintainer : Wojciech Daniło <wojciech.danilo@gmail.com>
-- Stability : stable
-- Portability : portable
-----------------------------------------------------------------------------
module System.Log.Logger.Handler where
import Data.Monoid
import Control.Applicative
import System.Log.Data (MonadRecord(appendRecord), LogBuilder, LookupDataSet, Msg, Lvl)
import System.Log.Filter (Filter, runFilter)
import Control.Lens hiding (children)
import System.Log.Log (Log, MonadLogger(appendLog), LogFormat, LogFormat)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.RWS
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Control.Monad.State (StateT, runStateT)
import qualified Control.Monad.State as State
import Control.Monad.IO.Class (MonadIO, liftIO)
import System.Log.Format (Formatter, runFormatter, defaultFormatter)
import qualified System.IO as IO
import Text.PrettyPrint.ANSI.Leijen (Doc, putDoc, hPutDoc)
----------------------------------------------------------------------
-- MonadLoggerHandler
----------------------------------------------------------------------
class MonadLoggerHandler n m | m -> n where
addHandler :: Handler n (LogFormat m) -> m ()
default addHandler :: (Monad m, MonadTrans t) => Handler n (LogFormat m) -> t m ()
addHandler = lift . addHandler
instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (ExceptT e m)
instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (ListT m)
instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (MaybeT m)
instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (ReaderT r m)
instance (Monad m, Monoid w, MonadLoggerHandler n m) => MonadLoggerHandler n (RWST r w s m)
instance (Monad m, MonadLoggerHandler n m) => MonadLoggerHandler n (StateT s m)
instance (Monad m, Monoid w, MonadLoggerHandler n m) => MonadLoggerHandler n (WriterT w m)
----------------------------------------------------------------------
-- Handler
----------------------------------------------------------------------
-- !!! dorobic formattery i filtracje do handlerow!
data Handler m l = Handler { _name :: String
, _action :: Doc -> Log l -> m ()
, _children :: [Handler m l]
, _formatter :: Maybe (Formatter l)
, _filters :: [Filter l]
}
makeLenses ''Handler
type Handler' m = Handler m (LogFormat m)
instance Show (Handler m l) where
show (Handler n _ _ _ _) = "Handler " <> n
mkHandler :: String -> (Doc -> Log l -> m ()) -> Maybe (Formatter l) -> Handler m l
mkHandler name f fmt = Handler name f [] fmt []
addChildHandler h ph = ph & children %~ (h:)
addFilter :: Filter l -> Handler m l -> Handler m l
addFilter f = filters %~ (f:)
setFormatter :: Formatter l -> Handler m l -> Handler m l
setFormatter f = formatter .~ (Just f)
-- === Handlers ===
topHandler :: Monad m => Formatter l -> Handler m l
topHandler fmt = mkHandler "TopHandler" (\_ _ -> return ()) Nothing
& formatter .~ (Just fmt)
printHandler :: MonadIO m => Maybe (Formatter l) -> Handler m l
printHandler = mkHandler "PrintHandler" handle where
handle defDoc l = liftIO $ putDoc defDoc *> putStrLn ""
fileHandler :: MonadIO m => IO.Handle -> Maybe (Formatter l) -> Handler m l
fileHandler h = mkHandler "FileHandler" (handle h) where
handle h defDoc l = liftIO $ hPutDoc h defDoc *> IO.hPutStrLn h ""
----------------------------------------------------------------------
-- HandlerLoggerT
----------------------------------------------------------------------
newtype HandlerLoggerT m a = HandlerLoggerT { fromHandlerLogger :: StateT (Handler' (HandlerLoggerT m)) m a } deriving (Monad, MonadIO, Applicative, Functor)
type instance LogFormat (HandlerLoggerT m) = LogFormat m
instance MonadTrans HandlerLoggerT where
lift = HandlerLoggerT . lift
runHandlerLoggerT :: (Functor m, Monad m) => Formatter (LogFormat m) -> HandlerLoggerT m b -> m b
runHandlerLoggerT fmt = fmap fst . flip runStateT (topHandler fmt) . fromHandlerLogger
runHandler :: (Applicative m, Monad m) => Doc -> Log (LogFormat m) -> Handler' m -> m ()
runHandler defDoc l h = act <* mapM (runHandler doc l) (h^.children) where
flt = runFilters h l
fmt = h^.formatter
act = if flt then (h^.action) doc l
else return ()
doc = case fmt of
Nothing -> defDoc
Just f -> runFormatter f l
runFilters h l = foldr (&&) True $ fmap (\f -> runFilter f l) (h^.filters)
getTopHandler :: Monad m => HandlerLoggerT m (Handler (HandlerLoggerT m) (LogFormat m))
getTopHandler = HandlerLoggerT State.get
putTopHandler :: Monad m => Handler (HandlerLoggerT m) (LogFormat m) -> HandlerLoggerT m ()
putTopHandler = HandlerLoggerT . State.put
-- === Instances ===
instance (MonadLogger m, Functor m, l~LogFormat m, LookupDataSet Msg l, LookupDataSet Lvl l)
=> MonadLogger (HandlerLoggerT m) where
appendLog l = (runHandler defDoc l =<< getTopHandler)
*> lift (appendLog l)
where defDoc = runFormatter defaultFormatter l
instance (Monad m, Functor m) => MonadLoggerHandler (HandlerLoggerT m) (HandlerLoggerT m) where
addHandler h = do
topH <- getTopHandler
putTopHandler $ addChildHandler h topH
instance (Functor m, MonadLogger m, l~LogFormat m, LogBuilder d (HandlerLoggerT m), LookupDataSet Msg l, LookupDataSet Lvl l)
=> MonadRecord d (HandlerLoggerT m)